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
;
531 /* In append, the last arg isn't treated like the others */
532 if (last_special
&& nargs
> 0)
535 last_tail
= args
[nargs
];
540 /* Canonicalize each argument. */
541 for (argnum
= 0; argnum
< nargs
; argnum
++)
544 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
545 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
548 args
[argnum
] = Fnumber_to_string (this);
550 args
[argnum
] = wrong_type_argument (Qsequencep
, this);
554 /* Compute total length in chars of arguments in RESULT_LEN.
555 If desired output is a string, also compute length in bytes
556 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
557 whether the result should be a multibyte string. */
561 for (argnum
= 0; argnum
< nargs
; argnum
++)
565 len
= XFASTINT (Flength (this));
566 if (target_type
== Lisp_String
)
568 /* We must count the number of bytes needed in the string
569 as well as the number of characters. */
575 for (i
= 0; i
< len
; i
++)
577 ch
= XVECTOR (this)->contents
[i
];
579 wrong_type_argument (Qintegerp
, ch
);
580 this_len_byte
= XFASTINT (Fchar_bytes (ch
));
581 result_len_byte
+= this_len_byte
;
582 if (this_len_byte
> 1)
585 else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size
> 0)
586 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
587 else if (CONSP (this))
588 for (; CONSP (this); this = XCONS (this)->cdr
)
590 ch
= XCONS (this)->car
;
592 wrong_type_argument (Qintegerp
, ch
);
593 this_len_byte
= XFASTINT (Fchar_bytes (ch
));
594 result_len_byte
+= this_len_byte
;
595 if (this_len_byte
> 1)
598 else if (STRINGP (this))
600 if (STRING_MULTIBYTE (this))
603 result_len_byte
+= STRING_BYTES (XSTRING (this));
606 result_len_byte
+= count_size_as_multibyte (XSTRING (this)->data
,
607 XSTRING (this)->size
);
614 if (! some_multibyte
)
615 result_len_byte
= result_len
;
617 /* Create the output object. */
618 if (target_type
== Lisp_Cons
)
619 val
= Fmake_list (make_number (result_len
), Qnil
);
620 else if (target_type
== Lisp_Vectorlike
)
621 val
= Fmake_vector (make_number (result_len
), Qnil
);
622 else if (some_multibyte
)
623 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
625 val
= make_uninit_string (result_len
);
627 /* In `append', if all but last arg are nil, return last arg. */
628 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
631 /* Copy the contents of the args into the result. */
633 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
635 toindex
= 0, toindex_byte
= 0;
639 for (argnum
= 0; argnum
< nargs
; argnum
++)
643 register unsigned int thisindex
= 0;
644 register unsigned int thisindex_byte
= 0;
648 thislen
= Flength (this), thisleni
= XINT (thislen
);
650 if (STRINGP (this) && STRINGP (val
)
651 && ! NULL_INTERVAL_P (XSTRING (this)->intervals
))
652 copy_text_properties (make_number (0), thislen
, this,
653 make_number (toindex
), val
, Qnil
);
655 /* Between strings of the same kind, copy fast. */
656 if (STRINGP (this) && STRINGP (val
)
657 && STRING_MULTIBYTE (this) == some_multibyte
)
659 int thislen_byte
= STRING_BYTES (XSTRING (this));
660 bcopy (XSTRING (this)->data
, XSTRING (val
)->data
+ toindex_byte
,
661 STRING_BYTES (XSTRING (this)));
662 toindex_byte
+= thislen_byte
;
665 /* Copy a single-byte string to a multibyte string. */
666 else if (STRINGP (this) && STRINGP (val
))
668 toindex_byte
+= copy_text (XSTRING (this)->data
,
669 XSTRING (val
)->data
+ toindex_byte
,
670 XSTRING (this)->size
, 0, 1);
674 /* Copy element by element. */
677 register Lisp_Object elt
;
679 /* Fetch next element of `this' arg into `elt', or break if
680 `this' is exhausted. */
681 if (NILP (this)) break;
683 elt
= XCONS (this)->car
, this = XCONS (this)->cdr
;
684 else if (thisindex
>= thisleni
)
686 else if (STRINGP (this))
689 if (STRING_MULTIBYTE (this))
691 FETCH_STRING_CHAR_ADVANCE (c
, this,
694 XSETFASTINT (elt
, c
);
698 XSETFASTINT (elt
, XSTRING (this)->data
[thisindex
++]);
699 if (some_multibyte
&& XINT (elt
) >= 0200
700 && XINT (elt
) < 0400)
702 c
= unibyte_char_to_multibyte (XINT (elt
));
707 else if (BOOL_VECTOR_P (this))
710 byte
= XBOOL_VECTOR (this)->data
[thisindex
/ BITS_PER_CHAR
];
711 if (byte
& (1 << (thisindex
% BITS_PER_CHAR
)))
718 elt
= XVECTOR (this)->contents
[thisindex
++];
720 /* Store this element into the result. */
723 XCONS (tail
)->car
= elt
;
725 tail
= XCONS (tail
)->cdr
;
727 else if (VECTORP (val
))
728 XVECTOR (val
)->contents
[toindex
++] = elt
;
731 CHECK_NUMBER (elt
, 0);
732 if (SINGLE_BYTE_CHAR_P (XINT (elt
)))
734 XSTRING (val
)->data
[toindex
++] = XINT (elt
);
738 /* If we have any multibyte characters,
739 we already decided to make a multibyte string. */
742 unsigned char work
[4], *str
;
743 int i
= CHAR_STRING (c
, work
, str
);
745 /* P exists as a variable
746 to avoid a bug on the Masscomp C compiler. */
747 unsigned char *p
= & XSTRING (val
)->data
[toindex_byte
];
756 XCONS (prev
)->cdr
= last_tail
;
761 static Lisp_Object string_char_byte_cache_string
;
762 static int string_char_byte_cache_charpos
;
763 static int string_char_byte_cache_bytepos
;
765 /* Return the character index corresponding to CHAR_INDEX in STRING. */
768 string_char_to_byte (string
, char_index
)
773 int best_below
, best_below_byte
;
774 int best_above
, best_above_byte
;
776 if (! STRING_MULTIBYTE (string
))
779 best_below
= best_below_byte
= 0;
780 best_above
= XSTRING (string
)->size
;
781 best_above_byte
= STRING_BYTES (XSTRING (string
));
783 if (EQ (string
, string_char_byte_cache_string
))
785 if (string_char_byte_cache_charpos
< char_index
)
787 best_below
= string_char_byte_cache_charpos
;
788 best_below_byte
= string_char_byte_cache_bytepos
;
792 best_above
= string_char_byte_cache_charpos
;
793 best_above_byte
= string_char_byte_cache_bytepos
;
797 if (char_index
- best_below
< best_above
- char_index
)
799 while (best_below
< char_index
)
802 FETCH_STRING_CHAR_ADVANCE (c
, string
, best_below
, best_below_byte
);
805 i_byte
= best_below_byte
;
809 while (best_above
> char_index
)
811 int best_above_byte_saved
= --best_above_byte
;
813 while (best_above_byte
> 0
814 && !CHAR_HEAD_P (XSTRING (string
)->data
[best_above_byte
]))
816 if (XSTRING (string
)->data
[best_above_byte
] < 0x80)
817 best_above_byte
= best_above_byte_saved
;
821 i_byte
= best_above_byte
;
824 string_char_byte_cache_bytepos
= i_byte
;
825 string_char_byte_cache_charpos
= i
;
826 string_char_byte_cache_string
= string
;
831 /* Return the character index corresponding to BYTE_INDEX in STRING. */
834 string_byte_to_char (string
, byte_index
)
839 int best_below
, best_below_byte
;
840 int best_above
, best_above_byte
;
842 if (! STRING_MULTIBYTE (string
))
845 best_below
= best_below_byte
= 0;
846 best_above
= XSTRING (string
)->size
;
847 best_above_byte
= STRING_BYTES (XSTRING (string
));
849 if (EQ (string
, string_char_byte_cache_string
))
851 if (string_char_byte_cache_bytepos
< byte_index
)
853 best_below
= string_char_byte_cache_charpos
;
854 best_below_byte
= string_char_byte_cache_bytepos
;
858 best_above
= string_char_byte_cache_charpos
;
859 best_above_byte
= string_char_byte_cache_bytepos
;
863 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
865 while (best_below_byte
< byte_index
)
868 FETCH_STRING_CHAR_ADVANCE (c
, string
, best_below
, best_below_byte
);
871 i_byte
= best_below_byte
;
875 while (best_above_byte
> byte_index
)
877 int best_above_byte_saved
= --best_above_byte
;
879 while (best_above_byte
> 0
880 && !CHAR_HEAD_P (XSTRING (string
)->data
[best_above_byte
]))
882 if (XSTRING (string
)->data
[best_above_byte
] < 0x80)
883 best_above_byte
= best_above_byte_saved
;
887 i_byte
= best_above_byte
;
890 string_char_byte_cache_bytepos
= i_byte
;
891 string_char_byte_cache_charpos
= i
;
892 string_char_byte_cache_string
= string
;
897 /* Convert STRING to a multibyte string.
898 Single-byte characters 0240 through 0377 are converted
899 by adding nonascii_insert_offset to each. */
902 string_make_multibyte (string
)
908 if (STRING_MULTIBYTE (string
))
911 nbytes
= count_size_as_multibyte (XSTRING (string
)->data
,
912 XSTRING (string
)->size
);
913 /* If all the chars are ASCII, they won't need any more bytes
914 once converted. In that case, we can return STRING itself. */
915 if (nbytes
== STRING_BYTES (XSTRING (string
)))
918 buf
= (unsigned char *) alloca (nbytes
);
919 copy_text (XSTRING (string
)->data
, buf
, STRING_BYTES (XSTRING (string
)),
922 return make_multibyte_string (buf
, XSTRING (string
)->size
, nbytes
);
925 /* Convert STRING to a single-byte string. */
928 string_make_unibyte (string
)
933 if (! STRING_MULTIBYTE (string
))
936 buf
= (unsigned char *) alloca (XSTRING (string
)->size
);
938 copy_text (XSTRING (string
)->data
, buf
, STRING_BYTES (XSTRING (string
)),
941 return make_unibyte_string (buf
, XSTRING (string
)->size
);
944 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
946 "Return the multibyte equivalent of STRING.\n\
947 The function `unibyte-char-to-multibyte' is used to convert\n\
948 each unibyte character to a multibyte character.")
952 return string_make_multibyte (string
);
955 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
957 "Return the unibyte equivalent of STRING.\n\
958 Multibyte character codes are converted to unibyte\n\
959 by using just the low 8 bits.")
963 return string_make_unibyte (string
);
966 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
968 "Return a unibyte string with the same individual bytes as STRING.\n\
969 If STRING is unibyte, the result is STRING itself.")
973 if (STRING_MULTIBYTE (string
))
975 string
= Fcopy_sequence (string
);
976 XSTRING (string
)->size
= STRING_BYTES (XSTRING (string
));
977 SET_STRING_BYTES (XSTRING (string
), -1);
982 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
984 "Return a multibyte string with the same individual bytes as STRING.\n\
985 If STRING is multibyte, the result is STRING itself.")
989 if (! STRING_MULTIBYTE (string
))
991 int nbytes
= STRING_BYTES (XSTRING (string
));
992 int newlen
= multibyte_chars_in_text (XSTRING (string
)->data
, nbytes
);
994 string
= Fcopy_sequence (string
);
995 XSTRING (string
)->size
= newlen
;
996 XSTRING (string
)->size_byte
= nbytes
;
1001 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1002 "Return a copy of ALIST.\n\
1003 This is an alist which represents the same mapping from objects to objects,\n\
1004 but does not share the alist structure with ALIST.\n\
1005 The objects mapped (cars and cdrs of elements of the alist)\n\
1006 are shared, however.\n\
1007 Elements of ALIST that are not conses are also shared.")
1011 register Lisp_Object tem
;
1013 CHECK_LIST (alist
, 0);
1016 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1017 for (tem
= alist
; CONSP (tem
); tem
= XCONS (tem
)->cdr
)
1019 register Lisp_Object car
;
1020 car
= XCONS (tem
)->car
;
1023 XCONS (tem
)->car
= Fcons (XCONS (car
)->car
, XCONS (car
)->cdr
);
1028 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
1029 "Return a substring of STRING, starting at index FROM and ending before TO.\n\
1030 TO may be nil or omitted; then the substring runs to the end of STRING.\n\
1031 If FROM or TO is negative, it counts from the end.\n\
1033 This function allows vectors as well as strings.")
1036 register Lisp_Object from
, to
;
1041 int from_char
, to_char
;
1042 int from_byte
, to_byte
;
1044 if (! (STRINGP (string
) || VECTORP (string
)))
1045 wrong_type_argument (Qarrayp
, string
);
1047 CHECK_NUMBER (from
, 1);
1049 if (STRINGP (string
))
1051 size
= XSTRING (string
)->size
;
1052 size_byte
= STRING_BYTES (XSTRING (string
));
1055 size
= XVECTOR (string
)->size
;
1060 to_byte
= size_byte
;
1064 CHECK_NUMBER (to
, 2);
1066 to_char
= XINT (to
);
1070 if (STRINGP (string
))
1071 to_byte
= string_char_to_byte (string
, to_char
);
1074 from_char
= XINT (from
);
1077 if (STRINGP (string
))
1078 from_byte
= string_char_to_byte (string
, from_char
);
1080 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1081 args_out_of_range_3 (string
, make_number (from_char
),
1082 make_number (to_char
));
1084 if (STRINGP (string
))
1086 res
= make_specified_string (XSTRING (string
)->data
+ from_byte
,
1087 to_char
- from_char
, to_byte
- from_byte
,
1088 STRING_MULTIBYTE (string
));
1089 copy_text_properties (make_number (from_char
), make_number (to_char
),
1090 string
, make_number (0), res
, Qnil
);
1093 res
= Fvector (to_char
- from_char
,
1094 XVECTOR (string
)->contents
+ from_char
);
1099 /* Extract a substring of STRING, giving start and end positions
1100 both in characters and in bytes. */
1103 substring_both (string
, from
, from_byte
, to
, to_byte
)
1105 int from
, from_byte
, to
, to_byte
;
1111 if (! (STRINGP (string
) || VECTORP (string
)))
1112 wrong_type_argument (Qarrayp
, string
);
1114 if (STRINGP (string
))
1116 size
= XSTRING (string
)->size
;
1117 size_byte
= STRING_BYTES (XSTRING (string
));
1120 size
= XVECTOR (string
)->size
;
1122 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1123 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1125 if (STRINGP (string
))
1127 res
= make_specified_string (XSTRING (string
)->data
+ from_byte
,
1128 to
- from
, to_byte
- from_byte
,
1129 STRING_MULTIBYTE (string
));
1130 copy_text_properties (make_number (from
), make_number (to
),
1131 string
, make_number (0), res
, Qnil
);
1134 res
= Fvector (to
- from
,
1135 XVECTOR (string
)->contents
+ from
);
1140 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1141 "Take cdr N times on LIST, returns the result.")
1144 register Lisp_Object list
;
1146 register int i
, num
;
1147 CHECK_NUMBER (n
, 0);
1149 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1157 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1158 "Return the Nth element of LIST.\n\
1159 N counts from zero. If LIST is not that long, nil is returned.")
1161 Lisp_Object n
, list
;
1163 return Fcar (Fnthcdr (n
, list
));
1166 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1167 "Return element of SEQUENCE at index N.")
1169 register Lisp_Object sequence
, n
;
1171 CHECK_NUMBER (n
, 0);
1174 if (CONSP (sequence
) || NILP (sequence
))
1175 return Fcar (Fnthcdr (n
, sequence
));
1176 else if (STRINGP (sequence
) || VECTORP (sequence
)
1177 || BOOL_VECTOR_P (sequence
) || CHAR_TABLE_P (sequence
))
1178 return Faref (sequence
, n
);
1180 sequence
= wrong_type_argument (Qsequencep
, sequence
);
1184 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1185 "Return non-nil if ELT is an element of LIST. Comparison done with `equal'.\n\
1186 The value is actually the tail of LIST whose car is ELT.")
1188 register Lisp_Object elt
;
1191 register Lisp_Object tail
;
1192 for (tail
= list
; !NILP (tail
); tail
= XCONS (tail
)->cdr
)
1194 register Lisp_Object tem
;
1196 if (! NILP (Fequal (elt
, tem
)))
1203 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1204 "Return non-nil if ELT is an element of LIST. Comparison done with EQ.\n\
1205 The value is actually the tail of LIST whose car is ELT.")
1207 register Lisp_Object elt
;
1210 register Lisp_Object tail
;
1211 for (tail
= list
; !NILP (tail
); tail
= XCONS (tail
)->cdr
)
1213 register Lisp_Object tem
;
1215 if (EQ (elt
, tem
)) return tail
;
1221 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1222 "Return non-nil if KEY is `eq' to the car of an element of LIST.\n\
1223 The value is actually the element of LIST whose car is KEY.\n\
1224 Elements of LIST that are not conses are ignored.")
1226 register Lisp_Object key
;
1229 register Lisp_Object tail
;
1230 for (tail
= list
; !NILP (tail
); tail
= XCONS (tail
)->cdr
)
1232 register Lisp_Object elt
, tem
;
1234 if (!CONSP (elt
)) continue;
1235 tem
= XCONS (elt
)->car
;
1236 if (EQ (key
, tem
)) return elt
;
1242 /* Like Fassq but never report an error and do not allow quits.
1243 Use only on lists known never to be circular. */
1246 assq_no_quit (key
, list
)
1247 register Lisp_Object key
;
1250 register Lisp_Object tail
;
1251 for (tail
= list
; CONSP (tail
); tail
= XCONS (tail
)->cdr
)
1253 register Lisp_Object elt
, tem
;
1255 if (!CONSP (elt
)) continue;
1256 tem
= XCONS (elt
)->car
;
1257 if (EQ (key
, tem
)) return elt
;
1262 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1263 "Return non-nil if KEY is `equal' to the car of an element of LIST.\n\
1264 The value is actually the element of LIST whose car equals KEY.")
1266 register Lisp_Object key
;
1269 register Lisp_Object tail
;
1270 for (tail
= list
; !NILP (tail
); tail
= XCONS (tail
)->cdr
)
1272 register Lisp_Object elt
, tem
;
1274 if (!CONSP (elt
)) continue;
1275 tem
= Fequal (XCONS (elt
)->car
, key
);
1276 if (!NILP (tem
)) return elt
;
1282 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1283 "Return non-nil if ELT is `eq' to the cdr of an element of LIST.\n\
1284 The value is actually the element of LIST whose cdr is ELT.")
1286 register Lisp_Object key
;
1289 register Lisp_Object tail
;
1290 for (tail
= list
; !NILP (tail
); tail
= XCONS (tail
)->cdr
)
1292 register Lisp_Object elt
, tem
;
1294 if (!CONSP (elt
)) continue;
1295 tem
= XCONS (elt
)->cdr
;
1296 if (EQ (key
, tem
)) return elt
;
1302 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1303 "Return non-nil if KEY is `equal' to the cdr of an element of LIST.\n\
1304 The value is actually the element of LIST whose cdr equals KEY.")
1306 register Lisp_Object key
;
1309 register Lisp_Object tail
;
1310 for (tail
= list
; !NILP (tail
); tail
= XCONS (tail
)->cdr
)
1312 register Lisp_Object elt
, tem
;
1314 if (!CONSP (elt
)) continue;
1315 tem
= Fequal (XCONS (elt
)->cdr
, key
);
1316 if (!NILP (tem
)) return elt
;
1322 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1323 "Delete by side effect any occurrences of ELT as a member of LIST.\n\
1324 The modified LIST is returned. Comparison is done with `eq'.\n\
1325 If the first member of LIST is ELT, there is no way to remove it by side effect;\n\
1326 therefore, write `(setq foo (delq element foo))'\n\
1327 to be sure of changing the value of `foo'.")
1329 register Lisp_Object elt
;
1332 register Lisp_Object tail
, prev
;
1333 register Lisp_Object tem
;
1337 while (!NILP (tail
))
1343 list
= XCONS (tail
)->cdr
;
1345 Fsetcdr (prev
, XCONS (tail
)->cdr
);
1349 tail
= XCONS (tail
)->cdr
;
1355 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1356 "Delete by side effect any occurrences of ELT as a member of LIST.\n\
1357 The modified LIST is returned. Comparison is done with `equal'.\n\
1358 If the first member of LIST is ELT, deleting it is not a side effect;\n\
1359 it is simply using a different list.\n\
1360 Therefore, write `(setq foo (delete element foo))'\n\
1361 to be sure of changing the value of `foo'.")
1363 register Lisp_Object elt
;
1366 register Lisp_Object tail
, prev
;
1367 register Lisp_Object tem
;
1371 while (!NILP (tail
))
1374 if (! NILP (Fequal (elt
, tem
)))
1377 list
= XCONS (tail
)->cdr
;
1379 Fsetcdr (prev
, XCONS (tail
)->cdr
);
1383 tail
= XCONS (tail
)->cdr
;
1389 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1390 "Reverse LIST by modifying cdr pointers.\n\
1391 Returns the beginning of the reversed list.")
1395 register Lisp_Object prev
, tail
, next
;
1397 if (NILP (list
)) return list
;
1400 while (!NILP (tail
))
1404 Fsetcdr (tail
, prev
);
1411 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1412 "Reverse LIST, copying. Returns the beginning of the reversed list.\n\
1413 See also the function `nreverse', which is used more often.")
1419 for (new = Qnil
; CONSP (list
); list
= XCONS (list
)->cdr
)
1420 new = Fcons (XCONS (list
)->car
, new);
1422 wrong_type_argument (Qconsp
, list
);
1426 Lisp_Object
merge ();
1428 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1429 "Sort LIST, stably, comparing elements using PREDICATE.\n\
1430 Returns the sorted list. LIST is modified by side effects.\n\
1431 PREDICATE is called with two elements of LIST, and should return T\n\
1432 if the first element is \"less\" than the second.")
1434 Lisp_Object list
, predicate
;
1436 Lisp_Object front
, back
;
1437 register Lisp_Object len
, tem
;
1438 struct gcpro gcpro1
, gcpro2
;
1439 register int length
;
1442 len
= Flength (list
);
1443 length
= XINT (len
);
1447 XSETINT (len
, (length
/ 2) - 1);
1448 tem
= Fnthcdr (len
, list
);
1450 Fsetcdr (tem
, Qnil
);
1452 GCPRO2 (front
, back
);
1453 front
= Fsort (front
, predicate
);
1454 back
= Fsort (back
, predicate
);
1456 return merge (front
, back
, predicate
);
1460 merge (org_l1
, org_l2
, pred
)
1461 Lisp_Object org_l1
, org_l2
;
1465 register Lisp_Object tail
;
1467 register Lisp_Object l1
, l2
;
1468 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1475 /* It is sufficient to protect org_l1 and org_l2.
1476 When l1 and l2 are updated, we copy the new values
1477 back into the org_ vars. */
1478 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1498 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1514 Fsetcdr (tail
, tem
);
1520 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1521 "Extract a value from a property list.\n\
1522 PLIST is a property list, which is a list of the form\n\
1523 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value\n\
1524 corresponding to the given PROP, or nil if PROP is not\n\
1525 one of the properties on the list.")
1528 register Lisp_Object prop
;
1530 register Lisp_Object tail
;
1531 for (tail
= plist
; !NILP (tail
); tail
= Fcdr (XCONS (tail
)->cdr
))
1533 register Lisp_Object tem
;
1536 return Fcar (XCONS (tail
)->cdr
);
1541 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
1542 "Return the value of SYMBOL's PROPNAME property.\n\
1543 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'.")
1545 Lisp_Object symbol
, propname
;
1547 CHECK_SYMBOL (symbol
, 0);
1548 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
1551 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
1552 "Change value in PLIST of PROP to VAL.\n\
1553 PLIST is a property list, which is a list of the form\n\
1554 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.\n\
1555 If PROP is already a property on the list, its value is set to VAL,\n\
1556 otherwise the new PROP VAL pair is added. The new plist is returned;\n\
1557 use `(setq x (plist-put x prop val))' to be sure to use the new value.\n\
1558 The PLIST is modified by side effects.")
1561 register Lisp_Object prop
;
1564 register Lisp_Object tail
, prev
;
1565 Lisp_Object newcell
;
1567 for (tail
= plist
; CONSP (tail
) && CONSP (XCONS (tail
)->cdr
);
1568 tail
= XCONS (XCONS (tail
)->cdr
)->cdr
)
1570 if (EQ (prop
, XCONS (tail
)->car
))
1572 Fsetcar (XCONS (tail
)->cdr
, val
);
1577 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
1581 Fsetcdr (XCONS (prev
)->cdr
, newcell
);
1585 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
1586 "Store SYMBOL's PROPNAME property with value VALUE.\n\
1587 It can be retrieved with `(get SYMBOL PROPNAME)'.")
1588 (symbol
, propname
, value
)
1589 Lisp_Object symbol
, propname
, value
;
1591 CHECK_SYMBOL (symbol
, 0);
1592 XSYMBOL (symbol
)->plist
1593 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
1597 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
1598 "Return t if two Lisp objects have similar structure and contents.\n\
1599 They must have the same data type.\n\
1600 Conses are compared by comparing the cars and the cdrs.\n\
1601 Vectors and strings are compared element by element.\n\
1602 Numbers are compared by value, but integers cannot equal floats.\n\
1603 (Use `=' if you want integers and floats to be able to be equal.)\n\
1604 Symbols must match exactly.")
1606 register Lisp_Object o1
, o2
;
1608 return internal_equal (o1
, o2
, 0) ? Qt
: Qnil
;
1612 internal_equal (o1
, o2
, depth
)
1613 register Lisp_Object o1
, o2
;
1617 error ("Stack overflow in equal");
1623 if (XTYPE (o1
) != XTYPE (o2
))
1628 #ifdef LISP_FLOAT_TYPE
1630 return (extract_float (o1
) == extract_float (o2
));
1634 if (!internal_equal (XCONS (o1
)->car
, XCONS (o2
)->car
, depth
+ 1))
1636 o1
= XCONS (o1
)->cdr
;
1637 o2
= XCONS (o2
)->cdr
;
1641 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
1645 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o1
),
1647 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o1
),
1650 o1
= XOVERLAY (o1
)->plist
;
1651 o2
= XOVERLAY (o2
)->plist
;
1656 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
1657 && (XMARKER (o1
)->buffer
== 0
1658 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
1662 case Lisp_Vectorlike
:
1664 register int i
, size
;
1665 size
= XVECTOR (o1
)->size
;
1666 /* Pseudovectors have the type encoded in the size field, so this test
1667 actually checks that the objects have the same type as well as the
1669 if (XVECTOR (o2
)->size
!= size
)
1671 /* Boolvectors are compared much like strings. */
1672 if (BOOL_VECTOR_P (o1
))
1675 = (XBOOL_VECTOR (o1
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
1677 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
1679 if (bcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
1684 if (WINDOW_CONFIGURATIONP (o1
))
1685 return compare_window_configurations (o1
, o2
, 0);
1687 /* Aside from them, only true vectors, char-tables, and compiled
1688 functions are sensible to compare, so eliminate the others now. */
1689 if (size
& PSEUDOVECTOR_FLAG
)
1691 if (!(size
& (PVEC_COMPILED
| PVEC_CHAR_TABLE
)))
1693 size
&= PSEUDOVECTOR_SIZE_MASK
;
1695 for (i
= 0; i
< size
; i
++)
1698 v1
= XVECTOR (o1
)->contents
[i
];
1699 v2
= XVECTOR (o2
)->contents
[i
];
1700 if (!internal_equal (v1
, v2
, depth
+ 1))
1708 if (XSTRING (o1
)->size
!= XSTRING (o2
)->size
)
1710 if (STRING_BYTES (XSTRING (o1
)) != STRING_BYTES (XSTRING (o2
)))
1712 if (bcmp (XSTRING (o1
)->data
, XSTRING (o2
)->data
,
1713 STRING_BYTES (XSTRING (o1
))))
1720 extern Lisp_Object
Fmake_char_internal ();
1722 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
1723 "Store each element of ARRAY with ITEM.\n\
1724 ARRAY is a vector, string, char-table, or bool-vector.")
1726 Lisp_Object array
, item
;
1728 register int size
, index
, charval
;
1730 if (VECTORP (array
))
1732 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
1733 size
= XVECTOR (array
)->size
;
1734 for (index
= 0; index
< size
; index
++)
1737 else if (CHAR_TABLE_P (array
))
1739 register Lisp_Object
*p
= XCHAR_TABLE (array
)->contents
;
1740 size
= CHAR_TABLE_ORDINARY_SLOTS
;
1741 for (index
= 0; index
< size
; index
++)
1743 XCHAR_TABLE (array
)->defalt
= Qnil
;
1745 else if (STRINGP (array
))
1747 register unsigned char *p
= XSTRING (array
)->data
;
1748 CHECK_NUMBER (item
, 1);
1749 charval
= XINT (item
);
1750 size
= XSTRING (array
)->size
;
1751 for (index
= 0; index
< size
; index
++)
1754 else if (BOOL_VECTOR_P (array
))
1756 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
1758 = (XBOOL_VECTOR (array
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
1760 charval
= (! NILP (item
) ? -1 : 0);
1761 for (index
= 0; index
< size_in_chars
; index
++)
1766 array
= wrong_type_argument (Qarrayp
, array
);
1772 DEFUN ("char-table-subtype", Fchar_table_subtype
, Schar_table_subtype
,
1774 "Return the subtype of char-table CHAR-TABLE. The value is a symbol.")
1776 Lisp_Object char_table
;
1778 CHECK_CHAR_TABLE (char_table
, 0);
1780 return XCHAR_TABLE (char_table
)->purpose
;
1783 DEFUN ("char-table-parent", Fchar_table_parent
, Schar_table_parent
,
1785 "Return the parent char-table of CHAR-TABLE.\n\
1786 The value is either nil or another char-table.\n\
1787 If CHAR-TABLE holds nil for a given character,\n\
1788 then the actual applicable value is inherited from the parent char-table\n\
1789 \(or from its parents, if necessary).")
1791 Lisp_Object char_table
;
1793 CHECK_CHAR_TABLE (char_table
, 0);
1795 return XCHAR_TABLE (char_table
)->parent
;
1798 DEFUN ("set-char-table-parent", Fset_char_table_parent
, Sset_char_table_parent
,
1800 "Set the parent char-table of CHAR-TABLE to PARENT.\n\
1801 PARENT must be either nil or another char-table.")
1802 (char_table
, parent
)
1803 Lisp_Object char_table
, parent
;
1807 CHECK_CHAR_TABLE (char_table
, 0);
1811 CHECK_CHAR_TABLE (parent
, 0);
1813 for (temp
= parent
; !NILP (temp
); temp
= XCHAR_TABLE (temp
)->parent
)
1814 if (EQ (temp
, char_table
))
1815 error ("Attempt to make a chartable be its own parent");
1818 XCHAR_TABLE (char_table
)->parent
= parent
;
1823 DEFUN ("char-table-extra-slot", Fchar_table_extra_slot
, Schar_table_extra_slot
,
1825 "Return the value of CHAR-TABLE's extra-slot number N.")
1827 Lisp_Object char_table
, n
;
1829 CHECK_CHAR_TABLE (char_table
, 1);
1830 CHECK_NUMBER (n
, 2);
1832 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
1833 args_out_of_range (char_table
, n
);
1835 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)];
1838 DEFUN ("set-char-table-extra-slot", Fset_char_table_extra_slot
,
1839 Sset_char_table_extra_slot
,
1841 "Set CHAR-TABLE's extra-slot number N to VALUE.")
1842 (char_table
, n
, value
)
1843 Lisp_Object char_table
, n
, value
;
1845 CHECK_CHAR_TABLE (char_table
, 1);
1846 CHECK_NUMBER (n
, 2);
1848 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
1849 args_out_of_range (char_table
, n
);
1851 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)] = value
;
1854 DEFUN ("char-table-range", Fchar_table_range
, Schar_table_range
,
1856 "Return the value in CHAR-TABLE for a range of characters RANGE.\n\
1857 RANGE should be nil (for the default value)\n\
1858 a vector which identifies a character set or a row of a character set,\n\
1859 a character set name, or a character code.")
1861 Lisp_Object char_table
, range
;
1865 CHECK_CHAR_TABLE (char_table
, 0);
1867 if (EQ (range
, Qnil
))
1868 return XCHAR_TABLE (char_table
)->defalt
;
1869 else if (INTEGERP (range
))
1870 return Faref (char_table
, range
);
1871 else if (SYMBOLP (range
))
1873 Lisp_Object charset_info
;
1875 charset_info
= Fget (range
, Qcharset
);
1876 CHECK_VECTOR (charset_info
, 0);
1878 return Faref (char_table
,
1879 make_number (XINT (XVECTOR (charset_info
)->contents
[0])
1882 else if (VECTORP (range
))
1884 if (XVECTOR (range
)->size
== 1)
1885 return Faref (char_table
,
1886 make_number (XINT (XVECTOR (range
)->contents
[0]) + 128));
1889 int size
= XVECTOR (range
)->size
;
1890 Lisp_Object
*val
= XVECTOR (range
)->contents
;
1891 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
1892 size
<= 1 ? Qnil
: val
[1],
1893 size
<= 2 ? Qnil
: val
[2]);
1894 return Faref (char_table
, ch
);
1898 error ("Invalid RANGE argument to `char-table-range'");
1901 DEFUN ("set-char-table-range", Fset_char_table_range
, Sset_char_table_range
,
1903 "Set the value in CHAR-TABLE for a range of characters RANGE to VALUE.\n\
1904 RANGE should be t (for all characters), nil (for the default value)\n\
1905 a vector which identifies a character set or a row of a character set,\n\
1906 a coding system, or a character code.")
1907 (char_table
, range
, value
)
1908 Lisp_Object char_table
, range
, value
;
1912 CHECK_CHAR_TABLE (char_table
, 0);
1915 for (i
= 0; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
1916 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
1917 else if (EQ (range
, Qnil
))
1918 XCHAR_TABLE (char_table
)->defalt
= value
;
1919 else if (SYMBOLP (range
))
1921 Lisp_Object charset_info
;
1923 charset_info
= Fget (range
, Qcharset
);
1924 CHECK_VECTOR (charset_info
, 0);
1926 return Faset (char_table
,
1927 make_number (XINT (XVECTOR (charset_info
)->contents
[0])
1931 else if (INTEGERP (range
))
1932 Faset (char_table
, range
, value
);
1933 else if (VECTORP (range
))
1935 if (XVECTOR (range
)->size
== 1)
1936 return Faset (char_table
,
1937 make_number (XINT (XVECTOR (range
)->contents
[0]) + 128),
1941 int size
= XVECTOR (range
)->size
;
1942 Lisp_Object
*val
= XVECTOR (range
)->contents
;
1943 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
1944 size
<= 1 ? Qnil
: val
[1],
1945 size
<= 2 ? Qnil
: val
[2]);
1946 return Faset (char_table
, ch
, value
);
1950 error ("Invalid RANGE argument to `set-char-table-range'");
1955 DEFUN ("set-char-table-default", Fset_char_table_default
,
1956 Sset_char_table_default
, 3, 3, 0,
1957 "Set the default value in CHAR-TABLE for a generic character CHAR to VALUE.\n\
1958 The generic character specifies the group of characters.\n\
1959 See also the documentation of make-char.")
1960 (char_table
, ch
, value
)
1961 Lisp_Object char_table
, ch
, value
;
1963 int c
, i
, charset
, code1
, code2
;
1966 CHECK_CHAR_TABLE (char_table
, 0);
1967 CHECK_NUMBER (ch
, 1);
1970 SPLIT_NON_ASCII_CHAR (c
, charset
, code1
, code2
);
1971 if (! CHARSET_DEFINED_P (charset
))
1972 invalid_character (c
);
1974 if (charset
== CHARSET_ASCII
)
1975 return (XCHAR_TABLE (char_table
)->defalt
= value
);
1977 /* Even if C is not a generic char, we had better behave as if a
1978 generic char is specified. */
1979 if (CHARSET_DIMENSION (charset
) == 1)
1981 temp
= XCHAR_TABLE (char_table
)->contents
[charset
+ 128];
1984 if (SUB_CHAR_TABLE_P (temp
))
1985 XCHAR_TABLE (temp
)->defalt
= value
;
1987 XCHAR_TABLE (char_table
)->contents
[charset
+ 128] = value
;
1991 if (! SUB_CHAR_TABLE_P (char_table
))
1992 char_table
= (XCHAR_TABLE (char_table
)->contents
[charset
+ 128]
1993 = make_sub_char_table (temp
));
1994 temp
= XCHAR_TABLE (char_table
)->contents
[code1
];
1995 if (SUB_CHAR_TABLE_P (temp
))
1996 XCHAR_TABLE (temp
)->defalt
= value
;
1998 XCHAR_TABLE (char_table
)->contents
[code1
] = value
;
2002 /* Look up the element in TABLE at index CH,
2003 and return it as an integer.
2004 If the element is nil, return CH itself.
2005 (Actually we do that for any non-integer.) */
2008 char_table_translate (table
, ch
)
2013 value
= Faref (table
, make_number (ch
));
2014 if (! INTEGERP (value
))
2016 return XINT (value
);
2019 /* Map C_FUNCTION or FUNCTION over SUBTABLE, calling it for each
2020 character or group of characters that share a value.
2021 DEPTH is the current depth in the originally specified
2022 chartable, and INDICES contains the vector indices
2023 for the levels our callers have descended.
2025 ARG is passed to C_FUNCTION when that is called. */
2028 map_char_table (c_function
, function
, subtable
, arg
, depth
, indices
)
2029 void (*c_function
) P_ ((Lisp_Object
, Lisp_Object
, Lisp_Object
));
2030 Lisp_Object function
, subtable
, arg
, *indices
;
2037 /* At first, handle ASCII and 8-bit European characters. */
2038 for (i
= 0; i
< CHAR_TABLE_SINGLE_BYTE_SLOTS
; i
++)
2040 Lisp_Object elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2042 (*c_function
) (arg
, make_number (i
), elt
);
2044 call2 (function
, make_number (i
), elt
);
2046 #if 0 /* If the char table has entries for higher characters,
2047 we should report them. */
2048 if (NILP (current_buffer
->enable_multibyte_characters
))
2051 to
= CHAR_TABLE_ORDINARY_SLOTS
;
2056 to
= SUB_CHAR_TABLE_ORDINARY_SLOTS
;
2061 Lisp_Object elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2063 XSETFASTINT (indices
[depth
], i
);
2065 if (SUB_CHAR_TABLE_P (elt
))
2068 error ("Too deep char table");
2069 map_char_table (c_function
, function
, elt
, arg
, depth
+ 1, indices
);
2073 int charset
= XFASTINT (indices
[0]) - 128, c1
, c2
, c
;
2075 if (CHARSET_DEFINED_P (charset
))
2077 c1
= depth
>= 1 ? XFASTINT (indices
[1]) : 0;
2078 c2
= depth
>= 2 ? XFASTINT (indices
[2]) : 0;
2079 c
= MAKE_NON_ASCII_CHAR (charset
, c1
, c2
);
2081 (*c_function
) (arg
, make_number (c
), elt
);
2083 call2 (function
, make_number (c
), elt
);
2089 DEFUN ("map-char-table", Fmap_char_table
, Smap_char_table
,
2091 "Call FUNCTION for each (normal and generic) characters in CHAR-TABLE.\n\
2092 FUNCTION is called with two arguments--a key and a value.\n\
2093 The key is always a possible IDX argument to `aref'.")
2094 (function
, char_table
)
2095 Lisp_Object function
, char_table
;
2097 /* The depth of char table is at most 3. */
2098 Lisp_Object indices
[3];
2100 CHECK_CHAR_TABLE (char_table
, 1);
2102 map_char_table (NULL
, function
, char_table
, char_table
, 0, indices
);
2112 Lisp_Object args
[2];
2115 return Fnconc (2, args
);
2117 return Fnconc (2, &s1
);
2118 #endif /* NO_ARG_ARRAY */
2121 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2122 "Concatenate any number of lists by altering them.\n\
2123 Only the last argument is not altered, and need not be a list.")
2128 register int argnum
;
2129 register Lisp_Object tail
, tem
, val
;
2133 for (argnum
= 0; argnum
< nargs
; argnum
++)
2136 if (NILP (tem
)) continue;
2141 if (argnum
+ 1 == nargs
) break;
2144 tem
= wrong_type_argument (Qlistp
, tem
);
2153 tem
= args
[argnum
+ 1];
2154 Fsetcdr (tail
, tem
);
2156 args
[argnum
+ 1] = tail
;
2162 /* This is the guts of all mapping functions.
2163 Apply FN to each element of SEQ, one by one,
2164 storing the results into elements of VALS, a C vector of Lisp_Objects.
2165 LENI is the length of VALS, which should also be the length of SEQ. */
2168 mapcar1 (leni
, vals
, fn
, seq
)
2171 Lisp_Object fn
, seq
;
2173 register Lisp_Object tail
;
2176 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2178 /* Don't let vals contain any garbage when GC happens. */
2179 for (i
= 0; i
< leni
; i
++)
2182 GCPRO3 (dummy
, fn
, seq
);
2184 gcpro1
.nvars
= leni
;
2185 /* We need not explicitly protect `tail' because it is used only on lists, and
2186 1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
2190 for (i
= 0; i
< leni
; i
++)
2192 dummy
= XVECTOR (seq
)->contents
[i
];
2193 vals
[i
] = call1 (fn
, dummy
);
2196 else if (BOOL_VECTOR_P (seq
))
2198 for (i
= 0; i
< leni
; i
++)
2201 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BITS_PER_CHAR
];
2202 if (byte
& (1 << (i
% BITS_PER_CHAR
)))
2207 vals
[i
] = call1 (fn
, dummy
);
2210 else if (STRINGP (seq
) && ! STRING_MULTIBYTE (seq
))
2212 /* Single-byte string. */
2213 for (i
= 0; i
< leni
; i
++)
2215 XSETFASTINT (dummy
, XSTRING (seq
)->data
[i
]);
2216 vals
[i
] = call1 (fn
, dummy
);
2219 else if (STRINGP (seq
))
2221 /* Multi-byte string. */
2222 int len_byte
= STRING_BYTES (XSTRING (seq
));
2225 for (i
= 0, i_byte
= 0; i
< leni
;)
2230 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2231 XSETFASTINT (dummy
, c
);
2232 vals
[i_before
] = call1 (fn
, dummy
);
2235 else /* Must be a list, since Flength did not get an error */
2238 for (i
= 0; i
< leni
; i
++)
2240 vals
[i
] = call1 (fn
, Fcar (tail
));
2241 tail
= XCONS (tail
)->cdr
;
2248 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2249 "Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.\n\
2250 In between each pair of results, stick in SEPARATOR. Thus, \" \" as\n\
2251 SEPARATOR results in spaces between the values returned by FUNCTION.\n\
2252 SEQUENCE may be a list, a vector, a bool-vector, or a string.")
2253 (function
, sequence
, separator
)
2254 Lisp_Object function
, sequence
, separator
;
2259 register Lisp_Object
*args
;
2261 struct gcpro gcpro1
;
2263 len
= Flength (sequence
);
2265 nargs
= leni
+ leni
- 1;
2266 if (nargs
< 0) return build_string ("");
2268 args
= (Lisp_Object
*) alloca (nargs
* sizeof (Lisp_Object
));
2271 mapcar1 (leni
, args
, function
, sequence
);
2274 for (i
= leni
- 1; i
>= 0; i
--)
2275 args
[i
+ i
] = args
[i
];
2277 for (i
= 1; i
< nargs
; i
+= 2)
2278 args
[i
] = separator
;
2280 return Fconcat (nargs
, args
);
2283 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2284 "Apply FUNCTION to each element of SEQUENCE, and make a list of the results.\n\
2285 The result is a list just as long as SEQUENCE.\n\
2286 SEQUENCE may be a list, a vector, a bool-vector, or a string.")
2287 (function
, sequence
)
2288 Lisp_Object function
, sequence
;
2290 register Lisp_Object len
;
2292 register Lisp_Object
*args
;
2294 len
= Flength (sequence
);
2295 leni
= XFASTINT (len
);
2296 args
= (Lisp_Object
*) alloca (leni
* sizeof (Lisp_Object
));
2298 mapcar1 (leni
, args
, function
, sequence
);
2300 return Flist (leni
, args
);
2303 /* Anything that calls this function must protect from GC! */
2305 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
2306 "Ask user a \"y or n\" question. Return t if answer is \"y\".\n\
2307 Takes one argument, which is the string to display to ask the question.\n\
2308 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.\n\
2309 No confirmation of the answer is requested; a single character is enough.\n\
2310 Also accepts Space to mean yes, or Delete to mean no.")
2314 register Lisp_Object obj
, key
, def
, answer_string
, map
;
2315 register int answer
;
2316 Lisp_Object xprompt
;
2317 Lisp_Object args
[2];
2318 struct gcpro gcpro1
, gcpro2
;
2319 int count
= specpdl_ptr
- specpdl
;
2321 specbind (Qcursor_in_echo_area
, Qt
);
2323 map
= Fsymbol_value (intern ("query-replace-map"));
2325 CHECK_STRING (prompt
, 0);
2327 GCPRO2 (prompt
, xprompt
);
2333 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2337 Lisp_Object pane
, menu
;
2338 redisplay_preserve_echo_area ();
2339 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2340 Fcons (Fcons (build_string ("No"), Qnil
),
2342 menu
= Fcons (prompt
, pane
);
2343 obj
= Fx_popup_dialog (Qt
, menu
);
2344 answer
= !NILP (obj
);
2347 #endif /* HAVE_MENUS */
2348 cursor_in_echo_area
= 1;
2349 choose_minibuf_frame ();
2350 message_with_string ("%s(y or n) ", xprompt
, 0);
2352 if (minibuffer_auto_raise
)
2354 Lisp_Object mini_frame
;
2356 mini_frame
= WINDOW_FRAME (XWINDOW (minibuf_window
));
2358 Fraise_frame (mini_frame
);
2361 obj
= read_filtered_event (1, 0, 0);
2362 cursor_in_echo_area
= 0;
2363 /* If we need to quit, quit with cursor_in_echo_area = 0. */
2366 key
= Fmake_vector (make_number (1), obj
);
2367 def
= Flookup_key (map
, key
, Qt
);
2368 answer_string
= Fsingle_key_description (obj
);
2370 if (EQ (def
, intern ("skip")))
2375 else if (EQ (def
, intern ("act")))
2380 else if (EQ (def
, intern ("recenter")))
2386 else if (EQ (def
, intern ("quit")))
2388 /* We want to exit this command for exit-prefix,
2389 and this is the only way to do it. */
2390 else if (EQ (def
, intern ("exit-prefix")))
2395 /* If we don't clear this, then the next call to read_char will
2396 return quit_char again, and we'll enter an infinite loop. */
2401 if (EQ (xprompt
, prompt
))
2403 args
[0] = build_string ("Please answer y or n. ");
2405 xprompt
= Fconcat (2, args
);
2410 if (! noninteractive
)
2412 cursor_in_echo_area
= -1;
2413 message_with_string (answer
? "%s(y or n) y" : "%s(y or n) n",
2417 unbind_to (count
, Qnil
);
2418 return answer
? Qt
: Qnil
;
2421 /* This is how C code calls `yes-or-no-p' and allows the user
2424 Anything that calls this function must protect from GC! */
2427 do_yes_or_no_p (prompt
)
2430 return call1 (intern ("yes-or-no-p"), prompt
);
2433 /* Anything that calls this function must protect from GC! */
2435 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2436 "Ask user a yes-or-no question. Return t if answer is yes.\n\
2437 Takes one argument, which is the string to display to ask the question.\n\
2438 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.\n\
2439 The user must confirm the answer with RET,\n\
2440 and can edit it until it has been confirmed.")
2444 register Lisp_Object ans
;
2445 Lisp_Object args
[2];
2446 struct gcpro gcpro1
;
2449 CHECK_STRING (prompt
, 0);
2452 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2456 Lisp_Object pane
, menu
, obj
;
2457 redisplay_preserve_echo_area ();
2458 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2459 Fcons (Fcons (build_string ("No"), Qnil
),
2462 menu
= Fcons (prompt
, pane
);
2463 obj
= Fx_popup_dialog (Qt
, menu
);
2467 #endif /* HAVE_MENUS */
2470 args
[1] = build_string ("(yes or no) ");
2471 prompt
= Fconcat (2, args
);
2477 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2478 Qyes_or_no_p_history
, Qnil
,
2480 if (XSTRING (ans
)->size
== 3 && !strcmp (XSTRING (ans
)->data
, "yes"))
2485 if (XSTRING (ans
)->size
== 2 && !strcmp (XSTRING (ans
)->data
, "no"))
2493 message ("Please answer yes or no.");
2494 Fsleep_for (make_number (2), Qnil
);
2498 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2499 "Return list of 1 minute, 5 minute and 15 minute load averages.\n\
2500 Each of the three load averages is multiplied by 100,\n\
2501 then converted to integer.\n\
2502 When USE-FLOATS is non-nil, floats will be used instead of integers.\n\
2503 These floats are not multiplied by 100.\n\n\
2504 If the 5-minute or 15-minute load averages are not available, return a\n\
2505 shortened list, containing only those averages which are available.")
2507 Lisp_Object use_floats
;
2510 int loads
= getloadavg (load_ave
, 3);
2511 Lisp_Object ret
= Qnil
;
2514 error ("load-average not implemented for this operating system");
2518 Lisp_Object load
= (NILP (use_floats
) ?
2519 make_number ((int) (100.0 * load_ave
[loads
]))
2520 : make_float (load_ave
[loads
]));
2521 ret
= Fcons (load
, ret
);
2527 Lisp_Object Vfeatures
;
2529 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 1, 0,
2530 "Returns t if FEATURE is present in this Emacs.\n\
2531 Use this to conditionalize execution of lisp code based on the presence or\n\
2532 absence of emacs or environment extensions.\n\
2533 Use `provide' to declare that a feature is available.\n\
2534 This function looks at the value of the variable `features'.")
2536 Lisp_Object feature
;
2538 register Lisp_Object tem
;
2539 CHECK_SYMBOL (feature
, 0);
2540 tem
= Fmemq (feature
, Vfeatures
);
2541 return (NILP (tem
)) ? Qnil
: Qt
;
2544 DEFUN ("provide", Fprovide
, Sprovide
, 1, 1, 0,
2545 "Announce that FEATURE is a feature of the current Emacs.")
2547 Lisp_Object feature
;
2549 register Lisp_Object tem
;
2550 CHECK_SYMBOL (feature
, 0);
2551 if (!NILP (Vautoload_queue
))
2552 Vautoload_queue
= Fcons (Fcons (Vfeatures
, Qnil
), Vautoload_queue
);
2553 tem
= Fmemq (feature
, Vfeatures
);
2555 Vfeatures
= Fcons (feature
, Vfeatures
);
2556 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2560 DEFUN ("require", Frequire
, Srequire
, 1, 2, 0,
2561 "If feature FEATURE is not loaded, load it from FILENAME.\n\
2562 If FEATURE is not a member of the list `features', then the feature\n\
2563 is not loaded; so load the file FILENAME.\n\
2564 If FILENAME is omitted, the printname of FEATURE is used as the file name,\n\
2565 but in this case `load' insists on adding the suffix `.el' or `.elc'.")
2566 (feature
, file_name
)
2567 Lisp_Object feature
, file_name
;
2569 register Lisp_Object tem
;
2570 CHECK_SYMBOL (feature
, 0);
2571 tem
= Fmemq (feature
, Vfeatures
);
2572 LOADHIST_ATTACH (Fcons (Qrequire
, feature
));
2575 int count
= specpdl_ptr
- specpdl
;
2577 /* Value saved here is to be restored into Vautoload_queue */
2578 record_unwind_protect (un_autoload
, Vautoload_queue
);
2579 Vautoload_queue
= Qt
;
2581 Fload (NILP (file_name
) ? Fsymbol_name (feature
) : file_name
,
2582 Qnil
, Qt
, Qnil
, (NILP (file_name
) ? Qt
: Qnil
));
2584 tem
= Fmemq (feature
, Vfeatures
);
2586 error ("Required feature %s was not provided",
2587 XSYMBOL (feature
)->name
->data
);
2589 /* Once loading finishes, don't undo it. */
2590 Vautoload_queue
= Qt
;
2591 feature
= unbind_to (count
, feature
);
2596 /* Primitives for work of the "widget" library.
2597 In an ideal world, this section would not have been necessary.
2598 However, lisp function calls being as slow as they are, it turns
2599 out that some functions in the widget library (wid-edit.el) are the
2600 bottleneck of Widget operation. Here is their translation to C,
2601 for the sole reason of efficiency. */
2603 DEFUN ("widget-plist-member", Fwidget_plist_member
, Swidget_plist_member
, 2, 2, 0,
2604 "Return non-nil if PLIST has the property PROP.\n\
2605 PLIST is a property list, which is a list of the form\n\
2606 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.\n\
2607 Unlike `plist-get', this allows you to distinguish between a missing\n\
2608 property and a property with the value nil.\n\
2609 The value is actually the tail of PLIST whose car is PROP.")
2611 Lisp_Object plist
, prop
;
2613 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
2616 plist
= XCDR (plist
);
2617 plist
= CDR (plist
);
2622 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
2623 "In WIDGET, set PROPERTY to VALUE.\n\
2624 The value can later be retrieved with `widget-get'.")
2625 (widget
, property
, value
)
2626 Lisp_Object widget
, property
, value
;
2628 CHECK_CONS (widget
, 1);
2629 XCDR (widget
) = Fplist_put (XCDR (widget
), property
, value
);
2632 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
2633 "In WIDGET, get the value of PROPERTY.\n\
2634 The value could either be specified when the widget was created, or\n\
2635 later with `widget-put'.")
2637 Lisp_Object widget
, property
;
2645 CHECK_CONS (widget
, 1);
2646 tmp
= Fwidget_plist_member (XCDR (widget
), property
);
2652 tmp
= XCAR (widget
);
2655 widget
= Fget (tmp
, Qwidget_type
);
2659 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
2660 "Apply the value of WIDGET's PROPERTY to the widget itself.\n\
2661 ARGS are passed as extra arguments to the function.")
2666 /* This function can GC. */
2667 Lisp_Object newargs
[3];
2668 struct gcpro gcpro1
, gcpro2
;
2671 newargs
[0] = Fwidget_get (args
[0], args
[1]);
2672 newargs
[1] = args
[0];
2673 newargs
[2] = Flist (nargs
- 2, args
+ 2);
2674 GCPRO2 (newargs
[0], newargs
[2]);
2675 result
= Fapply (3, newargs
);
2683 Qstring_lessp
= intern ("string-lessp");
2684 staticpro (&Qstring_lessp
);
2685 Qprovide
= intern ("provide");
2686 staticpro (&Qprovide
);
2687 Qrequire
= intern ("require");
2688 staticpro (&Qrequire
);
2689 Qyes_or_no_p_history
= intern ("yes-or-no-p-history");
2690 staticpro (&Qyes_or_no_p_history
);
2691 Qcursor_in_echo_area
= intern ("cursor-in-echo-area");
2692 staticpro (&Qcursor_in_echo_area
);
2693 Qwidget_type
= intern ("widget-type");
2694 staticpro (&Qwidget_type
);
2696 staticpro (&string_char_byte_cache_string
);
2697 string_char_byte_cache_string
= Qnil
;
2699 Fset (Qyes_or_no_p_history
, Qnil
);
2701 DEFVAR_LISP ("features", &Vfeatures
,
2702 "A list of symbols which are the features of the executing emacs.\n\
2703 Used by `featurep' and `require', and altered by `provide'.");
2706 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box
,
2707 "*Non-nil means mouse commands use dialog boxes to ask questions.\n\
2708 This applies to y-or-n and yes-or-no questions asked by commands\n\
2709 invoked by mouse clicks and mouse menu items.");
2712 defsubr (&Sidentity
);
2715 defsubr (&Ssafe_length
);
2716 defsubr (&Sstring_bytes
);
2717 defsubr (&Sstring_equal
);
2718 defsubr (&Scompare_strings
);
2719 defsubr (&Sstring_lessp
);
2722 defsubr (&Svconcat
);
2723 defsubr (&Scopy_sequence
);
2724 defsubr (&Sstring_make_multibyte
);
2725 defsubr (&Sstring_make_unibyte
);
2726 defsubr (&Sstring_as_multibyte
);
2727 defsubr (&Sstring_as_unibyte
);
2728 defsubr (&Scopy_alist
);
2729 defsubr (&Ssubstring
);
2741 defsubr (&Snreverse
);
2742 defsubr (&Sreverse
);
2744 defsubr (&Splist_get
);
2746 defsubr (&Splist_put
);
2749 defsubr (&Sfillarray
);
2750 defsubr (&Schar_table_subtype
);
2751 defsubr (&Schar_table_parent
);
2752 defsubr (&Sset_char_table_parent
);
2753 defsubr (&Schar_table_extra_slot
);
2754 defsubr (&Sset_char_table_extra_slot
);
2755 defsubr (&Schar_table_range
);
2756 defsubr (&Sset_char_table_range
);
2757 defsubr (&Sset_char_table_default
);
2758 defsubr (&Smap_char_table
);
2761 defsubr (&Smapconcat
);
2762 defsubr (&Sy_or_n_p
);
2763 defsubr (&Syes_or_no_p
);
2764 defsubr (&Sload_average
);
2765 defsubr (&Sfeaturep
);
2766 defsubr (&Srequire
);
2767 defsubr (&Sprovide
);
2768 defsubr (&Swidget_plist_member
);
2769 defsubr (&Swidget_put
);
2770 defsubr (&Swidget_get
);
2771 defsubr (&Swidget_apply
);