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. */
34 #include "intervals.h"
37 #define NULL (void *)0
40 extern Lisp_Object
Flookup_key ();
42 Lisp_Object Qstring_lessp
, Qprovide
, Qrequire
;
43 Lisp_Object Qyes_or_no_p_history
;
44 Lisp_Object Qcursor_in_echo_area
;
46 static int internal_equal ();
48 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
49 "Return the argument unchanged.")
56 extern long get_random ();
57 extern void seed_random ();
60 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
61 "Return a pseudo-random number.\n\
62 All integers representable in Lisp are equally likely.\n\
63 On most systems, this is 28 bits' worth.\n\
64 With positive integer argument N, return random number in interval [0,N).\n\
65 With argument t, set the random number seed from the current time and pid.")
70 Lisp_Object lispy_val
;
71 unsigned long denominator
;
74 seed_random (getpid () + time (NULL
));
75 if (NATNUMP (n
) && XFASTINT (n
) != 0)
77 /* Try to take our random number from the higher bits of VAL,
78 not the lower, since (says Gentzel) the low bits of `random'
79 are less random than the higher ones. We do this by using the
80 quotient rather than the remainder. At the high end of the RNG
81 it's possible to get a quotient larger than n; discarding
82 these values eliminates the bias that would otherwise appear
83 when using a large n. */
84 denominator
= ((unsigned long)1 << VALBITS
) / XFASTINT (n
);
86 val
= get_random () / denominator
;
87 while (val
>= XFASTINT (n
));
91 XSETINT (lispy_val
, val
);
95 /* Random data-structure functions */
97 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
98 "Return the length of vector, list or string SEQUENCE.\n\
99 A byte-code function object is also allowed.")
101 register Lisp_Object sequence
;
103 register Lisp_Object tail
, val
;
107 if (STRINGP (sequence
))
108 XSETFASTINT (val
, XSTRING (sequence
)->size
);
109 else if (VECTORP (sequence
))
110 XSETFASTINT (val
, XVECTOR (sequence
)->size
);
111 else if (CHAR_TABLE_P (sequence
))
112 XSETFASTINT (val
, CHAR_TABLE_ORDINARY_SLOTS
);
113 else if (BOOL_VECTOR_P (sequence
))
114 XSETFASTINT (val
, XBOOL_VECTOR (sequence
)->size
);
115 else if (COMPILEDP (sequence
))
116 XSETFASTINT (val
, XVECTOR (sequence
)->size
& PSEUDOVECTOR_SIZE_MASK
);
117 else if (CONSP (sequence
))
119 for (i
= 0, tail
= sequence
; !NILP (tail
); i
++)
125 XSETFASTINT (val
, i
);
127 else if (NILP (sequence
))
128 XSETFASTINT (val
, 0);
131 sequence
= wrong_type_argument (Qsequencep
, sequence
);
137 /* This does not check for quits. That is safe
138 since it must terminate. */
140 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
141 "Return the length of a list, but avoid error or infinite loop.\n\
142 This function never gets an error. If LIST is not really a list,\n\
143 it returns 0. If LIST is circular, it returns a finite value\n\
144 which is at least the number of distinct elements.")
148 Lisp_Object tail
, halftail
, length
;
151 /* halftail is used to detect circular lists. */
153 for (tail
= list
; CONSP (tail
); tail
= XCONS (tail
)->cdr
)
155 if (EQ (tail
, halftail
) && len
!= 0)
159 halftail
= XCONS (halftail
)->cdr
;
162 XSETINT (length
, len
);
166 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
167 "T if two strings have identical contents.\n\
168 Case is significant, but text properties are ignored.\n\
169 Symbols are also allowed; their print names are used instead.")
171 register Lisp_Object s1
, s2
;
174 XSETSTRING (s1
, XSYMBOL (s1
)->name
);
176 XSETSTRING (s2
, XSYMBOL (s2
)->name
);
177 CHECK_STRING (s1
, 0);
178 CHECK_STRING (s2
, 1);
180 if (XSTRING (s1
)->size
!= XSTRING (s2
)->size
||
181 bcmp (XSTRING (s1
)->data
, XSTRING (s2
)->data
, XSTRING (s1
)->size
))
186 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
187 "T if first arg string is less than second in lexicographic order.\n\
188 Case is significant.\n\
189 Symbols are also allowed; their print names are used instead.")
191 register Lisp_Object s1
, s2
;
194 register unsigned char *p1
, *p2
;
198 XSETSTRING (s1
, XSYMBOL (s1
)->name
);
200 XSETSTRING (s2
, XSYMBOL (s2
)->name
);
201 CHECK_STRING (s1
, 0);
202 CHECK_STRING (s2
, 1);
204 p1
= XSTRING (s1
)->data
;
205 p2
= XSTRING (s2
)->data
;
206 end
= XSTRING (s1
)->size
;
207 if (end
> XSTRING (s2
)->size
)
208 end
= XSTRING (s2
)->size
;
210 for (i
= 0; i
< end
; i
++)
213 return p1
[i
] < p2
[i
] ? Qt
: Qnil
;
215 return i
< XSTRING (s2
)->size
? Qt
: Qnil
;
218 static Lisp_Object
concat ();
229 return concat (2, args
, Lisp_String
, 0);
231 return concat (2, &s1
, Lisp_String
, 0);
232 #endif /* NO_ARG_ARRAY */
238 Lisp_Object s1
, s2
, s3
;
245 return concat (3, args
, Lisp_String
, 0);
247 return concat (3, &s1
, Lisp_String
, 0);
248 #endif /* NO_ARG_ARRAY */
251 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
252 "Concatenate all the arguments and make the result a list.\n\
253 The result is a list whose elements are the elements of all the arguments.\n\
254 Each argument may be a list, vector or string.\n\
255 The last argument is not copied, just used as the tail of the new list.")
260 return concat (nargs
, args
, Lisp_Cons
, 1);
263 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
264 "Concatenate all the arguments and make the result a string.\n\
265 The result is a string whose elements are the elements of all the arguments.\n\
266 Each argument may be a string or a list or vector of characters (integers).\n\
268 Do not use individual integers as arguments!\n\
269 The behavior of `concat' in that case will be changed later!\n\
270 If your program passes an integer as an argument to `concat',\n\
271 you should change it right away not to do so.")
276 return concat (nargs
, args
, Lisp_String
, 0);
279 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
280 "Concatenate all the arguments and make the result a vector.\n\
281 The result is a vector whose elements are the elements of all the arguments.\n\
282 Each argument may be a list, vector or string.")
287 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
290 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
291 "Return a copy of a list, vector or string.\n\
292 The elements of a list or vector are not copied; they are shared\n\
297 if (NILP (arg
)) return arg
;
299 if (CHAR_TABLE_P (arg
))
304 /* Calculate the number of extra slots. */
305 size
= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (arg
));
306 copy
= Fmake_char_table (XCHAR_TABLE (arg
)->purpose
, Qnil
);
307 /* Copy all the slots, including the extra ones. */
308 bcopy (XCHAR_TABLE (arg
)->contents
, XCHAR_TABLE (copy
)->contents
,
309 (XCHAR_TABLE (arg
)->size
& PSEUDOVECTOR_SIZE_MASK
) * sizeof (Lisp_Object
));
311 /* Recursively copy any char-tables in the ordinary slots. */
312 for (i
= 0; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
313 if (CHAR_TABLE_P (XCHAR_TABLE (arg
)->contents
[i
]))
314 XCHAR_TABLE (copy
)->contents
[i
]
315 = Fcopy_sequence (XCHAR_TABLE (copy
)->contents
[i
]);
320 if (BOOL_VECTOR_P (arg
))
324 = (XBOOL_VECTOR (arg
)->size
+ BITS_PER_CHAR
) / BITS_PER_CHAR
;
326 val
= Fmake_bool_vector (Flength (arg
), Qnil
);
327 bcopy (XBOOL_VECTOR (arg
)->data
, XBOOL_VECTOR (val
)->data
,
332 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
333 arg
= wrong_type_argument (Qsequencep
, arg
);
334 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
338 concat (nargs
, args
, target_type
, last_special
)
341 enum Lisp_Type target_type
;
346 register Lisp_Object tail
;
347 register Lisp_Object
this;
351 Lisp_Object last_tail
;
354 /* In append, the last arg isn't treated like the others */
355 if (last_special
&& nargs
> 0)
358 last_tail
= args
[nargs
];
363 for (argnum
= 0; argnum
< nargs
; argnum
++)
366 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
367 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
370 args
[argnum
] = Fnumber_to_string (this);
372 args
[argnum
] = wrong_type_argument (Qsequencep
, this);
376 for (argnum
= 0, leni
= 0; argnum
< nargs
; argnum
++)
379 len
= Flength (this);
380 leni
+= XFASTINT (len
);
383 XSETFASTINT (len
, leni
);
385 if (target_type
== Lisp_Cons
)
386 val
= Fmake_list (len
, Qnil
);
387 else if (target_type
== Lisp_Vectorlike
)
388 val
= Fmake_vector (len
, Qnil
);
390 val
= Fmake_string (len
, len
);
392 /* In append, if all but last arg are nil, return last arg */
393 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
397 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
403 for (argnum
= 0; argnum
< nargs
; argnum
++)
407 register int thisindex
= 0;
411 thislen
= Flength (this), thisleni
= XINT (thislen
);
413 if (STRINGP (this) && STRINGP (val
)
414 && ! NULL_INTERVAL_P (XSTRING (this)->intervals
))
416 copy_text_properties (make_number (0), thislen
, this,
417 make_number (toindex
), val
, Qnil
);
422 register Lisp_Object elt
;
424 /* Fetch next element of `this' arg into `elt', or break if
425 `this' is exhausted. */
426 if (NILP (this)) break;
428 elt
= Fcar (this), this = Fcdr (this);
431 if (thisindex
>= thisleni
) break;
433 XSETFASTINT (elt
, XSTRING (this)->data
[thisindex
++]);
434 else if (BOOL_VECTOR_P (this))
437 = ((XBOOL_VECTOR (this)->size
+ BITS_PER_CHAR
)
440 byte
= XBOOL_VECTOR (val
)->data
[thisindex
/ BITS_PER_CHAR
];
441 if (byte
& (1 << thisindex
))
447 elt
= XVECTOR (this)->contents
[thisindex
++];
450 /* Store into result */
453 XCONS (tail
)->car
= elt
;
455 tail
= XCONS (tail
)->cdr
;
457 else if (VECTORP (val
))
458 XVECTOR (val
)->contents
[toindex
++] = elt
;
461 while (!INTEGERP (elt
))
462 elt
= wrong_type_argument (Qintegerp
, elt
);
464 #ifdef MASSC_REGISTER_BUG
465 /* Even removing all "register"s doesn't disable this bug!
466 Nothing simpler than this seems to work. */
467 unsigned char *p
= & XSTRING (val
)->data
[toindex
++];
470 XSTRING (val
)->data
[toindex
++] = XINT (elt
);
477 XCONS (prev
)->cdr
= last_tail
;
482 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
483 "Return a copy of ALIST.\n\
484 This is an alist which represents the same mapping from objects to objects,\n\
485 but does not share the alist structure with ALIST.\n\
486 The objects mapped (cars and cdrs of elements of the alist)\n\
487 are shared, however.\n\
488 Elements of ALIST that are not conses are also shared.")
492 register Lisp_Object tem
;
494 CHECK_LIST (alist
, 0);
497 alist
= concat (1, &alist
, Lisp_Cons
, 0);
498 for (tem
= alist
; CONSP (tem
); tem
= XCONS (tem
)->cdr
)
500 register Lisp_Object car
;
501 car
= XCONS (tem
)->car
;
504 XCONS (tem
)->car
= Fcons (XCONS (car
)->car
, XCONS (car
)->cdr
);
509 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
510 "Return a substring of STRING, starting at index FROM and ending before TO.\n\
511 TO may be nil or omitted; then the substring runs to the end of STRING.\n\
512 If FROM or TO is negative, it counts from the end.\n\
514 This function allows vectors as well as strings.")
517 register Lisp_Object from
, to
;
522 if (! (STRINGP (string
) || VECTORP (string
)))
523 wrong_type_argument (Qarrayp
, string
);
525 CHECK_NUMBER (from
, 1);
527 if (STRINGP (string
))
528 size
= XSTRING (string
)->size
;
530 size
= XVECTOR (string
)->size
;
535 CHECK_NUMBER (to
, 2);
538 XSETINT (from
, XINT (from
) + size
);
540 XSETINT (to
, XINT (to
) + size
);
541 if (!(0 <= XINT (from
) && XINT (from
) <= XINT (to
)
542 && XINT (to
) <= size
))
543 args_out_of_range_3 (string
, from
, to
);
545 if (STRINGP (string
))
547 res
= make_string (XSTRING (string
)->data
+ XINT (from
),
548 XINT (to
) - XINT (from
));
549 copy_text_properties (from
, to
, string
, make_number (0), res
, Qnil
);
552 res
= Fvector (XINT (to
) - XINT (from
),
553 XVECTOR (string
)->contents
+ XINT (from
));
558 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
559 "Take cdr N times on LIST, returns the result.")
562 register Lisp_Object list
;
567 for (i
= 0; i
< num
&& !NILP (list
); i
++)
575 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
576 "Return the Nth element of LIST.\n\
577 N counts from zero. If LIST is not that long, nil is returned.")
581 return Fcar (Fnthcdr (n
, list
));
584 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
585 "Return element of SEQUENCE at index N.")
587 register Lisp_Object sequence
, n
;
592 if (CONSP (sequence
) || NILP (sequence
))
593 return Fcar (Fnthcdr (n
, sequence
));
594 else if (STRINGP (sequence
) || VECTORP (sequence
)
595 || BOOL_VECTOR_P (sequence
) || CHAR_TABLE_P (sequence
))
596 return Faref (sequence
, n
);
598 sequence
= wrong_type_argument (Qsequencep
, sequence
);
602 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
603 "Return non-nil if ELT is an element of LIST. Comparison done with `equal'.\n\
604 The value is actually the tail of LIST whose car is ELT.")
606 register Lisp_Object elt
;
609 register Lisp_Object tail
;
610 for (tail
= list
; !NILP (tail
); tail
= Fcdr (tail
))
612 register Lisp_Object tem
;
614 if (! NILP (Fequal (elt
, tem
)))
621 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
622 "Return non-nil if ELT is an element of LIST. Comparison done with EQ.\n\
623 The value is actually the tail of LIST whose car is ELT.")
625 register Lisp_Object elt
;
628 register Lisp_Object tail
;
629 for (tail
= list
; !NILP (tail
); tail
= Fcdr (tail
))
631 register Lisp_Object tem
;
633 if (EQ (elt
, tem
)) return tail
;
639 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
640 "Return non-nil if KEY is `eq' to the car of an element of LIST.\n\
641 The value is actually the element of LIST whose car is KEY.\n\
642 Elements of LIST that are not conses are ignored.")
644 register Lisp_Object key
;
647 register Lisp_Object tail
;
648 for (tail
= list
; !NILP (tail
); tail
= Fcdr (tail
))
650 register Lisp_Object elt
, tem
;
652 if (!CONSP (elt
)) continue;
654 if (EQ (key
, tem
)) return elt
;
660 /* Like Fassq but never report an error and do not allow quits.
661 Use only on lists known never to be circular. */
664 assq_no_quit (key
, list
)
665 register Lisp_Object key
;
668 register Lisp_Object tail
;
669 for (tail
= list
; CONSP (tail
); tail
= Fcdr (tail
))
671 register Lisp_Object elt
, tem
;
673 if (!CONSP (elt
)) continue;
675 if (EQ (key
, tem
)) return elt
;
680 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
681 "Return non-nil if KEY is `equal' to the car of an element of LIST.\n\
682 The value is actually the element of LIST whose car equals KEY.")
684 register Lisp_Object key
;
687 register Lisp_Object tail
;
688 for (tail
= list
; !NILP (tail
); tail
= Fcdr (tail
))
690 register Lisp_Object elt
, tem
;
692 if (!CONSP (elt
)) continue;
693 tem
= Fequal (Fcar (elt
), key
);
694 if (!NILP (tem
)) return elt
;
700 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
701 "Return non-nil if ELT is `eq' to the cdr of an element of LIST.\n\
702 The value is actually the element of LIST whose cdr is ELT.")
704 register Lisp_Object key
;
707 register Lisp_Object tail
;
708 for (tail
= list
; !NILP (tail
); tail
= Fcdr (tail
))
710 register Lisp_Object elt
, tem
;
712 if (!CONSP (elt
)) continue;
714 if (EQ (key
, tem
)) return elt
;
720 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
721 "Return non-nil if KEY is `equal' to the cdr of an element of LIST.\n\
722 The value is actually the element of LIST whose cdr equals KEY.")
724 register Lisp_Object key
;
727 register Lisp_Object tail
;
728 for (tail
= list
; !NILP (tail
); tail
= Fcdr (tail
))
730 register Lisp_Object elt
, tem
;
732 if (!CONSP (elt
)) continue;
733 tem
= Fequal (Fcdr (elt
), key
);
734 if (!NILP (tem
)) return elt
;
740 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
741 "Delete by side effect any occurrences of ELT as a member of LIST.\n\
742 The modified LIST is returned. Comparison is done with `eq'.\n\
743 If the first member of LIST is ELT, there is no way to remove it by side effect;\n\
744 therefore, write `(setq foo (delq element foo))'\n\
745 to be sure of changing the value of `foo'.")
747 register Lisp_Object elt
;
750 register Lisp_Object tail
, prev
;
751 register Lisp_Object tem
;
763 Fsetcdr (prev
, Fcdr (tail
));
773 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
774 "Delete by side effect any occurrences of ELT as a member of LIST.\n\
775 The modified LIST is returned. Comparison is done with `equal'.\n\
776 If the first member of LIST is ELT, deleting it is not a side effect;\n\
777 it is simply using a different list.\n\
778 Therefore, write `(setq foo (delete element foo))'\n\
779 to be sure of changing the value of `foo'.")
781 register Lisp_Object elt
;
784 register Lisp_Object tail
, prev
;
785 register Lisp_Object tem
;
792 if (! NILP (Fequal (elt
, tem
)))
797 Fsetcdr (prev
, Fcdr (tail
));
807 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
808 "Reverse LIST by modifying cdr pointers.\n\
809 Returns the beginning of the reversed list.")
813 register Lisp_Object prev
, tail
, next
;
815 if (NILP (list
)) return list
;
822 Fsetcdr (tail
, prev
);
829 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
830 "Reverse LIST, copying. Returns the beginning of the reversed list.\n\
831 See also the function `nreverse', which is used more often.")
836 register Lisp_Object
*vec
;
837 register Lisp_Object tail
;
840 length
= Flength (list
);
841 vec
= (Lisp_Object
*) alloca (XINT (length
) * sizeof (Lisp_Object
));
842 for (i
= XINT (length
) - 1, tail
= list
; i
>= 0; i
--, tail
= Fcdr (tail
))
843 vec
[i
] = Fcar (tail
);
845 return Flist (XINT (length
), vec
);
848 Lisp_Object
merge ();
850 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
851 "Sort LIST, stably, comparing elements using PREDICATE.\n\
852 Returns the sorted list. LIST is modified by side effects.\n\
853 PREDICATE is called with two elements of LIST, and should return T\n\
854 if the first element is \"less\" than the second.")
856 Lisp_Object list
, predicate
;
858 Lisp_Object front
, back
;
859 register Lisp_Object len
, tem
;
860 struct gcpro gcpro1
, gcpro2
;
864 len
= Flength (list
);
869 XSETINT (len
, (length
/ 2) - 1);
870 tem
= Fnthcdr (len
, list
);
874 GCPRO2 (front
, back
);
875 front
= Fsort (front
, predicate
);
876 back
= Fsort (back
, predicate
);
878 return merge (front
, back
, predicate
);
882 merge (org_l1
, org_l2
, pred
)
883 Lisp_Object org_l1
, org_l2
;
887 register Lisp_Object tail
;
889 register Lisp_Object l1
, l2
;
890 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
897 /* It is sufficient to protect org_l1 and org_l2.
898 When l1 and l2 are updated, we copy the new values
899 back into the org_ vars. */
900 GCPRO4 (org_l1
, org_l2
, pred
, value
);
920 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
942 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
943 "Extract a value from a property list.\n\
944 PLIST is a property list, which is a list of the form\n\
945 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value\n\
946 corresponding to the given PROP, or nil if PROP is not\n\
947 one of the properties on the list.")
950 register Lisp_Object prop
;
952 register Lisp_Object tail
;
953 for (tail
= plist
; !NILP (tail
); tail
= Fcdr (Fcdr (tail
)))
955 register Lisp_Object tem
;
958 return Fcar (Fcdr (tail
));
963 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
964 "Return the value of SYMBOL's PROPNAME property.\n\
965 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'.")
967 Lisp_Object symbol
, propname
;
969 CHECK_SYMBOL (symbol
, 0);
970 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
973 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
974 "Change value in PLIST of PROP to VAL.\n\
975 PLIST is a property list, which is a list of the form\n\
976 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.\n\
977 If PROP is already a property on the list, its value is set to VAL,\n\
978 otherwise the new PROP VAL pair is added. The new plist is returned;\n\
979 use `(setq x (plist-put x prop val))' to be sure to use the new value.\n\
980 The PLIST is modified by side effects.")
983 register Lisp_Object prop
;
986 register Lisp_Object tail
, prev
;
989 for (tail
= plist
; CONSP (tail
) && CONSP (XCONS (tail
)->cdr
);
990 tail
= XCONS (XCONS (tail
)->cdr
)->cdr
)
992 if (EQ (prop
, XCONS (tail
)->car
))
994 Fsetcar (XCONS (tail
)->cdr
, val
);
999 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
1003 Fsetcdr (XCONS (prev
)->cdr
, newcell
);
1007 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
1008 "Store SYMBOL's PROPNAME property with value VALUE.\n\
1009 It can be retrieved with `(get SYMBOL PROPNAME)'.")
1010 (symbol
, propname
, value
)
1011 Lisp_Object symbol
, propname
, value
;
1013 CHECK_SYMBOL (symbol
, 0);
1014 XSYMBOL (symbol
)->plist
1015 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
1019 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
1020 "T if two Lisp objects have similar structure and contents.\n\
1021 They must have the same data type.\n\
1022 Conses are compared by comparing the cars and the cdrs.\n\
1023 Vectors and strings are compared element by element.\n\
1024 Numbers are compared by value, but integers cannot equal floats.\n\
1025 (Use `=' if you want integers and floats to be able to be equal.)\n\
1026 Symbols must match exactly.")
1028 register Lisp_Object o1
, o2
;
1030 return internal_equal (o1
, o2
, 0) ? Qt
: Qnil
;
1034 internal_equal (o1
, o2
, depth
)
1035 register Lisp_Object o1
, o2
;
1039 error ("Stack overflow in equal");
1045 if (XTYPE (o1
) != XTYPE (o2
))
1050 #ifdef LISP_FLOAT_TYPE
1052 return (extract_float (o1
) == extract_float (o2
));
1056 if (!internal_equal (XCONS (o1
)->car
, XCONS (o2
)->car
, depth
+ 1))
1058 o1
= XCONS (o1
)->cdr
;
1059 o2
= XCONS (o2
)->cdr
;
1063 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
1067 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o1
),
1069 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o1
),
1072 o1
= XOVERLAY (o1
)->plist
;
1073 o2
= XOVERLAY (o2
)->plist
;
1078 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
1079 && (XMARKER (o1
)->buffer
== 0
1080 || XMARKER (o1
)->bufpos
== XMARKER (o2
)->bufpos
));
1084 case Lisp_Vectorlike
:
1086 register int i
, size
;
1087 size
= XVECTOR (o1
)->size
;
1088 /* Pseudovectors have the type encoded in the size field, so this test
1089 actually checks that the objects have the same type as well as the
1091 if (XVECTOR (o2
)->size
!= size
)
1093 /* Boolvectors are compared much like strings. */
1094 if (BOOL_VECTOR_P (o1
))
1097 = (XBOOL_VECTOR (o1
)->size
+ BITS_PER_CHAR
) / BITS_PER_CHAR
;
1099 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
1101 if (bcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
1107 /* Aside from them, only true vectors, char-tables, and compiled
1108 functions are sensible to compare, so eliminate the others now. */
1109 if (size
& PSEUDOVECTOR_FLAG
)
1111 if (!(size
& (PVEC_COMPILED
| PVEC_CHAR_TABLE
)))
1113 size
&= PSEUDOVECTOR_SIZE_MASK
;
1115 for (i
= 0; i
< size
; i
++)
1118 v1
= XVECTOR (o1
)->contents
[i
];
1119 v2
= XVECTOR (o2
)->contents
[i
];
1120 if (!internal_equal (v1
, v2
, depth
+ 1))
1128 if (XSTRING (o1
)->size
!= XSTRING (o2
)->size
)
1130 if (bcmp (XSTRING (o1
)->data
, XSTRING (o2
)->data
,
1131 XSTRING (o1
)->size
))
1133 #ifdef USE_TEXT_PROPERTIES
1134 /* If the strings have intervals, verify they match;
1135 if not, they are unequal. */
1136 if ((XSTRING (o1
)->intervals
!= 0 || XSTRING (o2
)->intervals
!= 0)
1137 && ! compare_string_intervals (o1
, o2
))
1145 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
1146 "Store each element of ARRAY with ITEM.\n\
1147 ARRAY is a vector, string, char-table, or bool-vector.")
1149 Lisp_Object array
, item
;
1151 register int size
, index
, charval
;
1153 if (VECTORP (array
))
1155 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
1156 size
= XVECTOR (array
)->size
;
1157 for (index
= 0; index
< size
; index
++)
1160 else if (CHAR_TABLE_P (array
))
1162 register Lisp_Object
*p
= XCHAR_TABLE (array
)->contents
;
1163 size
= CHAR_TABLE_ORDINARY_SLOTS
;
1164 for (index
= 0; index
< size
; index
++)
1166 XCHAR_TABLE (array
)->defalt
= Qnil
;
1168 else if (STRINGP (array
))
1170 register unsigned char *p
= XSTRING (array
)->data
;
1171 CHECK_NUMBER (item
, 1);
1172 charval
= XINT (item
);
1173 size
= XSTRING (array
)->size
;
1174 for (index
= 0; index
< size
; index
++)
1177 else if (BOOL_VECTOR_P (array
))
1179 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
1181 = (XBOOL_VECTOR (array
)->size
+ BITS_PER_CHAR
) / BITS_PER_CHAR
;
1183 charval
= (! NILP (item
) ? -1 : 0);
1184 for (index
= 0; index
< size_in_chars
; index
++)
1189 array
= wrong_type_argument (Qarrayp
, array
);
1195 DEFUN ("char-table-subtype", Fchar_table_subtype
, Schar_table_subtype
,
1197 "Return the subtype of char-table CHAR-TABLE. The value is a symbol.")
1199 Lisp_Object char_table
;
1201 CHECK_CHAR_TABLE (char_table
, 0);
1203 return XCHAR_TABLE (char_table
)->purpose
;
1206 DEFUN ("char-table-parent", Fchar_table_parent
, Schar_table_parent
,
1208 "Return the parent char-table of CHAR-TABLE.\n\
1209 The value is either nil or another char-table.\n\
1210 If CHAR-TABLE holds nil for a given character,\n\
1211 then the actual applicable value is inherited from the parent char-table\n\
1212 \(or from its parents, if necessary).")
1214 Lisp_Object char_table
;
1216 CHECK_CHAR_TABLE (char_table
, 0);
1218 return XCHAR_TABLE (char_table
)->parent
;
1221 DEFUN ("set-char-table-parent", Fset_char_table_parent
, Sset_char_table_parent
,
1223 "Set the parent char-table of CHAR-TABLE to PARENT.\n\
1224 PARENT must be either nil or another char-table.")
1225 (char_table
, parent
)
1226 Lisp_Object char_table
, parent
;
1230 CHECK_CHAR_TABLE (char_table
, 0);
1234 CHECK_CHAR_TABLE (parent
, 0);
1236 for (temp
= parent
; !NILP (temp
); temp
= XCHAR_TABLE (temp
)->parent
)
1237 if (EQ (temp
, char_table
))
1238 error ("Attempt to make a chartable be its own parent");
1241 XCHAR_TABLE (char_table
)->parent
= parent
;
1246 DEFUN ("char-table-extra-slot", Fchar_table_extra_slot
, Schar_table_extra_slot
,
1248 "Return the value in extra-slot number N of char-table CHAR-TABLE.")
1250 Lisp_Object char_table
, n
;
1252 CHECK_CHAR_TABLE (char_table
, 1);
1253 CHECK_NUMBER (n
, 2);
1255 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
1256 args_out_of_range (char_table
, n
);
1258 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)];
1261 DEFUN ("set-char-table-extra-slot", Fset_char_table_extra_slot
,
1262 Sset_char_table_extra_slot
,
1264 "Set extra-slot number N of CHAR-TABLE to VALUE.")
1265 (char_table
, n
, value
)
1266 Lisp_Object char_table
, n
, value
;
1268 CHECK_CHAR_TABLE (char_table
, 1);
1269 CHECK_NUMBER (n
, 2);
1271 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
1272 args_out_of_range (char_table
, n
);
1274 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)] = value
;
1277 DEFUN ("char-table-range", Fchar_table_range
, Schar_table_range
,
1279 "Return the value in CHAR-TABLE for a range of characters RANGE.\n\
1280 RANGE should be t (for all characters), nil (for the default value)\n\
1281 a vector which identifies a character set or a row of a character set,\n\
1282 or a character code.")
1284 Lisp_Object char_table
, range
;
1288 CHECK_CHAR_TABLE (char_table
, 0);
1290 if (EQ (range
, Qnil
))
1291 return XCHAR_TABLE (char_table
)->defalt
;
1292 else if (INTEGERP (range
))
1293 return Faref (char_table
, range
);
1294 else if (VECTORP (range
))
1296 for (i
= 0; i
< XVECTOR (range
)->size
- 1; i
++)
1297 char_table
= Faref (char_table
, XVECTOR (range
)->contents
[i
]);
1299 if (EQ (XVECTOR (range
)->contents
[i
], Qnil
))
1300 return XCHAR_TABLE (char_table
)->defalt
;
1302 return Faref (char_table
, XVECTOR (range
)->contents
[i
]);
1305 error ("Invalid RANGE argument to `char-table-range'");
1308 DEFUN ("set-char-table-range", Fset_char_table_range
, Sset_char_table_range
,
1310 "Set the value in CHAR-TABLE for a range of characters RANGE to VALUE.\n\
1311 RANGE should be t (for all characters), nil (for the default value)\n\
1312 a vector which identifies a character set or a row of a character set,\n\
1313 or a character code.")
1314 (char_table
, range
, value
)
1315 Lisp_Object char_table
, range
, value
;
1319 CHECK_CHAR_TABLE (char_table
, 0);
1322 for (i
= 0; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
1323 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
1324 else if (EQ (range
, Qnil
))
1325 XCHAR_TABLE (char_table
)->defalt
= value
;
1326 else if (INTEGERP (range
))
1327 Faset (char_table
, range
, value
);
1328 else if (VECTORP (range
))
1330 for (i
= 0; i
< XVECTOR (range
)->size
- 1; i
++)
1331 char_table
= Faref (char_table
, XVECTOR (range
)->contents
[i
]);
1333 if (EQ (XVECTOR (range
)->contents
[i
], Qnil
))
1334 XCHAR_TABLE (char_table
)->defalt
= value
;
1336 Faset (char_table
, XVECTOR (range
)->contents
[i
], value
);
1339 error ("Invalid RANGE argument to `set-char-table-range'");
1344 /* Map C_FUNCTION or FUNCTION over CHARTABLE, calling it for each
1345 character or group of characters that share a value.
1346 DEPTH is the current depth in the originally specified
1347 chartable, and INDICES contains the vector indices
1348 for the levels our callers have descended. */
1351 map_char_table (c_function
, function
, chartable
, depth
, indices
)
1352 Lisp_Object (*c_function
) (), function
, chartable
, *indices
;
1356 int size
= CHAR_TABLE_ORDINARY_SLOTS
;
1358 /* Make INDICES longer if we are about to fill it up. */
1359 if ((depth
% 10) == 9)
1361 Lisp_Object
*new_indices
1362 = (Lisp_Object
*) alloca ((depth
+= 10) * sizeof (Lisp_Object
));
1363 bcopy (indices
, new_indices
, depth
* sizeof (Lisp_Object
));
1364 indices
= new_indices
;
1367 for (i
= 0; i
< size
; i
++)
1371 elt
= XCHAR_TABLE (chartable
)->contents
[i
];
1372 if (CHAR_TABLE_P (elt
))
1373 map_char_table (c_function
, function
, chartable
, depth
+ 1, indices
);
1374 else if (c_function
)
1375 (*c_function
) (depth
+ 1, indices
, elt
);
1376 /* Here we should handle all cases where the range is a single character
1377 by passing that character as a number. Currently, that is
1378 all the time, but with the MULE code this will have to be changed. */
1379 else if (depth
== 0)
1380 call2 (function
, make_number (i
), elt
);
1382 call2 (function
, Fvector (depth
+ 1, indices
), elt
);
1386 DEFUN ("map-char-table", Fmap_char_table
, Smap_char_table
,
1388 "Call FUNCTION for each range of like characters in CHAR-TABLE.\n\
1389 FUNCTION is called with two arguments--a key and a value.\n\
1390 The key is always a possible RANGE argument to `set-char-table-range'.")
1391 (function
, char_table
)
1392 Lisp_Object function
, char_table
;
1395 Lisp_Object
*indices
= (Lisp_Object
*) alloca (10 * sizeof (Lisp_Object
));
1397 map_char_table (NULL
, function
, char_table
, 0, indices
);
1407 Lisp_Object args
[2];
1410 return Fnconc (2, args
);
1412 return Fnconc (2, &s1
);
1413 #endif /* NO_ARG_ARRAY */
1416 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
1417 "Concatenate any number of lists by altering them.\n\
1418 Only the last argument is not altered, and need not be a list.")
1423 register int argnum
;
1424 register Lisp_Object tail
, tem
, val
;
1428 for (argnum
= 0; argnum
< nargs
; argnum
++)
1431 if (NILP (tem
)) continue;
1436 if (argnum
+ 1 == nargs
) break;
1439 tem
= wrong_type_argument (Qlistp
, tem
);
1448 tem
= args
[argnum
+ 1];
1449 Fsetcdr (tail
, tem
);
1451 args
[argnum
+ 1] = tail
;
1457 /* This is the guts of all mapping functions.
1458 Apply fn to each element of seq, one by one,
1459 storing the results into elements of vals, a C vector of Lisp_Objects.
1460 leni is the length of vals, which should also be the length of seq. */
1463 mapcar1 (leni
, vals
, fn
, seq
)
1466 Lisp_Object fn
, seq
;
1468 register Lisp_Object tail
;
1471 struct gcpro gcpro1
, gcpro2
, gcpro3
;
1473 /* Don't let vals contain any garbage when GC happens. */
1474 for (i
= 0; i
< leni
; i
++)
1477 GCPRO3 (dummy
, fn
, seq
);
1479 gcpro1
.nvars
= leni
;
1480 /* We need not explicitly protect `tail' because it is used only on lists, and
1481 1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
1485 for (i
= 0; i
< leni
; i
++)
1487 dummy
= XVECTOR (seq
)->contents
[i
];
1488 vals
[i
] = call1 (fn
, dummy
);
1491 else if (STRINGP (seq
))
1493 for (i
= 0; i
< leni
; i
++)
1495 XSETFASTINT (dummy
, XSTRING (seq
)->data
[i
]);
1496 vals
[i
] = call1 (fn
, dummy
);
1499 else /* Must be a list, since Flength did not get an error */
1502 for (i
= 0; i
< leni
; i
++)
1504 vals
[i
] = call1 (fn
, Fcar (tail
));
1512 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
1513 "Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.\n\
1514 In between each pair of results, stick in SEPARATOR. Thus, \" \" as\n\
1515 SEPARATOR results in spaces between the values returned by FUNCTION.")
1516 (function
, sequence
, separator
)
1517 Lisp_Object function
, sequence
, separator
;
1522 register Lisp_Object
*args
;
1524 struct gcpro gcpro1
;
1526 len
= Flength (sequence
);
1528 nargs
= leni
+ leni
- 1;
1529 if (nargs
< 0) return build_string ("");
1531 args
= (Lisp_Object
*) alloca (nargs
* sizeof (Lisp_Object
));
1534 mapcar1 (leni
, args
, function
, sequence
);
1537 for (i
= leni
- 1; i
>= 0; i
--)
1538 args
[i
+ i
] = args
[i
];
1540 for (i
= 1; i
< nargs
; i
+= 2)
1541 args
[i
] = separator
;
1543 return Fconcat (nargs
, args
);
1546 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
1547 "Apply FUNCTION to each element of SEQUENCE, and make a list of the results.\n\
1548 The result is a list just as long as SEQUENCE.\n\
1549 SEQUENCE may be a list, a vector or a string.")
1550 (function
, sequence
)
1551 Lisp_Object function
, sequence
;
1553 register Lisp_Object len
;
1555 register Lisp_Object
*args
;
1557 len
= Flength (sequence
);
1558 leni
= XFASTINT (len
);
1559 args
= (Lisp_Object
*) alloca (leni
* sizeof (Lisp_Object
));
1561 mapcar1 (leni
, args
, function
, sequence
);
1563 return Flist (leni
, args
);
1566 /* Anything that calls this function must protect from GC! */
1568 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
1569 "Ask user a \"y or n\" question. Return t if answer is \"y\".\n\
1570 Takes one argument, which is the string to display to ask the question.\n\
1571 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.\n\
1572 No confirmation of the answer is requested; a single character is enough.\n\
1573 Also accepts Space to mean yes, or Delete to mean no.")
1577 register Lisp_Object obj
, key
, def
, answer_string
, map
;
1578 register int answer
;
1579 Lisp_Object xprompt
;
1580 Lisp_Object args
[2];
1581 struct gcpro gcpro1
, gcpro2
;
1582 int count
= specpdl_ptr
- specpdl
;
1584 specbind (Qcursor_in_echo_area
, Qt
);
1586 map
= Fsymbol_value (intern ("query-replace-map"));
1588 CHECK_STRING (prompt
, 0);
1590 GCPRO2 (prompt
, xprompt
);
1597 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
1600 Lisp_Object pane
, menu
;
1601 redisplay_preserve_echo_area ();
1602 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
1603 Fcons (Fcons (build_string ("No"), Qnil
),
1605 menu
= Fcons (prompt
, pane
);
1606 obj
= Fx_popup_dialog (Qt
, menu
);
1607 answer
= !NILP (obj
);
1610 #endif /* HAVE_MENUS */
1611 cursor_in_echo_area
= 1;
1612 choose_minibuf_frame ();
1613 message_nolog ("%s(y or n) ", XSTRING (xprompt
)->data
);
1615 obj
= read_filtered_event (1, 0, 0);
1616 cursor_in_echo_area
= 0;
1617 /* If we need to quit, quit with cursor_in_echo_area = 0. */
1620 key
= Fmake_vector (make_number (1), obj
);
1621 def
= Flookup_key (map
, key
, Qt
);
1622 answer_string
= Fsingle_key_description (obj
);
1624 if (EQ (def
, intern ("skip")))
1629 else if (EQ (def
, intern ("act")))
1634 else if (EQ (def
, intern ("recenter")))
1640 else if (EQ (def
, intern ("quit")))
1642 /* We want to exit this command for exit-prefix,
1643 and this is the only way to do it. */
1644 else if (EQ (def
, intern ("exit-prefix")))
1649 /* If we don't clear this, then the next call to read_char will
1650 return quit_char again, and we'll enter an infinite loop. */
1655 if (EQ (xprompt
, prompt
))
1657 args
[0] = build_string ("Please answer y or n. ");
1659 xprompt
= Fconcat (2, args
);
1664 if (! noninteractive
)
1666 cursor_in_echo_area
= -1;
1667 message_nolog ("%s(y or n) %c",
1668 XSTRING (xprompt
)->data
, answer
? 'y' : 'n');
1671 unbind_to (count
, Qnil
);
1672 return answer
? Qt
: Qnil
;
1675 /* This is how C code calls `yes-or-no-p' and allows the user
1678 Anything that calls this function must protect from GC! */
1681 do_yes_or_no_p (prompt
)
1684 return call1 (intern ("yes-or-no-p"), prompt
);
1687 /* Anything that calls this function must protect from GC! */
1689 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
1690 "Ask user a yes-or-no question. Return t if answer is yes.\n\
1691 Takes one argument, which is the string to display to ask the question.\n\
1692 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.\n\
1693 The user must confirm the answer with RET,\n\
1694 and can edit it until it has been confirmed.")
1698 register Lisp_Object ans
;
1699 Lisp_Object args
[2];
1700 struct gcpro gcpro1
;
1703 CHECK_STRING (prompt
, 0);
1706 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
1709 Lisp_Object pane
, menu
, obj
;
1710 redisplay_preserve_echo_area ();
1711 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
1712 Fcons (Fcons (build_string ("No"), Qnil
),
1715 menu
= Fcons (prompt
, pane
);
1716 obj
= Fx_popup_dialog (Qt
, menu
);
1720 #endif /* HAVE_MENUS */
1723 args
[1] = build_string ("(yes or no) ");
1724 prompt
= Fconcat (2, args
);
1730 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
1731 Qyes_or_no_p_history
));
1732 if (XSTRING (ans
)->size
== 3 && !strcmp (XSTRING (ans
)->data
, "yes"))
1737 if (XSTRING (ans
)->size
== 2 && !strcmp (XSTRING (ans
)->data
, "no"))
1745 message ("Please answer yes or no.");
1746 Fsleep_for (make_number (2), Qnil
);
1750 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 0, 0,
1751 "Return list of 1 minute, 5 minute and 15 minute load averages.\n\
1752 Each of the three load averages is multiplied by 100,\n\
1753 then converted to integer.\n\
1754 If the 5-minute or 15-minute load averages are not available, return a\n\
1755 shortened list, containing only those averages which are available.")
1759 int loads
= getloadavg (load_ave
, 3);
1763 error ("load-average not implemented for this operating system");
1767 ret
= Fcons (make_number ((int) (load_ave
[--loads
] * 100.0)), ret
);
1772 Lisp_Object Vfeatures
;
1774 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 1, 0,
1775 "Returns t if FEATURE is present in this Emacs.\n\
1776 Use this to conditionalize execution of lisp code based on the presence or\n\
1777 absence of emacs or environment extensions.\n\
1778 Use `provide' to declare that a feature is available.\n\
1779 This function looks at the value of the variable `features'.")
1781 Lisp_Object feature
;
1783 register Lisp_Object tem
;
1784 CHECK_SYMBOL (feature
, 0);
1785 tem
= Fmemq (feature
, Vfeatures
);
1786 return (NILP (tem
)) ? Qnil
: Qt
;
1789 DEFUN ("provide", Fprovide
, Sprovide
, 1, 1, 0,
1790 "Announce that FEATURE is a feature of the current Emacs.")
1792 Lisp_Object feature
;
1794 register Lisp_Object tem
;
1795 CHECK_SYMBOL (feature
, 0);
1796 if (!NILP (Vautoload_queue
))
1797 Vautoload_queue
= Fcons (Fcons (Vfeatures
, Qnil
), Vautoload_queue
);
1798 tem
= Fmemq (feature
, Vfeatures
);
1800 Vfeatures
= Fcons (feature
, Vfeatures
);
1801 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
1805 DEFUN ("require", Frequire
, Srequire
, 1, 2, 0,
1806 "If feature FEATURE is not loaded, load it from FILENAME.\n\
1807 If FEATURE is not a member of the list `features', then the feature\n\
1808 is not loaded; so load the file FILENAME.\n\
1809 If FILENAME is omitted, the printname of FEATURE is used as the file name.")
1810 (feature
, file_name
)
1811 Lisp_Object feature
, file_name
;
1813 register Lisp_Object tem
;
1814 CHECK_SYMBOL (feature
, 0);
1815 tem
= Fmemq (feature
, Vfeatures
);
1816 LOADHIST_ATTACH (Fcons (Qrequire
, feature
));
1819 int count
= specpdl_ptr
- specpdl
;
1821 /* Value saved here is to be restored into Vautoload_queue */
1822 record_unwind_protect (un_autoload
, Vautoload_queue
);
1823 Vautoload_queue
= Qt
;
1825 Fload (NILP (file_name
) ? Fsymbol_name (feature
) : file_name
,
1828 tem
= Fmemq (feature
, Vfeatures
);
1830 error ("Required feature %s was not provided",
1831 XSYMBOL (feature
)->name
->data
);
1833 /* Once loading finishes, don't undo it. */
1834 Vautoload_queue
= Qt
;
1835 feature
= unbind_to (count
, feature
);
1842 Qstring_lessp
= intern ("string-lessp");
1843 staticpro (&Qstring_lessp
);
1844 Qprovide
= intern ("provide");
1845 staticpro (&Qprovide
);
1846 Qrequire
= intern ("require");
1847 staticpro (&Qrequire
);
1848 Qyes_or_no_p_history
= intern ("yes-or-no-p-history");
1849 staticpro (&Qyes_or_no_p_history
);
1850 Qcursor_in_echo_area
= intern ("cursor-in-echo-area");
1851 staticpro (&Qcursor_in_echo_area
);
1853 Fset (Qyes_or_no_p_history
, Qnil
);
1855 DEFVAR_LISP ("features", &Vfeatures
,
1856 "A list of symbols which are the features of the executing emacs.\n\
1857 Used by `featurep' and `require', and altered by `provide'.");
1860 defsubr (&Sidentity
);
1863 defsubr (&Ssafe_length
);
1864 defsubr (&Sstring_equal
);
1865 defsubr (&Sstring_lessp
);
1868 defsubr (&Svconcat
);
1869 defsubr (&Scopy_sequence
);
1870 defsubr (&Scopy_alist
);
1871 defsubr (&Ssubstring
);
1883 defsubr (&Snreverse
);
1884 defsubr (&Sreverse
);
1886 defsubr (&Splist_get
);
1888 defsubr (&Splist_put
);
1891 defsubr (&Sfillarray
);
1892 defsubr (&Schar_table_subtype
);
1893 defsubr (&Schar_table_parent
);
1894 defsubr (&Sset_char_table_parent
);
1895 defsubr (&Schar_table_extra_slot
);
1896 defsubr (&Sset_char_table_extra_slot
);
1897 defsubr (&Schar_table_range
);
1898 defsubr (&Sset_char_table_range
);
1899 defsubr (&Smap_char_table
);
1902 defsubr (&Smapconcat
);
1903 defsubr (&Sy_or_n_p
);
1904 defsubr (&Syes_or_no_p
);
1905 defsubr (&Sload_average
);
1906 defsubr (&Sfeaturep
);
1907 defsubr (&Srequire
);
1908 defsubr (&Sprovide
);