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, 675 Mass Ave, Cambridge, MA 02139, USA. */
23 /* Note on some machines this defines `vector' as a typedef,
24 so make sure we don't use that name in this file. */
33 #include "intervals.h"
36 #define NULL (void *)0
39 extern Lisp_Object
Flookup_key ();
41 Lisp_Object Qstring_lessp
, Qprovide
, Qrequire
;
42 Lisp_Object Qyes_or_no_p_history
;
44 static int internal_equal ();
46 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
47 "Return the argument unchanged.")
54 extern long get_random ();
55 extern void seed_random ();
58 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
59 "Return a pseudo-random number.\n\
60 All integers representable in Lisp are equally likely.\n\
61 On most systems, this is 28 bits' worth.\n\
62 With positive integer argument N, return random number in interval [0,N).\n\
63 With argument t, set the random number seed from the current time and pid.")
68 Lisp_Object lispy_val
;
69 unsigned long denominator
;
72 seed_random (getpid () + time (NULL
));
73 if (NATNUMP (limit
) && XFASTINT (limit
) != 0)
75 /* Try to take our random number from the higher bits of VAL,
76 not the lower, since (says Gentzel) the low bits of `random'
77 are less random than the higher ones. We do this by using the
78 quotient rather than the remainder. At the high end of the RNG
79 it's possible to get a quotient larger than limit; discarding
80 these values eliminates the bias that would otherwise appear
81 when using a large limit. */
82 denominator
= ((unsigned long)1 << VALBITS
) / XFASTINT (limit
);
84 val
= get_random () / denominator
;
85 while (val
>= XFASTINT (limit
));
89 XSETINT (lispy_val
, val
);
93 /* Random data-structure functions */
95 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
96 "Return the length of vector, list or string SEQUENCE.\n\
97 A byte-code function object is also allowed.")
99 register Lisp_Object obj
;
101 register Lisp_Object tail
, val
;
106 XSETFASTINT (val
, XSTRING (obj
)->size
);
107 else if (VECTORP (obj
))
108 XSETFASTINT (val
, XVECTOR (obj
)->size
);
109 else if (CHAR_TABLE_P (obj
))
110 XSETFASTINT (val
, CHAR_TABLE_ORDINARY_SLOTS
);
111 else if (BOOL_VECTOR_P (obj
))
112 XSETFASTINT (val
, XBOOL_VECTOR (obj
)->size
);
113 else if (COMPILEDP (obj
))
114 XSETFASTINT (val
, XVECTOR (obj
)->size
& PSEUDOVECTOR_SIZE_MASK
);
115 else if (CONSP (obj
))
117 for (i
= 0, tail
= obj
; !NILP (tail
); i
++)
123 XSETFASTINT (val
, i
);
126 XSETFASTINT (val
, 0);
129 obj
= wrong_type_argument (Qsequencep
, obj
);
135 /* This does not check for quits. That is safe
136 since it must terminate. */
138 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
139 "Return the length of a list, but avoid error or infinite loop.\n\
140 This function never gets an error. If LIST is not really a list,\n\
141 it returns 0. If LIST is circular, it returns a finite value\n\
142 which is at least the number of distinct elements.")
146 Lisp_Object tail
, halftail
, length
;
149 /* halftail is used to detect circular lists. */
151 for (tail
= list
; CONSP (tail
); tail
= XCONS (tail
)->cdr
)
153 if (EQ (tail
, halftail
) && len
!= 0)
157 halftail
= XCONS (halftail
)->cdr
;
160 XSETINT (length
, len
);
164 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
165 "T if two strings have identical contents.\n\
166 Case is significant, but text properties are ignored.\n\
167 Symbols are also allowed; their print names are used instead.")
169 register Lisp_Object s1
, s2
;
172 XSETSTRING (s1
, XSYMBOL (s1
)->name
);
174 XSETSTRING (s2
, XSYMBOL (s2
)->name
);
175 CHECK_STRING (s1
, 0);
176 CHECK_STRING (s2
, 1);
178 if (XSTRING (s1
)->size
!= XSTRING (s2
)->size
||
179 bcmp (XSTRING (s1
)->data
, XSTRING (s2
)->data
, XSTRING (s1
)->size
))
184 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
185 "T if first arg string is less than second in lexicographic order.\n\
186 Case is significant.\n\
187 Symbols are also allowed; their print names are used instead.")
189 register Lisp_Object s1
, s2
;
192 register unsigned char *p1
, *p2
;
196 XSETSTRING (s1
, XSYMBOL (s1
)->name
);
198 XSETSTRING (s2
, XSYMBOL (s2
)->name
);
199 CHECK_STRING (s1
, 0);
200 CHECK_STRING (s2
, 1);
202 p1
= XSTRING (s1
)->data
;
203 p2
= XSTRING (s2
)->data
;
204 end
= XSTRING (s1
)->size
;
205 if (end
> XSTRING (s2
)->size
)
206 end
= XSTRING (s2
)->size
;
208 for (i
= 0; i
< end
; i
++)
211 return p1
[i
] < p2
[i
] ? Qt
: Qnil
;
213 return i
< XSTRING (s2
)->size
? Qt
: Qnil
;
216 static Lisp_Object
concat ();
227 return concat (2, args
, Lisp_String
, 0);
229 return concat (2, &s1
, Lisp_String
, 0);
230 #endif /* NO_ARG_ARRAY */
236 Lisp_Object s1
, s2
, s3
;
243 return concat (3, args
, Lisp_String
, 0);
245 return concat (3, &s1
, Lisp_String
, 0);
246 #endif /* NO_ARG_ARRAY */
249 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
250 "Concatenate all the arguments and make the result a list.\n\
251 The result is a list whose elements are the elements of all the arguments.\n\
252 Each argument may be a list, vector or string.\n\
253 The last argument is not copied, just used as the tail of the new list.")
258 return concat (nargs
, args
, Lisp_Cons
, 1);
261 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
262 "Concatenate all the arguments and make the result a string.\n\
263 The result is a string whose elements are the elements of all the arguments.\n\
264 Each argument may be a string or a list or vector of characters (integers).\n\
266 Do not use individual integers as arguments!\n\
267 The behavior of `concat' in that case will be changed later!\n\
268 If your program passes an integer as an argument to `concat',\n\
269 you should change it right away not to do so.")
274 return concat (nargs
, args
, Lisp_String
, 0);
277 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
278 "Concatenate all the arguments and make the result a vector.\n\
279 The result is a vector whose elements are the elements of all the arguments.\n\
280 Each argument may be a list, vector or string.")
285 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
288 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
289 "Return a copy of a list, vector or string.\n\
290 The elements of a list or vector are not copied; they are shared\n\
295 if (NILP (arg
)) return arg
;
297 if (CHAR_TABLE_P (arg
))
302 /* Calculate the number of extra slots. */
303 size
= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (arg
));
304 copy
= Fmake_char_table (XCHAR_TABLE (arg
)->purpose
, Qnil
);
305 /* Copy all the slots, including the extra ones. */
306 bcopy (XCHAR_TABLE (arg
)->contents
, XCHAR_TABLE (copy
)->contents
,
307 (XCHAR_TABLE (arg
)->size
& PSEUDOVECTOR_SIZE_MASK
) * sizeof (Lisp_Object
));
309 /* Recursively copy any char-tables in the ordinary slots. */
310 for (i
= 0; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
311 if (CHAR_TABLE_P (XCHAR_TABLE (arg
)->contents
[i
]))
312 XCHAR_TABLE (copy
)->contents
[i
]
313 = Fcopy_sequence (XCHAR_TABLE (copy
)->contents
[i
]);
318 if (BOOL_VECTOR_P (arg
))
321 int bits_per_char
= INTBITS
/ sizeof (int);
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))
435 int bits_per_char
= INTBITS
/ sizeof (int);
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.")
515 register Lisp_Object from
, to
;
519 CHECK_STRING (string
, 0);
520 CHECK_NUMBER (from
, 1);
522 to
= Flength (string
);
524 CHECK_NUMBER (to
, 2);
527 XSETINT (from
, XINT (from
) + XSTRING (string
)->size
);
529 XSETINT (to
, XINT (to
) + XSTRING (string
)->size
);
530 if (!(0 <= XINT (from
) && XINT (from
) <= XINT (to
)
531 && XINT (to
) <= XSTRING (string
)->size
))
532 args_out_of_range_3 (string
, from
, to
);
534 res
= make_string (XSTRING (string
)->data
+ XINT (from
),
535 XINT (to
) - XINT (from
));
536 copy_text_properties (from
, to
, string
, make_number (0), res
, Qnil
);
540 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
541 "Take cdr N times on LIST, returns the result.")
544 register Lisp_Object list
;
549 for (i
= 0; i
< num
&& !NILP (list
); i
++)
557 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
558 "Return the Nth element of LIST.\n\
559 N counts from zero. If LIST is not that long, nil is returned.")
563 return Fcar (Fnthcdr (n
, list
));
566 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
567 "Return element of SEQUENCE at index N.")
569 register Lisp_Object seq
, n
;
574 if (CONSP (seq
) || NILP (seq
))
575 return Fcar (Fnthcdr (n
, seq
));
576 else if (STRINGP (seq
) || VECTORP (seq
) || BOOL_VECTOR_P (seq
)
577 || CHAR_TABLE_P (seq
))
578 return Faref (seq
, n
);
580 seq
= wrong_type_argument (Qsequencep
, seq
);
584 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
585 "Return non-nil if ELT is an element of LIST. Comparison done with `equal'.\n\
586 The value is actually the tail of LIST whose car is ELT.")
588 register Lisp_Object elt
;
591 register Lisp_Object tail
;
592 for (tail
= list
; !NILP (tail
); tail
= Fcdr (tail
))
594 register Lisp_Object tem
;
596 if (! NILP (Fequal (elt
, tem
)))
603 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
604 "Return non-nil if ELT is an element of LIST. Comparison done with EQ.\n\
605 The value is actually the tail of LIST whose car is ELT.")
607 register Lisp_Object elt
;
610 register Lisp_Object tail
;
611 for (tail
= list
; !NILP (tail
); tail
= Fcdr (tail
))
613 register Lisp_Object tem
;
615 if (EQ (elt
, tem
)) return tail
;
621 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
622 "Return non-nil if KEY is `eq' to the car of an element of LIST.\n\
623 The value is actually the element of LIST whose car is KEY.\n\
624 Elements of LIST that are not conses are ignored.")
626 register Lisp_Object key
;
629 register Lisp_Object tail
;
630 for (tail
= list
; !NILP (tail
); tail
= Fcdr (tail
))
632 register Lisp_Object elt
, tem
;
634 if (!CONSP (elt
)) continue;
636 if (EQ (key
, tem
)) return elt
;
642 /* Like Fassq but never report an error and do not allow quits.
643 Use only on lists known never to be circular. */
646 assq_no_quit (key
, list
)
647 register Lisp_Object key
;
650 register Lisp_Object tail
;
651 for (tail
= list
; CONSP (tail
); tail
= Fcdr (tail
))
653 register Lisp_Object elt
, tem
;
655 if (!CONSP (elt
)) continue;
657 if (EQ (key
, tem
)) return elt
;
662 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
663 "Return non-nil if KEY is `equal' to the car of an element of LIST.\n\
664 The value is actually the element of LIST whose car equals KEY.")
666 register Lisp_Object key
;
669 register Lisp_Object tail
;
670 for (tail
= list
; !NILP (tail
); tail
= Fcdr (tail
))
672 register Lisp_Object elt
, tem
;
674 if (!CONSP (elt
)) continue;
675 tem
= Fequal (Fcar (elt
), key
);
676 if (!NILP (tem
)) return elt
;
682 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
683 "Return non-nil if ELT is `eq' to the cdr of an element of LIST.\n\
684 The value is actually the element of LIST whose cdr is ELT.")
686 register Lisp_Object key
;
689 register Lisp_Object tail
;
690 for (tail
= list
; !NILP (tail
); tail
= Fcdr (tail
))
692 register Lisp_Object elt
, tem
;
694 if (!CONSP (elt
)) continue;
696 if (EQ (key
, tem
)) return elt
;
702 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
703 "Return non-nil if KEY is `equal' to the cdr of an element of LIST.\n\
704 The value is actually the element of LIST whose cdr equals KEY.")
706 register Lisp_Object key
;
709 register Lisp_Object tail
;
710 for (tail
= list
; !NILP (tail
); tail
= Fcdr (tail
))
712 register Lisp_Object elt
, tem
;
714 if (!CONSP (elt
)) continue;
715 tem
= Fequal (Fcdr (elt
), key
);
716 if (!NILP (tem
)) return elt
;
722 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
723 "Delete by side effect any occurrences of ELT as a member of LIST.\n\
724 The modified LIST is returned. Comparison is done with `eq'.\n\
725 If the first member of LIST is ELT, there is no way to remove it by side effect;\n\
726 therefore, write `(setq foo (delq element foo))'\n\
727 to be sure of changing the value of `foo'.")
729 register Lisp_Object elt
;
732 register Lisp_Object tail
, prev
;
733 register Lisp_Object tem
;
745 Fsetcdr (prev
, Fcdr (tail
));
755 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
756 "Delete by side effect any occurrences of ELT as a member of LIST.\n\
757 The modified LIST is returned. Comparison is done with `equal'.\n\
758 If the first member of LIST is ELT, deleting it is not a side effect;\n\
759 it is simply using a different list.\n\
760 Therefore, write `(setq foo (delete element foo))'\n\
761 to be sure of changing the value of `foo'.")
763 register Lisp_Object elt
;
766 register Lisp_Object tail
, prev
;
767 register Lisp_Object tem
;
774 if (! NILP (Fequal (elt
, tem
)))
779 Fsetcdr (prev
, Fcdr (tail
));
789 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
790 "Reverse LIST by modifying cdr pointers.\n\
791 Returns the beginning of the reversed list.")
795 register Lisp_Object prev
, tail
, next
;
797 if (NILP (list
)) return list
;
804 Fsetcdr (tail
, prev
);
811 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
812 "Reverse LIST, copying. Returns the beginning of the reversed list.\n\
813 See also the function `nreverse', which is used more often.")
818 register Lisp_Object
*vec
;
819 register Lisp_Object tail
;
822 length
= Flength (list
);
823 vec
= (Lisp_Object
*) alloca (XINT (length
) * sizeof (Lisp_Object
));
824 for (i
= XINT (length
) - 1, tail
= list
; i
>= 0; i
--, tail
= Fcdr (tail
))
825 vec
[i
] = Fcar (tail
);
827 return Flist (XINT (length
), vec
);
830 Lisp_Object
merge ();
832 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
833 "Sort LIST, stably, comparing elements using PREDICATE.\n\
834 Returns the sorted list. LIST is modified by side effects.\n\
835 PREDICATE is called with two elements of LIST, and should return T\n\
836 if the first element is \"less\" than the second.")
838 Lisp_Object list
, pred
;
840 Lisp_Object front
, back
;
841 register Lisp_Object len
, tem
;
842 struct gcpro gcpro1
, gcpro2
;
846 len
= Flength (list
);
851 XSETINT (len
, (length
/ 2) - 1);
852 tem
= Fnthcdr (len
, list
);
856 GCPRO2 (front
, back
);
857 front
= Fsort (front
, pred
);
858 back
= Fsort (back
, pred
);
860 return merge (front
, back
, pred
);
864 merge (org_l1
, org_l2
, pred
)
865 Lisp_Object org_l1
, org_l2
;
869 register Lisp_Object tail
;
871 register Lisp_Object l1
, l2
;
872 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
879 /* It is sufficient to protect org_l1 and org_l2.
880 When l1 and l2 are updated, we copy the new values
881 back into the org_ vars. */
882 GCPRO4 (org_l1
, org_l2
, pred
, value
);
902 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
924 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
925 "Extract a value from a property list.\n\
926 PLIST is a property list, which is a list of the form\n\
927 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value\n\
928 corresponding to the given PROP, or nil if PROP is not\n\
929 one of the properties on the list.")
932 register Lisp_Object prop
;
934 register Lisp_Object tail
;
935 for (tail
= val
; !NILP (tail
); tail
= Fcdr (Fcdr (tail
)))
937 register Lisp_Object tem
;
940 return Fcar (Fcdr (tail
));
945 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
946 "Return the value of SYMBOL's PROPNAME property.\n\
947 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'.")
949 Lisp_Object symbol
, propname
;
951 CHECK_SYMBOL (symbol
, 0);
952 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
955 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
956 "Change value in PLIST of PROP to VAL.\n\
957 PLIST is a property list, which is a list of the form\n\
958 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.\n\
959 If PROP is already a property on the list, its value is set to VAL,\n\
960 otherwise the new PROP VAL pair is added. The new plist is returned;\n\
961 use `(setq x (plist-put x prop val))' to be sure to use the new value.\n\
962 The PLIST is modified by side effects.")
965 register Lisp_Object prop
;
968 register Lisp_Object tail
, prev
;
971 for (tail
= plist
; CONSP (tail
) && CONSP (XCONS (tail
)->cdr
);
972 tail
= XCONS (XCONS (tail
)->cdr
)->cdr
)
974 if (EQ (prop
, XCONS (tail
)->car
))
976 Fsetcar (XCONS (tail
)->cdr
, val
);
981 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
985 Fsetcdr (XCONS (prev
)->cdr
, newcell
);
989 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
990 "Store SYMBOL's PROPNAME property with value VALUE.\n\
991 It can be retrieved with `(get SYMBOL PROPNAME)'.")
992 (symbol
, propname
, value
)
993 Lisp_Object symbol
, propname
, value
;
995 CHECK_SYMBOL (symbol
, 0);
996 XSYMBOL (symbol
)->plist
997 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
1001 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
1002 "T if two Lisp objects have similar structure and contents.\n\
1003 They must have the same data type.\n\
1004 Conses are compared by comparing the cars and the cdrs.\n\
1005 Vectors and strings are compared element by element.\n\
1006 Numbers are compared by value, but integers cannot equal floats.\n\
1007 (Use `=' if you want integers and floats to be able to be equal.)\n\
1008 Symbols must match exactly.")
1010 register Lisp_Object o1
, o2
;
1012 return internal_equal (o1
, o2
, 0) ? Qt
: Qnil
;
1016 internal_equal (o1
, o2
, depth
)
1017 register Lisp_Object o1
, o2
;
1021 error ("Stack overflow in equal");
1027 if (XTYPE (o1
) != XTYPE (o2
))
1032 #ifdef LISP_FLOAT_TYPE
1034 return (extract_float (o1
) == extract_float (o2
));
1038 if (!internal_equal (XCONS (o1
)->car
, XCONS (o2
)->car
, depth
+ 1))
1040 o1
= XCONS (o1
)->cdr
;
1041 o2
= XCONS (o2
)->cdr
;
1045 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
1049 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o1
),
1051 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o1
),
1054 o1
= XOVERLAY (o1
)->plist
;
1055 o2
= XOVERLAY (o2
)->plist
;
1060 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
1061 && (XMARKER (o1
)->buffer
== 0
1062 || XMARKER (o1
)->bufpos
== XMARKER (o2
)->bufpos
));
1066 case Lisp_Vectorlike
:
1068 register int i
, size
;
1069 size
= XVECTOR (o1
)->size
;
1070 /* Pseudovectors have the type encoded in the size field, so this test
1071 actually checks that the objects have the same type as well as the
1073 if (XVECTOR (o2
)->size
!= size
)
1075 /* Boolvectors are compared much like strings. */
1076 if (BOOL_VECTOR_P (o1
))
1078 int bits_per_char
= INTBITS
/ sizeof (int);
1080 = (XBOOL_VECTOR (o1
)->size
+ bits_per_char
) / bits_per_char
;
1082 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
1084 if (bcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
1090 /* Aside from them, only true vectors, char-tables, and compiled
1091 functions are sensible to compare, so eliminate the others now. */
1092 if (size
& PSEUDOVECTOR_FLAG
)
1094 if (!(size
& (PVEC_COMPILED
| PVEC_CHAR_TABLE
)))
1096 size
&= PSEUDOVECTOR_SIZE_MASK
;
1098 for (i
= 0; i
< size
; i
++)
1101 v1
= XVECTOR (o1
)->contents
[i
];
1102 v2
= XVECTOR (o2
)->contents
[i
];
1103 if (!internal_equal (v1
, v2
, depth
+ 1))
1111 if (XSTRING (o1
)->size
!= XSTRING (o2
)->size
)
1113 if (bcmp (XSTRING (o1
)->data
, XSTRING (o2
)->data
,
1114 XSTRING (o1
)->size
))
1116 #ifdef USE_TEXT_PROPERTIES
1117 /* If the strings have intervals, verify they match;
1118 if not, they are unequal. */
1119 if ((XSTRING (o1
)->intervals
!= 0 || XSTRING (o2
)->intervals
!= 0)
1120 && ! compare_string_intervals (o1
, o2
))
1128 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
1129 "Store each element of ARRAY with ITEM.\n\
1130 ARRAY is a vector, string, char-table, or bool-vector.")
1132 Lisp_Object array
, item
;
1134 register int size
, index
, charval
;
1136 if (VECTORP (array
))
1138 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
1139 size
= XVECTOR (array
)->size
;
1140 for (index
= 0; index
< size
; index
++)
1143 else if (CHAR_TABLE_P (array
))
1145 register Lisp_Object
*p
= XCHAR_TABLE (array
)->contents
;
1146 size
= CHAR_TABLE_ORDINARY_SLOTS
;
1147 for (index
= 0; index
< size
; index
++)
1149 XCHAR_TABLE (array
)->defalt
= Qnil
;
1151 else if (STRINGP (array
))
1153 register unsigned char *p
= XSTRING (array
)->data
;
1154 CHECK_NUMBER (item
, 1);
1155 charval
= XINT (item
);
1156 size
= XSTRING (array
)->size
;
1157 for (index
= 0; index
< size
; index
++)
1160 else if (BOOL_VECTOR_P (array
))
1162 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
1163 int bits_per_char
= INTBITS
/ sizeof (int);
1165 = (XBOOL_VECTOR (array
)->size
+ bits_per_char
) / bits_per_char
;
1167 charval
= (! NILP (item
) ? -1 : 0);
1168 for (index
= 0; index
< size_in_chars
; index
++)
1173 array
= wrong_type_argument (Qarrayp
, array
);
1179 DEFUN ("char-table-subtype", Fchar_table_subtype
, Schar_table_subtype
,
1181 "Return the subtype of char-table CHAR-TABLE. The value is a symbol.")
1183 Lisp_Object chartable
;
1185 CHECK_CHAR_TABLE (chartable
, 0);
1187 return XCHAR_TABLE (chartable
)->purpose
;
1190 DEFUN ("char-table-parent", Fchar_table_parent
, Schar_table_parent
,
1192 "Return the parent char-table of CHAR-TABLE.\n\
1193 The value is either nil or another char-table.\n\
1194 If CHAR-TABLE holds nil for a given character,\n\
1195 then the actual applicable value is inherited from the parent char-table\n\
1196 \(or from its parents, if necessary).")
1198 Lisp_Object chartable
;
1200 CHECK_CHAR_TABLE (chartable
, 0);
1202 return XCHAR_TABLE (chartable
)->parent
;
1205 DEFUN ("set-char-table-parent", Fset_char_table_parent
, Sset_char_table_parent
,
1207 "Set the parent char-table of CHAR-TABLE to PARENT.\n\
1208 PARENT must be either nil or another char-table.")
1210 Lisp_Object chartable
, parent
;
1214 CHECK_CHAR_TABLE (chartable
, 0);
1218 CHECK_CHAR_TABLE (parent
, 0);
1220 for (temp
= parent
; !NILP (temp
); temp
= XCHAR_TABLE (temp
)->parent
)
1221 if (EQ (temp
, chartable
))
1222 error ("Attempt to make a chartable be its own parent");
1225 XCHAR_TABLE (chartable
)->parent
= parent
;
1230 DEFUN ("char-table-extra-slot", Fchar_table_extra_slot
, Schar_table_extra_slot
,
1232 "Return the value in extra-slot number N of char-table CHAR-TABLE.")
1234 Lisp_Object chartable
, n
;
1236 CHECK_CHAR_TABLE (chartable
, 1);
1237 CHECK_NUMBER (n
, 2);
1239 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (chartable
)))
1240 args_out_of_range (chartable
, n
);
1242 return XCHAR_TABLE (chartable
)->extras
[XINT (n
)];
1245 DEFUN ("set-char-table-extra-slot", Fset_char_table_extra_slot
,
1246 Sset_char_table_extra_slot
,
1248 "Set extra-slot number N of CHAR-TABLE to VALUE.")
1249 (chartable
, n
, value
)
1250 Lisp_Object chartable
, n
, value
;
1252 CHECK_CHAR_TABLE (chartable
, 1);
1253 CHECK_NUMBER (n
, 2);
1255 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (chartable
)))
1256 args_out_of_range (chartable
, n
);
1258 return XCHAR_TABLE (chartable
)->extras
[XINT (n
)] = value
;
1261 DEFUN ("char-table-range", Fchar_table_range
, Schar_table_range
,
1263 "Return the value in CHARTABLE for a range of characters RANGE.\n\
1264 RANGE should be t (for all characters), nil (for the default value)\n\
1265 a vector which identifies a character set or a row of a character set,\n\
1266 or a character code.")
1268 Lisp_Object chartable
, range
;
1272 CHECK_CHAR_TABLE (chartable
, 0);
1274 if (EQ (range
, Qnil
))
1275 return XCHAR_TABLE (chartable
)->defalt
;
1276 else if (INTEGERP (range
))
1277 return Faref (chartable
, range
);
1278 else if (VECTORP (range
))
1280 for (i
= 0; i
< XVECTOR (range
)->size
- 1; i
++)
1281 chartable
= Faref (chartable
, XVECTOR (range
)->contents
[i
]);
1283 if (EQ (XVECTOR (range
)->contents
[i
], Qnil
))
1284 return XCHAR_TABLE (chartable
)->defalt
;
1286 return Faref (chartable
, XVECTOR (range
)->contents
[i
]);
1289 error ("Invalid RANGE argument to `char-table-range'");
1292 DEFUN ("set-char-table-range", Fset_char_table_range
, Sset_char_table_range
,
1294 "Set the value in CHARTABLE for a range of characters RANGE to VALUE.\n\
1295 RANGE should be t (for all characters), nil (for the default value)\n\
1296 a vector which identifies a character set or a row of a character set,\n\
1297 or a character code.")
1298 (chartable
, range
, value
)
1299 Lisp_Object chartable
, range
, value
;
1303 CHECK_CHAR_TABLE (chartable
, 0);
1306 for (i
= 0; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
1307 XCHAR_TABLE (chartable
)->contents
[i
] = value
;
1308 else if (EQ (range
, Qnil
))
1309 XCHAR_TABLE (chartable
)->defalt
= value
;
1310 else if (INTEGERP (range
))
1311 Faset (chartable
, range
, value
);
1312 else if (VECTORP (range
))
1314 for (i
= 0; i
< XVECTOR (range
)->size
- 1; i
++)
1315 chartable
= Faref (chartable
, XVECTOR (range
)->contents
[i
]);
1317 if (EQ (XVECTOR (range
)->contents
[i
], Qnil
))
1318 XCHAR_TABLE (chartable
)->defalt
= value
;
1320 Faset (chartable
, XVECTOR (range
)->contents
[i
], value
);
1323 error ("Invalid RANGE argument to `set-char-table-range'");
1328 /* Map C_FUNCTION or FUNCTION over CHARTABLE, calling it for each
1329 character or group of characters that share a value.
1330 DEPTH is the current depth in the originally specified
1331 chartable, and INDICES contains the vector indices
1332 for the levels our callers have descended. */
1335 map_char_table (c_function
, function
, chartable
, depth
, indices
)
1336 Lisp_Object (*c_function
) (), function
, chartable
, depth
, *indices
;
1339 int size
= CHAR_TABLE_ORDINARY_SLOTS
;
1341 /* Make INDICES longer if we are about to fill it up. */
1342 if ((depth
% 10) == 9)
1344 Lisp_Object
*new_indices
1345 = (Lisp_Object
*) alloca ((depth
+= 10) * sizeof (Lisp_Object
));
1346 bcopy (indices
, new_indices
, depth
* sizeof (Lisp_Object
));
1347 indices
= new_indices
;
1350 for (i
= 0; i
< size
; i
++)
1354 elt
= XCHAR_TABLE (chartable
)->contents
[i
];
1355 if (CHAR_TABLE_P (elt
))
1356 map_char_table (chartable
, c_function
, function
, depth
+ 1, indices
);
1357 else if (c_function
)
1358 (*c_function
) (depth
+ 1, indices
, elt
);
1359 /* Here we should handle all cases where the range is a single character
1360 by passing that character as a number. Currently, that is
1361 all the time, but with the MULE code this will have to be changed. */
1362 else if (depth
== 0)
1363 call2 (function
, make_number (i
), elt
);
1365 call2 (function
, Fvector (depth
+ 1, indices
), elt
);
1369 DEFUN ("map-char-table", Fmap_char_table
, Smap_char_table
,
1371 "Call FUNCTION for each range of like characters in CHARTABLE.\n\
1372 FUNCTION is called with two arguments--a key and a value.\n\
1373 The key is always a possible RANGE argument to `set-char-table-range'.")
1374 (function
, chartable
)
1375 Lisp_Object function
, chartable
;
1378 Lisp_Object
*indices
= (Lisp_Object
*) alloca (10 * sizeof (Lisp_Object
));
1380 map_char_table (NULL
, function
, chartable
, 0, indices
);
1390 Lisp_Object args
[2];
1393 return Fnconc (2, args
);
1395 return Fnconc (2, &s1
);
1396 #endif /* NO_ARG_ARRAY */
1399 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
1400 "Concatenate any number of lists by altering them.\n\
1401 Only the last argument is not altered, and need not be a list.")
1406 register int argnum
;
1407 register Lisp_Object tail
, tem
, val
;
1411 for (argnum
= 0; argnum
< nargs
; argnum
++)
1414 if (NILP (tem
)) continue;
1419 if (argnum
+ 1 == nargs
) break;
1422 tem
= wrong_type_argument (Qlistp
, tem
);
1431 tem
= args
[argnum
+ 1];
1432 Fsetcdr (tail
, tem
);
1434 args
[argnum
+ 1] = tail
;
1440 /* This is the guts of all mapping functions.
1441 Apply fn to each element of seq, one by one,
1442 storing the results into elements of vals, a C vector of Lisp_Objects.
1443 leni is the length of vals, which should also be the length of seq. */
1446 mapcar1 (leni
, vals
, fn
, seq
)
1449 Lisp_Object fn
, seq
;
1451 register Lisp_Object tail
;
1454 struct gcpro gcpro1
, gcpro2
, gcpro3
;
1456 /* Don't let vals contain any garbage when GC happens. */
1457 for (i
= 0; i
< leni
; i
++)
1460 GCPRO3 (dummy
, fn
, seq
);
1462 gcpro1
.nvars
= leni
;
1463 /* We need not explicitly protect `tail' because it is used only on lists, and
1464 1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
1468 for (i
= 0; i
< leni
; i
++)
1470 dummy
= XVECTOR (seq
)->contents
[i
];
1471 vals
[i
] = call1 (fn
, dummy
);
1474 else if (STRINGP (seq
))
1476 for (i
= 0; i
< leni
; i
++)
1478 XSETFASTINT (dummy
, XSTRING (seq
)->data
[i
]);
1479 vals
[i
] = call1 (fn
, dummy
);
1482 else /* Must be a list, since Flength did not get an error */
1485 for (i
= 0; i
< leni
; i
++)
1487 vals
[i
] = call1 (fn
, Fcar (tail
));
1495 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
1496 "Apply FN to each element of SEQ, and concat the results as strings.\n\
1497 In between each pair of results, stick in SEP.\n\
1498 Thus, \" \" as SEP results in spaces between the values returned by FN.")
1500 Lisp_Object fn
, seq
, sep
;
1505 register Lisp_Object
*args
;
1507 struct gcpro gcpro1
;
1509 len
= Flength (seq
);
1511 nargs
= leni
+ leni
- 1;
1512 if (nargs
< 0) return build_string ("");
1514 args
= (Lisp_Object
*) alloca (nargs
* sizeof (Lisp_Object
));
1517 mapcar1 (leni
, args
, fn
, seq
);
1520 for (i
= leni
- 1; i
>= 0; i
--)
1521 args
[i
+ i
] = args
[i
];
1523 for (i
= 1; i
< nargs
; i
+= 2)
1526 return Fconcat (nargs
, args
);
1529 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
1530 "Apply FUNCTION to each element of SEQUENCE, and make a list of the results.\n\
1531 The result is a list just as long as SEQUENCE.\n\
1532 SEQUENCE may be a list, a vector or a string.")
1534 Lisp_Object fn
, seq
;
1536 register Lisp_Object len
;
1538 register Lisp_Object
*args
;
1540 len
= Flength (seq
);
1541 leni
= XFASTINT (len
);
1542 args
= (Lisp_Object
*) alloca (leni
* sizeof (Lisp_Object
));
1544 mapcar1 (leni
, args
, fn
, seq
);
1546 return Flist (leni
, args
);
1549 /* Anything that calls this function must protect from GC! */
1551 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
1552 "Ask user a \"y or n\" question. Return t if answer is \"y\".\n\
1553 Takes one argument, which is the string to display to ask the question.\n\
1554 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.\n\
1555 No confirmation of the answer is requested; a single character is enough.\n\
1556 Also accepts Space to mean yes, or Delete to mean no.")
1560 register Lisp_Object obj
, key
, def
, answer_string
, map
;
1561 register int answer
;
1562 Lisp_Object xprompt
;
1563 Lisp_Object args
[2];
1564 int ocech
= cursor_in_echo_area
;
1565 struct gcpro gcpro1
, gcpro2
;
1567 map
= Fsymbol_value (intern ("query-replace-map"));
1569 CHECK_STRING (prompt
, 0);
1571 GCPRO2 (prompt
, xprompt
);
1576 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
1579 Lisp_Object pane
, menu
;
1580 redisplay_preserve_echo_area ();
1581 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
1582 Fcons (Fcons (build_string ("No"), Qnil
),
1584 menu
= Fcons (prompt
, pane
);
1585 obj
= Fx_popup_dialog (Qt
, menu
);
1586 answer
= !NILP (obj
);
1590 cursor_in_echo_area
= 1;
1591 message_nolog ("%s(y or n) ", XSTRING (xprompt
)->data
);
1593 obj
= read_filtered_event (1, 0, 0);
1594 cursor_in_echo_area
= 0;
1595 /* If we need to quit, quit with cursor_in_echo_area = 0. */
1598 key
= Fmake_vector (make_number (1), obj
);
1599 def
= Flookup_key (map
, key
);
1600 answer_string
= Fsingle_key_description (obj
);
1602 if (EQ (def
, intern ("skip")))
1607 else if (EQ (def
, intern ("act")))
1612 else if (EQ (def
, intern ("recenter")))
1618 else if (EQ (def
, intern ("quit")))
1620 /* We want to exit this command for exit-prefix,
1621 and this is the only way to do it. */
1622 else if (EQ (def
, intern ("exit-prefix")))
1627 /* If we don't clear this, then the next call to read_char will
1628 return quit_char again, and we'll enter an infinite loop. */
1633 if (EQ (xprompt
, prompt
))
1635 args
[0] = build_string ("Please answer y or n. ");
1637 xprompt
= Fconcat (2, args
);
1642 if (! noninteractive
)
1644 cursor_in_echo_area
= -1;
1645 message_nolog ("%s(y or n) %c",
1646 XSTRING (xprompt
)->data
, answer
? 'y' : 'n');
1647 cursor_in_echo_area
= ocech
;
1650 return answer
? Qt
: Qnil
;
1653 /* This is how C code calls `yes-or-no-p' and allows the user
1656 Anything that calls this function must protect from GC! */
1659 do_yes_or_no_p (prompt
)
1662 return call1 (intern ("yes-or-no-p"), prompt
);
1665 /* Anything that calls this function must protect from GC! */
1667 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
1668 "Ask user a yes-or-no question. Return t if answer is yes.\n\
1669 Takes one argument, which is the string to display to ask the question.\n\
1670 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.\n\
1671 The user must confirm the answer with RET,\n\
1672 and can edit it until it has been confirmed.")
1676 register Lisp_Object ans
;
1677 Lisp_Object args
[2];
1678 struct gcpro gcpro1
;
1681 CHECK_STRING (prompt
, 0);
1684 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
1687 Lisp_Object pane
, menu
, obj
;
1688 redisplay_preserve_echo_area ();
1689 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
1690 Fcons (Fcons (build_string ("No"), Qnil
),
1693 menu
= Fcons (prompt
, pane
);
1694 obj
= Fx_popup_dialog (Qt
, menu
);
1701 args
[1] = build_string ("(yes or no) ");
1702 prompt
= Fconcat (2, args
);
1708 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
1709 Qyes_or_no_p_history
));
1710 if (XSTRING (ans
)->size
== 3 && !strcmp (XSTRING (ans
)->data
, "yes"))
1715 if (XSTRING (ans
)->size
== 2 && !strcmp (XSTRING (ans
)->data
, "no"))
1723 message ("Please answer yes or no.");
1724 Fsleep_for (make_number (2), Qnil
);
1728 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 0, 0,
1729 "Return list of 1 minute, 5 minute and 15 minute load averages.\n\
1730 Each of the three load averages is multiplied by 100,\n\
1731 then converted to integer.\n\
1732 If the 5-minute or 15-minute load averages are not available, return a\n\
1733 shortened list, containing only those averages which are available.")
1737 int loads
= getloadavg (load_ave
, 3);
1741 error ("load-average not implemented for this operating system");
1745 ret
= Fcons (make_number ((int) (load_ave
[--loads
] * 100.0)), ret
);
1750 Lisp_Object Vfeatures
;
1752 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 1, 0,
1753 "Returns t if FEATURE is present in this Emacs.\n\
1754 Use this to conditionalize execution of lisp code based on the presence or\n\
1755 absence of emacs or environment extensions.\n\
1756 Use `provide' to declare that a feature is available.\n\
1757 This function looks at the value of the variable `features'.")
1759 Lisp_Object feature
;
1761 register Lisp_Object tem
;
1762 CHECK_SYMBOL (feature
, 0);
1763 tem
= Fmemq (feature
, Vfeatures
);
1764 return (NILP (tem
)) ? Qnil
: Qt
;
1767 DEFUN ("provide", Fprovide
, Sprovide
, 1, 1, 0,
1768 "Announce that FEATURE is a feature of the current Emacs.")
1770 Lisp_Object feature
;
1772 register Lisp_Object tem
;
1773 CHECK_SYMBOL (feature
, 0);
1774 if (!NILP (Vautoload_queue
))
1775 Vautoload_queue
= Fcons (Fcons (Vfeatures
, Qnil
), Vautoload_queue
);
1776 tem
= Fmemq (feature
, Vfeatures
);
1778 Vfeatures
= Fcons (feature
, Vfeatures
);
1779 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
1783 DEFUN ("require", Frequire
, Srequire
, 1, 2, 0,
1784 "If feature FEATURE is not loaded, load it from FILENAME.\n\
1785 If FEATURE is not a member of the list `features', then the feature\n\
1786 is not loaded; so load the file FILENAME.\n\
1787 If FILENAME is omitted, the printname of FEATURE is used as the file name.")
1788 (feature
, file_name
)
1789 Lisp_Object feature
, file_name
;
1791 register Lisp_Object tem
;
1792 CHECK_SYMBOL (feature
, 0);
1793 tem
= Fmemq (feature
, Vfeatures
);
1794 LOADHIST_ATTACH (Fcons (Qrequire
, feature
));
1797 int count
= specpdl_ptr
- specpdl
;
1799 /* Value saved here is to be restored into Vautoload_queue */
1800 record_unwind_protect (un_autoload
, Vautoload_queue
);
1801 Vautoload_queue
= Qt
;
1803 Fload (NILP (file_name
) ? Fsymbol_name (feature
) : file_name
,
1806 tem
= Fmemq (feature
, Vfeatures
);
1808 error ("Required feature %s was not provided",
1809 XSYMBOL (feature
)->name
->data
);
1811 /* Once loading finishes, don't undo it. */
1812 Vautoload_queue
= Qt
;
1813 feature
= unbind_to (count
, feature
);
1820 Qstring_lessp
= intern ("string-lessp");
1821 staticpro (&Qstring_lessp
);
1822 Qprovide
= intern ("provide");
1823 staticpro (&Qprovide
);
1824 Qrequire
= intern ("require");
1825 staticpro (&Qrequire
);
1826 Qyes_or_no_p_history
= intern ("yes-or-no-p-history");
1827 staticpro (&Qyes_or_no_p_history
);
1829 DEFVAR_LISP ("features", &Vfeatures
,
1830 "A list of symbols which are the features of the executing emacs.\n\
1831 Used by `featurep' and `require', and altered by `provide'.");
1834 defsubr (&Sidentity
);
1837 defsubr (&Ssafe_length
);
1838 defsubr (&Sstring_equal
);
1839 defsubr (&Sstring_lessp
);
1842 defsubr (&Svconcat
);
1843 defsubr (&Scopy_sequence
);
1844 defsubr (&Scopy_alist
);
1845 defsubr (&Ssubstring
);
1857 defsubr (&Snreverse
);
1858 defsubr (&Sreverse
);
1860 defsubr (&Splist_get
);
1862 defsubr (&Splist_put
);
1865 defsubr (&Sfillarray
);
1866 defsubr (&Schar_table_subtype
);
1867 defsubr (&Schar_table_parent
);
1868 defsubr (&Sset_char_table_parent
);
1869 defsubr (&Schar_table_extra_slot
);
1870 defsubr (&Sset_char_table_extra_slot
);
1871 defsubr (&Schar_table_range
);
1872 defsubr (&Sset_char_table_range
);
1873 defsubr (&Smap_char_table
);
1876 defsubr (&Smapconcat
);
1877 defsubr (&Sy_or_n_p
);
1878 defsubr (&Syes_or_no_p
);
1879 defsubr (&Sload_average
);
1880 defsubr (&Sfeaturep
);
1881 defsubr (&Srequire
);
1882 defsubr (&Sprovide
);