1 /* Random utility Lisp functions.
2 Copyright (C) 1985, 86, 87, 93, 94, 95, 97, 1998 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. */
29 /* Note on some machines this defines `vector' as a typedef,
30 so make sure we don't use that name in this file. */
40 #include "intervals.h"
43 #if defined (HAVE_MENUS) && defined (HAVE_X_WINDOWS)
48 #define NULL (void *)0
51 /* Nonzero enables use of dialog boxes for questions
52 asked by mouse commands. */
55 extern int minibuffer_auto_raise
;
56 extern Lisp_Object minibuf_window
;
58 Lisp_Object Qstring_lessp
, Qprovide
, Qrequire
;
59 Lisp_Object Qyes_or_no_p_history
;
60 Lisp_Object Qcursor_in_echo_area
;
61 Lisp_Object Qwidget_type
;
63 static int internal_equal ();
65 extern long get_random ();
66 extern void seed_random ();
72 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
73 "Return the argument unchanged.")
80 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
81 "Return a pseudo-random number.\n\
82 All integers representable in Lisp are equally likely.\n\
83 On most systems, this is 28 bits' worth.\n\
84 With positive integer argument N, return random number in interval [0,N).\n\
85 With argument t, set the random number seed from the current time and pid.")
90 Lisp_Object lispy_val
;
91 unsigned long denominator
;
94 seed_random (getpid () + time (NULL
));
95 if (NATNUMP (n
) && XFASTINT (n
) != 0)
97 /* Try to take our random number from the higher bits of VAL,
98 not the lower, since (says Gentzel) the low bits of `random'
99 are less random than the higher ones. We do this by using the
100 quotient rather than the remainder. At the high end of the RNG
101 it's possible to get a quotient larger than n; discarding
102 these values eliminates the bias that would otherwise appear
103 when using a large n. */
104 denominator
= ((unsigned long)1 << VALBITS
) / XFASTINT (n
);
106 val
= get_random () / denominator
;
107 while (val
>= XFASTINT (n
));
111 XSETINT (lispy_val
, val
);
115 /* Random data-structure functions */
117 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
118 "Return the length of vector, list or string SEQUENCE.\n\
119 A byte-code function object is also allowed.\n\
120 If the string contains multibyte characters, this is not the necessarily\n\
121 the number of bytes in the string; it is the number of characters.\n\
122 To get the number of bytes, use `string-bytes'")
124 register Lisp_Object sequence
;
126 register Lisp_Object tail
, val
;
130 if (STRINGP (sequence
))
131 XSETFASTINT (val
, XSTRING (sequence
)->size
);
132 else if (VECTORP (sequence
))
133 XSETFASTINT (val
, XVECTOR (sequence
)->size
);
134 else if (CHAR_TABLE_P (sequence
))
135 XSETFASTINT (val
, (MIN_CHAR_COMPOSITION
136 + (CHAR_FIELD2_MASK
| CHAR_FIELD3_MASK
)
138 else if (BOOL_VECTOR_P (sequence
))
139 XSETFASTINT (val
, XBOOL_VECTOR (sequence
)->size
);
140 else if (COMPILEDP (sequence
))
141 XSETFASTINT (val
, XVECTOR (sequence
)->size
& PSEUDOVECTOR_SIZE_MASK
);
142 else if (CONSP (sequence
))
144 for (i
= 0, tail
= sequence
; !NILP (tail
); i
++)
150 XSETFASTINT (val
, i
);
152 else if (NILP (sequence
))
153 XSETFASTINT (val
, 0);
156 sequence
= wrong_type_argument (Qsequencep
, sequence
);
162 /* This does not check for quits. That is safe
163 since it must terminate. */
165 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
166 "Return the length of a list, but avoid error or infinite loop.\n\
167 This function never gets an error. If LIST is not really a list,\n\
168 it returns 0. If LIST is circular, it returns a finite value\n\
169 which is at least the number of distinct elements.")
173 Lisp_Object tail
, halftail
, length
;
176 /* halftail is used to detect circular lists. */
178 for (tail
= list
; CONSP (tail
); tail
= XCONS (tail
)->cdr
)
180 if (EQ (tail
, halftail
) && len
!= 0)
184 halftail
= XCONS (halftail
)->cdr
;
187 XSETINT (length
, len
);
191 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
192 "Return the number of bytes in STRING.\n\
193 If STRING is a multibyte string, this is greater than the length of STRING.")
197 CHECK_STRING (string
, 1);
198 return make_number (STRING_BYTES (XSTRING (string
)));
201 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
202 "Return t if two strings have identical contents.\n\
203 Case is significant, but text properties are ignored.\n\
204 Symbols are also allowed; their print names are used instead.")
206 register Lisp_Object s1
, s2
;
209 XSETSTRING (s1
, XSYMBOL (s1
)->name
);
211 XSETSTRING (s2
, XSYMBOL (s2
)->name
);
212 CHECK_STRING (s1
, 0);
213 CHECK_STRING (s2
, 1);
215 if (XSTRING (s1
)->size
!= XSTRING (s2
)->size
216 || STRING_BYTES (XSTRING (s1
)) != STRING_BYTES (XSTRING (s2
))
217 || bcmp (XSTRING (s1
)->data
, XSTRING (s2
)->data
, STRING_BYTES (XSTRING (s1
))))
222 DEFUN ("compare-strings", Fcompare_strings
,
223 Scompare_strings
, 6, 7, 0,
224 "Compare the contents of two strings, converting to multibyte if needed.\n\
225 In string STR1, skip the first START1 characters and stop at END1.\n\
226 In string STR2, skip the first START2 characters and stop at END2.\n\
227 END1 and END2 default to the full lengths of the respective strings.\n\
229 Case is significant in this comparison if IGNORE-CASE is nil.\n\
230 Unibyte strings are converted to multibyte for comparison.\n\
232 The value is t if the strings (or specified portions) match.\n\
233 If string STR1 is less, the value is a negative number N;\n\
234 - 1 - N is the number of characters that match at the beginning.\n\
235 If string STR1 is greater, the value is a positive number N;\n\
236 N - 1 is the number of characters that match at the beginning.")
237 (str1
, start1
, end1
, str2
, start2
, end2
, ignore_case
)
238 Lisp_Object str1
, start1
, end1
, start2
, str2
, end2
, ignore_case
;
240 register int end1_char
, end2_char
;
241 register int i1
, i1_byte
, i2
, i2_byte
;
243 CHECK_STRING (str1
, 0);
244 CHECK_STRING (str2
, 1);
246 start1
= make_number (0);
248 start2
= make_number (0);
249 CHECK_NATNUM (start1
, 2);
250 CHECK_NATNUM (start2
, 3);
252 CHECK_NATNUM (end1
, 4);
254 CHECK_NATNUM (end2
, 4);
259 i1_byte
= string_char_to_byte (str1
, i1
);
260 i2_byte
= string_char_to_byte (str2
, i2
);
262 end1_char
= XSTRING (str1
)->size
;
263 if (! NILP (end1
) && end1_char
> XINT (end1
))
264 end1_char
= XINT (end1
);
266 end2_char
= XSTRING (str2
)->size
;
267 if (! NILP (end2
) && end2_char
> XINT (end2
))
268 end2_char
= XINT (end2
);
270 while (i1
< end1_char
&& i2
< end2_char
)
272 /* When we find a mismatch, we must compare the
273 characters, not just the bytes. */
276 if (STRING_MULTIBYTE (str1
))
277 FETCH_STRING_CHAR_ADVANCE (c1
, str1
, i1
, i1_byte
);
280 c1
= XSTRING (str1
)->data
[i1
++];
281 c1
= unibyte_char_to_multibyte (c1
);
284 if (STRING_MULTIBYTE (str2
))
285 FETCH_STRING_CHAR_ADVANCE (c2
, str2
, i2
, i2_byte
);
288 c2
= XSTRING (str2
)->data
[i2
++];
289 c2
= unibyte_char_to_multibyte (c2
);
295 if (! NILP (ignore_case
))
299 tem
= Fupcase (make_number (c1
));
301 tem
= Fupcase (make_number (c2
));
308 /* Note that I1 has already been incremented
309 past the character that we are comparing;
310 hence we don't add or subtract 1 here. */
312 return make_number (- i1
);
314 return make_number (i1
);
318 return make_number (i1
- XINT (start1
) + 1);
320 return make_number (- i1
+ XINT (start1
) - 1);
325 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
326 "Return t if first arg string is less than second in lexicographic order.\n\
327 Case is significant.\n\
328 Symbols are also allowed; their print names are used instead.")
330 register Lisp_Object s1
, s2
;
333 register int i1
, i1_byte
, i2
, i2_byte
;
336 XSETSTRING (s1
, XSYMBOL (s1
)->name
);
338 XSETSTRING (s2
, XSYMBOL (s2
)->name
);
339 CHECK_STRING (s1
, 0);
340 CHECK_STRING (s2
, 1);
342 i1
= i1_byte
= i2
= i2_byte
= 0;
344 end
= XSTRING (s1
)->size
;
345 if (end
> XSTRING (s2
)->size
)
346 end
= XSTRING (s2
)->size
;
350 /* When we find a mismatch, we must compare the
351 characters, not just the bytes. */
354 if (STRING_MULTIBYTE (s1
))
355 FETCH_STRING_CHAR_ADVANCE (c1
, s1
, i1
, i1_byte
);
357 c1
= XSTRING (s1
)->data
[i1
++];
359 if (STRING_MULTIBYTE (s2
))
360 FETCH_STRING_CHAR_ADVANCE (c2
, s2
, i2
, i2_byte
);
362 c2
= XSTRING (s2
)->data
[i2
++];
365 return c1
< c2
? Qt
: Qnil
;
367 return i1
< XSTRING (s2
)->size
? Qt
: Qnil
;
370 static Lisp_Object
concat ();
381 return concat (2, args
, Lisp_String
, 0);
383 return concat (2, &s1
, Lisp_String
, 0);
384 #endif /* NO_ARG_ARRAY */
390 Lisp_Object s1
, s2
, s3
;
397 return concat (3, args
, Lisp_String
, 0);
399 return concat (3, &s1
, Lisp_String
, 0);
400 #endif /* NO_ARG_ARRAY */
403 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
404 "Concatenate all the arguments and make the result a list.\n\
405 The result is a list whose elements are the elements of all the arguments.\n\
406 Each argument may be a list, vector or string.\n\
407 The last argument is not copied, just used as the tail of the new list.")
412 return concat (nargs
, args
, Lisp_Cons
, 1);
415 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
416 "Concatenate all the arguments and make the result a string.\n\
417 The result is a string whose elements are the elements of all the arguments.\n\
418 Each argument may be a string or a list or vector of characters (integers).\n\
420 Do not use individual integers as arguments!\n\
421 The behavior of `concat' in that case will be changed later!\n\
422 If your program passes an integer as an argument to `concat',\n\
423 you should change it right away not to do so.")
428 return concat (nargs
, args
, Lisp_String
, 0);
431 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
432 "Concatenate all the arguments and make the result a vector.\n\
433 The result is a vector whose elements are the elements of all the arguments.\n\
434 Each argument may be a list, vector or string.")
439 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
442 /* Retrun a copy of a sub char table ARG. The elements except for a
443 nested sub char table are not copied. */
445 copy_sub_char_table (arg
)
448 Lisp_Object copy
= make_sub_char_table (XCHAR_TABLE (arg
)->defalt
);
451 /* Copy all the contents. */
452 bcopy (XCHAR_TABLE (arg
)->contents
, XCHAR_TABLE (copy
)->contents
,
453 SUB_CHAR_TABLE_ORDINARY_SLOTS
* sizeof (Lisp_Object
));
454 /* Recursively copy any sub char-tables in the ordinary slots. */
455 for (i
= 32; i
< SUB_CHAR_TABLE_ORDINARY_SLOTS
; i
++)
456 if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg
)->contents
[i
]))
457 XCHAR_TABLE (copy
)->contents
[i
]
458 = copy_sub_char_table (XCHAR_TABLE (copy
)->contents
[i
]);
464 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
465 "Return a copy of a list, vector or string.\n\
466 The elements of a list or vector are not copied; they are shared\n\
471 if (NILP (arg
)) return arg
;
473 if (CHAR_TABLE_P (arg
))
478 copy
= Fmake_char_table (XCHAR_TABLE (arg
)->purpose
, Qnil
);
479 /* Copy all the slots, including the extra ones. */
480 bcopy (XVECTOR (arg
)->contents
, XVECTOR (copy
)->contents
,
481 ((XCHAR_TABLE (arg
)->size
& PSEUDOVECTOR_SIZE_MASK
)
482 * sizeof (Lisp_Object
)));
484 /* Recursively copy any sub char tables in the ordinary slots
485 for multibyte characters. */
486 for (i
= CHAR_TABLE_SINGLE_BYTE_SLOTS
;
487 i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
488 if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg
)->contents
[i
]))
489 XCHAR_TABLE (copy
)->contents
[i
]
490 = copy_sub_char_table (XCHAR_TABLE (copy
)->contents
[i
]);
495 if (BOOL_VECTOR_P (arg
))
499 = (XBOOL_VECTOR (arg
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
501 val
= Fmake_bool_vector (Flength (arg
), Qnil
);
502 bcopy (XBOOL_VECTOR (arg
)->data
, XBOOL_VECTOR (val
)->data
,
507 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
508 arg
= wrong_type_argument (Qsequencep
, arg
);
509 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
513 concat (nargs
, args
, target_type
, last_special
)
516 enum Lisp_Type target_type
;
520 register Lisp_Object tail
;
521 register Lisp_Object
this;
524 register int result_len
;
525 register int result_len_byte
;
527 Lisp_Object last_tail
;
530 /* When we make a multibyte string, we must pay attention to the
531 byte combining problem, i.e., a byte may be combined with a
532 multibyte charcter of the previous string. This flag tells if we
533 must consider such a situation or not. */
534 int maybe_combine_byte
;
536 /* In append, the last arg isn't treated like the others */
537 if (last_special
&& nargs
> 0)
540 last_tail
= args
[nargs
];
545 /* Canonicalize each argument. */
546 for (argnum
= 0; argnum
< nargs
; argnum
++)
549 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
550 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
553 args
[argnum
] = Fnumber_to_string (this);
555 args
[argnum
] = wrong_type_argument (Qsequencep
, this);
559 /* Compute total length in chars of arguments in RESULT_LEN.
560 If desired output is a string, also compute length in bytes
561 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
562 whether the result should be a multibyte string. */
566 for (argnum
= 0; argnum
< nargs
; argnum
++)
570 len
= XFASTINT (Flength (this));
571 if (target_type
== Lisp_String
)
573 /* We must count the number of bytes needed in the string
574 as well as the number of characters. */
580 for (i
= 0; i
< len
; i
++)
582 ch
= XVECTOR (this)->contents
[i
];
584 wrong_type_argument (Qintegerp
, ch
);
585 this_len_byte
= XFASTINT (Fchar_bytes (ch
));
586 result_len_byte
+= this_len_byte
;
587 if (this_len_byte
> 1)
590 else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size
> 0)
591 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
592 else if (CONSP (this))
593 for (; CONSP (this); this = XCONS (this)->cdr
)
595 ch
= XCONS (this)->car
;
597 wrong_type_argument (Qintegerp
, ch
);
598 this_len_byte
= XFASTINT (Fchar_bytes (ch
));
599 result_len_byte
+= this_len_byte
;
600 if (this_len_byte
> 1)
603 else if (STRINGP (this))
605 if (STRING_MULTIBYTE (this))
608 result_len_byte
+= STRING_BYTES (XSTRING (this));
611 result_len_byte
+= count_size_as_multibyte (XSTRING (this)->data
,
612 XSTRING (this)->size
);
619 if (! some_multibyte
)
620 result_len_byte
= result_len
;
622 /* Create the output object. */
623 if (target_type
== Lisp_Cons
)
624 val
= Fmake_list (make_number (result_len
), Qnil
);
625 else if (target_type
== Lisp_Vectorlike
)
626 val
= Fmake_vector (make_number (result_len
), Qnil
);
627 else if (some_multibyte
)
628 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
630 val
= make_uninit_string (result_len
);
632 /* In `append', if all but last arg are nil, return last arg. */
633 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
636 /* Copy the contents of the args into the result. */
638 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
640 toindex
= 0, toindex_byte
= 0;
644 maybe_combine_byte
= 0;
645 for (argnum
= 0; argnum
< nargs
; argnum
++)
649 register unsigned int thisindex
= 0;
650 register unsigned int thisindex_byte
= 0;
654 thislen
= Flength (this), thisleni
= XINT (thislen
);
656 if (STRINGP (this) && STRINGP (val
)
657 && ! NULL_INTERVAL_P (XSTRING (this)->intervals
))
658 copy_text_properties (make_number (0), thislen
, this,
659 make_number (toindex
), val
, Qnil
);
661 /* Between strings of the same kind, copy fast. */
662 if (STRINGP (this) && STRINGP (val
)
663 && STRING_MULTIBYTE (this) == some_multibyte
)
665 int thislen_byte
= STRING_BYTES (XSTRING (this));
666 bcopy (XSTRING (this)->data
, XSTRING (val
)->data
+ toindex_byte
,
667 STRING_BYTES (XSTRING (this)));
670 && XSTRING (val
)->data
[toindex_byte
- 1] >= 0x80
671 && XSTRING (this)->data
[0] >= 0xA0)
672 maybe_combine_byte
= 1;
673 toindex_byte
+= thislen_byte
;
676 /* Copy a single-byte string to a multibyte string. */
677 else if (STRINGP (this) && STRINGP (val
))
679 toindex_byte
+= copy_text (XSTRING (this)->data
,
680 XSTRING (val
)->data
+ toindex_byte
,
681 XSTRING (this)->size
, 0, 1);
685 /* Copy element by element. */
688 register Lisp_Object elt
;
690 /* Fetch next element of `this' arg into `elt', or break if
691 `this' is exhausted. */
692 if (NILP (this)) break;
694 elt
= XCONS (this)->car
, this = XCONS (this)->cdr
;
695 else if (thisindex
>= thisleni
)
697 else if (STRINGP (this))
700 if (STRING_MULTIBYTE (this))
702 FETCH_STRING_CHAR_ADVANCE (c
, this,
705 XSETFASTINT (elt
, c
);
709 XSETFASTINT (elt
, XSTRING (this)->data
[thisindex
++]);
710 if (some_multibyte
&& XINT (elt
) >= 0200
711 && XINT (elt
) < 0400)
713 c
= unibyte_char_to_multibyte (XINT (elt
));
718 else if (BOOL_VECTOR_P (this))
721 byte
= XBOOL_VECTOR (this)->data
[thisindex
/ BITS_PER_CHAR
];
722 if (byte
& (1 << (thisindex
% BITS_PER_CHAR
)))
729 elt
= XVECTOR (this)->contents
[thisindex
++];
731 /* Store this element into the result. */
734 XCONS (tail
)->car
= elt
;
736 tail
= XCONS (tail
)->cdr
;
738 else if (VECTORP (val
))
739 XVECTOR (val
)->contents
[toindex
++] = elt
;
742 CHECK_NUMBER (elt
, 0);
743 if (SINGLE_BYTE_CHAR_P (XINT (elt
)))
747 && XSTRING (val
)->data
[toindex_byte
- 1] >= 0x80
748 && XINT (elt
) >= 0xA0)
749 maybe_combine_byte
= 1;
750 XSTRING (val
)->data
[toindex_byte
++] = XINT (elt
);
754 /* If we have any multibyte characters,
755 we already decided to make a multibyte string. */
758 unsigned char work
[4], *str
;
759 int i
= CHAR_STRING (c
, work
, str
);
761 /* P exists as a variable
762 to avoid a bug on the Masscomp C compiler. */
763 unsigned char *p
= & XSTRING (val
)->data
[toindex_byte
];
772 XCONS (prev
)->cdr
= last_tail
;
774 if (maybe_combine_byte
)
775 /* Characater counter of the multibyte string VAL may be wrong
776 because of byte combining problem. We must re-calculate it. */
777 XSTRING (val
)->size
= multibyte_chars_in_text (XSTRING (val
)->data
,
778 XSTRING (val
)->size_byte
);
783 static Lisp_Object string_char_byte_cache_string
;
784 static int string_char_byte_cache_charpos
;
785 static int string_char_byte_cache_bytepos
;
787 /* Return the character index corresponding to CHAR_INDEX in STRING. */
790 string_char_to_byte (string
, char_index
)
795 int best_below
, best_below_byte
;
796 int best_above
, best_above_byte
;
798 if (! STRING_MULTIBYTE (string
))
801 best_below
= best_below_byte
= 0;
802 best_above
= XSTRING (string
)->size
;
803 best_above_byte
= STRING_BYTES (XSTRING (string
));
805 if (EQ (string
, string_char_byte_cache_string
))
807 if (string_char_byte_cache_charpos
< char_index
)
809 best_below
= string_char_byte_cache_charpos
;
810 best_below_byte
= string_char_byte_cache_bytepos
;
814 best_above
= string_char_byte_cache_charpos
;
815 best_above_byte
= string_char_byte_cache_bytepos
;
819 if (char_index
- best_below
< best_above
- char_index
)
821 while (best_below
< char_index
)
824 FETCH_STRING_CHAR_ADVANCE (c
, string
, best_below
, best_below_byte
);
827 i_byte
= best_below_byte
;
831 while (best_above
> char_index
)
833 int best_above_byte_saved
= --best_above_byte
;
835 while (best_above_byte
> 0
836 && !CHAR_HEAD_P (XSTRING (string
)->data
[best_above_byte
]))
838 if (XSTRING (string
)->data
[best_above_byte
] < 0x80)
839 best_above_byte
= best_above_byte_saved
;
843 i_byte
= best_above_byte
;
846 string_char_byte_cache_bytepos
= i_byte
;
847 string_char_byte_cache_charpos
= i
;
848 string_char_byte_cache_string
= string
;
853 /* Return the character index corresponding to BYTE_INDEX in STRING. */
856 string_byte_to_char (string
, byte_index
)
861 int best_below
, best_below_byte
;
862 int best_above
, best_above_byte
;
864 if (! STRING_MULTIBYTE (string
))
867 best_below
= best_below_byte
= 0;
868 best_above
= XSTRING (string
)->size
;
869 best_above_byte
= STRING_BYTES (XSTRING (string
));
871 if (EQ (string
, string_char_byte_cache_string
))
873 if (string_char_byte_cache_bytepos
< byte_index
)
875 best_below
= string_char_byte_cache_charpos
;
876 best_below_byte
= string_char_byte_cache_bytepos
;
880 best_above
= string_char_byte_cache_charpos
;
881 best_above_byte
= string_char_byte_cache_bytepos
;
885 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
887 while (best_below_byte
< byte_index
)
890 FETCH_STRING_CHAR_ADVANCE (c
, string
, best_below
, best_below_byte
);
893 i_byte
= best_below_byte
;
897 while (best_above_byte
> byte_index
)
899 int best_above_byte_saved
= --best_above_byte
;
901 while (best_above_byte
> 0
902 && !CHAR_HEAD_P (XSTRING (string
)->data
[best_above_byte
]))
904 if (XSTRING (string
)->data
[best_above_byte
] < 0x80)
905 best_above_byte
= best_above_byte_saved
;
909 i_byte
= best_above_byte
;
912 string_char_byte_cache_bytepos
= i_byte
;
913 string_char_byte_cache_charpos
= i
;
914 string_char_byte_cache_string
= string
;
919 /* Convert STRING to a multibyte string.
920 Single-byte characters 0240 through 0377 are converted
921 by adding nonascii_insert_offset to each. */
924 string_make_multibyte (string
)
930 if (STRING_MULTIBYTE (string
))
933 nbytes
= count_size_as_multibyte (XSTRING (string
)->data
,
934 XSTRING (string
)->size
);
935 /* If all the chars are ASCII, they won't need any more bytes
936 once converted. In that case, we can return STRING itself. */
937 if (nbytes
== STRING_BYTES (XSTRING (string
)))
940 buf
= (unsigned char *) alloca (nbytes
);
941 copy_text (XSTRING (string
)->data
, buf
, STRING_BYTES (XSTRING (string
)),
944 return make_multibyte_string (buf
, XSTRING (string
)->size
, nbytes
);
947 /* Convert STRING to a single-byte string. */
950 string_make_unibyte (string
)
955 if (! STRING_MULTIBYTE (string
))
958 buf
= (unsigned char *) alloca (XSTRING (string
)->size
);
960 copy_text (XSTRING (string
)->data
, buf
, STRING_BYTES (XSTRING (string
)),
963 return make_unibyte_string (buf
, XSTRING (string
)->size
);
966 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
968 "Return the multibyte equivalent of STRING.\n\
969 The function `unibyte-char-to-multibyte' is used to convert\n\
970 each unibyte character to a multibyte character.")
974 CHECK_STRING (string
, 0);
976 return string_make_multibyte (string
);
979 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
981 "Return the unibyte equivalent of STRING.\n\
982 Multibyte character codes are converted to unibyte\n\
983 by using just the low 8 bits.")
987 CHECK_STRING (string
, 0);
989 return string_make_unibyte (string
);
992 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
994 "Return a unibyte string with the same individual bytes as STRING.\n\
995 If STRING is unibyte, the result is STRING itself.")
999 CHECK_STRING (string
, 0);
1001 if (STRING_MULTIBYTE (string
))
1003 string
= Fcopy_sequence (string
);
1004 XSTRING (string
)->size
= STRING_BYTES (XSTRING (string
));
1005 SET_STRING_BYTES (XSTRING (string
), -1);
1010 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1012 "Return a multibyte string with the same individual bytes as STRING.\n\
1013 If STRING is multibyte, the result is STRING itself.")
1017 CHECK_STRING (string
, 0);
1019 if (! STRING_MULTIBYTE (string
))
1021 int nbytes
= STRING_BYTES (XSTRING (string
));
1022 int newlen
= multibyte_chars_in_text (XSTRING (string
)->data
, nbytes
);
1024 string
= Fcopy_sequence (string
);
1025 XSTRING (string
)->size
= newlen
;
1026 XSTRING (string
)->size_byte
= nbytes
;
1031 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1032 "Return a copy of ALIST.\n\
1033 This is an alist which represents the same mapping from objects to objects,\n\
1034 but does not share the alist structure with ALIST.\n\
1035 The objects mapped (cars and cdrs of elements of the alist)\n\
1036 are shared, however.\n\
1037 Elements of ALIST that are not conses are also shared.")
1041 register Lisp_Object tem
;
1043 CHECK_LIST (alist
, 0);
1046 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1047 for (tem
= alist
; CONSP (tem
); tem
= XCONS (tem
)->cdr
)
1049 register Lisp_Object car
;
1050 car
= XCONS (tem
)->car
;
1053 XCONS (tem
)->car
= Fcons (XCONS (car
)->car
, XCONS (car
)->cdr
);
1058 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
1059 "Return a substring of STRING, starting at index FROM and ending before TO.\n\
1060 TO may be nil or omitted; then the substring runs to the end of STRING.\n\
1061 If FROM or TO is negative, it counts from the end.\n\
1063 This function allows vectors as well as strings.")
1066 register Lisp_Object from
, to
;
1071 int from_char
, to_char
;
1072 int from_byte
, to_byte
;
1074 if (! (STRINGP (string
) || VECTORP (string
)))
1075 wrong_type_argument (Qarrayp
, string
);
1077 CHECK_NUMBER (from
, 1);
1079 if (STRINGP (string
))
1081 size
= XSTRING (string
)->size
;
1082 size_byte
= STRING_BYTES (XSTRING (string
));
1085 size
= XVECTOR (string
)->size
;
1090 to_byte
= size_byte
;
1094 CHECK_NUMBER (to
, 2);
1096 to_char
= XINT (to
);
1100 if (STRINGP (string
))
1101 to_byte
= string_char_to_byte (string
, to_char
);
1104 from_char
= XINT (from
);
1107 if (STRINGP (string
))
1108 from_byte
= string_char_to_byte (string
, from_char
);
1110 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1111 args_out_of_range_3 (string
, make_number (from_char
),
1112 make_number (to_char
));
1114 if (STRINGP (string
))
1116 res
= make_specified_string (XSTRING (string
)->data
+ from_byte
,
1117 to_char
- from_char
, to_byte
- from_byte
,
1118 STRING_MULTIBYTE (string
));
1119 copy_text_properties (make_number (from_char
), make_number (to_char
),
1120 string
, make_number (0), res
, Qnil
);
1123 res
= Fvector (to_char
- from_char
,
1124 XVECTOR (string
)->contents
+ from_char
);
1129 /* Extract a substring of STRING, giving start and end positions
1130 both in characters and in bytes. */
1133 substring_both (string
, from
, from_byte
, to
, to_byte
)
1135 int from
, from_byte
, to
, to_byte
;
1141 if (! (STRINGP (string
) || VECTORP (string
)))
1142 wrong_type_argument (Qarrayp
, string
);
1144 if (STRINGP (string
))
1146 size
= XSTRING (string
)->size
;
1147 size_byte
= STRING_BYTES (XSTRING (string
));
1150 size
= XVECTOR (string
)->size
;
1152 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1153 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1155 if (STRINGP (string
))
1157 res
= make_specified_string (XSTRING (string
)->data
+ from_byte
,
1158 to
- from
, to_byte
- from_byte
,
1159 STRING_MULTIBYTE (string
));
1160 copy_text_properties (make_number (from
), make_number (to
),
1161 string
, make_number (0), res
, Qnil
);
1164 res
= Fvector (to
- from
,
1165 XVECTOR (string
)->contents
+ from
);
1170 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1171 "Take cdr N times on LIST, returns the result.")
1174 register Lisp_Object list
;
1176 register int i
, num
;
1177 CHECK_NUMBER (n
, 0);
1179 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1187 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1188 "Return the Nth element of LIST.\n\
1189 N counts from zero. If LIST is not that long, nil is returned.")
1191 Lisp_Object n
, list
;
1193 return Fcar (Fnthcdr (n
, list
));
1196 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1197 "Return element of SEQUENCE at index N.")
1199 register Lisp_Object sequence
, n
;
1201 CHECK_NUMBER (n
, 0);
1204 if (CONSP (sequence
) || NILP (sequence
))
1205 return Fcar (Fnthcdr (n
, sequence
));
1206 else if (STRINGP (sequence
) || VECTORP (sequence
)
1207 || BOOL_VECTOR_P (sequence
) || CHAR_TABLE_P (sequence
))
1208 return Faref (sequence
, n
);
1210 sequence
= wrong_type_argument (Qsequencep
, sequence
);
1214 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1215 "Return non-nil if ELT is an element of LIST. Comparison done with `equal'.\n\
1216 The value is actually the tail of LIST whose car is ELT.")
1218 register Lisp_Object elt
;
1221 register Lisp_Object tail
;
1222 for (tail
= list
; !NILP (tail
); tail
= XCONS (tail
)->cdr
)
1224 register Lisp_Object tem
;
1226 if (! NILP (Fequal (elt
, tem
)))
1233 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1234 "Return non-nil if ELT is an element of LIST. Comparison done with EQ.\n\
1235 The value is actually the tail of LIST whose car is ELT.")
1237 register Lisp_Object elt
;
1240 register Lisp_Object tail
;
1241 for (tail
= list
; !NILP (tail
); tail
= XCONS (tail
)->cdr
)
1243 register Lisp_Object tem
;
1245 if (EQ (elt
, tem
)) return tail
;
1251 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1252 "Return non-nil if KEY is `eq' to the car of an element of LIST.\n\
1253 The value is actually the element of LIST whose car is KEY.\n\
1254 Elements of LIST that are not conses are ignored.")
1256 register Lisp_Object key
;
1259 register Lisp_Object tail
;
1260 for (tail
= list
; !NILP (tail
); tail
= XCONS (tail
)->cdr
)
1262 register Lisp_Object elt
, tem
;
1264 if (!CONSP (elt
)) continue;
1265 tem
= XCONS (elt
)->car
;
1266 if (EQ (key
, tem
)) return elt
;
1272 /* Like Fassq but never report an error and do not allow quits.
1273 Use only on lists known never to be circular. */
1276 assq_no_quit (key
, list
)
1277 register Lisp_Object key
;
1280 register Lisp_Object tail
;
1281 for (tail
= list
; CONSP (tail
); tail
= XCONS (tail
)->cdr
)
1283 register Lisp_Object elt
, tem
;
1285 if (!CONSP (elt
)) continue;
1286 tem
= XCONS (elt
)->car
;
1287 if (EQ (key
, tem
)) return elt
;
1292 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1293 "Return non-nil if KEY is `equal' to the car of an element of LIST.\n\
1294 The value is actually the element of LIST whose car equals KEY.")
1296 register Lisp_Object key
;
1299 register Lisp_Object tail
;
1300 for (tail
= list
; !NILP (tail
); tail
= XCONS (tail
)->cdr
)
1302 register Lisp_Object elt
, tem
;
1304 if (!CONSP (elt
)) continue;
1305 tem
= Fequal (XCONS (elt
)->car
, key
);
1306 if (!NILP (tem
)) return elt
;
1312 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1313 "Return non-nil if ELT is `eq' to the cdr of an element of LIST.\n\
1314 The value is actually the element of LIST whose cdr is ELT.")
1316 register Lisp_Object key
;
1319 register Lisp_Object tail
;
1320 for (tail
= list
; !NILP (tail
); tail
= XCONS (tail
)->cdr
)
1322 register Lisp_Object elt
, tem
;
1324 if (!CONSP (elt
)) continue;
1325 tem
= XCONS (elt
)->cdr
;
1326 if (EQ (key
, tem
)) return elt
;
1332 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1333 "Return non-nil if KEY is `equal' to the cdr of an element of LIST.\n\
1334 The value is actually the element of LIST whose cdr equals KEY.")
1336 register Lisp_Object key
;
1339 register Lisp_Object tail
;
1340 for (tail
= list
; !NILP (tail
); tail
= XCONS (tail
)->cdr
)
1342 register Lisp_Object elt
, tem
;
1344 if (!CONSP (elt
)) continue;
1345 tem
= Fequal (XCONS (elt
)->cdr
, key
);
1346 if (!NILP (tem
)) return elt
;
1352 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1353 "Delete by side effect any occurrences of ELT as a member of LIST.\n\
1354 The modified LIST is returned. Comparison is done with `eq'.\n\
1355 If the first member of LIST is ELT, there is no way to remove it by side effect;\n\
1356 therefore, write `(setq foo (delq element foo))'\n\
1357 to be sure of changing the value of `foo'.")
1359 register Lisp_Object elt
;
1362 register Lisp_Object tail
, prev
;
1363 register Lisp_Object tem
;
1367 while (!NILP (tail
))
1373 list
= XCONS (tail
)->cdr
;
1375 Fsetcdr (prev
, XCONS (tail
)->cdr
);
1379 tail
= XCONS (tail
)->cdr
;
1385 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1386 "Delete by side effect any occurrences of ELT as a member of LIST.\n\
1387 The modified LIST is returned. Comparison is done with `equal'.\n\
1388 If the first member of LIST is ELT, deleting it is not a side effect;\n\
1389 it is simply using a different list.\n\
1390 Therefore, write `(setq foo (delete element foo))'\n\
1391 to be sure of changing the value of `foo'.")
1393 register Lisp_Object elt
;
1396 register Lisp_Object tail
, prev
;
1397 register Lisp_Object tem
;
1401 while (!NILP (tail
))
1404 if (! NILP (Fequal (elt
, tem
)))
1407 list
= XCONS (tail
)->cdr
;
1409 Fsetcdr (prev
, XCONS (tail
)->cdr
);
1413 tail
= XCONS (tail
)->cdr
;
1419 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1420 "Reverse LIST by modifying cdr pointers.\n\
1421 Returns the beginning of the reversed list.")
1425 register Lisp_Object prev
, tail
, next
;
1427 if (NILP (list
)) return list
;
1430 while (!NILP (tail
))
1434 Fsetcdr (tail
, prev
);
1441 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1442 "Reverse LIST, copying. Returns the beginning of the reversed list.\n\
1443 See also the function `nreverse', which is used more often.")
1449 for (new = Qnil
; CONSP (list
); list
= XCONS (list
)->cdr
)
1450 new = Fcons (XCONS (list
)->car
, new);
1452 wrong_type_argument (Qconsp
, list
);
1456 Lisp_Object
merge ();
1458 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1459 "Sort LIST, stably, comparing elements using PREDICATE.\n\
1460 Returns the sorted list. LIST is modified by side effects.\n\
1461 PREDICATE is called with two elements of LIST, and should return T\n\
1462 if the first element is \"less\" than the second.")
1464 Lisp_Object list
, predicate
;
1466 Lisp_Object front
, back
;
1467 register Lisp_Object len
, tem
;
1468 struct gcpro gcpro1
, gcpro2
;
1469 register int length
;
1472 len
= Flength (list
);
1473 length
= XINT (len
);
1477 XSETINT (len
, (length
/ 2) - 1);
1478 tem
= Fnthcdr (len
, list
);
1480 Fsetcdr (tem
, Qnil
);
1482 GCPRO2 (front
, back
);
1483 front
= Fsort (front
, predicate
);
1484 back
= Fsort (back
, predicate
);
1486 return merge (front
, back
, predicate
);
1490 merge (org_l1
, org_l2
, pred
)
1491 Lisp_Object org_l1
, org_l2
;
1495 register Lisp_Object tail
;
1497 register Lisp_Object l1
, l2
;
1498 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1505 /* It is sufficient to protect org_l1 and org_l2.
1506 When l1 and l2 are updated, we copy the new values
1507 back into the org_ vars. */
1508 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1528 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1544 Fsetcdr (tail
, tem
);
1550 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1551 "Extract a value from a property list.\n\
1552 PLIST is a property list, which is a list of the form\n\
1553 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value\n\
1554 corresponding to the given PROP, or nil if PROP is not\n\
1555 one of the properties on the list.")
1558 register Lisp_Object prop
;
1560 register Lisp_Object tail
;
1561 for (tail
= plist
; !NILP (tail
); tail
= Fcdr (XCONS (tail
)->cdr
))
1563 register Lisp_Object tem
;
1566 return Fcar (XCONS (tail
)->cdr
);
1571 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
1572 "Return the value of SYMBOL's PROPNAME property.\n\
1573 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'.")
1575 Lisp_Object symbol
, propname
;
1577 CHECK_SYMBOL (symbol
, 0);
1578 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
1581 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
1582 "Change value in PLIST of PROP to VAL.\n\
1583 PLIST is a property list, which is a list of the form\n\
1584 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.\n\
1585 If PROP is already a property on the list, its value is set to VAL,\n\
1586 otherwise the new PROP VAL pair is added. The new plist is returned;\n\
1587 use `(setq x (plist-put x prop val))' to be sure to use the new value.\n\
1588 The PLIST is modified by side effects.")
1591 register Lisp_Object prop
;
1594 register Lisp_Object tail
, prev
;
1595 Lisp_Object newcell
;
1597 for (tail
= plist
; CONSP (tail
) && CONSP (XCONS (tail
)->cdr
);
1598 tail
= XCONS (XCONS (tail
)->cdr
)->cdr
)
1600 if (EQ (prop
, XCONS (tail
)->car
))
1602 Fsetcar (XCONS (tail
)->cdr
, val
);
1607 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
1611 Fsetcdr (XCONS (prev
)->cdr
, newcell
);
1615 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
1616 "Store SYMBOL's PROPNAME property with value VALUE.\n\
1617 It can be retrieved with `(get SYMBOL PROPNAME)'.")
1618 (symbol
, propname
, value
)
1619 Lisp_Object symbol
, propname
, value
;
1621 CHECK_SYMBOL (symbol
, 0);
1622 XSYMBOL (symbol
)->plist
1623 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
1627 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
1628 "Return t if two Lisp objects have similar structure and contents.\n\
1629 They must have the same data type.\n\
1630 Conses are compared by comparing the cars and the cdrs.\n\
1631 Vectors and strings are compared element by element.\n\
1632 Numbers are compared by value, but integers cannot equal floats.\n\
1633 (Use `=' if you want integers and floats to be able to be equal.)\n\
1634 Symbols must match exactly.")
1636 register Lisp_Object o1
, o2
;
1638 return internal_equal (o1
, o2
, 0) ? Qt
: Qnil
;
1642 internal_equal (o1
, o2
, depth
)
1643 register Lisp_Object o1
, o2
;
1647 error ("Stack overflow in equal");
1653 if (XTYPE (o1
) != XTYPE (o2
))
1658 #ifdef LISP_FLOAT_TYPE
1660 return (extract_float (o1
) == extract_float (o2
));
1664 if (!internal_equal (XCONS (o1
)->car
, XCONS (o2
)->car
, depth
+ 1))
1666 o1
= XCONS (o1
)->cdr
;
1667 o2
= XCONS (o2
)->cdr
;
1671 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
1675 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o1
),
1677 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o1
),
1680 o1
= XOVERLAY (o1
)->plist
;
1681 o2
= XOVERLAY (o2
)->plist
;
1686 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
1687 && (XMARKER (o1
)->buffer
== 0
1688 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
1692 case Lisp_Vectorlike
:
1694 register int i
, size
;
1695 size
= XVECTOR (o1
)->size
;
1696 /* Pseudovectors have the type encoded in the size field, so this test
1697 actually checks that the objects have the same type as well as the
1699 if (XVECTOR (o2
)->size
!= size
)
1701 /* Boolvectors are compared much like strings. */
1702 if (BOOL_VECTOR_P (o1
))
1705 = (XBOOL_VECTOR (o1
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
1707 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
1709 if (bcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
1714 if (WINDOW_CONFIGURATIONP (o1
))
1715 return compare_window_configurations (o1
, o2
, 0);
1717 /* Aside from them, only true vectors, char-tables, and compiled
1718 functions are sensible to compare, so eliminate the others now. */
1719 if (size
& PSEUDOVECTOR_FLAG
)
1721 if (!(size
& (PVEC_COMPILED
| PVEC_CHAR_TABLE
)))
1723 size
&= PSEUDOVECTOR_SIZE_MASK
;
1725 for (i
= 0; i
< size
; i
++)
1728 v1
= XVECTOR (o1
)->contents
[i
];
1729 v2
= XVECTOR (o2
)->contents
[i
];
1730 if (!internal_equal (v1
, v2
, depth
+ 1))
1738 if (XSTRING (o1
)->size
!= XSTRING (o2
)->size
)
1740 if (STRING_BYTES (XSTRING (o1
)) != STRING_BYTES (XSTRING (o2
)))
1742 if (bcmp (XSTRING (o1
)->data
, XSTRING (o2
)->data
,
1743 STRING_BYTES (XSTRING (o1
))))
1750 extern Lisp_Object
Fmake_char_internal ();
1752 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
1753 "Store each element of ARRAY with ITEM.\n\
1754 ARRAY is a vector, string, char-table, or bool-vector.")
1756 Lisp_Object array
, item
;
1758 register int size
, index
, charval
;
1760 if (VECTORP (array
))
1762 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
1763 size
= XVECTOR (array
)->size
;
1764 for (index
= 0; index
< size
; index
++)
1767 else if (CHAR_TABLE_P (array
))
1769 register Lisp_Object
*p
= XCHAR_TABLE (array
)->contents
;
1770 size
= CHAR_TABLE_ORDINARY_SLOTS
;
1771 for (index
= 0; index
< size
; index
++)
1773 XCHAR_TABLE (array
)->defalt
= Qnil
;
1775 else if (STRINGP (array
))
1777 register unsigned char *p
= XSTRING (array
)->data
;
1778 CHECK_NUMBER (item
, 1);
1779 charval
= XINT (item
);
1780 size
= XSTRING (array
)->size
;
1781 for (index
= 0; index
< size
; index
++)
1784 else if (BOOL_VECTOR_P (array
))
1786 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
1788 = (XBOOL_VECTOR (array
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
1790 charval
= (! NILP (item
) ? -1 : 0);
1791 for (index
= 0; index
< size_in_chars
; index
++)
1796 array
= wrong_type_argument (Qarrayp
, array
);
1802 DEFUN ("char-table-subtype", Fchar_table_subtype
, Schar_table_subtype
,
1804 "Return the subtype of char-table CHAR-TABLE. The value is a symbol.")
1806 Lisp_Object char_table
;
1808 CHECK_CHAR_TABLE (char_table
, 0);
1810 return XCHAR_TABLE (char_table
)->purpose
;
1813 DEFUN ("char-table-parent", Fchar_table_parent
, Schar_table_parent
,
1815 "Return the parent char-table of CHAR-TABLE.\n\
1816 The value is either nil or another char-table.\n\
1817 If CHAR-TABLE holds nil for a given character,\n\
1818 then the actual applicable value is inherited from the parent char-table\n\
1819 \(or from its parents, if necessary).")
1821 Lisp_Object char_table
;
1823 CHECK_CHAR_TABLE (char_table
, 0);
1825 return XCHAR_TABLE (char_table
)->parent
;
1828 DEFUN ("set-char-table-parent", Fset_char_table_parent
, Sset_char_table_parent
,
1830 "Set the parent char-table of CHAR-TABLE to PARENT.\n\
1831 PARENT must be either nil or another char-table.")
1832 (char_table
, parent
)
1833 Lisp_Object char_table
, parent
;
1837 CHECK_CHAR_TABLE (char_table
, 0);
1841 CHECK_CHAR_TABLE (parent
, 0);
1843 for (temp
= parent
; !NILP (temp
); temp
= XCHAR_TABLE (temp
)->parent
)
1844 if (EQ (temp
, char_table
))
1845 error ("Attempt to make a chartable be its own parent");
1848 XCHAR_TABLE (char_table
)->parent
= parent
;
1853 DEFUN ("char-table-extra-slot", Fchar_table_extra_slot
, Schar_table_extra_slot
,
1855 "Return the value of CHAR-TABLE's extra-slot number N.")
1857 Lisp_Object char_table
, n
;
1859 CHECK_CHAR_TABLE (char_table
, 1);
1860 CHECK_NUMBER (n
, 2);
1862 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
1863 args_out_of_range (char_table
, n
);
1865 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)];
1868 DEFUN ("set-char-table-extra-slot", Fset_char_table_extra_slot
,
1869 Sset_char_table_extra_slot
,
1871 "Set CHAR-TABLE's extra-slot number N to VALUE.")
1872 (char_table
, n
, value
)
1873 Lisp_Object char_table
, n
, value
;
1875 CHECK_CHAR_TABLE (char_table
, 1);
1876 CHECK_NUMBER (n
, 2);
1878 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
1879 args_out_of_range (char_table
, n
);
1881 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)] = value
;
1884 DEFUN ("char-table-range", Fchar_table_range
, Schar_table_range
,
1886 "Return the value in CHAR-TABLE for a range of characters RANGE.\n\
1887 RANGE should be nil (for the default value)\n\
1888 a vector which identifies a character set or a row of a character set,\n\
1889 a character set name, or a character code.")
1891 Lisp_Object char_table
, range
;
1895 CHECK_CHAR_TABLE (char_table
, 0);
1897 if (EQ (range
, Qnil
))
1898 return XCHAR_TABLE (char_table
)->defalt
;
1899 else if (INTEGERP (range
))
1900 return Faref (char_table
, range
);
1901 else if (SYMBOLP (range
))
1903 Lisp_Object charset_info
;
1905 charset_info
= Fget (range
, Qcharset
);
1906 CHECK_VECTOR (charset_info
, 0);
1908 return Faref (char_table
,
1909 make_number (XINT (XVECTOR (charset_info
)->contents
[0])
1912 else if (VECTORP (range
))
1914 if (XVECTOR (range
)->size
== 1)
1915 return Faref (char_table
,
1916 make_number (XINT (XVECTOR (range
)->contents
[0]) + 128));
1919 int size
= XVECTOR (range
)->size
;
1920 Lisp_Object
*val
= XVECTOR (range
)->contents
;
1921 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
1922 size
<= 1 ? Qnil
: val
[1],
1923 size
<= 2 ? Qnil
: val
[2]);
1924 return Faref (char_table
, ch
);
1928 error ("Invalid RANGE argument to `char-table-range'");
1931 DEFUN ("set-char-table-range", Fset_char_table_range
, Sset_char_table_range
,
1933 "Set the value in CHAR-TABLE for a range of characters RANGE to VALUE.\n\
1934 RANGE should be t (for all characters), nil (for the default value)\n\
1935 a vector which identifies a character set or a row of a character set,\n\
1936 a coding system, or a character code.")
1937 (char_table
, range
, value
)
1938 Lisp_Object char_table
, range
, value
;
1942 CHECK_CHAR_TABLE (char_table
, 0);
1945 for (i
= 0; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
1946 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
1947 else if (EQ (range
, Qnil
))
1948 XCHAR_TABLE (char_table
)->defalt
= value
;
1949 else if (SYMBOLP (range
))
1951 Lisp_Object charset_info
;
1953 charset_info
= Fget (range
, Qcharset
);
1954 CHECK_VECTOR (charset_info
, 0);
1956 return Faset (char_table
,
1957 make_number (XINT (XVECTOR (charset_info
)->contents
[0])
1961 else if (INTEGERP (range
))
1962 Faset (char_table
, range
, value
);
1963 else if (VECTORP (range
))
1965 if (XVECTOR (range
)->size
== 1)
1966 return Faset (char_table
,
1967 make_number (XINT (XVECTOR (range
)->contents
[0]) + 128),
1971 int size
= XVECTOR (range
)->size
;
1972 Lisp_Object
*val
= XVECTOR (range
)->contents
;
1973 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
1974 size
<= 1 ? Qnil
: val
[1],
1975 size
<= 2 ? Qnil
: val
[2]);
1976 return Faset (char_table
, ch
, value
);
1980 error ("Invalid RANGE argument to `set-char-table-range'");
1985 DEFUN ("set-char-table-default", Fset_char_table_default
,
1986 Sset_char_table_default
, 3, 3, 0,
1987 "Set the default value in CHAR-TABLE for a generic character CHAR to VALUE.\n\
1988 The generic character specifies the group of characters.\n\
1989 See also the documentation of make-char.")
1990 (char_table
, ch
, value
)
1991 Lisp_Object char_table
, ch
, value
;
1993 int c
, i
, charset
, code1
, code2
;
1996 CHECK_CHAR_TABLE (char_table
, 0);
1997 CHECK_NUMBER (ch
, 1);
2000 SPLIT_NON_ASCII_CHAR (c
, charset
, code1
, code2
);
2002 /* Since we may want to set the default value for a character set
2003 not yet defined, we check only if the character set is in the
2004 valid range or not, instead of it is already defined or not. */
2005 if (! CHARSET_VALID_P (charset
))
2006 invalid_character (c
);
2008 if (charset
== CHARSET_ASCII
)
2009 return (XCHAR_TABLE (char_table
)->defalt
= value
);
2011 /* Even if C is not a generic char, we had better behave as if a
2012 generic char is specified. */
2013 if (charset
== CHARSET_COMPOSITION
|| CHARSET_DIMENSION (charset
) == 1)
2015 temp
= XCHAR_TABLE (char_table
)->contents
[charset
+ 128];
2018 if (SUB_CHAR_TABLE_P (temp
))
2019 XCHAR_TABLE (temp
)->defalt
= value
;
2021 XCHAR_TABLE (char_table
)->contents
[charset
+ 128] = value
;
2025 if (! SUB_CHAR_TABLE_P (char_table
))
2026 char_table
= (XCHAR_TABLE (char_table
)->contents
[charset
+ 128]
2027 = make_sub_char_table (temp
));
2028 temp
= XCHAR_TABLE (char_table
)->contents
[code1
];
2029 if (SUB_CHAR_TABLE_P (temp
))
2030 XCHAR_TABLE (temp
)->defalt
= value
;
2032 XCHAR_TABLE (char_table
)->contents
[code1
] = value
;
2036 /* Look up the element in TABLE at index CH,
2037 and return it as an integer.
2038 If the element is nil, return CH itself.
2039 (Actually we do that for any non-integer.) */
2042 char_table_translate (table
, ch
)
2047 value
= Faref (table
, make_number (ch
));
2048 if (! INTEGERP (value
))
2050 return XINT (value
);
2053 /* Map C_FUNCTION or FUNCTION over SUBTABLE, calling it for each
2054 character or group of characters that share a value.
2055 DEPTH is the current depth in the originally specified
2056 chartable, and INDICES contains the vector indices
2057 for the levels our callers have descended.
2059 ARG is passed to C_FUNCTION when that is called. */
2062 map_char_table (c_function
, function
, subtable
, arg
, depth
, indices
)
2063 void (*c_function
) P_ ((Lisp_Object
, Lisp_Object
, Lisp_Object
));
2064 Lisp_Object function
, subtable
, arg
, *indices
;
2071 /* At first, handle ASCII and 8-bit European characters. */
2072 for (i
= 0; i
< CHAR_TABLE_SINGLE_BYTE_SLOTS
; i
++)
2074 Lisp_Object elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2076 (*c_function
) (arg
, make_number (i
), elt
);
2078 call2 (function
, make_number (i
), elt
);
2080 #if 0 /* If the char table has entries for higher characters,
2081 we should report them. */
2082 if (NILP (current_buffer
->enable_multibyte_characters
))
2085 to
= CHAR_TABLE_ORDINARY_SLOTS
;
2090 to
= SUB_CHAR_TABLE_ORDINARY_SLOTS
;
2095 Lisp_Object elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2097 XSETFASTINT (indices
[depth
], i
);
2099 if (SUB_CHAR_TABLE_P (elt
))
2102 error ("Too deep char table");
2103 map_char_table (c_function
, function
, elt
, arg
, depth
+ 1, indices
);
2107 int charset
= XFASTINT (indices
[0]) - 128, c1
, c2
, c
;
2109 if (CHARSET_DEFINED_P (charset
))
2111 c1
= depth
>= 1 ? XFASTINT (indices
[1]) : 0;
2112 c2
= depth
>= 2 ? XFASTINT (indices
[2]) : 0;
2113 c
= MAKE_NON_ASCII_CHAR (charset
, c1
, c2
);
2115 (*c_function
) (arg
, make_number (c
), elt
);
2117 call2 (function
, make_number (c
), elt
);
2123 DEFUN ("map-char-table", Fmap_char_table
, Smap_char_table
,
2125 "Call FUNCTION for each (normal and generic) characters in CHAR-TABLE.\n\
2126 FUNCTION is called with two arguments--a key and a value.\n\
2127 The key is always a possible IDX argument to `aref'.")
2128 (function
, char_table
)
2129 Lisp_Object function
, char_table
;
2131 /* The depth of char table is at most 3. */
2132 Lisp_Object indices
[3];
2134 CHECK_CHAR_TABLE (char_table
, 1);
2136 map_char_table (NULL
, function
, char_table
, char_table
, 0, indices
);
2146 Lisp_Object args
[2];
2149 return Fnconc (2, args
);
2151 return Fnconc (2, &s1
);
2152 #endif /* NO_ARG_ARRAY */
2155 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2156 "Concatenate any number of lists by altering them.\n\
2157 Only the last argument is not altered, and need not be a list.")
2162 register int argnum
;
2163 register Lisp_Object tail
, tem
, val
;
2167 for (argnum
= 0; argnum
< nargs
; argnum
++)
2170 if (NILP (tem
)) continue;
2175 if (argnum
+ 1 == nargs
) break;
2178 tem
= wrong_type_argument (Qlistp
, tem
);
2187 tem
= args
[argnum
+ 1];
2188 Fsetcdr (tail
, tem
);
2190 args
[argnum
+ 1] = tail
;
2196 /* This is the guts of all mapping functions.
2197 Apply FN to each element of SEQ, one by one,
2198 storing the results into elements of VALS, a C vector of Lisp_Objects.
2199 LENI is the length of VALS, which should also be the length of SEQ. */
2202 mapcar1 (leni
, vals
, fn
, seq
)
2205 Lisp_Object fn
, seq
;
2207 register Lisp_Object tail
;
2210 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2212 /* Don't let vals contain any garbage when GC happens. */
2213 for (i
= 0; i
< leni
; i
++)
2216 GCPRO3 (dummy
, fn
, seq
);
2218 gcpro1
.nvars
= leni
;
2219 /* We need not explicitly protect `tail' because it is used only on lists, and
2220 1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
2224 for (i
= 0; i
< leni
; i
++)
2226 dummy
= XVECTOR (seq
)->contents
[i
];
2227 vals
[i
] = call1 (fn
, dummy
);
2230 else if (BOOL_VECTOR_P (seq
))
2232 for (i
= 0; i
< leni
; i
++)
2235 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BITS_PER_CHAR
];
2236 if (byte
& (1 << (i
% BITS_PER_CHAR
)))
2241 vals
[i
] = call1 (fn
, dummy
);
2244 else if (STRINGP (seq
) && ! STRING_MULTIBYTE (seq
))
2246 /* Single-byte string. */
2247 for (i
= 0; i
< leni
; i
++)
2249 XSETFASTINT (dummy
, XSTRING (seq
)->data
[i
]);
2250 vals
[i
] = call1 (fn
, dummy
);
2253 else if (STRINGP (seq
))
2255 /* Multi-byte string. */
2256 int len_byte
= STRING_BYTES (XSTRING (seq
));
2259 for (i
= 0, i_byte
= 0; i
< leni
;)
2264 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2265 XSETFASTINT (dummy
, c
);
2266 vals
[i_before
] = call1 (fn
, dummy
);
2269 else /* Must be a list, since Flength did not get an error */
2272 for (i
= 0; i
< leni
; i
++)
2274 vals
[i
] = call1 (fn
, Fcar (tail
));
2275 tail
= XCONS (tail
)->cdr
;
2282 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2283 "Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.\n\
2284 In between each pair of results, stick in SEPARATOR. Thus, \" \" as\n\
2285 SEPARATOR results in spaces between the values returned by FUNCTION.\n\
2286 SEQUENCE may be a list, a vector, a bool-vector, or a string.")
2287 (function
, sequence
, separator
)
2288 Lisp_Object function
, sequence
, separator
;
2293 register Lisp_Object
*args
;
2295 struct gcpro gcpro1
;
2297 len
= Flength (sequence
);
2299 nargs
= leni
+ leni
- 1;
2300 if (nargs
< 0) return build_string ("");
2302 args
= (Lisp_Object
*) alloca (nargs
* sizeof (Lisp_Object
));
2305 mapcar1 (leni
, args
, function
, sequence
);
2308 for (i
= leni
- 1; i
>= 0; i
--)
2309 args
[i
+ i
] = args
[i
];
2311 for (i
= 1; i
< nargs
; i
+= 2)
2312 args
[i
] = separator
;
2314 return Fconcat (nargs
, args
);
2317 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2318 "Apply FUNCTION to each element of SEQUENCE, and make a list of the results.\n\
2319 The result is a list just as long as SEQUENCE.\n\
2320 SEQUENCE may be a list, a vector, a bool-vector, or a string.")
2321 (function
, sequence
)
2322 Lisp_Object function
, sequence
;
2324 register Lisp_Object len
;
2326 register Lisp_Object
*args
;
2328 len
= Flength (sequence
);
2329 leni
= XFASTINT (len
);
2330 args
= (Lisp_Object
*) alloca (leni
* sizeof (Lisp_Object
));
2332 mapcar1 (leni
, args
, function
, sequence
);
2334 return Flist (leni
, args
);
2337 /* Anything that calls this function must protect from GC! */
2339 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
2340 "Ask user a \"y or n\" question. Return t if answer is \"y\".\n\
2341 Takes one argument, which is the string to display to ask the question.\n\
2342 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.\n\
2343 No confirmation of the answer is requested; a single character is enough.\n\
2344 Also accepts Space to mean yes, or Delete to mean no.")
2348 register Lisp_Object obj
, key
, def
, answer_string
, map
;
2349 register int answer
;
2350 Lisp_Object xprompt
;
2351 Lisp_Object args
[2];
2352 struct gcpro gcpro1
, gcpro2
;
2353 int count
= specpdl_ptr
- specpdl
;
2355 specbind (Qcursor_in_echo_area
, Qt
);
2357 map
= Fsymbol_value (intern ("query-replace-map"));
2359 CHECK_STRING (prompt
, 0);
2361 GCPRO2 (prompt
, xprompt
);
2367 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2371 Lisp_Object pane
, menu
;
2372 redisplay_preserve_echo_area ();
2373 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2374 Fcons (Fcons (build_string ("No"), Qnil
),
2376 menu
= Fcons (prompt
, pane
);
2377 obj
= Fx_popup_dialog (Qt
, menu
);
2378 answer
= !NILP (obj
);
2381 #endif /* HAVE_MENUS */
2382 cursor_in_echo_area
= 1;
2383 choose_minibuf_frame ();
2384 message_with_string ("%s(y or n) ", xprompt
, 0);
2386 if (minibuffer_auto_raise
)
2388 Lisp_Object mini_frame
;
2390 mini_frame
= WINDOW_FRAME (XWINDOW (minibuf_window
));
2392 Fraise_frame (mini_frame
);
2395 obj
= read_filtered_event (1, 0, 0);
2396 cursor_in_echo_area
= 0;
2397 /* If we need to quit, quit with cursor_in_echo_area = 0. */
2400 key
= Fmake_vector (make_number (1), obj
);
2401 def
= Flookup_key (map
, key
, Qt
);
2402 answer_string
= Fsingle_key_description (obj
);
2404 if (EQ (def
, intern ("skip")))
2409 else if (EQ (def
, intern ("act")))
2414 else if (EQ (def
, intern ("recenter")))
2420 else if (EQ (def
, intern ("quit")))
2422 /* We want to exit this command for exit-prefix,
2423 and this is the only way to do it. */
2424 else if (EQ (def
, intern ("exit-prefix")))
2429 /* If we don't clear this, then the next call to read_char will
2430 return quit_char again, and we'll enter an infinite loop. */
2435 if (EQ (xprompt
, prompt
))
2437 args
[0] = build_string ("Please answer y or n. ");
2439 xprompt
= Fconcat (2, args
);
2444 if (! noninteractive
)
2446 cursor_in_echo_area
= -1;
2447 message_with_string (answer
? "%s(y or n) y" : "%s(y or n) n",
2451 unbind_to (count
, Qnil
);
2452 return answer
? Qt
: Qnil
;
2455 /* This is how C code calls `yes-or-no-p' and allows the user
2458 Anything that calls this function must protect from GC! */
2461 do_yes_or_no_p (prompt
)
2464 return call1 (intern ("yes-or-no-p"), prompt
);
2467 /* Anything that calls this function must protect from GC! */
2469 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2470 "Ask user a yes-or-no question. Return t if answer is yes.\n\
2471 Takes one argument, which is the string to display to ask the question.\n\
2472 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.\n\
2473 The user must confirm the answer with RET,\n\
2474 and can edit it until it has been confirmed.")
2478 register Lisp_Object ans
;
2479 Lisp_Object args
[2];
2480 struct gcpro gcpro1
;
2483 CHECK_STRING (prompt
, 0);
2486 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2490 Lisp_Object pane
, menu
, obj
;
2491 redisplay_preserve_echo_area ();
2492 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2493 Fcons (Fcons (build_string ("No"), Qnil
),
2496 menu
= Fcons (prompt
, pane
);
2497 obj
= Fx_popup_dialog (Qt
, menu
);
2501 #endif /* HAVE_MENUS */
2504 args
[1] = build_string ("(yes or no) ");
2505 prompt
= Fconcat (2, args
);
2511 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2512 Qyes_or_no_p_history
, Qnil
,
2514 if (XSTRING (ans
)->size
== 3 && !strcmp (XSTRING (ans
)->data
, "yes"))
2519 if (XSTRING (ans
)->size
== 2 && !strcmp (XSTRING (ans
)->data
, "no"))
2527 message ("Please answer yes or no.");
2528 Fsleep_for (make_number (2), Qnil
);
2532 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2533 "Return list of 1 minute, 5 minute and 15 minute load averages.\n\
2534 Each of the three load averages is multiplied by 100,\n\
2535 then converted to integer.\n\
2536 When USE-FLOATS is non-nil, floats will be used instead of integers.\n\
2537 These floats are not multiplied by 100.\n\n\
2538 If the 5-minute or 15-minute load averages are not available, return a\n\
2539 shortened list, containing only those averages which are available.")
2541 Lisp_Object use_floats
;
2544 int loads
= getloadavg (load_ave
, 3);
2545 Lisp_Object ret
= Qnil
;
2548 error ("load-average not implemented for this operating system");
2552 Lisp_Object load
= (NILP (use_floats
) ?
2553 make_number ((int) (100.0 * load_ave
[loads
]))
2554 : make_float (load_ave
[loads
]));
2555 ret
= Fcons (load
, ret
);
2561 Lisp_Object Vfeatures
;
2563 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 1, 0,
2564 "Returns t if FEATURE is present in this Emacs.\n\
2565 Use this to conditionalize execution of lisp code based on the presence or\n\
2566 absence of emacs or environment extensions.\n\
2567 Use `provide' to declare that a feature is available.\n\
2568 This function looks at the value of the variable `features'.")
2570 Lisp_Object feature
;
2572 register Lisp_Object tem
;
2573 CHECK_SYMBOL (feature
, 0);
2574 tem
= Fmemq (feature
, Vfeatures
);
2575 return (NILP (tem
)) ? Qnil
: Qt
;
2578 DEFUN ("provide", Fprovide
, Sprovide
, 1, 1, 0,
2579 "Announce that FEATURE is a feature of the current Emacs.")
2581 Lisp_Object feature
;
2583 register Lisp_Object tem
;
2584 CHECK_SYMBOL (feature
, 0);
2585 if (!NILP (Vautoload_queue
))
2586 Vautoload_queue
= Fcons (Fcons (Vfeatures
, Qnil
), Vautoload_queue
);
2587 tem
= Fmemq (feature
, Vfeatures
);
2589 Vfeatures
= Fcons (feature
, Vfeatures
);
2590 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2594 DEFUN ("require", Frequire
, Srequire
, 1, 2, 0,
2595 "If feature FEATURE is not loaded, load it from FILENAME.\n\
2596 If FEATURE is not a member of the list `features', then the feature\n\
2597 is not loaded; so load the file FILENAME.\n\
2598 If FILENAME is omitted, the printname of FEATURE is used as the file name,\n\
2599 but in this case `load' insists on adding the suffix `.el' or `.elc'.")
2600 (feature
, file_name
)
2601 Lisp_Object feature
, file_name
;
2603 register Lisp_Object tem
;
2604 CHECK_SYMBOL (feature
, 0);
2605 tem
= Fmemq (feature
, Vfeatures
);
2606 LOADHIST_ATTACH (Fcons (Qrequire
, feature
));
2609 int count
= specpdl_ptr
- specpdl
;
2611 /* Value saved here is to be restored into Vautoload_queue */
2612 record_unwind_protect (un_autoload
, Vautoload_queue
);
2613 Vautoload_queue
= Qt
;
2615 Fload (NILP (file_name
) ? Fsymbol_name (feature
) : file_name
,
2616 Qnil
, Qt
, Qnil
, (NILP (file_name
) ? Qt
: Qnil
));
2618 tem
= Fmemq (feature
, Vfeatures
);
2620 error ("Required feature %s was not provided",
2621 XSYMBOL (feature
)->name
->data
);
2623 /* Once loading finishes, don't undo it. */
2624 Vautoload_queue
= Qt
;
2625 feature
= unbind_to (count
, feature
);
2630 /* Primitives for work of the "widget" library.
2631 In an ideal world, this section would not have been necessary.
2632 However, lisp function calls being as slow as they are, it turns
2633 out that some functions in the widget library (wid-edit.el) are the
2634 bottleneck of Widget operation. Here is their translation to C,
2635 for the sole reason of efficiency. */
2637 DEFUN ("widget-plist-member", Fwidget_plist_member
, Swidget_plist_member
, 2, 2, 0,
2638 "Return non-nil if PLIST has the property PROP.\n\
2639 PLIST is a property list, which is a list of the form\n\
2640 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.\n\
2641 Unlike `plist-get', this allows you to distinguish between a missing\n\
2642 property and a property with the value nil.\n\
2643 The value is actually the tail of PLIST whose car is PROP.")
2645 Lisp_Object plist
, prop
;
2647 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
2650 plist
= XCDR (plist
);
2651 plist
= CDR (plist
);
2656 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
2657 "In WIDGET, set PROPERTY to VALUE.\n\
2658 The value can later be retrieved with `widget-get'.")
2659 (widget
, property
, value
)
2660 Lisp_Object widget
, property
, value
;
2662 CHECK_CONS (widget
, 1);
2663 XCDR (widget
) = Fplist_put (XCDR (widget
), property
, value
);
2666 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
2667 "In WIDGET, get the value of PROPERTY.\n\
2668 The value could either be specified when the widget was created, or\n\
2669 later with `widget-put'.")
2671 Lisp_Object widget
, property
;
2679 CHECK_CONS (widget
, 1);
2680 tmp
= Fwidget_plist_member (XCDR (widget
), property
);
2686 tmp
= XCAR (widget
);
2689 widget
= Fget (tmp
, Qwidget_type
);
2693 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
2694 "Apply the value of WIDGET's PROPERTY to the widget itself.\n\
2695 ARGS are passed as extra arguments to the function.")
2700 /* This function can GC. */
2701 Lisp_Object newargs
[3];
2702 struct gcpro gcpro1
, gcpro2
;
2705 newargs
[0] = Fwidget_get (args
[0], args
[1]);
2706 newargs
[1] = args
[0];
2707 newargs
[2] = Flist (nargs
- 2, args
+ 2);
2708 GCPRO2 (newargs
[0], newargs
[2]);
2709 result
= Fapply (3, newargs
);
2717 Qstring_lessp
= intern ("string-lessp");
2718 staticpro (&Qstring_lessp
);
2719 Qprovide
= intern ("provide");
2720 staticpro (&Qprovide
);
2721 Qrequire
= intern ("require");
2722 staticpro (&Qrequire
);
2723 Qyes_or_no_p_history
= intern ("yes-or-no-p-history");
2724 staticpro (&Qyes_or_no_p_history
);
2725 Qcursor_in_echo_area
= intern ("cursor-in-echo-area");
2726 staticpro (&Qcursor_in_echo_area
);
2727 Qwidget_type
= intern ("widget-type");
2728 staticpro (&Qwidget_type
);
2730 staticpro (&string_char_byte_cache_string
);
2731 string_char_byte_cache_string
= Qnil
;
2733 Fset (Qyes_or_no_p_history
, Qnil
);
2735 DEFVAR_LISP ("features", &Vfeatures
,
2736 "A list of symbols which are the features of the executing emacs.\n\
2737 Used by `featurep' and `require', and altered by `provide'.");
2740 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box
,
2741 "*Non-nil means mouse commands use dialog boxes to ask questions.\n\
2742 This applies to y-or-n and yes-or-no questions asked by commands\n\
2743 invoked by mouse clicks and mouse menu items.");
2746 defsubr (&Sidentity
);
2749 defsubr (&Ssafe_length
);
2750 defsubr (&Sstring_bytes
);
2751 defsubr (&Sstring_equal
);
2752 defsubr (&Scompare_strings
);
2753 defsubr (&Sstring_lessp
);
2756 defsubr (&Svconcat
);
2757 defsubr (&Scopy_sequence
);
2758 defsubr (&Sstring_make_multibyte
);
2759 defsubr (&Sstring_make_unibyte
);
2760 defsubr (&Sstring_as_multibyte
);
2761 defsubr (&Sstring_as_unibyte
);
2762 defsubr (&Scopy_alist
);
2763 defsubr (&Ssubstring
);
2775 defsubr (&Snreverse
);
2776 defsubr (&Sreverse
);
2778 defsubr (&Splist_get
);
2780 defsubr (&Splist_put
);
2783 defsubr (&Sfillarray
);
2784 defsubr (&Schar_table_subtype
);
2785 defsubr (&Schar_table_parent
);
2786 defsubr (&Sset_char_table_parent
);
2787 defsubr (&Schar_table_extra_slot
);
2788 defsubr (&Sset_char_table_extra_slot
);
2789 defsubr (&Schar_table_range
);
2790 defsubr (&Sset_char_table_range
);
2791 defsubr (&Sset_char_table_default
);
2792 defsubr (&Smap_char_table
);
2795 defsubr (&Smapconcat
);
2796 defsubr (&Sy_or_n_p
);
2797 defsubr (&Syes_or_no_p
);
2798 defsubr (&Sload_average
);
2799 defsubr (&Sfeaturep
);
2800 defsubr (&Srequire
);
2801 defsubr (&Sprovide
);
2802 defsubr (&Swidget_plist_member
);
2803 defsubr (&Swidget_put
);
2804 defsubr (&Swidget_get
);
2805 defsubr (&Swidget_apply
);