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_byte
++] = 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 CHECK_STRING (string
, 0);
954 return string_make_multibyte (string
);
957 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
959 "Return the unibyte equivalent of STRING.\n\
960 Multibyte character codes are converted to unibyte\n\
961 by using just the low 8 bits.")
965 CHECK_STRING (string
, 0);
967 return string_make_unibyte (string
);
970 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
972 "Return a unibyte string with the same individual bytes as STRING.\n\
973 If STRING is unibyte, the result is STRING itself.")
977 CHECK_STRING (string
, 0);
979 if (STRING_MULTIBYTE (string
))
981 string
= Fcopy_sequence (string
);
982 XSTRING (string
)->size
= STRING_BYTES (XSTRING (string
));
983 SET_STRING_BYTES (XSTRING (string
), -1);
988 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
990 "Return a multibyte string with the same individual bytes as STRING.\n\
991 If STRING is multibyte, the result is STRING itself.")
995 CHECK_STRING (string
, 0);
997 if (! STRING_MULTIBYTE (string
))
999 int nbytes
= STRING_BYTES (XSTRING (string
));
1000 int newlen
= multibyte_chars_in_text (XSTRING (string
)->data
, nbytes
);
1002 string
= Fcopy_sequence (string
);
1003 XSTRING (string
)->size
= newlen
;
1004 XSTRING (string
)->size_byte
= nbytes
;
1009 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1010 "Return a copy of ALIST.\n\
1011 This is an alist which represents the same mapping from objects to objects,\n\
1012 but does not share the alist structure with ALIST.\n\
1013 The objects mapped (cars and cdrs of elements of the alist)\n\
1014 are shared, however.\n\
1015 Elements of ALIST that are not conses are also shared.")
1019 register Lisp_Object tem
;
1021 CHECK_LIST (alist
, 0);
1024 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1025 for (tem
= alist
; CONSP (tem
); tem
= XCONS (tem
)->cdr
)
1027 register Lisp_Object car
;
1028 car
= XCONS (tem
)->car
;
1031 XCONS (tem
)->car
= Fcons (XCONS (car
)->car
, XCONS (car
)->cdr
);
1036 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
1037 "Return a substring of STRING, starting at index FROM and ending before TO.\n\
1038 TO may be nil or omitted; then the substring runs to the end of STRING.\n\
1039 If FROM or TO is negative, it counts from the end.\n\
1041 This function allows vectors as well as strings.")
1044 register Lisp_Object from
, to
;
1049 int from_char
, to_char
;
1050 int from_byte
, to_byte
;
1052 if (! (STRINGP (string
) || VECTORP (string
)))
1053 wrong_type_argument (Qarrayp
, string
);
1055 CHECK_NUMBER (from
, 1);
1057 if (STRINGP (string
))
1059 size
= XSTRING (string
)->size
;
1060 size_byte
= STRING_BYTES (XSTRING (string
));
1063 size
= XVECTOR (string
)->size
;
1068 to_byte
= size_byte
;
1072 CHECK_NUMBER (to
, 2);
1074 to_char
= XINT (to
);
1078 if (STRINGP (string
))
1079 to_byte
= string_char_to_byte (string
, to_char
);
1082 from_char
= XINT (from
);
1085 if (STRINGP (string
))
1086 from_byte
= string_char_to_byte (string
, from_char
);
1088 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1089 args_out_of_range_3 (string
, make_number (from_char
),
1090 make_number (to_char
));
1092 if (STRINGP (string
))
1094 res
= make_specified_string (XSTRING (string
)->data
+ from_byte
,
1095 to_char
- from_char
, to_byte
- from_byte
,
1096 STRING_MULTIBYTE (string
));
1097 copy_text_properties (make_number (from_char
), make_number (to_char
),
1098 string
, make_number (0), res
, Qnil
);
1101 res
= Fvector (to_char
- from_char
,
1102 XVECTOR (string
)->contents
+ from_char
);
1107 /* Extract a substring of STRING, giving start and end positions
1108 both in characters and in bytes. */
1111 substring_both (string
, from
, from_byte
, to
, to_byte
)
1113 int from
, from_byte
, to
, to_byte
;
1119 if (! (STRINGP (string
) || VECTORP (string
)))
1120 wrong_type_argument (Qarrayp
, string
);
1122 if (STRINGP (string
))
1124 size
= XSTRING (string
)->size
;
1125 size_byte
= STRING_BYTES (XSTRING (string
));
1128 size
= XVECTOR (string
)->size
;
1130 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1131 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1133 if (STRINGP (string
))
1135 res
= make_specified_string (XSTRING (string
)->data
+ from_byte
,
1136 to
- from
, to_byte
- from_byte
,
1137 STRING_MULTIBYTE (string
));
1138 copy_text_properties (make_number (from
), make_number (to
),
1139 string
, make_number (0), res
, Qnil
);
1142 res
= Fvector (to
- from
,
1143 XVECTOR (string
)->contents
+ from
);
1148 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1149 "Take cdr N times on LIST, returns the result.")
1152 register Lisp_Object list
;
1154 register int i
, num
;
1155 CHECK_NUMBER (n
, 0);
1157 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1165 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1166 "Return the Nth element of LIST.\n\
1167 N counts from zero. If LIST is not that long, nil is returned.")
1169 Lisp_Object n
, list
;
1171 return Fcar (Fnthcdr (n
, list
));
1174 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1175 "Return element of SEQUENCE at index N.")
1177 register Lisp_Object sequence
, n
;
1179 CHECK_NUMBER (n
, 0);
1182 if (CONSP (sequence
) || NILP (sequence
))
1183 return Fcar (Fnthcdr (n
, sequence
));
1184 else if (STRINGP (sequence
) || VECTORP (sequence
)
1185 || BOOL_VECTOR_P (sequence
) || CHAR_TABLE_P (sequence
))
1186 return Faref (sequence
, n
);
1188 sequence
= wrong_type_argument (Qsequencep
, sequence
);
1192 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1193 "Return non-nil if ELT is an element of LIST. Comparison done with `equal'.\n\
1194 The value is actually the tail of LIST whose car is ELT.")
1196 register Lisp_Object elt
;
1199 register Lisp_Object tail
;
1200 for (tail
= list
; !NILP (tail
); tail
= XCONS (tail
)->cdr
)
1202 register Lisp_Object tem
;
1204 if (! NILP (Fequal (elt
, tem
)))
1211 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1212 "Return non-nil if ELT is an element of LIST. Comparison done with EQ.\n\
1213 The value is actually the tail of LIST whose car is ELT.")
1215 register Lisp_Object elt
;
1218 register Lisp_Object tail
;
1219 for (tail
= list
; !NILP (tail
); tail
= XCONS (tail
)->cdr
)
1221 register Lisp_Object tem
;
1223 if (EQ (elt
, tem
)) return tail
;
1229 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1230 "Return non-nil if KEY is `eq' to the car of an element of LIST.\n\
1231 The value is actually the element of LIST whose car is KEY.\n\
1232 Elements of LIST that are not conses are ignored.")
1234 register Lisp_Object key
;
1237 register Lisp_Object tail
;
1238 for (tail
= list
; !NILP (tail
); tail
= XCONS (tail
)->cdr
)
1240 register Lisp_Object elt
, tem
;
1242 if (!CONSP (elt
)) continue;
1243 tem
= XCONS (elt
)->car
;
1244 if (EQ (key
, tem
)) return elt
;
1250 /* Like Fassq but never report an error and do not allow quits.
1251 Use only on lists known never to be circular. */
1254 assq_no_quit (key
, list
)
1255 register Lisp_Object key
;
1258 register Lisp_Object tail
;
1259 for (tail
= list
; CONSP (tail
); tail
= XCONS (tail
)->cdr
)
1261 register Lisp_Object elt
, tem
;
1263 if (!CONSP (elt
)) continue;
1264 tem
= XCONS (elt
)->car
;
1265 if (EQ (key
, tem
)) return elt
;
1270 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1271 "Return non-nil if KEY is `equal' to the car of an element of LIST.\n\
1272 The value is actually the element of LIST whose car equals KEY.")
1274 register Lisp_Object key
;
1277 register Lisp_Object tail
;
1278 for (tail
= list
; !NILP (tail
); tail
= XCONS (tail
)->cdr
)
1280 register Lisp_Object elt
, tem
;
1282 if (!CONSP (elt
)) continue;
1283 tem
= Fequal (XCONS (elt
)->car
, key
);
1284 if (!NILP (tem
)) return elt
;
1290 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1291 "Return non-nil if ELT is `eq' to the cdr of an element of LIST.\n\
1292 The value is actually the element of LIST whose cdr is ELT.")
1294 register Lisp_Object key
;
1297 register Lisp_Object tail
;
1298 for (tail
= list
; !NILP (tail
); tail
= XCONS (tail
)->cdr
)
1300 register Lisp_Object elt
, tem
;
1302 if (!CONSP (elt
)) continue;
1303 tem
= XCONS (elt
)->cdr
;
1304 if (EQ (key
, tem
)) return elt
;
1310 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1311 "Return non-nil if KEY is `equal' to the cdr of an element of LIST.\n\
1312 The value is actually the element of LIST whose cdr equals KEY.")
1314 register Lisp_Object key
;
1317 register Lisp_Object tail
;
1318 for (tail
= list
; !NILP (tail
); tail
= XCONS (tail
)->cdr
)
1320 register Lisp_Object elt
, tem
;
1322 if (!CONSP (elt
)) continue;
1323 tem
= Fequal (XCONS (elt
)->cdr
, key
);
1324 if (!NILP (tem
)) return elt
;
1330 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1331 "Delete by side effect any occurrences of ELT as a member of LIST.\n\
1332 The modified LIST is returned. Comparison is done with `eq'.\n\
1333 If the first member of LIST is ELT, there is no way to remove it by side effect;\n\
1334 therefore, write `(setq foo (delq element foo))'\n\
1335 to be sure of changing the value of `foo'.")
1337 register Lisp_Object elt
;
1340 register Lisp_Object tail
, prev
;
1341 register Lisp_Object tem
;
1345 while (!NILP (tail
))
1351 list
= XCONS (tail
)->cdr
;
1353 Fsetcdr (prev
, XCONS (tail
)->cdr
);
1357 tail
= XCONS (tail
)->cdr
;
1363 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1364 "Delete by side effect any occurrences of ELT as a member of LIST.\n\
1365 The modified LIST is returned. Comparison is done with `equal'.\n\
1366 If the first member of LIST is ELT, deleting it is not a side effect;\n\
1367 it is simply using a different list.\n\
1368 Therefore, write `(setq foo (delete element foo))'\n\
1369 to be sure of changing the value of `foo'.")
1371 register Lisp_Object elt
;
1374 register Lisp_Object tail
, prev
;
1375 register Lisp_Object tem
;
1379 while (!NILP (tail
))
1382 if (! NILP (Fequal (elt
, tem
)))
1385 list
= XCONS (tail
)->cdr
;
1387 Fsetcdr (prev
, XCONS (tail
)->cdr
);
1391 tail
= XCONS (tail
)->cdr
;
1397 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1398 "Reverse LIST by modifying cdr pointers.\n\
1399 Returns the beginning of the reversed list.")
1403 register Lisp_Object prev
, tail
, next
;
1405 if (NILP (list
)) return list
;
1408 while (!NILP (tail
))
1412 Fsetcdr (tail
, prev
);
1419 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1420 "Reverse LIST, copying. Returns the beginning of the reversed list.\n\
1421 See also the function `nreverse', which is used more often.")
1427 for (new = Qnil
; CONSP (list
); list
= XCONS (list
)->cdr
)
1428 new = Fcons (XCONS (list
)->car
, new);
1430 wrong_type_argument (Qconsp
, list
);
1434 Lisp_Object
merge ();
1436 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1437 "Sort LIST, stably, comparing elements using PREDICATE.\n\
1438 Returns the sorted list. LIST is modified by side effects.\n\
1439 PREDICATE is called with two elements of LIST, and should return T\n\
1440 if the first element is \"less\" than the second.")
1442 Lisp_Object list
, predicate
;
1444 Lisp_Object front
, back
;
1445 register Lisp_Object len
, tem
;
1446 struct gcpro gcpro1
, gcpro2
;
1447 register int length
;
1450 len
= Flength (list
);
1451 length
= XINT (len
);
1455 XSETINT (len
, (length
/ 2) - 1);
1456 tem
= Fnthcdr (len
, list
);
1458 Fsetcdr (tem
, Qnil
);
1460 GCPRO2 (front
, back
);
1461 front
= Fsort (front
, predicate
);
1462 back
= Fsort (back
, predicate
);
1464 return merge (front
, back
, predicate
);
1468 merge (org_l1
, org_l2
, pred
)
1469 Lisp_Object org_l1
, org_l2
;
1473 register Lisp_Object tail
;
1475 register Lisp_Object l1
, l2
;
1476 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1483 /* It is sufficient to protect org_l1 and org_l2.
1484 When l1 and l2 are updated, we copy the new values
1485 back into the org_ vars. */
1486 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1506 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1522 Fsetcdr (tail
, tem
);
1528 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1529 "Extract a value from a property list.\n\
1530 PLIST is a property list, which is a list of the form\n\
1531 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value\n\
1532 corresponding to the given PROP, or nil if PROP is not\n\
1533 one of the properties on the list.")
1536 register Lisp_Object prop
;
1538 register Lisp_Object tail
;
1539 for (tail
= plist
; !NILP (tail
); tail
= Fcdr (XCONS (tail
)->cdr
))
1541 register Lisp_Object tem
;
1544 return Fcar (XCONS (tail
)->cdr
);
1549 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
1550 "Return the value of SYMBOL's PROPNAME property.\n\
1551 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'.")
1553 Lisp_Object symbol
, propname
;
1555 CHECK_SYMBOL (symbol
, 0);
1556 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
1559 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
1560 "Change value in PLIST of PROP to VAL.\n\
1561 PLIST is a property list, which is a list of the form\n\
1562 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.\n\
1563 If PROP is already a property on the list, its value is set to VAL,\n\
1564 otherwise the new PROP VAL pair is added. The new plist is returned;\n\
1565 use `(setq x (plist-put x prop val))' to be sure to use the new value.\n\
1566 The PLIST is modified by side effects.")
1569 register Lisp_Object prop
;
1572 register Lisp_Object tail
, prev
;
1573 Lisp_Object newcell
;
1575 for (tail
= plist
; CONSP (tail
) && CONSP (XCONS (tail
)->cdr
);
1576 tail
= XCONS (XCONS (tail
)->cdr
)->cdr
)
1578 if (EQ (prop
, XCONS (tail
)->car
))
1580 Fsetcar (XCONS (tail
)->cdr
, val
);
1585 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
1589 Fsetcdr (XCONS (prev
)->cdr
, newcell
);
1593 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
1594 "Store SYMBOL's PROPNAME property with value VALUE.\n\
1595 It can be retrieved with `(get SYMBOL PROPNAME)'.")
1596 (symbol
, propname
, value
)
1597 Lisp_Object symbol
, propname
, value
;
1599 CHECK_SYMBOL (symbol
, 0);
1600 XSYMBOL (symbol
)->plist
1601 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
1605 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
1606 "Return t if two Lisp objects have similar structure and contents.\n\
1607 They must have the same data type.\n\
1608 Conses are compared by comparing the cars and the cdrs.\n\
1609 Vectors and strings are compared element by element.\n\
1610 Numbers are compared by value, but integers cannot equal floats.\n\
1611 (Use `=' if you want integers and floats to be able to be equal.)\n\
1612 Symbols must match exactly.")
1614 register Lisp_Object o1
, o2
;
1616 return internal_equal (o1
, o2
, 0) ? Qt
: Qnil
;
1620 internal_equal (o1
, o2
, depth
)
1621 register Lisp_Object o1
, o2
;
1625 error ("Stack overflow in equal");
1631 if (XTYPE (o1
) != XTYPE (o2
))
1636 #ifdef LISP_FLOAT_TYPE
1638 return (extract_float (o1
) == extract_float (o2
));
1642 if (!internal_equal (XCONS (o1
)->car
, XCONS (o2
)->car
, depth
+ 1))
1644 o1
= XCONS (o1
)->cdr
;
1645 o2
= XCONS (o2
)->cdr
;
1649 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
1653 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o1
),
1655 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o1
),
1658 o1
= XOVERLAY (o1
)->plist
;
1659 o2
= XOVERLAY (o2
)->plist
;
1664 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
1665 && (XMARKER (o1
)->buffer
== 0
1666 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
1670 case Lisp_Vectorlike
:
1672 register int i
, size
;
1673 size
= XVECTOR (o1
)->size
;
1674 /* Pseudovectors have the type encoded in the size field, so this test
1675 actually checks that the objects have the same type as well as the
1677 if (XVECTOR (o2
)->size
!= size
)
1679 /* Boolvectors are compared much like strings. */
1680 if (BOOL_VECTOR_P (o1
))
1683 = (XBOOL_VECTOR (o1
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
1685 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
1687 if (bcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
1692 if (WINDOW_CONFIGURATIONP (o1
))
1693 return compare_window_configurations (o1
, o2
, 0);
1695 /* Aside from them, only true vectors, char-tables, and compiled
1696 functions are sensible to compare, so eliminate the others now. */
1697 if (size
& PSEUDOVECTOR_FLAG
)
1699 if (!(size
& (PVEC_COMPILED
| PVEC_CHAR_TABLE
)))
1701 size
&= PSEUDOVECTOR_SIZE_MASK
;
1703 for (i
= 0; i
< size
; i
++)
1706 v1
= XVECTOR (o1
)->contents
[i
];
1707 v2
= XVECTOR (o2
)->contents
[i
];
1708 if (!internal_equal (v1
, v2
, depth
+ 1))
1716 if (XSTRING (o1
)->size
!= XSTRING (o2
)->size
)
1718 if (STRING_BYTES (XSTRING (o1
)) != STRING_BYTES (XSTRING (o2
)))
1720 if (bcmp (XSTRING (o1
)->data
, XSTRING (o2
)->data
,
1721 STRING_BYTES (XSTRING (o1
))))
1728 extern Lisp_Object
Fmake_char_internal ();
1730 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
1731 "Store each element of ARRAY with ITEM.\n\
1732 ARRAY is a vector, string, char-table, or bool-vector.")
1734 Lisp_Object array
, item
;
1736 register int size
, index
, charval
;
1738 if (VECTORP (array
))
1740 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
1741 size
= XVECTOR (array
)->size
;
1742 for (index
= 0; index
< size
; index
++)
1745 else if (CHAR_TABLE_P (array
))
1747 register Lisp_Object
*p
= XCHAR_TABLE (array
)->contents
;
1748 size
= CHAR_TABLE_ORDINARY_SLOTS
;
1749 for (index
= 0; index
< size
; index
++)
1751 XCHAR_TABLE (array
)->defalt
= Qnil
;
1753 else if (STRINGP (array
))
1755 register unsigned char *p
= XSTRING (array
)->data
;
1756 CHECK_NUMBER (item
, 1);
1757 charval
= XINT (item
);
1758 size
= XSTRING (array
)->size
;
1759 for (index
= 0; index
< size
; index
++)
1762 else if (BOOL_VECTOR_P (array
))
1764 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
1766 = (XBOOL_VECTOR (array
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
1768 charval
= (! NILP (item
) ? -1 : 0);
1769 for (index
= 0; index
< size_in_chars
; index
++)
1774 array
= wrong_type_argument (Qarrayp
, array
);
1780 DEFUN ("char-table-subtype", Fchar_table_subtype
, Schar_table_subtype
,
1782 "Return the subtype of char-table CHAR-TABLE. The value is a symbol.")
1784 Lisp_Object char_table
;
1786 CHECK_CHAR_TABLE (char_table
, 0);
1788 return XCHAR_TABLE (char_table
)->purpose
;
1791 DEFUN ("char-table-parent", Fchar_table_parent
, Schar_table_parent
,
1793 "Return the parent char-table of CHAR-TABLE.\n\
1794 The value is either nil or another char-table.\n\
1795 If CHAR-TABLE holds nil for a given character,\n\
1796 then the actual applicable value is inherited from the parent char-table\n\
1797 \(or from its parents, if necessary).")
1799 Lisp_Object char_table
;
1801 CHECK_CHAR_TABLE (char_table
, 0);
1803 return XCHAR_TABLE (char_table
)->parent
;
1806 DEFUN ("set-char-table-parent", Fset_char_table_parent
, Sset_char_table_parent
,
1808 "Set the parent char-table of CHAR-TABLE to PARENT.\n\
1809 PARENT must be either nil or another char-table.")
1810 (char_table
, parent
)
1811 Lisp_Object char_table
, parent
;
1815 CHECK_CHAR_TABLE (char_table
, 0);
1819 CHECK_CHAR_TABLE (parent
, 0);
1821 for (temp
= parent
; !NILP (temp
); temp
= XCHAR_TABLE (temp
)->parent
)
1822 if (EQ (temp
, char_table
))
1823 error ("Attempt to make a chartable be its own parent");
1826 XCHAR_TABLE (char_table
)->parent
= parent
;
1831 DEFUN ("char-table-extra-slot", Fchar_table_extra_slot
, Schar_table_extra_slot
,
1833 "Return the value of CHAR-TABLE's extra-slot number N.")
1835 Lisp_Object char_table
, n
;
1837 CHECK_CHAR_TABLE (char_table
, 1);
1838 CHECK_NUMBER (n
, 2);
1840 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
1841 args_out_of_range (char_table
, n
);
1843 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)];
1846 DEFUN ("set-char-table-extra-slot", Fset_char_table_extra_slot
,
1847 Sset_char_table_extra_slot
,
1849 "Set CHAR-TABLE's extra-slot number N to VALUE.")
1850 (char_table
, n
, value
)
1851 Lisp_Object char_table
, n
, value
;
1853 CHECK_CHAR_TABLE (char_table
, 1);
1854 CHECK_NUMBER (n
, 2);
1856 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
1857 args_out_of_range (char_table
, n
);
1859 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)] = value
;
1862 DEFUN ("char-table-range", Fchar_table_range
, Schar_table_range
,
1864 "Return the value in CHAR-TABLE for a range of characters RANGE.\n\
1865 RANGE should be nil (for the default value)\n\
1866 a vector which identifies a character set or a row of a character set,\n\
1867 a character set name, or a character code.")
1869 Lisp_Object char_table
, range
;
1873 CHECK_CHAR_TABLE (char_table
, 0);
1875 if (EQ (range
, Qnil
))
1876 return XCHAR_TABLE (char_table
)->defalt
;
1877 else if (INTEGERP (range
))
1878 return Faref (char_table
, range
);
1879 else if (SYMBOLP (range
))
1881 Lisp_Object charset_info
;
1883 charset_info
= Fget (range
, Qcharset
);
1884 CHECK_VECTOR (charset_info
, 0);
1886 return Faref (char_table
,
1887 make_number (XINT (XVECTOR (charset_info
)->contents
[0])
1890 else if (VECTORP (range
))
1892 if (XVECTOR (range
)->size
== 1)
1893 return Faref (char_table
,
1894 make_number (XINT (XVECTOR (range
)->contents
[0]) + 128));
1897 int size
= XVECTOR (range
)->size
;
1898 Lisp_Object
*val
= XVECTOR (range
)->contents
;
1899 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
1900 size
<= 1 ? Qnil
: val
[1],
1901 size
<= 2 ? Qnil
: val
[2]);
1902 return Faref (char_table
, ch
);
1906 error ("Invalid RANGE argument to `char-table-range'");
1909 DEFUN ("set-char-table-range", Fset_char_table_range
, Sset_char_table_range
,
1911 "Set the value in CHAR-TABLE for a range of characters RANGE to VALUE.\n\
1912 RANGE should be t (for all characters), nil (for the default value)\n\
1913 a vector which identifies a character set or a row of a character set,\n\
1914 a coding system, or a character code.")
1915 (char_table
, range
, value
)
1916 Lisp_Object char_table
, range
, value
;
1920 CHECK_CHAR_TABLE (char_table
, 0);
1923 for (i
= 0; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
1924 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
1925 else if (EQ (range
, Qnil
))
1926 XCHAR_TABLE (char_table
)->defalt
= value
;
1927 else if (SYMBOLP (range
))
1929 Lisp_Object charset_info
;
1931 charset_info
= Fget (range
, Qcharset
);
1932 CHECK_VECTOR (charset_info
, 0);
1934 return Faset (char_table
,
1935 make_number (XINT (XVECTOR (charset_info
)->contents
[0])
1939 else if (INTEGERP (range
))
1940 Faset (char_table
, range
, value
);
1941 else if (VECTORP (range
))
1943 if (XVECTOR (range
)->size
== 1)
1944 return Faset (char_table
,
1945 make_number (XINT (XVECTOR (range
)->contents
[0]) + 128),
1949 int size
= XVECTOR (range
)->size
;
1950 Lisp_Object
*val
= XVECTOR (range
)->contents
;
1951 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
1952 size
<= 1 ? Qnil
: val
[1],
1953 size
<= 2 ? Qnil
: val
[2]);
1954 return Faset (char_table
, ch
, value
);
1958 error ("Invalid RANGE argument to `set-char-table-range'");
1963 DEFUN ("set-char-table-default", Fset_char_table_default
,
1964 Sset_char_table_default
, 3, 3, 0,
1965 "Set the default value in CHAR-TABLE for a generic character CHAR to VALUE.\n\
1966 The generic character specifies the group of characters.\n\
1967 See also the documentation of make-char.")
1968 (char_table
, ch
, value
)
1969 Lisp_Object char_table
, ch
, value
;
1971 int c
, i
, charset
, code1
, code2
;
1974 CHECK_CHAR_TABLE (char_table
, 0);
1975 CHECK_NUMBER (ch
, 1);
1978 SPLIT_NON_ASCII_CHAR (c
, charset
, code1
, code2
);
1979 if (! CHARSET_DEFINED_P (charset
))
1980 invalid_character (c
);
1982 if (charset
== CHARSET_ASCII
)
1983 return (XCHAR_TABLE (char_table
)->defalt
= value
);
1985 /* Even if C is not a generic char, we had better behave as if a
1986 generic char is specified. */
1987 if (CHARSET_DIMENSION (charset
) == 1)
1989 temp
= XCHAR_TABLE (char_table
)->contents
[charset
+ 128];
1992 if (SUB_CHAR_TABLE_P (temp
))
1993 XCHAR_TABLE (temp
)->defalt
= value
;
1995 XCHAR_TABLE (char_table
)->contents
[charset
+ 128] = value
;
1999 if (! SUB_CHAR_TABLE_P (char_table
))
2000 char_table
= (XCHAR_TABLE (char_table
)->contents
[charset
+ 128]
2001 = make_sub_char_table (temp
));
2002 temp
= XCHAR_TABLE (char_table
)->contents
[code1
];
2003 if (SUB_CHAR_TABLE_P (temp
))
2004 XCHAR_TABLE (temp
)->defalt
= value
;
2006 XCHAR_TABLE (char_table
)->contents
[code1
] = value
;
2010 /* Look up the element in TABLE at index CH,
2011 and return it as an integer.
2012 If the element is nil, return CH itself.
2013 (Actually we do that for any non-integer.) */
2016 char_table_translate (table
, ch
)
2021 value
= Faref (table
, make_number (ch
));
2022 if (! INTEGERP (value
))
2024 return XINT (value
);
2027 /* Map C_FUNCTION or FUNCTION over SUBTABLE, calling it for each
2028 character or group of characters that share a value.
2029 DEPTH is the current depth in the originally specified
2030 chartable, and INDICES contains the vector indices
2031 for the levels our callers have descended.
2033 ARG is passed to C_FUNCTION when that is called. */
2036 map_char_table (c_function
, function
, subtable
, arg
, depth
, indices
)
2037 void (*c_function
) P_ ((Lisp_Object
, Lisp_Object
, Lisp_Object
));
2038 Lisp_Object function
, subtable
, arg
, *indices
;
2045 /* At first, handle ASCII and 8-bit European characters. */
2046 for (i
= 0; i
< CHAR_TABLE_SINGLE_BYTE_SLOTS
; i
++)
2048 Lisp_Object elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2050 (*c_function
) (arg
, make_number (i
), elt
);
2052 call2 (function
, make_number (i
), elt
);
2054 #if 0 /* If the char table has entries for higher characters,
2055 we should report them. */
2056 if (NILP (current_buffer
->enable_multibyte_characters
))
2059 to
= CHAR_TABLE_ORDINARY_SLOTS
;
2064 to
= SUB_CHAR_TABLE_ORDINARY_SLOTS
;
2069 Lisp_Object elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2071 XSETFASTINT (indices
[depth
], i
);
2073 if (SUB_CHAR_TABLE_P (elt
))
2076 error ("Too deep char table");
2077 map_char_table (c_function
, function
, elt
, arg
, depth
+ 1, indices
);
2081 int charset
= XFASTINT (indices
[0]) - 128, c1
, c2
, c
;
2083 if (CHARSET_DEFINED_P (charset
))
2085 c1
= depth
>= 1 ? XFASTINT (indices
[1]) : 0;
2086 c2
= depth
>= 2 ? XFASTINT (indices
[2]) : 0;
2087 c
= MAKE_NON_ASCII_CHAR (charset
, c1
, c2
);
2089 (*c_function
) (arg
, make_number (c
), elt
);
2091 call2 (function
, make_number (c
), elt
);
2097 DEFUN ("map-char-table", Fmap_char_table
, Smap_char_table
,
2099 "Call FUNCTION for each (normal and generic) characters in CHAR-TABLE.\n\
2100 FUNCTION is called with two arguments--a key and a value.\n\
2101 The key is always a possible IDX argument to `aref'.")
2102 (function
, char_table
)
2103 Lisp_Object function
, char_table
;
2105 /* The depth of char table is at most 3. */
2106 Lisp_Object indices
[3];
2108 CHECK_CHAR_TABLE (char_table
, 1);
2110 map_char_table (NULL
, function
, char_table
, char_table
, 0, indices
);
2120 Lisp_Object args
[2];
2123 return Fnconc (2, args
);
2125 return Fnconc (2, &s1
);
2126 #endif /* NO_ARG_ARRAY */
2129 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2130 "Concatenate any number of lists by altering them.\n\
2131 Only the last argument is not altered, and need not be a list.")
2136 register int argnum
;
2137 register Lisp_Object tail
, tem
, val
;
2141 for (argnum
= 0; argnum
< nargs
; argnum
++)
2144 if (NILP (tem
)) continue;
2149 if (argnum
+ 1 == nargs
) break;
2152 tem
= wrong_type_argument (Qlistp
, tem
);
2161 tem
= args
[argnum
+ 1];
2162 Fsetcdr (tail
, tem
);
2164 args
[argnum
+ 1] = tail
;
2170 /* This is the guts of all mapping functions.
2171 Apply FN to each element of SEQ, one by one,
2172 storing the results into elements of VALS, a C vector of Lisp_Objects.
2173 LENI is the length of VALS, which should also be the length of SEQ. */
2176 mapcar1 (leni
, vals
, fn
, seq
)
2179 Lisp_Object fn
, seq
;
2181 register Lisp_Object tail
;
2184 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2186 /* Don't let vals contain any garbage when GC happens. */
2187 for (i
= 0; i
< leni
; i
++)
2190 GCPRO3 (dummy
, fn
, seq
);
2192 gcpro1
.nvars
= leni
;
2193 /* We need not explicitly protect `tail' because it is used only on lists, and
2194 1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
2198 for (i
= 0; i
< leni
; i
++)
2200 dummy
= XVECTOR (seq
)->contents
[i
];
2201 vals
[i
] = call1 (fn
, dummy
);
2204 else if (BOOL_VECTOR_P (seq
))
2206 for (i
= 0; i
< leni
; i
++)
2209 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BITS_PER_CHAR
];
2210 if (byte
& (1 << (i
% BITS_PER_CHAR
)))
2215 vals
[i
] = call1 (fn
, dummy
);
2218 else if (STRINGP (seq
) && ! STRING_MULTIBYTE (seq
))
2220 /* Single-byte string. */
2221 for (i
= 0; i
< leni
; i
++)
2223 XSETFASTINT (dummy
, XSTRING (seq
)->data
[i
]);
2224 vals
[i
] = call1 (fn
, dummy
);
2227 else if (STRINGP (seq
))
2229 /* Multi-byte string. */
2230 int len_byte
= STRING_BYTES (XSTRING (seq
));
2233 for (i
= 0, i_byte
= 0; i
< leni
;)
2238 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2239 XSETFASTINT (dummy
, c
);
2240 vals
[i_before
] = call1 (fn
, dummy
);
2243 else /* Must be a list, since Flength did not get an error */
2246 for (i
= 0; i
< leni
; i
++)
2248 vals
[i
] = call1 (fn
, Fcar (tail
));
2249 tail
= XCONS (tail
)->cdr
;
2256 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2257 "Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.\n\
2258 In between each pair of results, stick in SEPARATOR. Thus, \" \" as\n\
2259 SEPARATOR results in spaces between the values returned by FUNCTION.\n\
2260 SEQUENCE may be a list, a vector, a bool-vector, or a string.")
2261 (function
, sequence
, separator
)
2262 Lisp_Object function
, sequence
, separator
;
2267 register Lisp_Object
*args
;
2269 struct gcpro gcpro1
;
2271 len
= Flength (sequence
);
2273 nargs
= leni
+ leni
- 1;
2274 if (nargs
< 0) return build_string ("");
2276 args
= (Lisp_Object
*) alloca (nargs
* sizeof (Lisp_Object
));
2279 mapcar1 (leni
, args
, function
, sequence
);
2282 for (i
= leni
- 1; i
>= 0; i
--)
2283 args
[i
+ i
] = args
[i
];
2285 for (i
= 1; i
< nargs
; i
+= 2)
2286 args
[i
] = separator
;
2288 return Fconcat (nargs
, args
);
2291 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2292 "Apply FUNCTION to each element of SEQUENCE, and make a list of the results.\n\
2293 The result is a list just as long as SEQUENCE.\n\
2294 SEQUENCE may be a list, a vector, a bool-vector, or a string.")
2295 (function
, sequence
)
2296 Lisp_Object function
, sequence
;
2298 register Lisp_Object len
;
2300 register Lisp_Object
*args
;
2302 len
= Flength (sequence
);
2303 leni
= XFASTINT (len
);
2304 args
= (Lisp_Object
*) alloca (leni
* sizeof (Lisp_Object
));
2306 mapcar1 (leni
, args
, function
, sequence
);
2308 return Flist (leni
, args
);
2311 /* Anything that calls this function must protect from GC! */
2313 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
2314 "Ask user a \"y or n\" question. Return t if answer is \"y\".\n\
2315 Takes one argument, which is the string to display to ask the question.\n\
2316 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.\n\
2317 No confirmation of the answer is requested; a single character is enough.\n\
2318 Also accepts Space to mean yes, or Delete to mean no.")
2322 register Lisp_Object obj
, key
, def
, answer_string
, map
;
2323 register int answer
;
2324 Lisp_Object xprompt
;
2325 Lisp_Object args
[2];
2326 struct gcpro gcpro1
, gcpro2
;
2327 int count
= specpdl_ptr
- specpdl
;
2329 specbind (Qcursor_in_echo_area
, Qt
);
2331 map
= Fsymbol_value (intern ("query-replace-map"));
2333 CHECK_STRING (prompt
, 0);
2335 GCPRO2 (prompt
, xprompt
);
2341 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2345 Lisp_Object pane
, menu
;
2346 redisplay_preserve_echo_area ();
2347 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2348 Fcons (Fcons (build_string ("No"), Qnil
),
2350 menu
= Fcons (prompt
, pane
);
2351 obj
= Fx_popup_dialog (Qt
, menu
);
2352 answer
= !NILP (obj
);
2355 #endif /* HAVE_MENUS */
2356 cursor_in_echo_area
= 1;
2357 choose_minibuf_frame ();
2358 message_with_string ("%s(y or n) ", xprompt
, 0);
2360 if (minibuffer_auto_raise
)
2362 Lisp_Object mini_frame
;
2364 mini_frame
= WINDOW_FRAME (XWINDOW (minibuf_window
));
2366 Fraise_frame (mini_frame
);
2369 obj
= read_filtered_event (1, 0, 0);
2370 cursor_in_echo_area
= 0;
2371 /* If we need to quit, quit with cursor_in_echo_area = 0. */
2374 key
= Fmake_vector (make_number (1), obj
);
2375 def
= Flookup_key (map
, key
, Qt
);
2376 answer_string
= Fsingle_key_description (obj
);
2378 if (EQ (def
, intern ("skip")))
2383 else if (EQ (def
, intern ("act")))
2388 else if (EQ (def
, intern ("recenter")))
2394 else if (EQ (def
, intern ("quit")))
2396 /* We want to exit this command for exit-prefix,
2397 and this is the only way to do it. */
2398 else if (EQ (def
, intern ("exit-prefix")))
2403 /* If we don't clear this, then the next call to read_char will
2404 return quit_char again, and we'll enter an infinite loop. */
2409 if (EQ (xprompt
, prompt
))
2411 args
[0] = build_string ("Please answer y or n. ");
2413 xprompt
= Fconcat (2, args
);
2418 if (! noninteractive
)
2420 cursor_in_echo_area
= -1;
2421 message_with_string (answer
? "%s(y or n) y" : "%s(y or n) n",
2425 unbind_to (count
, Qnil
);
2426 return answer
? Qt
: Qnil
;
2429 /* This is how C code calls `yes-or-no-p' and allows the user
2432 Anything that calls this function must protect from GC! */
2435 do_yes_or_no_p (prompt
)
2438 return call1 (intern ("yes-or-no-p"), prompt
);
2441 /* Anything that calls this function must protect from GC! */
2443 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2444 "Ask user a yes-or-no question. Return t if answer is yes.\n\
2445 Takes one argument, which is the string to display to ask the question.\n\
2446 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.\n\
2447 The user must confirm the answer with RET,\n\
2448 and can edit it until it has been confirmed.")
2452 register Lisp_Object ans
;
2453 Lisp_Object args
[2];
2454 struct gcpro gcpro1
;
2457 CHECK_STRING (prompt
, 0);
2460 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2464 Lisp_Object pane
, menu
, obj
;
2465 redisplay_preserve_echo_area ();
2466 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2467 Fcons (Fcons (build_string ("No"), Qnil
),
2470 menu
= Fcons (prompt
, pane
);
2471 obj
= Fx_popup_dialog (Qt
, menu
);
2475 #endif /* HAVE_MENUS */
2478 args
[1] = build_string ("(yes or no) ");
2479 prompt
= Fconcat (2, args
);
2485 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2486 Qyes_or_no_p_history
, Qnil
,
2488 if (XSTRING (ans
)->size
== 3 && !strcmp (XSTRING (ans
)->data
, "yes"))
2493 if (XSTRING (ans
)->size
== 2 && !strcmp (XSTRING (ans
)->data
, "no"))
2501 message ("Please answer yes or no.");
2502 Fsleep_for (make_number (2), Qnil
);
2506 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2507 "Return list of 1 minute, 5 minute and 15 minute load averages.\n\
2508 Each of the three load averages is multiplied by 100,\n\
2509 then converted to integer.\n\
2510 When USE-FLOATS is non-nil, floats will be used instead of integers.\n\
2511 These floats are not multiplied by 100.\n\n\
2512 If the 5-minute or 15-minute load averages are not available, return a\n\
2513 shortened list, containing only those averages which are available.")
2515 Lisp_Object use_floats
;
2518 int loads
= getloadavg (load_ave
, 3);
2519 Lisp_Object ret
= Qnil
;
2522 error ("load-average not implemented for this operating system");
2526 Lisp_Object load
= (NILP (use_floats
) ?
2527 make_number ((int) (100.0 * load_ave
[loads
]))
2528 : make_float (load_ave
[loads
]));
2529 ret
= Fcons (load
, ret
);
2535 Lisp_Object Vfeatures
;
2537 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 1, 0,
2538 "Returns t if FEATURE is present in this Emacs.\n\
2539 Use this to conditionalize execution of lisp code based on the presence or\n\
2540 absence of emacs or environment extensions.\n\
2541 Use `provide' to declare that a feature is available.\n\
2542 This function looks at the value of the variable `features'.")
2544 Lisp_Object feature
;
2546 register Lisp_Object tem
;
2547 CHECK_SYMBOL (feature
, 0);
2548 tem
= Fmemq (feature
, Vfeatures
);
2549 return (NILP (tem
)) ? Qnil
: Qt
;
2552 DEFUN ("provide", Fprovide
, Sprovide
, 1, 1, 0,
2553 "Announce that FEATURE is a feature of the current Emacs.")
2555 Lisp_Object feature
;
2557 register Lisp_Object tem
;
2558 CHECK_SYMBOL (feature
, 0);
2559 if (!NILP (Vautoload_queue
))
2560 Vautoload_queue
= Fcons (Fcons (Vfeatures
, Qnil
), Vautoload_queue
);
2561 tem
= Fmemq (feature
, Vfeatures
);
2563 Vfeatures
= Fcons (feature
, Vfeatures
);
2564 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2568 DEFUN ("require", Frequire
, Srequire
, 1, 2, 0,
2569 "If feature FEATURE is not loaded, load it from FILENAME.\n\
2570 If FEATURE is not a member of the list `features', then the feature\n\
2571 is not loaded; so load the file FILENAME.\n\
2572 If FILENAME is omitted, the printname of FEATURE is used as the file name,\n\
2573 but in this case `load' insists on adding the suffix `.el' or `.elc'.")
2574 (feature
, file_name
)
2575 Lisp_Object feature
, file_name
;
2577 register Lisp_Object tem
;
2578 CHECK_SYMBOL (feature
, 0);
2579 tem
= Fmemq (feature
, Vfeatures
);
2580 LOADHIST_ATTACH (Fcons (Qrequire
, feature
));
2583 int count
= specpdl_ptr
- specpdl
;
2585 /* Value saved here is to be restored into Vautoload_queue */
2586 record_unwind_protect (un_autoload
, Vautoload_queue
);
2587 Vautoload_queue
= Qt
;
2589 Fload (NILP (file_name
) ? Fsymbol_name (feature
) : file_name
,
2590 Qnil
, Qt
, Qnil
, (NILP (file_name
) ? Qt
: Qnil
));
2592 tem
= Fmemq (feature
, Vfeatures
);
2594 error ("Required feature %s was not provided",
2595 XSYMBOL (feature
)->name
->data
);
2597 /* Once loading finishes, don't undo it. */
2598 Vautoload_queue
= Qt
;
2599 feature
= unbind_to (count
, feature
);
2604 /* Primitives for work of the "widget" library.
2605 In an ideal world, this section would not have been necessary.
2606 However, lisp function calls being as slow as they are, it turns
2607 out that some functions in the widget library (wid-edit.el) are the
2608 bottleneck of Widget operation. Here is their translation to C,
2609 for the sole reason of efficiency. */
2611 DEFUN ("widget-plist-member", Fwidget_plist_member
, Swidget_plist_member
, 2, 2, 0,
2612 "Return non-nil if PLIST has the property PROP.\n\
2613 PLIST is a property list, which is a list of the form\n\
2614 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.\n\
2615 Unlike `plist-get', this allows you to distinguish between a missing\n\
2616 property and a property with the value nil.\n\
2617 The value is actually the tail of PLIST whose car is PROP.")
2619 Lisp_Object plist
, prop
;
2621 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
2624 plist
= XCDR (plist
);
2625 plist
= CDR (plist
);
2630 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
2631 "In WIDGET, set PROPERTY to VALUE.\n\
2632 The value can later be retrieved with `widget-get'.")
2633 (widget
, property
, value
)
2634 Lisp_Object widget
, property
, value
;
2636 CHECK_CONS (widget
, 1);
2637 XCDR (widget
) = Fplist_put (XCDR (widget
), property
, value
);
2640 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
2641 "In WIDGET, get the value of PROPERTY.\n\
2642 The value could either be specified when the widget was created, or\n\
2643 later with `widget-put'.")
2645 Lisp_Object widget
, property
;
2653 CHECK_CONS (widget
, 1);
2654 tmp
= Fwidget_plist_member (XCDR (widget
), property
);
2660 tmp
= XCAR (widget
);
2663 widget
= Fget (tmp
, Qwidget_type
);
2667 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
2668 "Apply the value of WIDGET's PROPERTY to the widget itself.\n\
2669 ARGS are passed as extra arguments to the function.")
2674 /* This function can GC. */
2675 Lisp_Object newargs
[3];
2676 struct gcpro gcpro1
, gcpro2
;
2679 newargs
[0] = Fwidget_get (args
[0], args
[1]);
2680 newargs
[1] = args
[0];
2681 newargs
[2] = Flist (nargs
- 2, args
+ 2);
2682 GCPRO2 (newargs
[0], newargs
[2]);
2683 result
= Fapply (3, newargs
);
2691 Qstring_lessp
= intern ("string-lessp");
2692 staticpro (&Qstring_lessp
);
2693 Qprovide
= intern ("provide");
2694 staticpro (&Qprovide
);
2695 Qrequire
= intern ("require");
2696 staticpro (&Qrequire
);
2697 Qyes_or_no_p_history
= intern ("yes-or-no-p-history");
2698 staticpro (&Qyes_or_no_p_history
);
2699 Qcursor_in_echo_area
= intern ("cursor-in-echo-area");
2700 staticpro (&Qcursor_in_echo_area
);
2701 Qwidget_type
= intern ("widget-type");
2702 staticpro (&Qwidget_type
);
2704 staticpro (&string_char_byte_cache_string
);
2705 string_char_byte_cache_string
= Qnil
;
2707 Fset (Qyes_or_no_p_history
, Qnil
);
2709 DEFVAR_LISP ("features", &Vfeatures
,
2710 "A list of symbols which are the features of the executing emacs.\n\
2711 Used by `featurep' and `require', and altered by `provide'.");
2714 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box
,
2715 "*Non-nil means mouse commands use dialog boxes to ask questions.\n\
2716 This applies to y-or-n and yes-or-no questions asked by commands\n\
2717 invoked by mouse clicks and mouse menu items.");
2720 defsubr (&Sidentity
);
2723 defsubr (&Ssafe_length
);
2724 defsubr (&Sstring_bytes
);
2725 defsubr (&Sstring_equal
);
2726 defsubr (&Scompare_strings
);
2727 defsubr (&Sstring_lessp
);
2730 defsubr (&Svconcat
);
2731 defsubr (&Scopy_sequence
);
2732 defsubr (&Sstring_make_multibyte
);
2733 defsubr (&Sstring_make_unibyte
);
2734 defsubr (&Sstring_as_multibyte
);
2735 defsubr (&Sstring_as_unibyte
);
2736 defsubr (&Scopy_alist
);
2737 defsubr (&Ssubstring
);
2749 defsubr (&Snreverse
);
2750 defsubr (&Sreverse
);
2752 defsubr (&Splist_get
);
2754 defsubr (&Splist_put
);
2757 defsubr (&Sfillarray
);
2758 defsubr (&Schar_table_subtype
);
2759 defsubr (&Schar_table_parent
);
2760 defsubr (&Sset_char_table_parent
);
2761 defsubr (&Schar_table_extra_slot
);
2762 defsubr (&Sset_char_table_extra_slot
);
2763 defsubr (&Schar_table_range
);
2764 defsubr (&Sset_char_table_range
);
2765 defsubr (&Sset_char_table_default
);
2766 defsubr (&Smap_char_table
);
2769 defsubr (&Smapconcat
);
2770 defsubr (&Sy_or_n_p
);
2771 defsubr (&Syes_or_no_p
);
2772 defsubr (&Sload_average
);
2773 defsubr (&Sfeaturep
);
2774 defsubr (&Srequire
);
2775 defsubr (&Sprovide
);
2776 defsubr (&Swidget_plist_member
);
2777 defsubr (&Swidget_put
);
2778 defsubr (&Swidget_get
);
2779 defsubr (&Swidget_apply
);