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
;
45 static int internal_equal ();
47 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
48 "Return the argument unchanged.")
55 extern long get_random ();
56 extern void seed_random ();
59 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
60 "Return a pseudo-random number.\n\
61 All integers representable in Lisp are equally likely.\n\
62 On most systems, this is 28 bits' worth.\n\
63 With positive integer argument N, return random number in interval [0,N).\n\
64 With argument t, set the random number seed from the current time and pid.")
69 Lisp_Object lispy_val
;
70 unsigned long denominator
;
73 seed_random (getpid () + time (NULL
));
74 if (NATNUMP (n
) && XFASTINT (n
) != 0)
76 /* Try to take our random number from the higher bits of VAL,
77 not the lower, since (says Gentzel) the low bits of `random'
78 are less random than the higher ones. We do this by using the
79 quotient rather than the remainder. At the high end of the RNG
80 it's possible to get a quotient larger than n; discarding
81 these values eliminates the bias that would otherwise appear
82 when using a large n. */
83 denominator
= ((unsigned long)1 << VALBITS
) / XFASTINT (n
);
85 val
= get_random () / denominator
;
86 while (val
>= XFASTINT (n
));
90 XSETINT (lispy_val
, val
);
94 /* Random data-structure functions */
96 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
97 "Return the length of vector, list or string SEQUENCE.\n\
98 A byte-code function object is also allowed.")
100 register Lisp_Object sequence
;
102 register Lisp_Object tail
, val
;
106 if (STRINGP (sequence
))
107 XSETFASTINT (val
, XSTRING (sequence
)->size
);
108 else if (VECTORP (sequence
))
109 XSETFASTINT (val
, XVECTOR (sequence
)->size
);
110 else if (CHAR_TABLE_P (sequence
))
111 XSETFASTINT (val
, CHAR_TABLE_ORDINARY_SLOTS
);
112 else if (BOOL_VECTOR_P (sequence
))
113 XSETFASTINT (val
, XBOOL_VECTOR (sequence
)->size
);
114 else if (COMPILEDP (sequence
))
115 XSETFASTINT (val
, XVECTOR (sequence
)->size
& PSEUDOVECTOR_SIZE_MASK
);
116 else if (CONSP (sequence
))
118 for (i
= 0, tail
= sequence
; !NILP (tail
); i
++)
124 XSETFASTINT (val
, i
);
126 else if (NILP (sequence
))
127 XSETFASTINT (val
, 0);
130 sequence
= wrong_type_argument (Qsequencep
, sequence
);
136 /* This does not check for quits. That is safe
137 since it must terminate. */
139 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
140 "Return the length of a list, but avoid error or infinite loop.\n\
141 This function never gets an error. If LIST is not really a list,\n\
142 it returns 0. If LIST is circular, it returns a finite value\n\
143 which is at least the number of distinct elements.")
147 Lisp_Object tail
, halftail
, length
;
150 /* halftail is used to detect circular lists. */
152 for (tail
= list
; CONSP (tail
); tail
= XCONS (tail
)->cdr
)
154 if (EQ (tail
, halftail
) && len
!= 0)
158 halftail
= XCONS (halftail
)->cdr
;
161 XSETINT (length
, len
);
165 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
166 "T if two strings have identical contents.\n\
167 Case is significant, but text properties are ignored.\n\
168 Symbols are also allowed; their print names are used instead.")
170 register Lisp_Object s1
, s2
;
173 XSETSTRING (s1
, XSYMBOL (s1
)->name
);
175 XSETSTRING (s2
, XSYMBOL (s2
)->name
);
176 CHECK_STRING (s1
, 0);
177 CHECK_STRING (s2
, 1);
179 if (XSTRING (s1
)->size
!= XSTRING (s2
)->size
||
180 bcmp (XSTRING (s1
)->data
, XSTRING (s2
)->data
, XSTRING (s1
)->size
))
185 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
186 "T if first arg string is less than second in lexicographic order.\n\
187 Case is significant.\n\
188 Symbols are also allowed; their print names are used instead.")
190 register Lisp_Object s1
, s2
;
193 register unsigned char *p1
, *p2
;
197 XSETSTRING (s1
, XSYMBOL (s1
)->name
);
199 XSETSTRING (s2
, XSYMBOL (s2
)->name
);
200 CHECK_STRING (s1
, 0);
201 CHECK_STRING (s2
, 1);
203 p1
= XSTRING (s1
)->data
;
204 p2
= XSTRING (s2
)->data
;
205 end
= XSTRING (s1
)->size
;
206 if (end
> XSTRING (s2
)->size
)
207 end
= XSTRING (s2
)->size
;
209 for (i
= 0; i
< end
; i
++)
212 return p1
[i
] < p2
[i
] ? Qt
: Qnil
;
214 return i
< XSTRING (s2
)->size
? Qt
: Qnil
;
217 static Lisp_Object
concat ();
228 return concat (2, args
, Lisp_String
, 0);
230 return concat (2, &s1
, Lisp_String
, 0);
231 #endif /* NO_ARG_ARRAY */
237 Lisp_Object s1
, s2
, s3
;
244 return concat (3, args
, Lisp_String
, 0);
246 return concat (3, &s1
, Lisp_String
, 0);
247 #endif /* NO_ARG_ARRAY */
250 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
251 "Concatenate all the arguments and make the result a list.\n\
252 The result is a list whose elements are the elements of all the arguments.\n\
253 Each argument may be a list, vector or string.\n\
254 The last argument is not copied, just used as the tail of the new list.")
259 return concat (nargs
, args
, Lisp_Cons
, 1);
262 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
263 "Concatenate all the arguments and make the result a string.\n\
264 The result is a string whose elements are the elements of all the arguments.\n\
265 Each argument may be a string or a list or vector of characters (integers).\n\
267 Do not use individual integers as arguments!\n\
268 The behavior of `concat' in that case will be changed later!\n\
269 If your program passes an integer as an argument to `concat',\n\
270 you should change it right away not to do so.")
275 return concat (nargs
, args
, Lisp_String
, 0);
278 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
279 "Concatenate all the arguments and make the result a vector.\n\
280 The result is a vector whose elements are the elements of all the arguments.\n\
281 Each argument may be a list, vector or string.")
286 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
289 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
290 "Return a copy of a list, vector or string.\n\
291 The elements of a list or vector are not copied; they are shared\n\
296 if (NILP (arg
)) return arg
;
298 if (CHAR_TABLE_P (arg
))
303 /* Calculate the number of extra slots. */
304 size
= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (arg
));
305 copy
= Fmake_char_table (XCHAR_TABLE (arg
)->purpose
, Qnil
);
306 /* Copy all the slots, including the extra ones. */
307 bcopy (XCHAR_TABLE (arg
)->contents
, XCHAR_TABLE (copy
)->contents
,
308 (XCHAR_TABLE (arg
)->size
& PSEUDOVECTOR_SIZE_MASK
) * sizeof (Lisp_Object
));
310 /* Recursively copy any char-tables in the ordinary slots. */
311 for (i
= 0; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
312 if (CHAR_TABLE_P (XCHAR_TABLE (arg
)->contents
[i
]))
313 XCHAR_TABLE (copy
)->contents
[i
]
314 = Fcopy_sequence (XCHAR_TABLE (copy
)->contents
[i
]);
319 if (BOOL_VECTOR_P (arg
))
323 = (XBOOL_VECTOR (arg
)->size
+ BITS_PER_CHAR
) / BITS_PER_CHAR
;
325 val
= Fmake_bool_vector (Flength (arg
), Qnil
);
326 bcopy (XBOOL_VECTOR (arg
)->data
, XBOOL_VECTOR (val
)->data
,
331 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
332 arg
= wrong_type_argument (Qsequencep
, arg
);
333 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
337 concat (nargs
, args
, target_type
, last_special
)
340 enum Lisp_Type target_type
;
345 register Lisp_Object tail
;
346 register Lisp_Object
this;
350 Lisp_Object last_tail
;
353 /* In append, the last arg isn't treated like the others */
354 if (last_special
&& nargs
> 0)
357 last_tail
= args
[nargs
];
362 for (argnum
= 0; argnum
< nargs
; argnum
++)
365 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
366 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
369 args
[argnum
] = Fnumber_to_string (this);
371 args
[argnum
] = wrong_type_argument (Qsequencep
, this);
375 for (argnum
= 0, leni
= 0; argnum
< nargs
; argnum
++)
378 len
= Flength (this);
379 leni
+= XFASTINT (len
);
382 XSETFASTINT (len
, leni
);
384 if (target_type
== Lisp_Cons
)
385 val
= Fmake_list (len
, Qnil
);
386 else if (target_type
== Lisp_Vectorlike
)
387 val
= Fmake_vector (len
, Qnil
);
389 val
= Fmake_string (len
, len
);
391 /* In append, if all but last arg are nil, return last arg */
392 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
396 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
402 for (argnum
= 0; argnum
< nargs
; argnum
++)
406 register int thisindex
= 0;
410 thislen
= Flength (this), thisleni
= XINT (thislen
);
412 if (STRINGP (this) && STRINGP (val
)
413 && ! NULL_INTERVAL_P (XSTRING (this)->intervals
))
415 copy_text_properties (make_number (0), thislen
, this,
416 make_number (toindex
), val
, Qnil
);
421 register Lisp_Object elt
;
423 /* Fetch next element of `this' arg into `elt', or break if
424 `this' is exhausted. */
425 if (NILP (this)) break;
427 elt
= Fcar (this), this = Fcdr (this);
430 if (thisindex
>= thisleni
) break;
432 XSETFASTINT (elt
, XSTRING (this)->data
[thisindex
++]);
433 else if (BOOL_VECTOR_P (this))
436 = ((XBOOL_VECTOR (this)->size
+ BITS_PER_CHAR
)
439 byte
= XBOOL_VECTOR (val
)->data
[thisindex
/ BITS_PER_CHAR
];
440 if (byte
& (1 << thisindex
))
446 elt
= XVECTOR (this)->contents
[thisindex
++];
449 /* Store into result */
452 XCONS (tail
)->car
= elt
;
454 tail
= XCONS (tail
)->cdr
;
456 else if (VECTORP (val
))
457 XVECTOR (val
)->contents
[toindex
++] = elt
;
460 while (!INTEGERP (elt
))
461 elt
= wrong_type_argument (Qintegerp
, elt
);
463 #ifdef MASSC_REGISTER_BUG
464 /* Even removing all "register"s doesn't disable this bug!
465 Nothing simpler than this seems to work. */
466 unsigned char *p
= & XSTRING (val
)->data
[toindex
++];
469 XSTRING (val
)->data
[toindex
++] = XINT (elt
);
476 XCONS (prev
)->cdr
= last_tail
;
481 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
482 "Return a copy of ALIST.\n\
483 This is an alist which represents the same mapping from objects to objects,\n\
484 but does not share the alist structure with ALIST.\n\
485 The objects mapped (cars and cdrs of elements of the alist)\n\
486 are shared, however.\n\
487 Elements of ALIST that are not conses are also shared.")
491 register Lisp_Object tem
;
493 CHECK_LIST (alist
, 0);
496 alist
= concat (1, &alist
, Lisp_Cons
, 0);
497 for (tem
= alist
; CONSP (tem
); tem
= XCONS (tem
)->cdr
)
499 register Lisp_Object car
;
500 car
= XCONS (tem
)->car
;
503 XCONS (tem
)->car
= Fcons (XCONS (car
)->car
, XCONS (car
)->cdr
);
508 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
509 "Return a substring of STRING, starting at index FROM and ending before TO.\n\
510 TO may be nil or omitted; then the substring runs to the end of STRING.\n\
511 If FROM or TO is negative, it counts from the end.")
514 register Lisp_Object from
, to
;
518 CHECK_STRING (string
, 0);
519 CHECK_NUMBER (from
, 1);
521 to
= Flength (string
);
523 CHECK_NUMBER (to
, 2);
526 XSETINT (from
, XINT (from
) + XSTRING (string
)->size
);
528 XSETINT (to
, XINT (to
) + XSTRING (string
)->size
);
529 if (!(0 <= XINT (from
) && XINT (from
) <= XINT (to
)
530 && XINT (to
) <= XSTRING (string
)->size
))
531 args_out_of_range_3 (string
, from
, to
);
533 res
= make_string (XSTRING (string
)->data
+ XINT (from
),
534 XINT (to
) - XINT (from
));
535 copy_text_properties (from
, to
, string
, make_number (0), res
, Qnil
);
539 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
540 "Take cdr N times on LIST, returns the result.")
543 register Lisp_Object list
;
548 for (i
= 0; i
< num
&& !NILP (list
); i
++)
556 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
557 "Return the Nth element of LIST.\n\
558 N counts from zero. If LIST is not that long, nil is returned.")
562 return Fcar (Fnthcdr (n
, list
));
565 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
566 "Return element of SEQUENCE at index N.")
568 register Lisp_Object sequence
, n
;
573 if (CONSP (sequence
) || NILP (sequence
))
574 return Fcar (Fnthcdr (n
, sequence
));
575 else if (STRINGP (sequence
) || VECTORP (sequence
)
576 || BOOL_VECTOR_P (sequence
) || CHAR_TABLE_P (sequence
))
577 return Faref (sequence
, n
);
579 sequence
= wrong_type_argument (Qsequencep
, sequence
);
583 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
584 "Return non-nil if ELT is an element of LIST. Comparison done with `equal'.\n\
585 The value is actually the tail of LIST whose car is ELT.")
587 register Lisp_Object elt
;
590 register Lisp_Object tail
;
591 for (tail
= list
; !NILP (tail
); tail
= Fcdr (tail
))
593 register Lisp_Object tem
;
595 if (! NILP (Fequal (elt
, tem
)))
602 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
603 "Return non-nil if ELT is an element of LIST. Comparison done with EQ.\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 (EQ (elt
, tem
)) return tail
;
620 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
621 "Return non-nil if KEY is `eq' to the car of an element of LIST.\n\
622 The value is actually the element of LIST whose car is KEY.\n\
623 Elements of LIST that are not conses are ignored.")
625 register Lisp_Object key
;
628 register Lisp_Object tail
;
629 for (tail
= list
; !NILP (tail
); tail
= Fcdr (tail
))
631 register Lisp_Object elt
, tem
;
633 if (!CONSP (elt
)) continue;
635 if (EQ (key
, tem
)) return elt
;
641 /* Like Fassq but never report an error and do not allow quits.
642 Use only on lists known never to be circular. */
645 assq_no_quit (key
, list
)
646 register Lisp_Object key
;
649 register Lisp_Object tail
;
650 for (tail
= list
; CONSP (tail
); tail
= Fcdr (tail
))
652 register Lisp_Object elt
, tem
;
654 if (!CONSP (elt
)) continue;
656 if (EQ (key
, tem
)) return elt
;
661 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
662 "Return non-nil if KEY is `equal' to the car of an element of LIST.\n\
663 The value is actually the element of LIST whose car equals KEY.")
665 register Lisp_Object key
;
668 register Lisp_Object tail
;
669 for (tail
= list
; !NILP (tail
); tail
= Fcdr (tail
))
671 register Lisp_Object elt
, tem
;
673 if (!CONSP (elt
)) continue;
674 tem
= Fequal (Fcar (elt
), key
);
675 if (!NILP (tem
)) return elt
;
681 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
682 "Return non-nil if ELT is `eq' to the cdr of an element of LIST.\n\
683 The value is actually the element of LIST whose cdr is ELT.")
685 register Lisp_Object key
;
688 register Lisp_Object tail
;
689 for (tail
= list
; !NILP (tail
); tail
= Fcdr (tail
))
691 register Lisp_Object elt
, tem
;
693 if (!CONSP (elt
)) continue;
695 if (EQ (key
, tem
)) return elt
;
701 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
702 "Return non-nil if KEY is `equal' to the cdr of an element of LIST.\n\
703 The value is actually the element of LIST whose cdr equals KEY.")
705 register Lisp_Object key
;
708 register Lisp_Object tail
;
709 for (tail
= list
; !NILP (tail
); tail
= Fcdr (tail
))
711 register Lisp_Object elt
, tem
;
713 if (!CONSP (elt
)) continue;
714 tem
= Fequal (Fcdr (elt
), key
);
715 if (!NILP (tem
)) return elt
;
721 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
722 "Delete by side effect any occurrences of ELT as a member of LIST.\n\
723 The modified LIST is returned. Comparison is done with `eq'.\n\
724 If the first member of LIST is ELT, there is no way to remove it by side effect;\n\
725 therefore, write `(setq foo (delq element foo))'\n\
726 to be sure of changing the value of `foo'.")
728 register Lisp_Object elt
;
731 register Lisp_Object tail
, prev
;
732 register Lisp_Object tem
;
744 Fsetcdr (prev
, Fcdr (tail
));
754 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
755 "Delete by side effect any occurrences of ELT as a member of LIST.\n\
756 The modified LIST is returned. Comparison is done with `equal'.\n\
757 If the first member of LIST is ELT, deleting it is not a side effect;\n\
758 it is simply using a different list.\n\
759 Therefore, write `(setq foo (delete element foo))'\n\
760 to be sure of changing the value of `foo'.")
762 register Lisp_Object elt
;
765 register Lisp_Object tail
, prev
;
766 register Lisp_Object tem
;
773 if (! NILP (Fequal (elt
, tem
)))
778 Fsetcdr (prev
, Fcdr (tail
));
788 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
789 "Reverse LIST by modifying cdr pointers.\n\
790 Returns the beginning of the reversed list.")
794 register Lisp_Object prev
, tail
, next
;
796 if (NILP (list
)) return list
;
803 Fsetcdr (tail
, prev
);
810 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
811 "Reverse LIST, copying. Returns the beginning of the reversed list.\n\
812 See also the function `nreverse', which is used more often.")
817 register Lisp_Object
*vec
;
818 register Lisp_Object tail
;
821 length
= Flength (list
);
822 vec
= (Lisp_Object
*) alloca (XINT (length
) * sizeof (Lisp_Object
));
823 for (i
= XINT (length
) - 1, tail
= list
; i
>= 0; i
--, tail
= Fcdr (tail
))
824 vec
[i
] = Fcar (tail
);
826 return Flist (XINT (length
), vec
);
829 Lisp_Object
merge ();
831 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
832 "Sort LIST, stably, comparing elements using PREDICATE.\n\
833 Returns the sorted list. LIST is modified by side effects.\n\
834 PREDICATE is called with two elements of LIST, and should return T\n\
835 if the first element is \"less\" than the second.")
837 Lisp_Object list
, predicate
;
839 Lisp_Object front
, back
;
840 register Lisp_Object len
, tem
;
841 struct gcpro gcpro1
, gcpro2
;
845 len
= Flength (list
);
850 XSETINT (len
, (length
/ 2) - 1);
851 tem
= Fnthcdr (len
, list
);
855 GCPRO2 (front
, back
);
856 front
= Fsort (front
, predicate
);
857 back
= Fsort (back
, predicate
);
859 return merge (front
, back
, predicate
);
863 merge (org_l1
, org_l2
, pred
)
864 Lisp_Object org_l1
, org_l2
;
868 register Lisp_Object tail
;
870 register Lisp_Object l1
, l2
;
871 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
878 /* It is sufficient to protect org_l1 and org_l2.
879 When l1 and l2 are updated, we copy the new values
880 back into the org_ vars. */
881 GCPRO4 (org_l1
, org_l2
, pred
, value
);
901 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
923 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
924 "Extract a value from a property list.\n\
925 PLIST is a property list, which is a list of the form\n\
926 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value\n\
927 corresponding to the given PROP, or nil if PROP is not\n\
928 one of the properties on the list.")
931 register Lisp_Object prop
;
933 register Lisp_Object tail
;
934 for (tail
= plist
; !NILP (tail
); tail
= Fcdr (Fcdr (tail
)))
936 register Lisp_Object tem
;
939 return Fcar (Fcdr (tail
));
944 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
945 "Return the value of SYMBOL's PROPNAME property.\n\
946 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'.")
948 Lisp_Object symbol
, propname
;
950 CHECK_SYMBOL (symbol
, 0);
951 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
954 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
955 "Change value in PLIST of PROP to VAL.\n\
956 PLIST is a property list, which is a list of the form\n\
957 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.\n\
958 If PROP is already a property on the list, its value is set to VAL,\n\
959 otherwise the new PROP VAL pair is added. The new plist is returned;\n\
960 use `(setq x (plist-put x prop val))' to be sure to use the new value.\n\
961 The PLIST is modified by side effects.")
964 register Lisp_Object prop
;
967 register Lisp_Object tail
, prev
;
970 for (tail
= plist
; CONSP (tail
) && CONSP (XCONS (tail
)->cdr
);
971 tail
= XCONS (XCONS (tail
)->cdr
)->cdr
)
973 if (EQ (prop
, XCONS (tail
)->car
))
975 Fsetcar (XCONS (tail
)->cdr
, val
);
980 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
984 Fsetcdr (XCONS (prev
)->cdr
, newcell
);
988 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
989 "Store SYMBOL's PROPNAME property with value VALUE.\n\
990 It can be retrieved with `(get SYMBOL PROPNAME)'.")
991 (symbol
, propname
, value
)
992 Lisp_Object symbol
, propname
, value
;
994 CHECK_SYMBOL (symbol
, 0);
995 XSYMBOL (symbol
)->plist
996 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
1000 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
1001 "T if two Lisp objects have similar structure and contents.\n\
1002 They must have the same data type.\n\
1003 Conses are compared by comparing the cars and the cdrs.\n\
1004 Vectors and strings are compared element by element.\n\
1005 Numbers are compared by value, but integers cannot equal floats.\n\
1006 (Use `=' if you want integers and floats to be able to be equal.)\n\
1007 Symbols must match exactly.")
1009 register Lisp_Object o1
, o2
;
1011 return internal_equal (o1
, o2
, 0) ? Qt
: Qnil
;
1015 internal_equal (o1
, o2
, depth
)
1016 register Lisp_Object o1
, o2
;
1020 error ("Stack overflow in equal");
1026 if (XTYPE (o1
) != XTYPE (o2
))
1031 #ifdef LISP_FLOAT_TYPE
1033 return (extract_float (o1
) == extract_float (o2
));
1037 if (!internal_equal (XCONS (o1
)->car
, XCONS (o2
)->car
, depth
+ 1))
1039 o1
= XCONS (o1
)->cdr
;
1040 o2
= XCONS (o2
)->cdr
;
1044 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
1048 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o1
),
1050 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o1
),
1053 o1
= XOVERLAY (o1
)->plist
;
1054 o2
= XOVERLAY (o2
)->plist
;
1059 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
1060 && (XMARKER (o1
)->buffer
== 0
1061 || XMARKER (o1
)->bufpos
== XMARKER (o2
)->bufpos
));
1065 case Lisp_Vectorlike
:
1067 register int i
, size
;
1068 size
= XVECTOR (o1
)->size
;
1069 /* Pseudovectors have the type encoded in the size field, so this test
1070 actually checks that the objects have the same type as well as the
1072 if (XVECTOR (o2
)->size
!= size
)
1074 /* Boolvectors are compared much like strings. */
1075 if (BOOL_VECTOR_P (o1
))
1078 = (XBOOL_VECTOR (o1
)->size
+ BITS_PER_CHAR
) / BITS_PER_CHAR
;
1080 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
1082 if (bcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
1088 /* Aside from them, only true vectors, char-tables, and compiled
1089 functions are sensible to compare, so eliminate the others now. */
1090 if (size
& PSEUDOVECTOR_FLAG
)
1092 if (!(size
& (PVEC_COMPILED
| PVEC_CHAR_TABLE
)))
1094 size
&= PSEUDOVECTOR_SIZE_MASK
;
1096 for (i
= 0; i
< size
; i
++)
1099 v1
= XVECTOR (o1
)->contents
[i
];
1100 v2
= XVECTOR (o2
)->contents
[i
];
1101 if (!internal_equal (v1
, v2
, depth
+ 1))
1109 if (XSTRING (o1
)->size
!= XSTRING (o2
)->size
)
1111 if (bcmp (XSTRING (o1
)->data
, XSTRING (o2
)->data
,
1112 XSTRING (o1
)->size
))
1114 #ifdef USE_TEXT_PROPERTIES
1115 /* If the strings have intervals, verify they match;
1116 if not, they are unequal. */
1117 if ((XSTRING (o1
)->intervals
!= 0 || XSTRING (o2
)->intervals
!= 0)
1118 && ! compare_string_intervals (o1
, o2
))
1126 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
1127 "Store each element of ARRAY with ITEM.\n\
1128 ARRAY is a vector, string, char-table, or bool-vector.")
1130 Lisp_Object array
, item
;
1132 register int size
, index
, charval
;
1134 if (VECTORP (array
))
1136 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
1137 size
= XVECTOR (array
)->size
;
1138 for (index
= 0; index
< size
; index
++)
1141 else if (CHAR_TABLE_P (array
))
1143 register Lisp_Object
*p
= XCHAR_TABLE (array
)->contents
;
1144 size
= CHAR_TABLE_ORDINARY_SLOTS
;
1145 for (index
= 0; index
< size
; index
++)
1147 XCHAR_TABLE (array
)->defalt
= Qnil
;
1149 else if (STRINGP (array
))
1151 register unsigned char *p
= XSTRING (array
)->data
;
1152 CHECK_NUMBER (item
, 1);
1153 charval
= XINT (item
);
1154 size
= XSTRING (array
)->size
;
1155 for (index
= 0; index
< size
; index
++)
1158 else if (BOOL_VECTOR_P (array
))
1160 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
1162 = (XBOOL_VECTOR (array
)->size
+ BITS_PER_CHAR
) / BITS_PER_CHAR
;
1164 charval
= (! NILP (item
) ? -1 : 0);
1165 for (index
= 0; index
< size_in_chars
; index
++)
1170 array
= wrong_type_argument (Qarrayp
, array
);
1176 DEFUN ("char-table-subtype", Fchar_table_subtype
, Schar_table_subtype
,
1178 "Return the subtype of char-table CHAR-TABLE. The value is a symbol.")
1180 Lisp_Object char_table
;
1182 CHECK_CHAR_TABLE (char_table
, 0);
1184 return XCHAR_TABLE (char_table
)->purpose
;
1187 DEFUN ("char-table-parent", Fchar_table_parent
, Schar_table_parent
,
1189 "Return the parent char-table of CHAR-TABLE.\n\
1190 The value is either nil or another char-table.\n\
1191 If CHAR-TABLE holds nil for a given character,\n\
1192 then the actual applicable value is inherited from the parent char-table\n\
1193 \(or from its parents, if necessary).")
1195 Lisp_Object char_table
;
1197 CHECK_CHAR_TABLE (char_table
, 0);
1199 return XCHAR_TABLE (char_table
)->parent
;
1202 DEFUN ("set-char-table-parent", Fset_char_table_parent
, Sset_char_table_parent
,
1204 "Set the parent char-table of CHAR-TABLE to PARENT.\n\
1205 PARENT must be either nil or another char-table.")
1206 (char_table
, parent
)
1207 Lisp_Object char_table
, parent
;
1211 CHECK_CHAR_TABLE (char_table
, 0);
1215 CHECK_CHAR_TABLE (parent
, 0);
1217 for (temp
= parent
; !NILP (temp
); temp
= XCHAR_TABLE (temp
)->parent
)
1218 if (EQ (temp
, char_table
))
1219 error ("Attempt to make a chartable be its own parent");
1222 XCHAR_TABLE (char_table
)->parent
= parent
;
1227 DEFUN ("char-table-extra-slot", Fchar_table_extra_slot
, Schar_table_extra_slot
,
1229 "Return the value in extra-slot number N of char-table CHAR-TABLE.")
1231 Lisp_Object char_table
, n
;
1233 CHECK_CHAR_TABLE (char_table
, 1);
1234 CHECK_NUMBER (n
, 2);
1236 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
1237 args_out_of_range (char_table
, n
);
1239 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)];
1242 DEFUN ("set-char-table-extra-slot", Fset_char_table_extra_slot
,
1243 Sset_char_table_extra_slot
,
1245 "Set extra-slot number N of CHAR-TABLE to VALUE.")
1246 (char_table
, n
, value
)
1247 Lisp_Object char_table
, n
, value
;
1249 CHECK_CHAR_TABLE (char_table
, 1);
1250 CHECK_NUMBER (n
, 2);
1252 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
1253 args_out_of_range (char_table
, n
);
1255 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)] = value
;
1258 DEFUN ("char-table-range", Fchar_table_range
, Schar_table_range
,
1260 "Return the value in CHAR-TABLE for a range of characters RANGE.\n\
1261 RANGE should be t (for all characters), nil (for the default value)\n\
1262 a vector which identifies a character set or a row of a character set,\n\
1263 or a character code.")
1265 Lisp_Object char_table
, range
;
1269 CHECK_CHAR_TABLE (char_table
, 0);
1271 if (EQ (range
, Qnil
))
1272 return XCHAR_TABLE (char_table
)->defalt
;
1273 else if (INTEGERP (range
))
1274 return Faref (char_table
, range
);
1275 else if (VECTORP (range
))
1277 for (i
= 0; i
< XVECTOR (range
)->size
- 1; i
++)
1278 char_table
= Faref (char_table
, XVECTOR (range
)->contents
[i
]);
1280 if (EQ (XVECTOR (range
)->contents
[i
], Qnil
))
1281 return XCHAR_TABLE (char_table
)->defalt
;
1283 return Faref (char_table
, XVECTOR (range
)->contents
[i
]);
1286 error ("Invalid RANGE argument to `char-table-range'");
1289 DEFUN ("set-char-table-range", Fset_char_table_range
, Sset_char_table_range
,
1291 "Set the value in CHAR-TABLE for a range of characters RANGE to VALUE.\n\
1292 RANGE should be t (for all characters), nil (for the default value)\n\
1293 a vector which identifies a character set or a row of a character set,\n\
1294 or a character code.")
1295 (char_table
, range
, value
)
1296 Lisp_Object char_table
, range
, value
;
1300 CHECK_CHAR_TABLE (char_table
, 0);
1303 for (i
= 0; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
1304 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
1305 else if (EQ (range
, Qnil
))
1306 XCHAR_TABLE (char_table
)->defalt
= value
;
1307 else if (INTEGERP (range
))
1308 Faset (char_table
, range
, value
);
1309 else if (VECTORP (range
))
1311 for (i
= 0; i
< XVECTOR (range
)->size
- 1; i
++)
1312 char_table
= Faref (char_table
, XVECTOR (range
)->contents
[i
]);
1314 if (EQ (XVECTOR (range
)->contents
[i
], Qnil
))
1315 XCHAR_TABLE (char_table
)->defalt
= value
;
1317 Faset (char_table
, XVECTOR (range
)->contents
[i
], value
);
1320 error ("Invalid RANGE argument to `set-char-table-range'");
1325 /* Map C_FUNCTION or FUNCTION over CHARTABLE, calling it for each
1326 character or group of characters that share a value.
1327 DEPTH is the current depth in the originally specified
1328 chartable, and INDICES contains the vector indices
1329 for the levels our callers have descended. */
1332 map_char_table (c_function
, function
, chartable
, depth
, indices
)
1333 Lisp_Object (*c_function
) (), function
, chartable
, depth
, *indices
;
1336 int size
= CHAR_TABLE_ORDINARY_SLOTS
;
1338 /* Make INDICES longer if we are about to fill it up. */
1339 if ((depth
% 10) == 9)
1341 Lisp_Object
*new_indices
1342 = (Lisp_Object
*) alloca ((depth
+= 10) * sizeof (Lisp_Object
));
1343 bcopy (indices
, new_indices
, depth
* sizeof (Lisp_Object
));
1344 indices
= new_indices
;
1347 for (i
= 0; i
< size
; i
++)
1351 elt
= XCHAR_TABLE (chartable
)->contents
[i
];
1352 if (CHAR_TABLE_P (elt
))
1353 map_char_table (chartable
, c_function
, function
, depth
+ 1, indices
);
1354 else if (c_function
)
1355 (*c_function
) (depth
+ 1, indices
, elt
);
1356 /* Here we should handle all cases where the range is a single character
1357 by passing that character as a number. Currently, that is
1358 all the time, but with the MULE code this will have to be changed. */
1359 else if (depth
== 0)
1360 call2 (function
, make_number (i
), elt
);
1362 call2 (function
, Fvector (depth
+ 1, indices
), elt
);
1366 DEFUN ("map-char-table", Fmap_char_table
, Smap_char_table
,
1368 "Call FUNCTION for each range of like characters in CHAR-TABLE.\n\
1369 FUNCTION is called with two arguments--a key and a value.\n\
1370 The key is always a possible RANGE argument to `set-char-table-range'.")
1371 (function
, char_table
)
1372 Lisp_Object function
, char_table
;
1375 Lisp_Object
*indices
= (Lisp_Object
*) alloca (10 * sizeof (Lisp_Object
));
1377 map_char_table (NULL
, function
, char_table
, 0, indices
);
1387 Lisp_Object args
[2];
1390 return Fnconc (2, args
);
1392 return Fnconc (2, &s1
);
1393 #endif /* NO_ARG_ARRAY */
1396 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
1397 "Concatenate any number of lists by altering them.\n\
1398 Only the last argument is not altered, and need not be a list.")
1403 register int argnum
;
1404 register Lisp_Object tail
, tem
, val
;
1408 for (argnum
= 0; argnum
< nargs
; argnum
++)
1411 if (NILP (tem
)) continue;
1416 if (argnum
+ 1 == nargs
) break;
1419 tem
= wrong_type_argument (Qlistp
, tem
);
1428 tem
= args
[argnum
+ 1];
1429 Fsetcdr (tail
, tem
);
1431 args
[argnum
+ 1] = tail
;
1437 /* This is the guts of all mapping functions.
1438 Apply fn to each element of seq, one by one,
1439 storing the results into elements of vals, a C vector of Lisp_Objects.
1440 leni is the length of vals, which should also be the length of seq. */
1443 mapcar1 (leni
, vals
, fn
, seq
)
1446 Lisp_Object fn
, seq
;
1448 register Lisp_Object tail
;
1451 struct gcpro gcpro1
, gcpro2
, gcpro3
;
1453 /* Don't let vals contain any garbage when GC happens. */
1454 for (i
= 0; i
< leni
; i
++)
1457 GCPRO3 (dummy
, fn
, seq
);
1459 gcpro1
.nvars
= leni
;
1460 /* We need not explicitly protect `tail' because it is used only on lists, and
1461 1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
1465 for (i
= 0; i
< leni
; i
++)
1467 dummy
= XVECTOR (seq
)->contents
[i
];
1468 vals
[i
] = call1 (fn
, dummy
);
1471 else if (STRINGP (seq
))
1473 for (i
= 0; i
< leni
; i
++)
1475 XSETFASTINT (dummy
, XSTRING (seq
)->data
[i
]);
1476 vals
[i
] = call1 (fn
, dummy
);
1479 else /* Must be a list, since Flength did not get an error */
1482 for (i
= 0; i
< leni
; i
++)
1484 vals
[i
] = call1 (fn
, Fcar (tail
));
1492 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
1493 "Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.\n\
1494 In between each pair of results, stick in SEPARATOR. Thus, \" \" as\n\
1495 SEPARATOR results in spaces between the values returned by FUNCTION.")
1496 (function
, sequence
, separator
)
1497 Lisp_Object function
, sequence
, separator
;
1502 register Lisp_Object
*args
;
1504 struct gcpro gcpro1
;
1506 len
= Flength (sequence
);
1508 nargs
= leni
+ leni
- 1;
1509 if (nargs
< 0) return build_string ("");
1511 args
= (Lisp_Object
*) alloca (nargs
* sizeof (Lisp_Object
));
1514 mapcar1 (leni
, args
, function
, sequence
);
1517 for (i
= leni
- 1; i
>= 0; i
--)
1518 args
[i
+ i
] = args
[i
];
1520 for (i
= 1; i
< nargs
; i
+= 2)
1521 args
[i
] = separator
;
1523 return Fconcat (nargs
, args
);
1526 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
1527 "Apply FUNCTION to each element of SEQUENCE, and make a list of the results.\n\
1528 The result is a list just as long as SEQUENCE.\n\
1529 SEQUENCE may be a list, a vector or a string.")
1530 (function
, sequence
)
1531 Lisp_Object function
, sequence
;
1533 register Lisp_Object len
;
1535 register Lisp_Object
*args
;
1537 len
= Flength (sequence
);
1538 leni
= XFASTINT (len
);
1539 args
= (Lisp_Object
*) alloca (leni
* sizeof (Lisp_Object
));
1541 mapcar1 (leni
, args
, function
, sequence
);
1543 return Flist (leni
, args
);
1546 /* Anything that calls this function must protect from GC! */
1548 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
1549 "Ask user a \"y or n\" question. Return t if answer is \"y\".\n\
1550 Takes one argument, which is the string to display to ask the question.\n\
1551 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.\n\
1552 No confirmation of the answer is requested; a single character is enough.\n\
1553 Also accepts Space to mean yes, or Delete to mean no.")
1557 register Lisp_Object obj
, key
, def
, answer_string
, map
;
1558 register int answer
;
1559 Lisp_Object xprompt
;
1560 Lisp_Object args
[2];
1561 int ocech
= cursor_in_echo_area
;
1562 struct gcpro gcpro1
, gcpro2
;
1564 map
= Fsymbol_value (intern ("query-replace-map"));
1566 CHECK_STRING (prompt
, 0);
1568 GCPRO2 (prompt
, xprompt
);
1573 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
1576 Lisp_Object pane
, menu
;
1577 redisplay_preserve_echo_area ();
1578 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
1579 Fcons (Fcons (build_string ("No"), Qnil
),
1581 menu
= Fcons (prompt
, pane
);
1582 obj
= Fx_popup_dialog (Qt
, menu
);
1583 answer
= !NILP (obj
);
1586 #endif /* HAVE_MENUS */
1587 cursor_in_echo_area
= 1;
1588 message_nolog ("%s(y or n) ", XSTRING (xprompt
)->data
);
1590 obj
= read_filtered_event (1, 0, 0);
1591 cursor_in_echo_area
= 0;
1592 /* If we need to quit, quit with cursor_in_echo_area = 0. */
1595 key
= Fmake_vector (make_number (1), obj
);
1596 def
= Flookup_key (map
, key
);
1597 answer_string
= Fsingle_key_description (obj
);
1599 if (EQ (def
, intern ("skip")))
1604 else if (EQ (def
, intern ("act")))
1609 else if (EQ (def
, intern ("recenter")))
1615 else if (EQ (def
, intern ("quit")))
1617 /* We want to exit this command for exit-prefix,
1618 and this is the only way to do it. */
1619 else if (EQ (def
, intern ("exit-prefix")))
1624 /* If we don't clear this, then the next call to read_char will
1625 return quit_char again, and we'll enter an infinite loop. */
1630 if (EQ (xprompt
, prompt
))
1632 args
[0] = build_string ("Please answer y or n. ");
1634 xprompt
= Fconcat (2, args
);
1639 if (! noninteractive
)
1641 cursor_in_echo_area
= -1;
1642 message_nolog ("%s(y or n) %c",
1643 XSTRING (xprompt
)->data
, answer
? 'y' : 'n');
1644 cursor_in_echo_area
= ocech
;
1647 return answer
? Qt
: Qnil
;
1650 /* This is how C code calls `yes-or-no-p' and allows the user
1653 Anything that calls this function must protect from GC! */
1656 do_yes_or_no_p (prompt
)
1659 return call1 (intern ("yes-or-no-p"), prompt
);
1662 /* Anything that calls this function must protect from GC! */
1664 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
1665 "Ask user a yes-or-no question. Return t if answer is yes.\n\
1666 Takes one argument, which is the string to display to ask the question.\n\
1667 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.\n\
1668 The user must confirm the answer with RET,\n\
1669 and can edit it until it has been confirmed.")
1673 register Lisp_Object ans
;
1674 Lisp_Object args
[2];
1675 struct gcpro gcpro1
;
1678 CHECK_STRING (prompt
, 0);
1681 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
1684 Lisp_Object pane
, menu
, obj
;
1685 redisplay_preserve_echo_area ();
1686 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
1687 Fcons (Fcons (build_string ("No"), Qnil
),
1690 menu
= Fcons (prompt
, pane
);
1691 obj
= Fx_popup_dialog (Qt
, menu
);
1695 #endif /* HAVE_MENUS */
1698 args
[1] = build_string ("(yes or no) ");
1699 prompt
= Fconcat (2, args
);
1705 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
1706 Qyes_or_no_p_history
));
1707 if (XSTRING (ans
)->size
== 3 && !strcmp (XSTRING (ans
)->data
, "yes"))
1712 if (XSTRING (ans
)->size
== 2 && !strcmp (XSTRING (ans
)->data
, "no"))
1720 message ("Please answer yes or no.");
1721 Fsleep_for (make_number (2), Qnil
);
1725 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 0, 0,
1726 "Return list of 1 minute, 5 minute and 15 minute load averages.\n\
1727 Each of the three load averages is multiplied by 100,\n\
1728 then converted to integer.\n\
1729 If the 5-minute or 15-minute load averages are not available, return a\n\
1730 shortened list, containing only those averages which are available.")
1734 int loads
= getloadavg (load_ave
, 3);
1738 error ("load-average not implemented for this operating system");
1742 ret
= Fcons (make_number ((int) (load_ave
[--loads
] * 100.0)), ret
);
1747 Lisp_Object Vfeatures
;
1749 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 1, 0,
1750 "Returns t if FEATURE is present in this Emacs.\n\
1751 Use this to conditionalize execution of lisp code based on the presence or\n\
1752 absence of emacs or environment extensions.\n\
1753 Use `provide' to declare that a feature is available.\n\
1754 This function looks at the value of the variable `features'.")
1756 Lisp_Object feature
;
1758 register Lisp_Object tem
;
1759 CHECK_SYMBOL (feature
, 0);
1760 tem
= Fmemq (feature
, Vfeatures
);
1761 return (NILP (tem
)) ? Qnil
: Qt
;
1764 DEFUN ("provide", Fprovide
, Sprovide
, 1, 1, 0,
1765 "Announce that FEATURE is a feature of the current Emacs.")
1767 Lisp_Object feature
;
1769 register Lisp_Object tem
;
1770 CHECK_SYMBOL (feature
, 0);
1771 if (!NILP (Vautoload_queue
))
1772 Vautoload_queue
= Fcons (Fcons (Vfeatures
, Qnil
), Vautoload_queue
);
1773 tem
= Fmemq (feature
, Vfeatures
);
1775 Vfeatures
= Fcons (feature
, Vfeatures
);
1776 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
1780 DEFUN ("require", Frequire
, Srequire
, 1, 2, 0,
1781 "If feature FEATURE is not loaded, load it from FILENAME.\n\
1782 If FEATURE is not a member of the list `features', then the feature\n\
1783 is not loaded; so load the file FILENAME.\n\
1784 If FILENAME is omitted, the printname of FEATURE is used as the file name.")
1785 (feature
, file_name
)
1786 Lisp_Object feature
, file_name
;
1788 register Lisp_Object tem
;
1789 CHECK_SYMBOL (feature
, 0);
1790 tem
= Fmemq (feature
, Vfeatures
);
1791 LOADHIST_ATTACH (Fcons (Qrequire
, feature
));
1794 int count
= specpdl_ptr
- specpdl
;
1796 /* Value saved here is to be restored into Vautoload_queue */
1797 record_unwind_protect (un_autoload
, Vautoload_queue
);
1798 Vautoload_queue
= Qt
;
1800 Fload (NILP (file_name
) ? Fsymbol_name (feature
) : file_name
,
1803 tem
= Fmemq (feature
, Vfeatures
);
1805 error ("Required feature %s was not provided",
1806 XSYMBOL (feature
)->name
->data
);
1808 /* Once loading finishes, don't undo it. */
1809 Vautoload_queue
= Qt
;
1810 feature
= unbind_to (count
, feature
);
1817 Qstring_lessp
= intern ("string-lessp");
1818 staticpro (&Qstring_lessp
);
1819 Qprovide
= intern ("provide");
1820 staticpro (&Qprovide
);
1821 Qrequire
= intern ("require");
1822 staticpro (&Qrequire
);
1823 Qyes_or_no_p_history
= intern ("yes-or-no-p-history");
1824 staticpro (&Qyes_or_no_p_history
);
1826 DEFVAR_LISP ("features", &Vfeatures
,
1827 "A list of symbols which are the features of the executing emacs.\n\
1828 Used by `featurep' and `require', and altered by `provide'.");
1831 defsubr (&Sidentity
);
1834 defsubr (&Ssafe_length
);
1835 defsubr (&Sstring_equal
);
1836 defsubr (&Sstring_lessp
);
1839 defsubr (&Svconcat
);
1840 defsubr (&Scopy_sequence
);
1841 defsubr (&Scopy_alist
);
1842 defsubr (&Ssubstring
);
1854 defsubr (&Snreverse
);
1855 defsubr (&Sreverse
);
1857 defsubr (&Splist_get
);
1859 defsubr (&Splist_put
);
1862 defsubr (&Sfillarray
);
1863 defsubr (&Schar_table_subtype
);
1864 defsubr (&Schar_table_parent
);
1865 defsubr (&Sset_char_table_parent
);
1866 defsubr (&Schar_table_extra_slot
);
1867 defsubr (&Sset_char_table_extra_slot
);
1868 defsubr (&Schar_table_range
);
1869 defsubr (&Sset_char_table_range
);
1870 defsubr (&Smap_char_table
);
1873 defsubr (&Smapconcat
);
1874 defsubr (&Sy_or_n_p
);
1875 defsubr (&Syes_or_no_p
);
1876 defsubr (&Sload_average
);
1877 defsubr (&Sfeaturep
);
1878 defsubr (&Srequire
);
1879 defsubr (&Sprovide
);