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 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
297 "Return a copy of a list, vector or string.\n\
298 The elements of a list or vector are not copied; they are shared\n\
303 if (NILP (arg
)) return arg
;
305 if (CHAR_TABLE_P (arg
))
310 /* Calculate the number of extra slots. */
311 size
= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (arg
));
312 copy
= Fmake_char_table (XCHAR_TABLE (arg
)->purpose
, Qnil
);
313 /* Copy all the slots, including the extra ones. */
314 bcopy (XCHAR_TABLE (arg
)->contents
, XCHAR_TABLE (copy
)->contents
,
315 (XCHAR_TABLE (arg
)->size
& PSEUDOVECTOR_SIZE_MASK
) * sizeof (Lisp_Object
));
317 /* Recursively copy any char-tables in the ordinary slots. */
318 for (i
= 0; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
319 if (CHAR_TABLE_P (XCHAR_TABLE (arg
)->contents
[i
]))
320 XCHAR_TABLE (copy
)->contents
[i
]
321 = Fcopy_sequence (XCHAR_TABLE (copy
)->contents
[i
]);
326 if (BOOL_VECTOR_P (arg
))
330 = (XBOOL_VECTOR (arg
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
332 val
= Fmake_bool_vector (Flength (arg
), Qnil
);
333 bcopy (XBOOL_VECTOR (arg
)->data
, XBOOL_VECTOR (val
)->data
,
338 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
339 arg
= wrong_type_argument (Qsequencep
, arg
);
340 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
344 concat (nargs
, args
, target_type
, last_special
)
347 enum Lisp_Type target_type
;
352 register Lisp_Object tail
;
353 register Lisp_Object
this;
357 Lisp_Object last_tail
;
360 /* In append, the last arg isn't treated like the others */
361 if (last_special
&& nargs
> 0)
364 last_tail
= args
[nargs
];
369 for (argnum
= 0; argnum
< nargs
; argnum
++)
372 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
373 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
376 args
[argnum
] = Fnumber_to_string (this);
378 args
[argnum
] = wrong_type_argument (Qsequencep
, this);
382 for (argnum
= 0, leni
= 0; argnum
< nargs
; argnum
++)
385 len
= Flength (this);
386 leni
+= XFASTINT (len
);
389 XSETFASTINT (len
, leni
);
391 if (target_type
== Lisp_Cons
)
392 val
= Fmake_list (len
, Qnil
);
393 else if (target_type
== Lisp_Vectorlike
)
394 val
= Fmake_vector (len
, Qnil
);
396 val
= Fmake_string (len
, len
);
398 /* In append, if all but last arg are nil, return last arg */
399 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
403 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
409 for (argnum
= 0; argnum
< nargs
; argnum
++)
413 register unsigned int thisindex
= 0;
417 thislen
= Flength (this), thisleni
= XINT (thislen
);
419 if (STRINGP (this) && STRINGP (val
)
420 && ! NULL_INTERVAL_P (XSTRING (this)->intervals
))
422 copy_text_properties (make_number (0), thislen
, this,
423 make_number (toindex
), val
, Qnil
);
428 register Lisp_Object elt
;
430 /* Fetch next element of `this' arg into `elt', or break if
431 `this' is exhausted. */
432 if (NILP (this)) break;
434 elt
= Fcar (this), this = Fcdr (this);
437 if (thisindex
>= thisleni
) break;
439 XSETFASTINT (elt
, XSTRING (this)->data
[thisindex
++]);
440 else if (BOOL_VECTOR_P (this))
443 = ((XBOOL_VECTOR (this)->size
+ BITS_PER_CHAR
- 1)
446 byte
= XBOOL_VECTOR (val
)->data
[thisindex
/ BITS_PER_CHAR
];
447 if (byte
& (1 << (thisindex
% BITS_PER_CHAR
)))
453 elt
= XVECTOR (this)->contents
[thisindex
++];
456 /* Store into result */
459 XCONS (tail
)->car
= elt
;
461 tail
= XCONS (tail
)->cdr
;
463 else if (VECTORP (val
))
464 XVECTOR (val
)->contents
[toindex
++] = elt
;
467 while (!INTEGERP (elt
))
468 elt
= wrong_type_argument (Qintegerp
, elt
);
470 #ifdef MASSC_REGISTER_BUG
471 /* Even removing all "register"s doesn't disable this bug!
472 Nothing simpler than this seems to work. */
473 unsigned char *p
= & XSTRING (val
)->data
[toindex
++];
476 XSTRING (val
)->data
[toindex
++] = XINT (elt
);
483 XCONS (prev
)->cdr
= last_tail
;
488 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
489 "Return a copy of ALIST.\n\
490 This is an alist which represents the same mapping from objects to objects,\n\
491 but does not share the alist structure with ALIST.\n\
492 The objects mapped (cars and cdrs of elements of the alist)\n\
493 are shared, however.\n\
494 Elements of ALIST that are not conses are also shared.")
498 register Lisp_Object tem
;
500 CHECK_LIST (alist
, 0);
503 alist
= concat (1, &alist
, Lisp_Cons
, 0);
504 for (tem
= alist
; CONSP (tem
); tem
= XCONS (tem
)->cdr
)
506 register Lisp_Object car
;
507 car
= XCONS (tem
)->car
;
510 XCONS (tem
)->car
= Fcons (XCONS (car
)->car
, XCONS (car
)->cdr
);
515 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
516 "Return a substring of STRING, starting at index FROM and ending before TO.\n\
517 TO may be nil or omitted; then the substring runs to the end of STRING.\n\
518 If FROM or TO is negative, it counts from the end.\n\
520 This function allows vectors as well as strings.")
523 register Lisp_Object from
, to
;
528 if (! (STRINGP (string
) || VECTORP (string
)))
529 wrong_type_argument (Qarrayp
, string
);
531 CHECK_NUMBER (from
, 1);
533 if (STRINGP (string
))
534 size
= XSTRING (string
)->size
;
536 size
= XVECTOR (string
)->size
;
541 CHECK_NUMBER (to
, 2);
544 XSETINT (from
, XINT (from
) + size
);
546 XSETINT (to
, XINT (to
) + size
);
547 if (!(0 <= XINT (from
) && XINT (from
) <= XINT (to
)
548 && XINT (to
) <= size
))
549 args_out_of_range_3 (string
, from
, to
);
551 if (STRINGP (string
))
553 res
= make_string (XSTRING (string
)->data
+ XINT (from
),
554 XINT (to
) - XINT (from
));
555 copy_text_properties (from
, to
, string
, make_number (0), res
, Qnil
);
558 res
= Fvector (XINT (to
) - XINT (from
),
559 XVECTOR (string
)->contents
+ XINT (from
));
564 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
565 "Take cdr N times on LIST, returns the result.")
568 register Lisp_Object list
;
573 for (i
= 0; i
< num
&& !NILP (list
); i
++)
581 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
582 "Return the Nth element of LIST.\n\
583 N counts from zero. If LIST is not that long, nil is returned.")
587 return Fcar (Fnthcdr (n
, list
));
590 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
591 "Return element of SEQUENCE at index N.")
593 register Lisp_Object sequence
, n
;
598 if (CONSP (sequence
) || NILP (sequence
))
599 return Fcar (Fnthcdr (n
, sequence
));
600 else if (STRINGP (sequence
) || VECTORP (sequence
)
601 || BOOL_VECTOR_P (sequence
) || CHAR_TABLE_P (sequence
))
602 return Faref (sequence
, n
);
604 sequence
= wrong_type_argument (Qsequencep
, sequence
);
608 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
609 "Return non-nil if ELT is an element of LIST. Comparison done with `equal'.\n\
610 The value is actually the tail of LIST whose car is ELT.")
612 register Lisp_Object elt
;
615 register Lisp_Object tail
;
616 for (tail
= list
; !NILP (tail
); tail
= Fcdr (tail
))
618 register Lisp_Object tem
;
620 if (! NILP (Fequal (elt
, tem
)))
627 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
628 "Return non-nil if ELT is an element of LIST. Comparison done with EQ.\n\
629 The value is actually the tail of LIST whose car is ELT.")
631 register Lisp_Object elt
;
634 register Lisp_Object tail
;
635 for (tail
= list
; !NILP (tail
); tail
= Fcdr (tail
))
637 register Lisp_Object tem
;
639 if (EQ (elt
, tem
)) return tail
;
645 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
646 "Return non-nil if KEY is `eq' to the car of an element of LIST.\n\
647 The value is actually the element of LIST whose car is KEY.\n\
648 Elements of LIST that are not conses are ignored.")
650 register Lisp_Object key
;
653 register Lisp_Object tail
;
654 for (tail
= list
; !NILP (tail
); tail
= Fcdr (tail
))
656 register Lisp_Object elt
, tem
;
658 if (!CONSP (elt
)) continue;
660 if (EQ (key
, tem
)) return elt
;
666 /* Like Fassq but never report an error and do not allow quits.
667 Use only on lists known never to be circular. */
670 assq_no_quit (key
, list
)
671 register Lisp_Object key
;
674 register Lisp_Object tail
;
675 for (tail
= list
; CONSP (tail
); tail
= Fcdr (tail
))
677 register Lisp_Object elt
, tem
;
679 if (!CONSP (elt
)) continue;
681 if (EQ (key
, tem
)) return elt
;
686 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
687 "Return non-nil if KEY is `equal' to the car of an element of LIST.\n\
688 The value is actually the element of LIST whose car equals KEY.")
690 register Lisp_Object key
;
693 register Lisp_Object tail
;
694 for (tail
= list
; !NILP (tail
); tail
= Fcdr (tail
))
696 register Lisp_Object elt
, tem
;
698 if (!CONSP (elt
)) continue;
699 tem
= Fequal (Fcar (elt
), key
);
700 if (!NILP (tem
)) return elt
;
706 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
707 "Return non-nil if ELT is `eq' to the cdr of an element of LIST.\n\
708 The value is actually the element of LIST whose cdr is ELT.")
710 register Lisp_Object key
;
713 register Lisp_Object tail
;
714 for (tail
= list
; !NILP (tail
); tail
= Fcdr (tail
))
716 register Lisp_Object elt
, tem
;
718 if (!CONSP (elt
)) continue;
720 if (EQ (key
, tem
)) return elt
;
726 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
727 "Return non-nil if KEY is `equal' to the cdr of an element of LIST.\n\
728 The value is actually the element of LIST whose cdr equals KEY.")
730 register Lisp_Object key
;
733 register Lisp_Object tail
;
734 for (tail
= list
; !NILP (tail
); tail
= Fcdr (tail
))
736 register Lisp_Object elt
, tem
;
738 if (!CONSP (elt
)) continue;
739 tem
= Fequal (Fcdr (elt
), key
);
740 if (!NILP (tem
)) return elt
;
746 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
747 "Delete by side effect any occurrences of ELT as a member of LIST.\n\
748 The modified LIST is returned. Comparison is done with `eq'.\n\
749 If the first member of LIST is ELT, there is no way to remove it by side effect;\n\
750 therefore, write `(setq foo (delq element foo))'\n\
751 to be sure of changing the value of `foo'.")
753 register Lisp_Object elt
;
756 register Lisp_Object tail
, prev
;
757 register Lisp_Object tem
;
769 Fsetcdr (prev
, Fcdr (tail
));
779 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
780 "Delete by side effect any occurrences of ELT as a member of LIST.\n\
781 The modified LIST is returned. Comparison is done with `equal'.\n\
782 If the first member of LIST is ELT, deleting it is not a side effect;\n\
783 it is simply using a different list.\n\
784 Therefore, write `(setq foo (delete element foo))'\n\
785 to be sure of changing the value of `foo'.")
787 register Lisp_Object elt
;
790 register Lisp_Object tail
, prev
;
791 register Lisp_Object tem
;
798 if (! NILP (Fequal (elt
, tem
)))
803 Fsetcdr (prev
, Fcdr (tail
));
813 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
814 "Reverse LIST by modifying cdr pointers.\n\
815 Returns the beginning of the reversed list.")
819 register Lisp_Object prev
, tail
, next
;
821 if (NILP (list
)) return list
;
828 Fsetcdr (tail
, prev
);
835 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
836 "Reverse LIST, copying. Returns the beginning of the reversed list.\n\
837 See also the function `nreverse', which is used more often.")
842 register Lisp_Object
*vec
;
843 register Lisp_Object tail
;
846 length
= Flength (list
);
847 vec
= (Lisp_Object
*) alloca (XINT (length
) * sizeof (Lisp_Object
));
848 for (i
= XINT (length
) - 1, tail
= list
; i
>= 0; i
--, tail
= Fcdr (tail
))
849 vec
[i
] = Fcar (tail
);
851 return Flist (XINT (length
), vec
);
854 Lisp_Object
merge ();
856 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
857 "Sort LIST, stably, comparing elements using PREDICATE.\n\
858 Returns the sorted list. LIST is modified by side effects.\n\
859 PREDICATE is called with two elements of LIST, and should return T\n\
860 if the first element is \"less\" than the second.")
862 Lisp_Object list
, predicate
;
864 Lisp_Object front
, back
;
865 register Lisp_Object len
, tem
;
866 struct gcpro gcpro1
, gcpro2
;
870 len
= Flength (list
);
875 XSETINT (len
, (length
/ 2) - 1);
876 tem
= Fnthcdr (len
, list
);
880 GCPRO2 (front
, back
);
881 front
= Fsort (front
, predicate
);
882 back
= Fsort (back
, predicate
);
884 return merge (front
, back
, predicate
);
888 merge (org_l1
, org_l2
, pred
)
889 Lisp_Object org_l1
, org_l2
;
893 register Lisp_Object tail
;
895 register Lisp_Object l1
, l2
;
896 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
903 /* It is sufficient to protect org_l1 and org_l2.
904 When l1 and l2 are updated, we copy the new values
905 back into the org_ vars. */
906 GCPRO4 (org_l1
, org_l2
, pred
, value
);
926 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
948 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
949 "Extract a value from a property list.\n\
950 PLIST is a property list, which is a list of the form\n\
951 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value\n\
952 corresponding to the given PROP, or nil if PROP is not\n\
953 one of the properties on the list.")
956 register Lisp_Object prop
;
958 register Lisp_Object tail
;
959 for (tail
= plist
; !NILP (tail
); tail
= Fcdr (Fcdr (tail
)))
961 register Lisp_Object tem
;
964 return Fcar (Fcdr (tail
));
969 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
970 "Return the value of SYMBOL's PROPNAME property.\n\
971 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'.")
973 Lisp_Object symbol
, propname
;
975 CHECK_SYMBOL (symbol
, 0);
976 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
979 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
980 "Change value in PLIST of PROP to VAL.\n\
981 PLIST is a property list, which is a list of the form\n\
982 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.\n\
983 If PROP is already a property on the list, its value is set to VAL,\n\
984 otherwise the new PROP VAL pair is added. The new plist is returned;\n\
985 use `(setq x (plist-put x prop val))' to be sure to use the new value.\n\
986 The PLIST is modified by side effects.")
989 register Lisp_Object prop
;
992 register Lisp_Object tail
, prev
;
995 for (tail
= plist
; CONSP (tail
) && CONSP (XCONS (tail
)->cdr
);
996 tail
= XCONS (XCONS (tail
)->cdr
)->cdr
)
998 if (EQ (prop
, XCONS (tail
)->car
))
1000 Fsetcar (XCONS (tail
)->cdr
, val
);
1005 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
1009 Fsetcdr (XCONS (prev
)->cdr
, newcell
);
1013 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
1014 "Store SYMBOL's PROPNAME property with value VALUE.\n\
1015 It can be retrieved with `(get SYMBOL PROPNAME)'.")
1016 (symbol
, propname
, value
)
1017 Lisp_Object symbol
, propname
, value
;
1019 CHECK_SYMBOL (symbol
, 0);
1020 XSYMBOL (symbol
)->plist
1021 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
1025 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
1026 "T if two Lisp objects have similar structure and contents.\n\
1027 They must have the same data type.\n\
1028 Conses are compared by comparing the cars and the cdrs.\n\
1029 Vectors and strings are compared element by element.\n\
1030 Numbers are compared by value, but integers cannot equal floats.\n\
1031 (Use `=' if you want integers and floats to be able to be equal.)\n\
1032 Symbols must match exactly.")
1034 register Lisp_Object o1
, o2
;
1036 return internal_equal (o1
, o2
, 0) ? Qt
: Qnil
;
1040 internal_equal (o1
, o2
, depth
)
1041 register Lisp_Object o1
, o2
;
1045 error ("Stack overflow in equal");
1051 if (XTYPE (o1
) != XTYPE (o2
))
1056 #ifdef LISP_FLOAT_TYPE
1058 return (extract_float (o1
) == extract_float (o2
));
1062 if (!internal_equal (XCONS (o1
)->car
, XCONS (o2
)->car
, depth
+ 1))
1064 o1
= XCONS (o1
)->cdr
;
1065 o2
= XCONS (o2
)->cdr
;
1069 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
1073 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o1
),
1075 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o1
),
1078 o1
= XOVERLAY (o1
)->plist
;
1079 o2
= XOVERLAY (o2
)->plist
;
1084 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
1085 && (XMARKER (o1
)->buffer
== 0
1086 || XMARKER (o1
)->bufpos
== XMARKER (o2
)->bufpos
));
1090 case Lisp_Vectorlike
:
1092 register int i
, size
;
1093 size
= XVECTOR (o1
)->size
;
1094 /* Pseudovectors have the type encoded in the size field, so this test
1095 actually checks that the objects have the same type as well as the
1097 if (XVECTOR (o2
)->size
!= size
)
1099 /* Boolvectors are compared much like strings. */
1100 if (BOOL_VECTOR_P (o1
))
1103 = (XBOOL_VECTOR (o1
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
1105 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
1107 if (bcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
1113 /* Aside from them, only true vectors, char-tables, and compiled
1114 functions are sensible to compare, so eliminate the others now. */
1115 if (size
& PSEUDOVECTOR_FLAG
)
1117 if (!(size
& (PVEC_COMPILED
| PVEC_CHAR_TABLE
)))
1119 size
&= PSEUDOVECTOR_SIZE_MASK
;
1121 for (i
= 0; i
< size
; i
++)
1124 v1
= XVECTOR (o1
)->contents
[i
];
1125 v2
= XVECTOR (o2
)->contents
[i
];
1126 if (!internal_equal (v1
, v2
, depth
+ 1))
1134 if (XSTRING (o1
)->size
!= XSTRING (o2
)->size
)
1136 if (bcmp (XSTRING (o1
)->data
, XSTRING (o2
)->data
,
1137 XSTRING (o1
)->size
))
1139 #ifdef USE_TEXT_PROPERTIES
1140 /* If the strings have intervals, verify they match;
1141 if not, they are unequal. */
1142 if ((XSTRING (o1
)->intervals
!= 0 || XSTRING (o2
)->intervals
!= 0)
1143 && ! compare_string_intervals (o1
, o2
))
1151 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
1152 "Store each element of ARRAY with ITEM.\n\
1153 ARRAY is a vector, string, char-table, or bool-vector.")
1155 Lisp_Object array
, item
;
1157 register int size
, index
, charval
;
1159 if (VECTORP (array
))
1161 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
1162 size
= XVECTOR (array
)->size
;
1163 for (index
= 0; index
< size
; index
++)
1166 else if (CHAR_TABLE_P (array
))
1168 register Lisp_Object
*p
= XCHAR_TABLE (array
)->contents
;
1169 size
= CHAR_TABLE_ORDINARY_SLOTS
;
1170 for (index
= 0; index
< size
; index
++)
1172 XCHAR_TABLE (array
)->defalt
= Qnil
;
1174 else if (STRINGP (array
))
1176 register unsigned char *p
= XSTRING (array
)->data
;
1177 CHECK_NUMBER (item
, 1);
1178 charval
= XINT (item
);
1179 size
= XSTRING (array
)->size
;
1180 for (index
= 0; index
< size
; index
++)
1183 else if (BOOL_VECTOR_P (array
))
1185 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
1187 = (XBOOL_VECTOR (array
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
1189 charval
= (! NILP (item
) ? -1 : 0);
1190 for (index
= 0; index
< size_in_chars
; index
++)
1195 array
= wrong_type_argument (Qarrayp
, array
);
1201 DEFUN ("char-table-subtype", Fchar_table_subtype
, Schar_table_subtype
,
1203 "Return the subtype of char-table CHAR-TABLE. The value is a symbol.")
1205 Lisp_Object char_table
;
1207 CHECK_CHAR_TABLE (char_table
, 0);
1209 return XCHAR_TABLE (char_table
)->purpose
;
1212 DEFUN ("char-table-parent", Fchar_table_parent
, Schar_table_parent
,
1214 "Return the parent char-table of CHAR-TABLE.\n\
1215 The value is either nil or another char-table.\n\
1216 If CHAR-TABLE holds nil for a given character,\n\
1217 then the actual applicable value is inherited from the parent char-table\n\
1218 \(or from its parents, if necessary).")
1220 Lisp_Object char_table
;
1222 CHECK_CHAR_TABLE (char_table
, 0);
1224 return XCHAR_TABLE (char_table
)->parent
;
1227 DEFUN ("set-char-table-parent", Fset_char_table_parent
, Sset_char_table_parent
,
1229 "Set the parent char-table of CHAR-TABLE to PARENT.\n\
1230 PARENT must be either nil or another char-table.")
1231 (char_table
, parent
)
1232 Lisp_Object char_table
, parent
;
1236 CHECK_CHAR_TABLE (char_table
, 0);
1240 CHECK_CHAR_TABLE (parent
, 0);
1242 for (temp
= parent
; !NILP (temp
); temp
= XCHAR_TABLE (temp
)->parent
)
1243 if (EQ (temp
, char_table
))
1244 error ("Attempt to make a chartable be its own parent");
1247 XCHAR_TABLE (char_table
)->parent
= parent
;
1252 DEFUN ("char-table-extra-slot", Fchar_table_extra_slot
, Schar_table_extra_slot
,
1254 "Return the value in extra-slot number N of char-table CHAR-TABLE.")
1256 Lisp_Object char_table
, n
;
1258 CHECK_CHAR_TABLE (char_table
, 1);
1259 CHECK_NUMBER (n
, 2);
1261 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
1262 args_out_of_range (char_table
, n
);
1264 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)];
1267 DEFUN ("set-char-table-extra-slot", Fset_char_table_extra_slot
,
1268 Sset_char_table_extra_slot
,
1270 "Set extra-slot number N of CHAR-TABLE to VALUE.")
1271 (char_table
, n
, value
)
1272 Lisp_Object char_table
, n
, value
;
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
)] = value
;
1283 DEFUN ("char-table-range", Fchar_table_range
, Schar_table_range
,
1285 "Return the value in CHAR-TABLE for a range of characters RANGE.\n\
1286 RANGE should be t (for all characters), nil (for the default value)\n\
1287 a vector which identifies a character set or a row of a character set,\n\
1288 or a character code.")
1290 Lisp_Object char_table
, range
;
1294 CHECK_CHAR_TABLE (char_table
, 0);
1296 if (EQ (range
, Qnil
))
1297 return XCHAR_TABLE (char_table
)->defalt
;
1298 else if (INTEGERP (range
))
1299 return Faref (char_table
, range
);
1300 else if (VECTORP (range
))
1302 for (i
= 0; i
< XVECTOR (range
)->size
- 1; i
++)
1303 char_table
= Faref (char_table
, XVECTOR (range
)->contents
[i
]);
1305 if (EQ (XVECTOR (range
)->contents
[i
], Qnil
))
1306 return XCHAR_TABLE (char_table
)->defalt
;
1308 return Faref (char_table
, XVECTOR (range
)->contents
[i
]);
1311 error ("Invalid RANGE argument to `char-table-range'");
1314 DEFUN ("set-char-table-range", Fset_char_table_range
, Sset_char_table_range
,
1316 "Set the value in CHAR-TABLE for a range of characters RANGE to VALUE.\n\
1317 RANGE should be t (for all characters), nil (for the default value)\n\
1318 a vector which identifies a character set or a row of a character set,\n\
1319 or a character code.")
1320 (char_table
, range
, value
)
1321 Lisp_Object char_table
, range
, value
;
1325 CHECK_CHAR_TABLE (char_table
, 0);
1328 for (i
= 0; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
1329 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
1330 else if (EQ (range
, Qnil
))
1331 XCHAR_TABLE (char_table
)->defalt
= value
;
1332 else if (INTEGERP (range
))
1333 Faset (char_table
, range
, value
);
1334 else if (VECTORP (range
))
1336 for (i
= 0; i
< XVECTOR (range
)->size
- 1; i
++)
1338 Lisp_Object tmp
= Faref (char_table
, XVECTOR (range
)->contents
[i
]);
1341 /* Make this char-table deeper. */
1342 XVECTOR (char_table
)->contents
[XVECTOR (range
)->contents
[i
]]
1343 = tmp
= Fmake_char_table (Qnil
, Qnil
);
1348 if (EQ (XVECTOR (range
)->contents
[i
], Qnil
))
1349 XCHAR_TABLE (char_table
)->defalt
= value
;
1351 Faset (char_table
, XVECTOR (range
)->contents
[i
], value
);
1354 error ("Invalid RANGE argument to `set-char-table-range'");
1359 /* Map C_FUNCTION or FUNCTION over CHARTABLE, calling it for each
1360 character or group of characters that share a value.
1361 DEPTH is the current depth in the originally specified
1362 chartable, and INDICES contains the vector indices
1363 for the levels our callers have descended. */
1366 map_char_table (c_function
, function
, chartable
, depth
, indices
)
1367 Lisp_Object (*c_function
) (), function
, chartable
, *indices
;
1374 from
= 0, to
= CHAR_TABLE_ORDINARY_SLOTS
;
1376 from
= 32, to
= 128;
1377 /* Make INDICES longer if we are about to fill it up. */
1378 if ((depth
% 10) == 9)
1380 Lisp_Object
*new_indices
1381 = (Lisp_Object
*) alloca ((depth
+= 10) * sizeof (Lisp_Object
));
1382 bcopy (indices
, new_indices
, depth
* sizeof (Lisp_Object
));
1383 indices
= new_indices
;
1386 for (i
= from
; i
< to
; i
++)
1390 elt
= XCHAR_TABLE (chartable
)->contents
[i
];
1391 if (CHAR_TABLE_P (elt
))
1392 map_char_table (c_function
, function
, elt
, depth
+ 1, indices
);
1393 else if (c_function
)
1394 (*c_function
) (depth
+ 1, indices
, elt
);
1395 else if (depth
== 0 && i
< 256)
1396 /* This is an ASCII or 8-bit European character. */
1397 call2 (function
, make_number (i
), elt
);
1400 /* This is an entry for multibyte characters. */
1401 unsigned int charset
= XFASTINT (indices
[0]) - 128, c1
, c2
, c
;
1402 if (CHARSET_DEFINED_P (charset
))
1404 c1
= depth
< 1 ? 0 : XFASTINT (indices
[1]);
1405 c2
= depth
< 2 ? 0 : XFASTINT (indices
[2]);
1406 c
= MAKE_NON_ASCII_CHAR (charset
, c1
, c2
);
1407 call2 (function
, make_number (c
), elt
);
1413 DEFUN ("map-char-table", Fmap_char_table
, Smap_char_table
,
1415 "Call FUNCTION for each range of like characters in CHAR-TABLE.\n\
1416 FUNCTION is called with two arguments--a key and a value.\n\
1417 The key is always a possible RANGE argument to `set-char-table-range'.")
1418 (function
, char_table
)
1419 Lisp_Object function
, char_table
;
1422 Lisp_Object
*indices
= (Lisp_Object
*) alloca (10 * sizeof (Lisp_Object
));
1424 map_char_table (NULL
, function
, char_table
, 0, indices
);
1434 Lisp_Object args
[2];
1437 return Fnconc (2, args
);
1439 return Fnconc (2, &s1
);
1440 #endif /* NO_ARG_ARRAY */
1443 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
1444 "Concatenate any number of lists by altering them.\n\
1445 Only the last argument is not altered, and need not be a list.")
1450 register int argnum
;
1451 register Lisp_Object tail
, tem
, val
;
1455 for (argnum
= 0; argnum
< nargs
; argnum
++)
1458 if (NILP (tem
)) continue;
1463 if (argnum
+ 1 == nargs
) break;
1466 tem
= wrong_type_argument (Qlistp
, tem
);
1475 tem
= args
[argnum
+ 1];
1476 Fsetcdr (tail
, tem
);
1478 args
[argnum
+ 1] = tail
;
1484 /* This is the guts of all mapping functions.
1485 Apply fn to each element of seq, one by one,
1486 storing the results into elements of vals, a C vector of Lisp_Objects.
1487 leni is the length of vals, which should also be the length of seq. */
1490 mapcar1 (leni
, vals
, fn
, seq
)
1493 Lisp_Object fn
, seq
;
1495 register Lisp_Object tail
;
1498 struct gcpro gcpro1
, gcpro2
, gcpro3
;
1500 /* Don't let vals contain any garbage when GC happens. */
1501 for (i
= 0; i
< leni
; i
++)
1504 GCPRO3 (dummy
, fn
, seq
);
1506 gcpro1
.nvars
= leni
;
1507 /* We need not explicitly protect `tail' because it is used only on lists, and
1508 1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
1512 for (i
= 0; i
< leni
; i
++)
1514 dummy
= XVECTOR (seq
)->contents
[i
];
1515 vals
[i
] = call1 (fn
, dummy
);
1518 else if (STRINGP (seq
))
1520 for (i
= 0; i
< leni
; i
++)
1522 XSETFASTINT (dummy
, XSTRING (seq
)->data
[i
]);
1523 vals
[i
] = call1 (fn
, dummy
);
1526 else /* Must be a list, since Flength did not get an error */
1529 for (i
= 0; i
< leni
; i
++)
1531 vals
[i
] = call1 (fn
, Fcar (tail
));
1539 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
1540 "Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.\n\
1541 In between each pair of results, stick in SEPARATOR. Thus, \" \" as\n\
1542 SEPARATOR results in spaces between the values returned by FUNCTION.")
1543 (function
, sequence
, separator
)
1544 Lisp_Object function
, sequence
, separator
;
1549 register Lisp_Object
*args
;
1551 struct gcpro gcpro1
;
1553 len
= Flength (sequence
);
1555 nargs
= leni
+ leni
- 1;
1556 if (nargs
< 0) return build_string ("");
1558 args
= (Lisp_Object
*) alloca (nargs
* sizeof (Lisp_Object
));
1561 mapcar1 (leni
, args
, function
, sequence
);
1564 for (i
= leni
- 1; i
>= 0; i
--)
1565 args
[i
+ i
] = args
[i
];
1567 for (i
= 1; i
< nargs
; i
+= 2)
1568 args
[i
] = separator
;
1570 return Fconcat (nargs
, args
);
1573 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
1574 "Apply FUNCTION to each element of SEQUENCE, and make a list of the results.\n\
1575 The result is a list just as long as SEQUENCE.\n\
1576 SEQUENCE may be a list, a vector or a string.")
1577 (function
, sequence
)
1578 Lisp_Object function
, sequence
;
1580 register Lisp_Object len
;
1582 register Lisp_Object
*args
;
1584 len
= Flength (sequence
);
1585 leni
= XFASTINT (len
);
1586 args
= (Lisp_Object
*) alloca (leni
* sizeof (Lisp_Object
));
1588 mapcar1 (leni
, args
, function
, sequence
);
1590 return Flist (leni
, args
);
1593 /* Anything that calls this function must protect from GC! */
1595 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
1596 "Ask user a \"y or n\" question. Return t if answer is \"y\".\n\
1597 Takes one argument, which is the string to display to ask the question.\n\
1598 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.\n\
1599 No confirmation of the answer is requested; a single character is enough.\n\
1600 Also accepts Space to mean yes, or Delete to mean no.")
1604 register Lisp_Object obj
, key
, def
, answer_string
, map
;
1605 register int answer
;
1606 Lisp_Object xprompt
;
1607 Lisp_Object args
[2];
1608 struct gcpro gcpro1
, gcpro2
;
1609 int count
= specpdl_ptr
- specpdl
;
1611 specbind (Qcursor_in_echo_area
, Qt
);
1613 map
= Fsymbol_value (intern ("query-replace-map"));
1615 CHECK_STRING (prompt
, 0);
1617 GCPRO2 (prompt
, xprompt
);
1624 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
1627 Lisp_Object pane
, menu
;
1628 redisplay_preserve_echo_area ();
1629 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
1630 Fcons (Fcons (build_string ("No"), Qnil
),
1632 menu
= Fcons (prompt
, pane
);
1633 obj
= Fx_popup_dialog (Qt
, menu
);
1634 answer
= !NILP (obj
);
1637 #endif /* HAVE_MENUS */
1638 cursor_in_echo_area
= 1;
1639 choose_minibuf_frame ();
1640 message_nolog ("%s(y or n) ", XSTRING (xprompt
)->data
);
1642 if (minibuffer_auto_raise
)
1644 Lisp_Object mini_frame
;
1646 mini_frame
= WINDOW_FRAME (XWINDOW (minibuf_window
));
1648 Fraise_frame (mini_frame
);
1651 obj
= read_filtered_event (1, 0, 0);
1652 cursor_in_echo_area
= 0;
1653 /* If we need to quit, quit with cursor_in_echo_area = 0. */
1656 key
= Fmake_vector (make_number (1), obj
);
1657 def
= Flookup_key (map
, key
, Qt
);
1658 answer_string
= Fsingle_key_description (obj
);
1660 if (EQ (def
, intern ("skip")))
1665 else if (EQ (def
, intern ("act")))
1670 else if (EQ (def
, intern ("recenter")))
1676 else if (EQ (def
, intern ("quit")))
1678 /* We want to exit this command for exit-prefix,
1679 and this is the only way to do it. */
1680 else if (EQ (def
, intern ("exit-prefix")))
1685 /* If we don't clear this, then the next call to read_char will
1686 return quit_char again, and we'll enter an infinite loop. */
1691 if (EQ (xprompt
, prompt
))
1693 args
[0] = build_string ("Please answer y or n. ");
1695 xprompt
= Fconcat (2, args
);
1700 if (! noninteractive
)
1702 cursor_in_echo_area
= -1;
1703 message_nolog ("%s(y or n) %c",
1704 XSTRING (xprompt
)->data
, answer
? 'y' : 'n');
1707 unbind_to (count
, Qnil
);
1708 return answer
? Qt
: Qnil
;
1711 /* This is how C code calls `yes-or-no-p' and allows the user
1714 Anything that calls this function must protect from GC! */
1717 do_yes_or_no_p (prompt
)
1720 return call1 (intern ("yes-or-no-p"), prompt
);
1723 /* Anything that calls this function must protect from GC! */
1725 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
1726 "Ask user a yes-or-no question. Return t if answer is yes.\n\
1727 Takes one argument, which is the string to display to ask the question.\n\
1728 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.\n\
1729 The user must confirm the answer with RET,\n\
1730 and can edit it until it has been confirmed.")
1734 register Lisp_Object ans
;
1735 Lisp_Object args
[2];
1736 struct gcpro gcpro1
;
1739 CHECK_STRING (prompt
, 0);
1742 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
1745 Lisp_Object pane
, menu
, obj
;
1746 redisplay_preserve_echo_area ();
1747 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
1748 Fcons (Fcons (build_string ("No"), Qnil
),
1751 menu
= Fcons (prompt
, pane
);
1752 obj
= Fx_popup_dialog (Qt
, menu
);
1756 #endif /* HAVE_MENUS */
1759 args
[1] = build_string ("(yes or no) ");
1760 prompt
= Fconcat (2, args
);
1766 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
1767 Qyes_or_no_p_history
));
1768 if (XSTRING (ans
)->size
== 3 && !strcmp (XSTRING (ans
)->data
, "yes"))
1773 if (XSTRING (ans
)->size
== 2 && !strcmp (XSTRING (ans
)->data
, "no"))
1781 message ("Please answer yes or no.");
1782 Fsleep_for (make_number (2), Qnil
);
1786 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 0, 0,
1787 "Return list of 1 minute, 5 minute and 15 minute load averages.\n\
1788 Each of the three load averages is multiplied by 100,\n\
1789 then converted to integer.\n\
1790 If the 5-minute or 15-minute load averages are not available, return a\n\
1791 shortened list, containing only those averages which are available.")
1795 int loads
= getloadavg (load_ave
, 3);
1799 error ("load-average not implemented for this operating system");
1803 ret
= Fcons (make_number ((int) (load_ave
[--loads
] * 100.0)), ret
);
1808 Lisp_Object Vfeatures
;
1810 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 1, 0,
1811 "Returns t if FEATURE is present in this Emacs.\n\
1812 Use this to conditionalize execution of lisp code based on the presence or\n\
1813 absence of emacs or environment extensions.\n\
1814 Use `provide' to declare that a feature is available.\n\
1815 This function looks at the value of the variable `features'.")
1817 Lisp_Object feature
;
1819 register Lisp_Object tem
;
1820 CHECK_SYMBOL (feature
, 0);
1821 tem
= Fmemq (feature
, Vfeatures
);
1822 return (NILP (tem
)) ? Qnil
: Qt
;
1825 DEFUN ("provide", Fprovide
, Sprovide
, 1, 1, 0,
1826 "Announce that FEATURE is a feature of the current Emacs.")
1828 Lisp_Object feature
;
1830 register Lisp_Object tem
;
1831 CHECK_SYMBOL (feature
, 0);
1832 if (!NILP (Vautoload_queue
))
1833 Vautoload_queue
= Fcons (Fcons (Vfeatures
, Qnil
), Vautoload_queue
);
1834 tem
= Fmemq (feature
, Vfeatures
);
1836 Vfeatures
= Fcons (feature
, Vfeatures
);
1837 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
1841 DEFUN ("require", Frequire
, Srequire
, 1, 2, 0,
1842 "If feature FEATURE is not loaded, load it from FILENAME.\n\
1843 If FEATURE is not a member of the list `features', then the feature\n\
1844 is not loaded; so load the file FILENAME.\n\
1845 If FILENAME is omitted, the printname of FEATURE is used as the file name.")
1846 (feature
, file_name
)
1847 Lisp_Object feature
, file_name
;
1849 register Lisp_Object tem
;
1850 CHECK_SYMBOL (feature
, 0);
1851 tem
= Fmemq (feature
, Vfeatures
);
1852 LOADHIST_ATTACH (Fcons (Qrequire
, feature
));
1855 int count
= specpdl_ptr
- specpdl
;
1857 /* Value saved here is to be restored into Vautoload_queue */
1858 record_unwind_protect (un_autoload
, Vautoload_queue
);
1859 Vautoload_queue
= Qt
;
1861 Fload (NILP (file_name
) ? Fsymbol_name (feature
) : file_name
,
1864 tem
= Fmemq (feature
, Vfeatures
);
1866 error ("Required feature %s was not provided",
1867 XSYMBOL (feature
)->name
->data
);
1869 /* Once loading finishes, don't undo it. */
1870 Vautoload_queue
= Qt
;
1871 feature
= unbind_to (count
, feature
);
1878 Qstring_lessp
= intern ("string-lessp");
1879 staticpro (&Qstring_lessp
);
1880 Qprovide
= intern ("provide");
1881 staticpro (&Qprovide
);
1882 Qrequire
= intern ("require");
1883 staticpro (&Qrequire
);
1884 Qyes_or_no_p_history
= intern ("yes-or-no-p-history");
1885 staticpro (&Qyes_or_no_p_history
);
1886 Qcursor_in_echo_area
= intern ("cursor-in-echo-area");
1887 staticpro (&Qcursor_in_echo_area
);
1889 Fset (Qyes_or_no_p_history
, Qnil
);
1891 DEFVAR_LISP ("features", &Vfeatures
,
1892 "A list of symbols which are the features of the executing emacs.\n\
1893 Used by `featurep' and `require', and altered by `provide'.");
1896 defsubr (&Sidentity
);
1899 defsubr (&Ssafe_length
);
1900 defsubr (&Sstring_equal
);
1901 defsubr (&Sstring_lessp
);
1904 defsubr (&Svconcat
);
1905 defsubr (&Scopy_sequence
);
1906 defsubr (&Scopy_alist
);
1907 defsubr (&Ssubstring
);
1919 defsubr (&Snreverse
);
1920 defsubr (&Sreverse
);
1922 defsubr (&Splist_get
);
1924 defsubr (&Splist_put
);
1927 defsubr (&Sfillarray
);
1928 defsubr (&Schar_table_subtype
);
1929 defsubr (&Schar_table_parent
);
1930 defsubr (&Sset_char_table_parent
);
1931 defsubr (&Schar_table_extra_slot
);
1932 defsubr (&Sset_char_table_extra_slot
);
1933 defsubr (&Schar_table_range
);
1934 defsubr (&Sset_char_table_range
);
1935 defsubr (&Smap_char_table
);
1938 defsubr (&Smapconcat
);
1939 defsubr (&Sy_or_n_p
);
1940 defsubr (&Syes_or_no_p
);
1941 defsubr (&Sload_average
);
1942 defsubr (&Sfeaturep
);
1943 defsubr (&Srequire
);
1944 defsubr (&Sprovide
);