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 extern Lisp_Object Qinput_method_function
;
65 static int internal_equal ();
67 extern long get_random ();
68 extern void seed_random ();
74 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
75 "Return the argument unchanged.")
82 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
83 "Return a pseudo-random number.\n\
84 All integers representable in Lisp are equally likely.\n\
85 On most systems, this is 28 bits' worth.\n\
86 With positive integer argument N, return random number in interval [0,N).\n\
87 With argument t, set the random number seed from the current time and pid.")
92 Lisp_Object lispy_val
;
93 unsigned long denominator
;
96 seed_random (getpid () + time (NULL
));
97 if (NATNUMP (n
) && XFASTINT (n
) != 0)
99 /* Try to take our random number from the higher bits of VAL,
100 not the lower, since (says Gentzel) the low bits of `random'
101 are less random than the higher ones. We do this by using the
102 quotient rather than the remainder. At the high end of the RNG
103 it's possible to get a quotient larger than n; discarding
104 these values eliminates the bias that would otherwise appear
105 when using a large n. */
106 denominator
= ((unsigned long)1 << VALBITS
) / XFASTINT (n
);
108 val
= get_random () / denominator
;
109 while (val
>= XFASTINT (n
));
113 XSETINT (lispy_val
, val
);
117 /* Random data-structure functions */
119 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
120 "Return the length of vector, list or string SEQUENCE.\n\
121 A byte-code function object is also allowed.\n\
122 If the string contains multibyte characters, this is not the necessarily\n\
123 the number of bytes in the string; it is the number of characters.\n\
124 To get the number of bytes, use `string-bytes'")
126 register Lisp_Object sequence
;
128 register Lisp_Object tail
, val
;
132 if (STRINGP (sequence
))
133 XSETFASTINT (val
, XSTRING (sequence
)->size
);
134 else if (VECTORP (sequence
))
135 XSETFASTINT (val
, XVECTOR (sequence
)->size
);
136 else if (CHAR_TABLE_P (sequence
))
137 XSETFASTINT (val
, (MIN_CHAR_COMPOSITION
138 + (CHAR_FIELD2_MASK
| CHAR_FIELD3_MASK
)
140 else if (BOOL_VECTOR_P (sequence
))
141 XSETFASTINT (val
, XBOOL_VECTOR (sequence
)->size
);
142 else if (COMPILEDP (sequence
))
143 XSETFASTINT (val
, XVECTOR (sequence
)->size
& PSEUDOVECTOR_SIZE_MASK
);
144 else if (CONSP (sequence
))
146 for (i
= 0, tail
= sequence
; !NILP (tail
); i
++)
152 XSETFASTINT (val
, i
);
154 else if (NILP (sequence
))
155 XSETFASTINT (val
, 0);
158 sequence
= wrong_type_argument (Qsequencep
, sequence
);
164 /* This does not check for quits. That is safe
165 since it must terminate. */
167 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
168 "Return the length of a list, but avoid error or infinite loop.\n\
169 This function never gets an error. If LIST is not really a list,\n\
170 it returns 0. If LIST is circular, it returns a finite value\n\
171 which is at least the number of distinct elements.")
175 Lisp_Object tail
, halftail
, length
;
178 /* halftail is used to detect circular lists. */
180 for (tail
= list
; CONSP (tail
); tail
= XCONS (tail
)->cdr
)
182 if (EQ (tail
, halftail
) && len
!= 0)
186 halftail
= XCONS (halftail
)->cdr
;
189 XSETINT (length
, len
);
193 DEFUN ("string-bytes", Fstring_bytes
, Sstring_bytes
, 1, 1, 0,
194 "Return the number of bytes in STRING.\n\
195 If STRING is a multibyte string, this is greater than the length of STRING.")
199 CHECK_STRING (string
, 1);
200 return make_number (STRING_BYTES (XSTRING (string
)));
203 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
204 "Return t if two strings have identical contents.\n\
205 Case is significant, but text properties are ignored.\n\
206 Symbols are also allowed; their print names are used instead.")
208 register Lisp_Object s1
, s2
;
211 XSETSTRING (s1
, XSYMBOL (s1
)->name
);
213 XSETSTRING (s2
, XSYMBOL (s2
)->name
);
214 CHECK_STRING (s1
, 0);
215 CHECK_STRING (s2
, 1);
217 if (XSTRING (s1
)->size
!= XSTRING (s2
)->size
218 || STRING_BYTES (XSTRING (s1
)) != STRING_BYTES (XSTRING (s2
))
219 || bcmp (XSTRING (s1
)->data
, XSTRING (s2
)->data
, STRING_BYTES (XSTRING (s1
))))
224 DEFUN ("compare-strings", Fcompare_strings
,
225 Scompare_strings
, 6, 7, 0,
226 "Compare the contents of two strings, converting to multibyte if needed.\n\
227 In string STR1, skip the first START1 characters and stop at END1.\n\
228 In string STR2, skip the first START2 characters and stop at END2.\n\
229 END1 and END2 default to the full lengths of the respective strings.\n\
231 Case is significant in this comparison if IGNORE-CASE is nil.\n\
232 Unibyte strings are converted to multibyte for comparison.\n\
234 The value is t if the strings (or specified portions) match.\n\
235 If string STR1 is less, the value is a negative number N;\n\
236 - 1 - N is the number of characters that match at the beginning.\n\
237 If string STR1 is greater, the value is a positive number N;\n\
238 N - 1 is the number of characters that match at the beginning.")
239 (str1
, start1
, end1
, str2
, start2
, end2
, ignore_case
)
240 Lisp_Object str1
, start1
, end1
, start2
, str2
, end2
, ignore_case
;
242 register int end1_char
, end2_char
;
243 register int i1
, i1_byte
, i2
, i2_byte
;
245 CHECK_STRING (str1
, 0);
246 CHECK_STRING (str2
, 1);
248 start1
= make_number (0);
250 start2
= make_number (0);
251 CHECK_NATNUM (start1
, 2);
252 CHECK_NATNUM (start2
, 3);
254 CHECK_NATNUM (end1
, 4);
256 CHECK_NATNUM (end2
, 4);
261 i1_byte
= string_char_to_byte (str1
, i1
);
262 i2_byte
= string_char_to_byte (str2
, i2
);
264 end1_char
= XSTRING (str1
)->size
;
265 if (! NILP (end1
) && end1_char
> XINT (end1
))
266 end1_char
= XINT (end1
);
268 end2_char
= XSTRING (str2
)->size
;
269 if (! NILP (end2
) && end2_char
> XINT (end2
))
270 end2_char
= XINT (end2
);
272 while (i1
< end1_char
&& i2
< end2_char
)
274 /* When we find a mismatch, we must compare the
275 characters, not just the bytes. */
278 if (STRING_MULTIBYTE (str1
))
279 FETCH_STRING_CHAR_ADVANCE (c1
, str1
, i1
, i1_byte
);
282 c1
= XSTRING (str1
)->data
[i1
++];
283 c1
= unibyte_char_to_multibyte (c1
);
286 if (STRING_MULTIBYTE (str2
))
287 FETCH_STRING_CHAR_ADVANCE (c2
, str2
, i2
, i2_byte
);
290 c2
= XSTRING (str2
)->data
[i2
++];
291 c2
= unibyte_char_to_multibyte (c2
);
297 if (! NILP (ignore_case
))
301 tem
= Fupcase (make_number (c1
));
303 tem
= Fupcase (make_number (c2
));
310 /* Note that I1 has already been incremented
311 past the character that we are comparing;
312 hence we don't add or subtract 1 here. */
314 return make_number (- i1
);
316 return make_number (i1
);
320 return make_number (i1
- XINT (start1
) + 1);
322 return make_number (- i1
+ XINT (start1
) - 1);
327 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
328 "Return t if first arg string is less than second in lexicographic order.\n\
329 Case is significant.\n\
330 Symbols are also allowed; their print names are used instead.")
332 register Lisp_Object s1
, s2
;
335 register int i1
, i1_byte
, i2
, i2_byte
;
338 XSETSTRING (s1
, XSYMBOL (s1
)->name
);
340 XSETSTRING (s2
, XSYMBOL (s2
)->name
);
341 CHECK_STRING (s1
, 0);
342 CHECK_STRING (s2
, 1);
344 i1
= i1_byte
= i2
= i2_byte
= 0;
346 end
= XSTRING (s1
)->size
;
347 if (end
> XSTRING (s2
)->size
)
348 end
= XSTRING (s2
)->size
;
352 /* When we find a mismatch, we must compare the
353 characters, not just the bytes. */
356 if (STRING_MULTIBYTE (s1
))
357 FETCH_STRING_CHAR_ADVANCE (c1
, s1
, i1
, i1_byte
);
359 c1
= XSTRING (s1
)->data
[i1
++];
361 if (STRING_MULTIBYTE (s2
))
362 FETCH_STRING_CHAR_ADVANCE (c2
, s2
, i2
, i2_byte
);
364 c2
= XSTRING (s2
)->data
[i2
++];
367 return c1
< c2
? Qt
: Qnil
;
369 return i1
< XSTRING (s2
)->size
? Qt
: Qnil
;
372 static Lisp_Object
concat ();
383 return concat (2, args
, Lisp_String
, 0);
385 return concat (2, &s1
, Lisp_String
, 0);
386 #endif /* NO_ARG_ARRAY */
392 Lisp_Object s1
, s2
, s3
;
399 return concat (3, args
, Lisp_String
, 0);
401 return concat (3, &s1
, Lisp_String
, 0);
402 #endif /* NO_ARG_ARRAY */
405 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
406 "Concatenate all the arguments and make the result a list.\n\
407 The result is a list whose elements are the elements of all the arguments.\n\
408 Each argument may be a list, vector or string.\n\
409 The last argument is not copied, just used as the tail of the new list.")
414 return concat (nargs
, args
, Lisp_Cons
, 1);
417 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
418 "Concatenate all the arguments and make the result a string.\n\
419 The result is a string whose elements are the elements of all the arguments.\n\
420 Each argument may be a string or a list or vector of characters (integers).\n\
422 Do not use individual integers as arguments!\n\
423 The behavior of `concat' in that case will be changed later!\n\
424 If your program passes an integer as an argument to `concat',\n\
425 you should change it right away not to do so.")
430 return concat (nargs
, args
, Lisp_String
, 0);
433 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
434 "Concatenate all the arguments and make the result a vector.\n\
435 The result is a vector whose elements are the elements of all the arguments.\n\
436 Each argument may be a list, vector or string.")
441 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
444 /* Retrun a copy of a sub char table ARG. The elements except for a
445 nested sub char table are not copied. */
447 copy_sub_char_table (arg
)
450 Lisp_Object copy
= make_sub_char_table (XCHAR_TABLE (arg
)->defalt
);
453 /* Copy all the contents. */
454 bcopy (XCHAR_TABLE (arg
)->contents
, XCHAR_TABLE (copy
)->contents
,
455 SUB_CHAR_TABLE_ORDINARY_SLOTS
* sizeof (Lisp_Object
));
456 /* Recursively copy any sub char-tables in the ordinary slots. */
457 for (i
= 32; i
< SUB_CHAR_TABLE_ORDINARY_SLOTS
; i
++)
458 if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg
)->contents
[i
]))
459 XCHAR_TABLE (copy
)->contents
[i
]
460 = copy_sub_char_table (XCHAR_TABLE (copy
)->contents
[i
]);
466 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
467 "Return a copy of a list, vector or string.\n\
468 The elements of a list or vector are not copied; they are shared\n\
473 if (NILP (arg
)) return arg
;
475 if (CHAR_TABLE_P (arg
))
480 copy
= Fmake_char_table (XCHAR_TABLE (arg
)->purpose
, Qnil
);
481 /* Copy all the slots, including the extra ones. */
482 bcopy (XVECTOR (arg
)->contents
, XVECTOR (copy
)->contents
,
483 ((XCHAR_TABLE (arg
)->size
& PSEUDOVECTOR_SIZE_MASK
)
484 * sizeof (Lisp_Object
)));
486 /* Recursively copy any sub char tables in the ordinary slots
487 for multibyte characters. */
488 for (i
= CHAR_TABLE_SINGLE_BYTE_SLOTS
;
489 i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
490 if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg
)->contents
[i
]))
491 XCHAR_TABLE (copy
)->contents
[i
]
492 = copy_sub_char_table (XCHAR_TABLE (copy
)->contents
[i
]);
497 if (BOOL_VECTOR_P (arg
))
501 = (XBOOL_VECTOR (arg
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
503 val
= Fmake_bool_vector (Flength (arg
), Qnil
);
504 bcopy (XBOOL_VECTOR (arg
)->data
, XBOOL_VECTOR (val
)->data
,
509 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
510 arg
= wrong_type_argument (Qsequencep
, arg
);
511 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
515 concat (nargs
, args
, target_type
, last_special
)
518 enum Lisp_Type target_type
;
522 register Lisp_Object tail
;
523 register Lisp_Object
this;
526 register int result_len
;
527 register int result_len_byte
;
529 Lisp_Object last_tail
;
532 /* When we make a multibyte string, we must pay attention to the
533 byte combining problem, i.e., a byte may be combined with a
534 multibyte charcter of the previous string. This flag tells if we
535 must consider such a situation or not. */
536 int maybe_combine_byte
;
538 /* In append, the last arg isn't treated like the others */
539 if (last_special
&& nargs
> 0)
542 last_tail
= args
[nargs
];
547 /* Canonicalize each argument. */
548 for (argnum
= 0; argnum
< nargs
; argnum
++)
551 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
552 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
555 args
[argnum
] = Fnumber_to_string (this);
557 args
[argnum
] = wrong_type_argument (Qsequencep
, this);
561 /* Compute total length in chars of arguments in RESULT_LEN.
562 If desired output is a string, also compute length in bytes
563 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
564 whether the result should be a multibyte string. */
568 for (argnum
= 0; argnum
< nargs
; argnum
++)
572 len
= XFASTINT (Flength (this));
573 if (target_type
== Lisp_String
)
575 /* We must count the number of bytes needed in the string
576 as well as the number of characters. */
582 for (i
= 0; i
< len
; i
++)
584 ch
= XVECTOR (this)->contents
[i
];
586 wrong_type_argument (Qintegerp
, ch
);
587 this_len_byte
= CHAR_BYTES (XINT (ch
));
588 result_len_byte
+= this_len_byte
;
589 if (this_len_byte
> 1)
592 else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size
> 0)
593 wrong_type_argument (Qintegerp
, Faref (this, make_number (0)));
594 else if (CONSP (this))
595 for (; CONSP (this); this = XCONS (this)->cdr
)
597 ch
= XCONS (this)->car
;
599 wrong_type_argument (Qintegerp
, ch
);
600 this_len_byte
= CHAR_BYTES (XINT (ch
));
601 result_len_byte
+= this_len_byte
;
602 if (this_len_byte
> 1)
605 else if (STRINGP (this))
607 if (STRING_MULTIBYTE (this))
610 result_len_byte
+= STRING_BYTES (XSTRING (this));
613 result_len_byte
+= count_size_as_multibyte (XSTRING (this)->data
,
614 XSTRING (this)->size
);
621 if (! some_multibyte
)
622 result_len_byte
= result_len
;
624 /* Create the output object. */
625 if (target_type
== Lisp_Cons
)
626 val
= Fmake_list (make_number (result_len
), Qnil
);
627 else if (target_type
== Lisp_Vectorlike
)
628 val
= Fmake_vector (make_number (result_len
), Qnil
);
629 else if (some_multibyte
)
630 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
632 val
= make_uninit_string (result_len
);
634 /* In `append', if all but last arg are nil, return last arg. */
635 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
638 /* Copy the contents of the args into the result. */
640 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
642 toindex
= 0, toindex_byte
= 0;
646 maybe_combine_byte
= 0;
647 for (argnum
= 0; argnum
< nargs
; argnum
++)
651 register unsigned int thisindex
= 0;
652 register unsigned int thisindex_byte
= 0;
656 thislen
= Flength (this), thisleni
= XINT (thislen
);
658 if (STRINGP (this) && STRINGP (val
)
659 && ! NULL_INTERVAL_P (XSTRING (this)->intervals
))
660 copy_text_properties (make_number (0), thislen
, this,
661 make_number (toindex
), val
, Qnil
);
663 /* Between strings of the same kind, copy fast. */
664 if (STRINGP (this) && STRINGP (val
)
665 && STRING_MULTIBYTE (this) == some_multibyte
)
667 int thislen_byte
= STRING_BYTES (XSTRING (this));
668 bcopy (XSTRING (this)->data
, XSTRING (val
)->data
+ toindex_byte
,
669 STRING_BYTES (XSTRING (this)));
672 && !ASCII_BYTE_P (XSTRING (val
)->data
[toindex_byte
- 1])
673 && !CHAR_HEAD_P (XSTRING (this)->data
[0]))
674 maybe_combine_byte
= 1;
675 toindex_byte
+= thislen_byte
;
678 /* Copy a single-byte string to a multibyte string. */
679 else if (STRINGP (this) && STRINGP (val
))
681 toindex_byte
+= copy_text (XSTRING (this)->data
,
682 XSTRING (val
)->data
+ toindex_byte
,
683 XSTRING (this)->size
, 0, 1);
687 /* Copy element by element. */
690 register Lisp_Object elt
;
692 /* Fetch next element of `this' arg into `elt', or break if
693 `this' is exhausted. */
694 if (NILP (this)) break;
696 elt
= XCONS (this)->car
, this = XCONS (this)->cdr
;
697 else if (thisindex
>= thisleni
)
699 else if (STRINGP (this))
702 if (STRING_MULTIBYTE (this))
704 FETCH_STRING_CHAR_ADVANCE (c
, this,
707 XSETFASTINT (elt
, c
);
711 XSETFASTINT (elt
, XSTRING (this)->data
[thisindex
++]);
713 && (XINT (elt
) >= 0240
714 || ! NILP (Vnonascii_translation_table
))
715 && XINT (elt
) < 0400)
717 c
= unibyte_char_to_multibyte (XINT (elt
));
722 else if (BOOL_VECTOR_P (this))
725 byte
= XBOOL_VECTOR (this)->data
[thisindex
/ BITS_PER_CHAR
];
726 if (byte
& (1 << (thisindex
% BITS_PER_CHAR
)))
733 elt
= XVECTOR (this)->contents
[thisindex
++];
735 /* Store this element into the result. */
738 XCONS (tail
)->car
= elt
;
740 tail
= XCONS (tail
)->cdr
;
742 else if (VECTORP (val
))
743 XVECTOR (val
)->contents
[toindex
++] = elt
;
746 CHECK_NUMBER (elt
, 0);
747 if (SINGLE_BYTE_CHAR_P (XINT (elt
)))
751 && !ASCII_BYTE_P (XSTRING (val
)->data
[toindex_byte
- 1])
752 && !CHAR_HEAD_P (XINT (elt
)))
753 maybe_combine_byte
= 1;
754 XSTRING (val
)->data
[toindex_byte
++] = XINT (elt
);
758 /* If we have any multibyte characters,
759 we already decided to make a multibyte string. */
762 unsigned char work
[4], *str
;
763 int i
= CHAR_STRING (c
, work
, str
);
765 /* P exists as a variable
766 to avoid a bug on the Masscomp C compiler. */
767 unsigned char *p
= & XSTRING (val
)->data
[toindex_byte
];
776 XCONS (prev
)->cdr
= last_tail
;
778 if (maybe_combine_byte
)
779 /* Character counter of the multibyte string VAL may be wrong
780 because of byte combining problem. We must re-calculate it. */
781 XSTRING (val
)->size
= multibyte_chars_in_text (XSTRING (val
)->data
,
782 XSTRING (val
)->size_byte
);
787 static Lisp_Object string_char_byte_cache_string
;
788 static int string_char_byte_cache_charpos
;
789 static int string_char_byte_cache_bytepos
;
792 clear_string_char_byte_cache ()
794 string_char_byte_cache_string
= Qnil
;
797 /* Return the character index corresponding to CHAR_INDEX in STRING. */
800 string_char_to_byte (string
, char_index
)
805 int best_below
, best_below_byte
;
806 int best_above
, best_above_byte
;
808 if (! STRING_MULTIBYTE (string
))
811 best_below
= best_below_byte
= 0;
812 best_above
= XSTRING (string
)->size
;
813 best_above_byte
= STRING_BYTES (XSTRING (string
));
815 if (EQ (string
, string_char_byte_cache_string
))
817 if (string_char_byte_cache_charpos
< char_index
)
819 best_below
= string_char_byte_cache_charpos
;
820 best_below_byte
= string_char_byte_cache_bytepos
;
824 best_above
= string_char_byte_cache_charpos
;
825 best_above_byte
= string_char_byte_cache_bytepos
;
829 if (char_index
- best_below
< best_above
- char_index
)
831 while (best_below
< char_index
)
834 FETCH_STRING_CHAR_ADVANCE (c
, string
, best_below
, best_below_byte
);
837 i_byte
= best_below_byte
;
841 while (best_above
> char_index
)
843 int best_above_byte_saved
= --best_above_byte
;
845 while (best_above_byte
> 0
846 && !CHAR_HEAD_P (XSTRING (string
)->data
[best_above_byte
]))
848 if (!BASE_LEADING_CODE_P (XSTRING (string
)->data
[best_above_byte
]))
849 best_above_byte
= best_above_byte_saved
;
853 i_byte
= best_above_byte
;
856 string_char_byte_cache_bytepos
= i_byte
;
857 string_char_byte_cache_charpos
= i
;
858 string_char_byte_cache_string
= string
;
863 /* Return the character index corresponding to BYTE_INDEX in STRING. */
866 string_byte_to_char (string
, byte_index
)
871 int best_below
, best_below_byte
;
872 int best_above
, best_above_byte
;
874 if (! STRING_MULTIBYTE (string
))
877 best_below
= best_below_byte
= 0;
878 best_above
= XSTRING (string
)->size
;
879 best_above_byte
= STRING_BYTES (XSTRING (string
));
881 if (EQ (string
, string_char_byte_cache_string
))
883 if (string_char_byte_cache_bytepos
< byte_index
)
885 best_below
= string_char_byte_cache_charpos
;
886 best_below_byte
= string_char_byte_cache_bytepos
;
890 best_above
= string_char_byte_cache_charpos
;
891 best_above_byte
= string_char_byte_cache_bytepos
;
895 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
897 while (best_below_byte
< byte_index
)
900 FETCH_STRING_CHAR_ADVANCE (c
, string
, best_below
, best_below_byte
);
903 i_byte
= best_below_byte
;
907 while (best_above_byte
> byte_index
)
909 int best_above_byte_saved
= --best_above_byte
;
911 while (best_above_byte
> 0
912 && !CHAR_HEAD_P (XSTRING (string
)->data
[best_above_byte
]))
914 if (!BASE_LEADING_CODE_P (XSTRING (string
)->data
[best_above_byte
]))
915 best_above_byte
= best_above_byte_saved
;
919 i_byte
= best_above_byte
;
922 string_char_byte_cache_bytepos
= i_byte
;
923 string_char_byte_cache_charpos
= i
;
924 string_char_byte_cache_string
= string
;
929 /* Convert STRING to a multibyte string.
930 Single-byte characters 0240 through 0377 are converted
931 by adding nonascii_insert_offset to each. */
934 string_make_multibyte (string
)
940 if (STRING_MULTIBYTE (string
))
943 nbytes
= count_size_as_multibyte (XSTRING (string
)->data
,
944 XSTRING (string
)->size
);
945 /* If all the chars are ASCII, they won't need any more bytes
946 once converted. In that case, we can return STRING itself. */
947 if (nbytes
== STRING_BYTES (XSTRING (string
)))
950 buf
= (unsigned char *) alloca (nbytes
);
951 copy_text (XSTRING (string
)->data
, buf
, STRING_BYTES (XSTRING (string
)),
954 return make_multibyte_string (buf
, XSTRING (string
)->size
, nbytes
);
957 /* Convert STRING to a single-byte string. */
960 string_make_unibyte (string
)
965 if (! STRING_MULTIBYTE (string
))
968 buf
= (unsigned char *) alloca (XSTRING (string
)->size
);
970 copy_text (XSTRING (string
)->data
, buf
, STRING_BYTES (XSTRING (string
)),
973 return make_unibyte_string (buf
, XSTRING (string
)->size
);
976 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
978 "Return the multibyte equivalent of STRING.\n\
979 The function `unibyte-char-to-multibyte' is used to convert\n\
980 each unibyte character to a multibyte character.")
984 CHECK_STRING (string
, 0);
986 return string_make_multibyte (string
);
989 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
991 "Return the unibyte equivalent of STRING.\n\
992 Multibyte character codes are converted to unibyte\n\
993 by using just the low 8 bits.")
997 CHECK_STRING (string
, 0);
999 return string_make_unibyte (string
);
1002 DEFUN ("string-as-unibyte", Fstring_as_unibyte
, Sstring_as_unibyte
,
1004 "Return a unibyte string with the same individual bytes as STRING.\n\
1005 If STRING is unibyte, the result is STRING itself.\n\
1006 Otherwise it is a newly created string, with no text properties.")
1010 CHECK_STRING (string
, 0);
1012 if (STRING_MULTIBYTE (string
))
1014 string
= Fcopy_sequence (string
);
1015 XSTRING (string
)->size
= STRING_BYTES (XSTRING (string
));
1016 XSTRING (string
)->intervals
= NULL_INTERVAL
;
1017 SET_STRING_BYTES (XSTRING (string
), -1);
1022 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1024 "Return a multibyte string with the same individual bytes as STRING.\n\
1025 If STRING is multibyte, the result is STRING itself.\n\
1026 Otherwise it is a newly created string, with no text properties.")
1030 CHECK_STRING (string
, 0);
1032 if (! STRING_MULTIBYTE (string
))
1034 int nbytes
= STRING_BYTES (XSTRING (string
));
1035 int newlen
= multibyte_chars_in_text (XSTRING (string
)->data
, nbytes
);
1037 string
= Fcopy_sequence (string
);
1038 XSTRING (string
)->size
= newlen
;
1039 XSTRING (string
)->size_byte
= nbytes
;
1040 XSTRING (string
)->intervals
= NULL_INTERVAL
;
1045 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1046 "Return a copy of ALIST.\n\
1047 This is an alist which represents the same mapping from objects to objects,\n\
1048 but does not share the alist structure with ALIST.\n\
1049 The objects mapped (cars and cdrs of elements of the alist)\n\
1050 are shared, however.\n\
1051 Elements of ALIST that are not conses are also shared.")
1055 register Lisp_Object tem
;
1057 CHECK_LIST (alist
, 0);
1060 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1061 for (tem
= alist
; CONSP (tem
); tem
= XCONS (tem
)->cdr
)
1063 register Lisp_Object car
;
1064 car
= XCONS (tem
)->car
;
1067 XCONS (tem
)->car
= Fcons (XCONS (car
)->car
, XCONS (car
)->cdr
);
1072 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
1073 "Return a substring of STRING, starting at index FROM and ending before TO.\n\
1074 TO may be nil or omitted; then the substring runs to the end of STRING.\n\
1075 If FROM or TO is negative, it counts from the end.\n\
1077 This function allows vectors as well as strings.")
1080 register Lisp_Object from
, to
;
1085 int from_char
, to_char
;
1086 int from_byte
, to_byte
;
1088 if (! (STRINGP (string
) || VECTORP (string
)))
1089 wrong_type_argument (Qarrayp
, string
);
1091 CHECK_NUMBER (from
, 1);
1093 if (STRINGP (string
))
1095 size
= XSTRING (string
)->size
;
1096 size_byte
= STRING_BYTES (XSTRING (string
));
1099 size
= XVECTOR (string
)->size
;
1104 to_byte
= size_byte
;
1108 CHECK_NUMBER (to
, 2);
1110 to_char
= XINT (to
);
1114 if (STRINGP (string
))
1115 to_byte
= string_char_to_byte (string
, to_char
);
1118 from_char
= XINT (from
);
1121 if (STRINGP (string
))
1122 from_byte
= string_char_to_byte (string
, from_char
);
1124 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1125 args_out_of_range_3 (string
, make_number (from_char
),
1126 make_number (to_char
));
1128 if (STRINGP (string
))
1130 res
= make_specified_string (XSTRING (string
)->data
+ from_byte
,
1131 to_char
- from_char
, to_byte
- from_byte
,
1132 STRING_MULTIBYTE (string
));
1133 copy_text_properties (make_number (from_char
), make_number (to_char
),
1134 string
, make_number (0), res
, Qnil
);
1137 res
= Fvector (to_char
- from_char
,
1138 XVECTOR (string
)->contents
+ from_char
);
1143 /* Extract a substring of STRING, giving start and end positions
1144 both in characters and in bytes. */
1147 substring_both (string
, from
, from_byte
, to
, to_byte
)
1149 int from
, from_byte
, to
, to_byte
;
1155 if (! (STRINGP (string
) || VECTORP (string
)))
1156 wrong_type_argument (Qarrayp
, string
);
1158 if (STRINGP (string
))
1160 size
= XSTRING (string
)->size
;
1161 size_byte
= STRING_BYTES (XSTRING (string
));
1164 size
= XVECTOR (string
)->size
;
1166 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1167 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1169 if (STRINGP (string
))
1171 res
= make_specified_string (XSTRING (string
)->data
+ from_byte
,
1172 to
- from
, to_byte
- from_byte
,
1173 STRING_MULTIBYTE (string
));
1174 copy_text_properties (make_number (from
), make_number (to
),
1175 string
, make_number (0), res
, Qnil
);
1178 res
= Fvector (to
- from
,
1179 XVECTOR (string
)->contents
+ from
);
1184 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1185 "Take cdr N times on LIST, returns the result.")
1188 register Lisp_Object list
;
1190 register int i
, num
;
1191 CHECK_NUMBER (n
, 0);
1193 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1201 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1202 "Return the Nth element of LIST.\n\
1203 N counts from zero. If LIST is not that long, nil is returned.")
1205 Lisp_Object n
, list
;
1207 return Fcar (Fnthcdr (n
, list
));
1210 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1211 "Return element of SEQUENCE at index N.")
1213 register Lisp_Object sequence
, n
;
1215 CHECK_NUMBER (n
, 0);
1218 if (CONSP (sequence
) || NILP (sequence
))
1219 return Fcar (Fnthcdr (n
, sequence
));
1220 else if (STRINGP (sequence
) || VECTORP (sequence
)
1221 || BOOL_VECTOR_P (sequence
) || CHAR_TABLE_P (sequence
))
1222 return Faref (sequence
, n
);
1224 sequence
= wrong_type_argument (Qsequencep
, sequence
);
1228 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1229 "Return non-nil if ELT is an element of LIST. Comparison done with `equal'.\n\
1230 The value is actually the tail of LIST whose car is ELT.")
1232 register Lisp_Object elt
;
1235 register Lisp_Object tail
;
1236 for (tail
= list
; !NILP (tail
); tail
= XCONS (tail
)->cdr
)
1238 register Lisp_Object tem
;
1240 if (! NILP (Fequal (elt
, tem
)))
1247 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1248 "Return non-nil if ELT is an element of LIST. Comparison done with EQ.\n\
1249 The value is actually the tail of LIST whose car is ELT.")
1251 register Lisp_Object elt
;
1254 register Lisp_Object tail
;
1255 for (tail
= list
; !NILP (tail
); tail
= XCONS (tail
)->cdr
)
1257 register Lisp_Object tem
;
1259 if (EQ (elt
, tem
)) return tail
;
1265 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1266 "Return non-nil if KEY is `eq' to the car of an element of LIST.\n\
1267 The value is actually the element of LIST whose car is KEY.\n\
1268 Elements of LIST that are not conses are ignored.")
1270 register Lisp_Object key
;
1273 register Lisp_Object tail
;
1274 for (tail
= list
; !NILP (tail
); tail
= XCONS (tail
)->cdr
)
1276 register Lisp_Object elt
, tem
;
1278 if (!CONSP (elt
)) continue;
1279 tem
= XCONS (elt
)->car
;
1280 if (EQ (key
, tem
)) return elt
;
1286 /* Like Fassq but never report an error and do not allow quits.
1287 Use only on lists known never to be circular. */
1290 assq_no_quit (key
, list
)
1291 register Lisp_Object key
;
1294 register Lisp_Object tail
;
1295 for (tail
= list
; CONSP (tail
); tail
= XCONS (tail
)->cdr
)
1297 register Lisp_Object elt
, tem
;
1299 if (!CONSP (elt
)) continue;
1300 tem
= XCONS (elt
)->car
;
1301 if (EQ (key
, tem
)) return elt
;
1306 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1307 "Return non-nil if KEY is `equal' to the car of an element of LIST.\n\
1308 The value is actually the element of LIST whose car equals KEY.")
1310 register Lisp_Object key
;
1313 register Lisp_Object tail
;
1314 for (tail
= list
; !NILP (tail
); tail
= XCONS (tail
)->cdr
)
1316 register Lisp_Object elt
, tem
;
1318 if (!CONSP (elt
)) continue;
1319 tem
= Fequal (XCONS (elt
)->car
, key
);
1320 if (!NILP (tem
)) return elt
;
1326 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1327 "Return non-nil if ELT is `eq' to the cdr of an element of LIST.\n\
1328 The value is actually the element of LIST whose cdr is ELT.")
1330 register Lisp_Object key
;
1333 register Lisp_Object tail
;
1334 for (tail
= list
; !NILP (tail
); tail
= XCONS (tail
)->cdr
)
1336 register Lisp_Object elt
, tem
;
1338 if (!CONSP (elt
)) continue;
1339 tem
= XCONS (elt
)->cdr
;
1340 if (EQ (key
, tem
)) return elt
;
1346 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1347 "Return non-nil if KEY is `equal' to the cdr of an element of LIST.\n\
1348 The value is actually the element of LIST whose cdr equals KEY.")
1350 register Lisp_Object key
;
1353 register Lisp_Object tail
;
1354 for (tail
= list
; !NILP (tail
); tail
= XCONS (tail
)->cdr
)
1356 register Lisp_Object elt
, tem
;
1358 if (!CONSP (elt
)) continue;
1359 tem
= Fequal (XCONS (elt
)->cdr
, key
);
1360 if (!NILP (tem
)) return elt
;
1366 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1367 "Delete by side effect any occurrences of ELT as a member of LIST.\n\
1368 The modified LIST is returned. Comparison is done with `eq'.\n\
1369 If the first member of LIST is ELT, there is no way to remove it by side effect;\n\
1370 therefore, write `(setq foo (delq element foo))'\n\
1371 to be sure of changing the value of `foo'.")
1373 register Lisp_Object elt
;
1376 register Lisp_Object tail
, prev
;
1377 register Lisp_Object tem
;
1381 while (!NILP (tail
))
1387 list
= XCONS (tail
)->cdr
;
1389 Fsetcdr (prev
, XCONS (tail
)->cdr
);
1393 tail
= XCONS (tail
)->cdr
;
1399 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1400 "Delete by side effect any occurrences of ELT as a member of LIST.\n\
1401 The modified LIST is returned. Comparison is done with `equal'.\n\
1402 If the first member of LIST is ELT, deleting it is not a side effect;\n\
1403 it is simply using a different list.\n\
1404 Therefore, write `(setq foo (delete element foo))'\n\
1405 to be sure of changing the value of `foo'.")
1407 register Lisp_Object elt
;
1410 register Lisp_Object tail
, prev
;
1411 register Lisp_Object tem
;
1415 while (!NILP (tail
))
1418 if (! NILP (Fequal (elt
, tem
)))
1421 list
= XCONS (tail
)->cdr
;
1423 Fsetcdr (prev
, XCONS (tail
)->cdr
);
1427 tail
= XCONS (tail
)->cdr
;
1433 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1434 "Reverse LIST by modifying cdr pointers.\n\
1435 Returns the beginning of the reversed list.")
1439 register Lisp_Object prev
, tail
, next
;
1441 if (NILP (list
)) return list
;
1444 while (!NILP (tail
))
1448 Fsetcdr (tail
, prev
);
1455 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1456 "Reverse LIST, copying. Returns the beginning of the reversed list.\n\
1457 See also the function `nreverse', which is used more often.")
1463 for (new = Qnil
; CONSP (list
); list
= XCONS (list
)->cdr
)
1464 new = Fcons (XCONS (list
)->car
, new);
1466 wrong_type_argument (Qconsp
, list
);
1470 Lisp_Object
merge ();
1472 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1473 "Sort LIST, stably, comparing elements using PREDICATE.\n\
1474 Returns the sorted list. LIST is modified by side effects.\n\
1475 PREDICATE is called with two elements of LIST, and should return T\n\
1476 if the first element is \"less\" than the second.")
1478 Lisp_Object list
, predicate
;
1480 Lisp_Object front
, back
;
1481 register Lisp_Object len
, tem
;
1482 struct gcpro gcpro1
, gcpro2
;
1483 register int length
;
1486 len
= Flength (list
);
1487 length
= XINT (len
);
1491 XSETINT (len
, (length
/ 2) - 1);
1492 tem
= Fnthcdr (len
, list
);
1494 Fsetcdr (tem
, Qnil
);
1496 GCPRO2 (front
, back
);
1497 front
= Fsort (front
, predicate
);
1498 back
= Fsort (back
, predicate
);
1500 return merge (front
, back
, predicate
);
1504 merge (org_l1
, org_l2
, pred
)
1505 Lisp_Object org_l1
, org_l2
;
1509 register Lisp_Object tail
;
1511 register Lisp_Object l1
, l2
;
1512 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1519 /* It is sufficient to protect org_l1 and org_l2.
1520 When l1 and l2 are updated, we copy the new values
1521 back into the org_ vars. */
1522 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1542 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1558 Fsetcdr (tail
, tem
);
1564 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1565 "Extract a value from a property list.\n\
1566 PLIST is a property list, which is a list of the form\n\
1567 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value\n\
1568 corresponding to the given PROP, or nil if PROP is not\n\
1569 one of the properties on the list.")
1572 register Lisp_Object prop
;
1574 register Lisp_Object tail
;
1575 for (tail
= plist
; !NILP (tail
); tail
= Fcdr (XCONS (tail
)->cdr
))
1577 register Lisp_Object tem
;
1580 return Fcar (XCONS (tail
)->cdr
);
1585 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
1586 "Return the value of SYMBOL's PROPNAME property.\n\
1587 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'.")
1589 Lisp_Object symbol
, propname
;
1591 CHECK_SYMBOL (symbol
, 0);
1592 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
1595 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
1596 "Change value in PLIST of PROP to VAL.\n\
1597 PLIST is a property list, which is a list of the form\n\
1598 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.\n\
1599 If PROP is already a property on the list, its value is set to VAL,\n\
1600 otherwise the new PROP VAL pair is added. The new plist is returned;\n\
1601 use `(setq x (plist-put x prop val))' to be sure to use the new value.\n\
1602 The PLIST is modified by side effects.")
1605 register Lisp_Object prop
;
1608 register Lisp_Object tail
, prev
;
1609 Lisp_Object newcell
;
1611 for (tail
= plist
; CONSP (tail
) && CONSP (XCONS (tail
)->cdr
);
1612 tail
= XCONS (XCONS (tail
)->cdr
)->cdr
)
1614 if (EQ (prop
, XCONS (tail
)->car
))
1616 Fsetcar (XCONS (tail
)->cdr
, val
);
1621 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
1625 Fsetcdr (XCONS (prev
)->cdr
, newcell
);
1629 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
1630 "Store SYMBOL's PROPNAME property with value VALUE.\n\
1631 It can be retrieved with `(get SYMBOL PROPNAME)'.")
1632 (symbol
, propname
, value
)
1633 Lisp_Object symbol
, propname
, value
;
1635 CHECK_SYMBOL (symbol
, 0);
1636 XSYMBOL (symbol
)->plist
1637 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
1641 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
1642 "Return t if two Lisp objects have similar structure and contents.\n\
1643 They must have the same data type.\n\
1644 Conses are compared by comparing the cars and the cdrs.\n\
1645 Vectors and strings are compared element by element.\n\
1646 Numbers are compared by value, but integers cannot equal floats.\n\
1647 (Use `=' if you want integers and floats to be able to be equal.)\n\
1648 Symbols must match exactly.")
1650 register Lisp_Object o1
, o2
;
1652 return internal_equal (o1
, o2
, 0) ? Qt
: Qnil
;
1656 internal_equal (o1
, o2
, depth
)
1657 register Lisp_Object o1
, o2
;
1661 error ("Stack overflow in equal");
1667 if (XTYPE (o1
) != XTYPE (o2
))
1672 #ifdef LISP_FLOAT_TYPE
1674 return (extract_float (o1
) == extract_float (o2
));
1678 if (!internal_equal (XCONS (o1
)->car
, XCONS (o2
)->car
, depth
+ 1))
1680 o1
= XCONS (o1
)->cdr
;
1681 o2
= XCONS (o2
)->cdr
;
1685 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
1689 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o1
),
1691 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o1
),
1694 o1
= XOVERLAY (o1
)->plist
;
1695 o2
= XOVERLAY (o2
)->plist
;
1700 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
1701 && (XMARKER (o1
)->buffer
== 0
1702 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
1706 case Lisp_Vectorlike
:
1708 register int i
, size
;
1709 size
= XVECTOR (o1
)->size
;
1710 /* Pseudovectors have the type encoded in the size field, so this test
1711 actually checks that the objects have the same type as well as the
1713 if (XVECTOR (o2
)->size
!= size
)
1715 /* Boolvectors are compared much like strings. */
1716 if (BOOL_VECTOR_P (o1
))
1719 = (XBOOL_VECTOR (o1
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
1721 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
1723 if (bcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
1728 if (WINDOW_CONFIGURATIONP (o1
))
1729 return compare_window_configurations (o1
, o2
, 0);
1731 /* Aside from them, only true vectors, char-tables, and compiled
1732 functions are sensible to compare, so eliminate the others now. */
1733 if (size
& PSEUDOVECTOR_FLAG
)
1735 if (!(size
& (PVEC_COMPILED
| PVEC_CHAR_TABLE
)))
1737 size
&= PSEUDOVECTOR_SIZE_MASK
;
1739 for (i
= 0; i
< size
; i
++)
1742 v1
= XVECTOR (o1
)->contents
[i
];
1743 v2
= XVECTOR (o2
)->contents
[i
];
1744 if (!internal_equal (v1
, v2
, depth
+ 1))
1752 if (XSTRING (o1
)->size
!= XSTRING (o2
)->size
)
1754 if (STRING_BYTES (XSTRING (o1
)) != STRING_BYTES (XSTRING (o2
)))
1756 if (bcmp (XSTRING (o1
)->data
, XSTRING (o2
)->data
,
1757 STRING_BYTES (XSTRING (o1
))))
1764 extern Lisp_Object
Fmake_char_internal ();
1766 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
1767 "Store each element of ARRAY with ITEM.\n\
1768 ARRAY is a vector, string, char-table, or bool-vector.")
1770 Lisp_Object array
, item
;
1772 register int size
, index
, charval
;
1774 if (VECTORP (array
))
1776 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
1777 size
= XVECTOR (array
)->size
;
1778 for (index
= 0; index
< size
; index
++)
1781 else if (CHAR_TABLE_P (array
))
1783 register Lisp_Object
*p
= XCHAR_TABLE (array
)->contents
;
1784 size
= CHAR_TABLE_ORDINARY_SLOTS
;
1785 for (index
= 0; index
< size
; index
++)
1787 XCHAR_TABLE (array
)->defalt
= Qnil
;
1789 else if (STRINGP (array
))
1791 register unsigned char *p
= XSTRING (array
)->data
;
1792 CHECK_NUMBER (item
, 1);
1793 charval
= XINT (item
);
1794 size
= XSTRING (array
)->size
;
1795 if (STRING_MULTIBYTE (array
))
1797 unsigned char workbuf
[4], *str
;
1798 int len
= CHAR_STRING (charval
, workbuf
, str
);
1799 int size_byte
= STRING_BYTES (XSTRING (array
));
1800 unsigned char *p1
= p
, *endp
= p
+ size_byte
;
1803 if (size
!= size_byte
)
1806 int this_len
= MULTIBYTE_FORM_LENGTH (p1
, endp
- p1
);
1807 if (len
!= this_len
)
1808 error ("Attempt to change byte length of a string");
1811 for (i
= 0; i
< size_byte
; i
++)
1812 *p
++ = str
[i
% len
];
1815 for (index
= 0; index
< size
; index
++)
1818 else if (BOOL_VECTOR_P (array
))
1820 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
1822 = (XBOOL_VECTOR (array
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
1824 charval
= (! NILP (item
) ? -1 : 0);
1825 for (index
= 0; index
< size_in_chars
; index
++)
1830 array
= wrong_type_argument (Qarrayp
, array
);
1836 DEFUN ("char-table-subtype", Fchar_table_subtype
, Schar_table_subtype
,
1838 "Return the subtype of char-table CHAR-TABLE. The value is a symbol.")
1840 Lisp_Object char_table
;
1842 CHECK_CHAR_TABLE (char_table
, 0);
1844 return XCHAR_TABLE (char_table
)->purpose
;
1847 DEFUN ("char-table-parent", Fchar_table_parent
, Schar_table_parent
,
1849 "Return the parent char-table of CHAR-TABLE.\n\
1850 The value is either nil or another char-table.\n\
1851 If CHAR-TABLE holds nil for a given character,\n\
1852 then the actual applicable value is inherited from the parent char-table\n\
1853 \(or from its parents, if necessary).")
1855 Lisp_Object char_table
;
1857 CHECK_CHAR_TABLE (char_table
, 0);
1859 return XCHAR_TABLE (char_table
)->parent
;
1862 DEFUN ("set-char-table-parent", Fset_char_table_parent
, Sset_char_table_parent
,
1864 "Set the parent char-table of CHAR-TABLE to PARENT.\n\
1865 PARENT must be either nil or another char-table.")
1866 (char_table
, parent
)
1867 Lisp_Object char_table
, parent
;
1871 CHECK_CHAR_TABLE (char_table
, 0);
1875 CHECK_CHAR_TABLE (parent
, 0);
1877 for (temp
= parent
; !NILP (temp
); temp
= XCHAR_TABLE (temp
)->parent
)
1878 if (EQ (temp
, char_table
))
1879 error ("Attempt to make a chartable be its own parent");
1882 XCHAR_TABLE (char_table
)->parent
= parent
;
1887 DEFUN ("char-table-extra-slot", Fchar_table_extra_slot
, Schar_table_extra_slot
,
1889 "Return the value of CHAR-TABLE's extra-slot number N.")
1891 Lisp_Object char_table
, n
;
1893 CHECK_CHAR_TABLE (char_table
, 1);
1894 CHECK_NUMBER (n
, 2);
1896 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
1897 args_out_of_range (char_table
, n
);
1899 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)];
1902 DEFUN ("set-char-table-extra-slot", Fset_char_table_extra_slot
,
1903 Sset_char_table_extra_slot
,
1905 "Set CHAR-TABLE's extra-slot number N to VALUE.")
1906 (char_table
, n
, value
)
1907 Lisp_Object char_table
, n
, value
;
1909 CHECK_CHAR_TABLE (char_table
, 1);
1910 CHECK_NUMBER (n
, 2);
1912 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
1913 args_out_of_range (char_table
, n
);
1915 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)] = value
;
1918 DEFUN ("char-table-range", Fchar_table_range
, Schar_table_range
,
1920 "Return the value in CHAR-TABLE for a range of characters RANGE.\n\
1921 RANGE should be nil (for the default value)\n\
1922 a vector which identifies a character set or a row of a character set,\n\
1923 a character set name, or a character code.")
1925 Lisp_Object char_table
, range
;
1929 CHECK_CHAR_TABLE (char_table
, 0);
1931 if (EQ (range
, Qnil
))
1932 return XCHAR_TABLE (char_table
)->defalt
;
1933 else if (INTEGERP (range
))
1934 return Faref (char_table
, range
);
1935 else if (SYMBOLP (range
))
1937 Lisp_Object charset_info
;
1939 charset_info
= Fget (range
, Qcharset
);
1940 CHECK_VECTOR (charset_info
, 0);
1942 return Faref (char_table
,
1943 make_number (XINT (XVECTOR (charset_info
)->contents
[0])
1946 else if (VECTORP (range
))
1948 if (XVECTOR (range
)->size
== 1)
1949 return Faref (char_table
,
1950 make_number (XINT (XVECTOR (range
)->contents
[0]) + 128));
1953 int size
= XVECTOR (range
)->size
;
1954 Lisp_Object
*val
= XVECTOR (range
)->contents
;
1955 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
1956 size
<= 1 ? Qnil
: val
[1],
1957 size
<= 2 ? Qnil
: val
[2]);
1958 return Faref (char_table
, ch
);
1962 error ("Invalid RANGE argument to `char-table-range'");
1965 DEFUN ("set-char-table-range", Fset_char_table_range
, Sset_char_table_range
,
1967 "Set the value in CHAR-TABLE for a range of characters RANGE to VALUE.\n\
1968 RANGE should be t (for all characters), nil (for the default value)\n\
1969 a vector which identifies a character set or a row of a character set,\n\
1970 a coding system, or a character code.")
1971 (char_table
, range
, value
)
1972 Lisp_Object char_table
, range
, value
;
1976 CHECK_CHAR_TABLE (char_table
, 0);
1979 for (i
= 0; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
1980 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
1981 else if (EQ (range
, Qnil
))
1982 XCHAR_TABLE (char_table
)->defalt
= value
;
1983 else if (SYMBOLP (range
))
1985 Lisp_Object charset_info
;
1987 charset_info
= Fget (range
, Qcharset
);
1988 CHECK_VECTOR (charset_info
, 0);
1990 return Faset (char_table
,
1991 make_number (XINT (XVECTOR (charset_info
)->contents
[0])
1995 else if (INTEGERP (range
))
1996 Faset (char_table
, range
, value
);
1997 else if (VECTORP (range
))
1999 if (XVECTOR (range
)->size
== 1)
2000 return Faset (char_table
,
2001 make_number (XINT (XVECTOR (range
)->contents
[0]) + 128),
2005 int size
= XVECTOR (range
)->size
;
2006 Lisp_Object
*val
= XVECTOR (range
)->contents
;
2007 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
2008 size
<= 1 ? Qnil
: val
[1],
2009 size
<= 2 ? Qnil
: val
[2]);
2010 return Faset (char_table
, ch
, value
);
2014 error ("Invalid RANGE argument to `set-char-table-range'");
2019 DEFUN ("set-char-table-default", Fset_char_table_default
,
2020 Sset_char_table_default
, 3, 3, 0,
2021 "Set the default value in CHAR-TABLE for a generic character CHAR to VALUE.\n\
2022 The generic character specifies the group of characters.\n\
2023 See also the documentation of make-char.")
2024 (char_table
, ch
, value
)
2025 Lisp_Object char_table
, ch
, value
;
2027 int c
, i
, charset
, code1
, code2
;
2030 CHECK_CHAR_TABLE (char_table
, 0);
2031 CHECK_NUMBER (ch
, 1);
2034 SPLIT_NON_ASCII_CHAR (c
, charset
, code1
, code2
);
2036 /* Since we may want to set the default value for a character set
2037 not yet defined, we check only if the character set is in the
2038 valid range or not, instead of it is already defined or not. */
2039 if (! CHARSET_VALID_P (charset
))
2040 invalid_character (c
);
2042 if (charset
== CHARSET_ASCII
)
2043 return (XCHAR_TABLE (char_table
)->defalt
= value
);
2045 /* Even if C is not a generic char, we had better behave as if a
2046 generic char is specified. */
2047 if (charset
== CHARSET_COMPOSITION
|| CHARSET_DIMENSION (charset
) == 1)
2049 temp
= XCHAR_TABLE (char_table
)->contents
[charset
+ 128];
2052 if (SUB_CHAR_TABLE_P (temp
))
2053 XCHAR_TABLE (temp
)->defalt
= value
;
2055 XCHAR_TABLE (char_table
)->contents
[charset
+ 128] = value
;
2059 if (! SUB_CHAR_TABLE_P (char_table
))
2060 char_table
= (XCHAR_TABLE (char_table
)->contents
[charset
+ 128]
2061 = make_sub_char_table (temp
));
2062 temp
= XCHAR_TABLE (char_table
)->contents
[code1
];
2063 if (SUB_CHAR_TABLE_P (temp
))
2064 XCHAR_TABLE (temp
)->defalt
= value
;
2066 XCHAR_TABLE (char_table
)->contents
[code1
] = value
;
2070 /* Look up the element in TABLE at index CH,
2071 and return it as an integer.
2072 If the element is nil, return CH itself.
2073 (Actually we do that for any non-integer.) */
2076 char_table_translate (table
, ch
)
2081 value
= Faref (table
, make_number (ch
));
2082 if (! INTEGERP (value
))
2084 return XINT (value
);
2087 /* Map C_FUNCTION or FUNCTION over SUBTABLE, calling it for each
2088 character or group of characters that share a value.
2089 DEPTH is the current depth in the originally specified
2090 chartable, and INDICES contains the vector indices
2091 for the levels our callers have descended.
2093 ARG is passed to C_FUNCTION when that is called. */
2096 map_char_table (c_function
, function
, subtable
, arg
, depth
, indices
)
2097 void (*c_function
) P_ ((Lisp_Object
, Lisp_Object
, Lisp_Object
));
2098 Lisp_Object function
, subtable
, arg
, *indices
;
2105 /* At first, handle ASCII and 8-bit European characters. */
2106 for (i
= 0; i
< CHAR_TABLE_SINGLE_BYTE_SLOTS
; i
++)
2108 Lisp_Object elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2110 (*c_function
) (arg
, make_number (i
), elt
);
2112 call2 (function
, make_number (i
), elt
);
2114 #if 0 /* If the char table has entries for higher characters,
2115 we should report them. */
2116 if (NILP (current_buffer
->enable_multibyte_characters
))
2119 to
= CHAR_TABLE_ORDINARY_SLOTS
;
2124 to
= SUB_CHAR_TABLE_ORDINARY_SLOTS
;
2129 Lisp_Object elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2131 XSETFASTINT (indices
[depth
], i
);
2133 if (SUB_CHAR_TABLE_P (elt
))
2136 error ("Too deep char table");
2137 map_char_table (c_function
, function
, elt
, arg
, depth
+ 1, indices
);
2141 int charset
= XFASTINT (indices
[0]) - 128, c1
, c2
, c
;
2143 if (CHARSET_DEFINED_P (charset
))
2145 c1
= depth
>= 1 ? XFASTINT (indices
[1]) : 0;
2146 c2
= depth
>= 2 ? XFASTINT (indices
[2]) : 0;
2147 c
= MAKE_NON_ASCII_CHAR (charset
, c1
, c2
);
2149 (*c_function
) (arg
, make_number (c
), elt
);
2151 call2 (function
, make_number (c
), elt
);
2157 DEFUN ("map-char-table", Fmap_char_table
, Smap_char_table
,
2159 "Call FUNCTION for each (normal and generic) characters in CHAR-TABLE.\n\
2160 FUNCTION is called with two arguments--a key and a value.\n\
2161 The key is always a possible IDX argument to `aref'.")
2162 (function
, char_table
)
2163 Lisp_Object function
, char_table
;
2165 /* The depth of char table is at most 3. */
2166 Lisp_Object indices
[3];
2168 CHECK_CHAR_TABLE (char_table
, 1);
2170 map_char_table (NULL
, function
, char_table
, char_table
, 0, indices
);
2180 Lisp_Object args
[2];
2183 return Fnconc (2, args
);
2185 return Fnconc (2, &s1
);
2186 #endif /* NO_ARG_ARRAY */
2189 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2190 "Concatenate any number of lists by altering them.\n\
2191 Only the last argument is not altered, and need not be a list.")
2196 register int argnum
;
2197 register Lisp_Object tail
, tem
, val
;
2201 for (argnum
= 0; argnum
< nargs
; argnum
++)
2204 if (NILP (tem
)) continue;
2209 if (argnum
+ 1 == nargs
) break;
2212 tem
= wrong_type_argument (Qlistp
, tem
);
2221 tem
= args
[argnum
+ 1];
2222 Fsetcdr (tail
, tem
);
2224 args
[argnum
+ 1] = tail
;
2230 /* This is the guts of all mapping functions.
2231 Apply FN to each element of SEQ, one by one,
2232 storing the results into elements of VALS, a C vector of Lisp_Objects.
2233 LENI is the length of VALS, which should also be the length of SEQ. */
2236 mapcar1 (leni
, vals
, fn
, seq
)
2239 Lisp_Object fn
, seq
;
2241 register Lisp_Object tail
;
2244 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2246 /* Don't let vals contain any garbage when GC happens. */
2247 for (i
= 0; i
< leni
; i
++)
2250 GCPRO3 (dummy
, fn
, seq
);
2252 gcpro1
.nvars
= leni
;
2253 /* We need not explicitly protect `tail' because it is used only on lists, and
2254 1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
2258 for (i
= 0; i
< leni
; i
++)
2260 dummy
= XVECTOR (seq
)->contents
[i
];
2261 vals
[i
] = call1 (fn
, dummy
);
2264 else if (BOOL_VECTOR_P (seq
))
2266 for (i
= 0; i
< leni
; i
++)
2269 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BITS_PER_CHAR
];
2270 if (byte
& (1 << (i
% BITS_PER_CHAR
)))
2275 vals
[i
] = call1 (fn
, dummy
);
2278 else if (STRINGP (seq
) && ! STRING_MULTIBYTE (seq
))
2280 /* Single-byte string. */
2281 for (i
= 0; i
< leni
; i
++)
2283 XSETFASTINT (dummy
, XSTRING (seq
)->data
[i
]);
2284 vals
[i
] = call1 (fn
, dummy
);
2287 else if (STRINGP (seq
))
2289 /* Multi-byte string. */
2290 int len_byte
= STRING_BYTES (XSTRING (seq
));
2293 for (i
= 0, i_byte
= 0; i
< leni
;)
2298 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2299 XSETFASTINT (dummy
, c
);
2300 vals
[i_before
] = call1 (fn
, dummy
);
2303 else /* Must be a list, since Flength did not get an error */
2306 for (i
= 0; i
< leni
; i
++)
2308 vals
[i
] = call1 (fn
, Fcar (tail
));
2309 tail
= XCONS (tail
)->cdr
;
2316 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2317 "Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.\n\
2318 In between each pair of results, stick in SEPARATOR. Thus, \" \" as\n\
2319 SEPARATOR results in spaces between the values returned by FUNCTION.\n\
2320 SEQUENCE may be a list, a vector, a bool-vector, or a string.")
2321 (function
, sequence
, separator
)
2322 Lisp_Object function
, sequence
, separator
;
2327 register Lisp_Object
*args
;
2329 struct gcpro gcpro1
;
2331 len
= Flength (sequence
);
2333 nargs
= leni
+ leni
- 1;
2334 if (nargs
< 0) return build_string ("");
2336 args
= (Lisp_Object
*) alloca (nargs
* sizeof (Lisp_Object
));
2339 mapcar1 (leni
, args
, function
, sequence
);
2342 for (i
= leni
- 1; i
>= 0; i
--)
2343 args
[i
+ i
] = args
[i
];
2345 for (i
= 1; i
< nargs
; i
+= 2)
2346 args
[i
] = separator
;
2348 return Fconcat (nargs
, args
);
2351 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2352 "Apply FUNCTION to each element of SEQUENCE, and make a list of the results.\n\
2353 The result is a list just as long as SEQUENCE.\n\
2354 SEQUENCE may be a list, a vector, a bool-vector, or a string.")
2355 (function
, sequence
)
2356 Lisp_Object function
, sequence
;
2358 register Lisp_Object len
;
2360 register Lisp_Object
*args
;
2362 len
= Flength (sequence
);
2363 leni
= XFASTINT (len
);
2364 args
= (Lisp_Object
*) alloca (leni
* sizeof (Lisp_Object
));
2366 mapcar1 (leni
, args
, function
, sequence
);
2368 return Flist (leni
, args
);
2371 /* Anything that calls this function must protect from GC! */
2373 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
2374 "Ask user a \"y or n\" question. Return t if answer is \"y\".\n\
2375 Takes one argument, which is the string to display to ask the question.\n\
2376 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.\n\
2377 No confirmation of the answer is requested; a single character is enough.\n\
2378 Also accepts Space to mean yes, or Delete to mean no.")
2382 register Lisp_Object obj
, key
, def
, answer_string
, map
;
2383 register int answer
;
2384 Lisp_Object xprompt
;
2385 Lisp_Object args
[2];
2386 struct gcpro gcpro1
, gcpro2
;
2387 int count
= specpdl_ptr
- specpdl
;
2389 specbind (Qcursor_in_echo_area
, Qt
);
2391 map
= Fsymbol_value (intern ("query-replace-map"));
2393 CHECK_STRING (prompt
, 0);
2395 GCPRO2 (prompt
, xprompt
);
2401 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2405 Lisp_Object pane
, menu
;
2406 redisplay_preserve_echo_area ();
2407 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2408 Fcons (Fcons (build_string ("No"), Qnil
),
2410 menu
= Fcons (prompt
, pane
);
2411 obj
= Fx_popup_dialog (Qt
, menu
);
2412 answer
= !NILP (obj
);
2415 #endif /* HAVE_MENUS */
2416 cursor_in_echo_area
= 1;
2417 choose_minibuf_frame ();
2418 message_with_string ("%s(y or n) ", xprompt
, 0);
2420 if (minibuffer_auto_raise
)
2422 Lisp_Object mini_frame
;
2424 mini_frame
= WINDOW_FRAME (XWINDOW (minibuf_window
));
2426 Fraise_frame (mini_frame
);
2429 obj
= read_filtered_event (1, 0, 0, 0);
2430 cursor_in_echo_area
= 0;
2431 /* If we need to quit, quit with cursor_in_echo_area = 0. */
2434 key
= Fmake_vector (make_number (1), obj
);
2435 def
= Flookup_key (map
, key
, Qt
);
2436 answer_string
= Fsingle_key_description (obj
);
2438 if (EQ (def
, intern ("skip")))
2443 else if (EQ (def
, intern ("act")))
2448 else if (EQ (def
, intern ("recenter")))
2454 else if (EQ (def
, intern ("quit")))
2456 /* We want to exit this command for exit-prefix,
2457 and this is the only way to do it. */
2458 else if (EQ (def
, intern ("exit-prefix")))
2463 /* If we don't clear this, then the next call to read_char will
2464 return quit_char again, and we'll enter an infinite loop. */
2469 if (EQ (xprompt
, prompt
))
2471 args
[0] = build_string ("Please answer y or n. ");
2473 xprompt
= Fconcat (2, args
);
2478 if (! noninteractive
)
2480 cursor_in_echo_area
= -1;
2481 message_with_string (answer
? "%s(y or n) y" : "%s(y or n) n",
2485 unbind_to (count
, Qnil
);
2486 return answer
? Qt
: Qnil
;
2489 /* This is how C code calls `yes-or-no-p' and allows the user
2492 Anything that calls this function must protect from GC! */
2495 do_yes_or_no_p (prompt
)
2498 return call1 (intern ("yes-or-no-p"), prompt
);
2501 /* Anything that calls this function must protect from GC! */
2503 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2504 "Ask user a yes-or-no question. Return t if answer is yes.\n\
2505 Takes one argument, which is the string to display to ask the question.\n\
2506 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.\n\
2507 The user must confirm the answer with RET,\n\
2508 and can edit it until it has been confirmed.")
2512 register Lisp_Object ans
;
2513 Lisp_Object args
[2];
2514 struct gcpro gcpro1
;
2517 CHECK_STRING (prompt
, 0);
2520 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2524 Lisp_Object pane
, menu
, obj
;
2525 redisplay_preserve_echo_area ();
2526 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2527 Fcons (Fcons (build_string ("No"), Qnil
),
2530 menu
= Fcons (prompt
, pane
);
2531 obj
= Fx_popup_dialog (Qt
, menu
);
2535 #endif /* HAVE_MENUS */
2538 args
[1] = build_string ("(yes or no) ");
2539 prompt
= Fconcat (2, args
);
2545 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2546 Qyes_or_no_p_history
, Qnil
,
2548 if (XSTRING (ans
)->size
== 3 && !strcmp (XSTRING (ans
)->data
, "yes"))
2553 if (XSTRING (ans
)->size
== 2 && !strcmp (XSTRING (ans
)->data
, "no"))
2561 message ("Please answer yes or no.");
2562 Fsleep_for (make_number (2), Qnil
);
2566 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2567 "Return list of 1 minute, 5 minute and 15 minute load averages.\n\
2568 Each of the three load averages is multiplied by 100,\n\
2569 then converted to integer.\n\
2570 When USE-FLOATS is non-nil, floats will be used instead of integers.\n\
2571 These floats are not multiplied by 100.\n\n\
2572 If the 5-minute or 15-minute load averages are not available, return a\n\
2573 shortened list, containing only those averages which are available.")
2575 Lisp_Object use_floats
;
2578 int loads
= getloadavg (load_ave
, 3);
2579 Lisp_Object ret
= Qnil
;
2582 error ("load-average not implemented for this operating system");
2586 Lisp_Object load
= (NILP (use_floats
) ?
2587 make_number ((int) (100.0 * load_ave
[loads
]))
2588 : make_float (load_ave
[loads
]));
2589 ret
= Fcons (load
, ret
);
2595 Lisp_Object Vfeatures
;
2597 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 1, 0,
2598 "Returns t if FEATURE is present in this Emacs.\n\
2599 Use this to conditionalize execution of lisp code based on the presence or\n\
2600 absence of emacs or environment extensions.\n\
2601 Use `provide' to declare that a feature is available.\n\
2602 This function looks at the value of the variable `features'.")
2604 Lisp_Object feature
;
2606 register Lisp_Object tem
;
2607 CHECK_SYMBOL (feature
, 0);
2608 tem
= Fmemq (feature
, Vfeatures
);
2609 return (NILP (tem
)) ? Qnil
: Qt
;
2612 DEFUN ("provide", Fprovide
, Sprovide
, 1, 1, 0,
2613 "Announce that FEATURE is a feature of the current Emacs.")
2615 Lisp_Object feature
;
2617 register Lisp_Object tem
;
2618 CHECK_SYMBOL (feature
, 0);
2619 if (!NILP (Vautoload_queue
))
2620 Vautoload_queue
= Fcons (Fcons (Vfeatures
, Qnil
), Vautoload_queue
);
2621 tem
= Fmemq (feature
, Vfeatures
);
2623 Vfeatures
= Fcons (feature
, Vfeatures
);
2624 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2628 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2629 "If feature FEATURE is not loaded, load it from FILENAME.\n\
2630 If FEATURE is not a member of the list `features', then the feature\n\
2631 is not loaded; so load the file FILENAME.\n\
2632 If FILENAME is omitted, the printname of FEATURE is used as the file name,\n\
2633 but in this case `load' insists on adding the suffix `.el' or `.elc'.\n\
2634 If the optional third argument NOERROR is non-nil,\n\
2635 then return nil if the file is not found.\n\
2636 Normally the return value is FEATURE.")
2637 (feature
, file_name
, noerror
)
2638 Lisp_Object feature
, file_name
, noerror
;
2640 register Lisp_Object tem
;
2641 CHECK_SYMBOL (feature
, 0);
2642 tem
= Fmemq (feature
, Vfeatures
);
2643 LOADHIST_ATTACH (Fcons (Qrequire
, feature
));
2646 int count
= specpdl_ptr
- specpdl
;
2648 /* Value saved here is to be restored into Vautoload_queue */
2649 record_unwind_protect (un_autoload
, Vautoload_queue
);
2650 Vautoload_queue
= Qt
;
2652 tem
= Fload (NILP (file_name
) ? Fsymbol_name (feature
) : file_name
,
2653 noerror
, Qt
, Qnil
, (NILP (file_name
) ? Qt
: Qnil
));
2654 /* If load failed entirely, return nil. */
2658 tem
= Fmemq (feature
, Vfeatures
);
2660 error ("Required feature %s was not provided",
2661 XSYMBOL (feature
)->name
->data
);
2663 /* Once loading finishes, don't undo it. */
2664 Vautoload_queue
= Qt
;
2665 feature
= unbind_to (count
, feature
);
2670 /* Primitives for work of the "widget" library.
2671 In an ideal world, this section would not have been necessary.
2672 However, lisp function calls being as slow as they are, it turns
2673 out that some functions in the widget library (wid-edit.el) are the
2674 bottleneck of Widget operation. Here is their translation to C,
2675 for the sole reason of efficiency. */
2677 DEFUN ("widget-plist-member", Fwidget_plist_member
, Swidget_plist_member
, 2, 2, 0,
2678 "Return non-nil if PLIST has the property PROP.\n\
2679 PLIST is a property list, which is a list of the form\n\
2680 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.\n\
2681 Unlike `plist-get', this allows you to distinguish between a missing\n\
2682 property and a property with the value nil.\n\
2683 The value is actually the tail of PLIST whose car is PROP.")
2685 Lisp_Object plist
, prop
;
2687 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
2690 plist
= XCDR (plist
);
2691 plist
= CDR (plist
);
2696 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
2697 "In WIDGET, set PROPERTY to VALUE.\n\
2698 The value can later be retrieved with `widget-get'.")
2699 (widget
, property
, value
)
2700 Lisp_Object widget
, property
, value
;
2702 CHECK_CONS (widget
, 1);
2703 XCDR (widget
) = Fplist_put (XCDR (widget
), property
, value
);
2707 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
2708 "In WIDGET, get the value of PROPERTY.\n\
2709 The value could either be specified when the widget was created, or\n\
2710 later with `widget-put'.")
2712 Lisp_Object widget
, property
;
2720 CHECK_CONS (widget
, 1);
2721 tmp
= Fwidget_plist_member (XCDR (widget
), property
);
2727 tmp
= XCAR (widget
);
2730 widget
= Fget (tmp
, Qwidget_type
);
2734 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
2735 "Apply the value of WIDGET's PROPERTY to the widget itself.\n\
2736 ARGS are passed as extra arguments to the function.")
2741 /* This function can GC. */
2742 Lisp_Object newargs
[3];
2743 struct gcpro gcpro1
, gcpro2
;
2746 newargs
[0] = Fwidget_get (args
[0], args
[1]);
2747 newargs
[1] = args
[0];
2748 newargs
[2] = Flist (nargs
- 2, args
+ 2);
2749 GCPRO2 (newargs
[0], newargs
[2]);
2750 result
= Fapply (3, newargs
);
2755 /* base64 encode/decode functions.
2756 Based on code from GNU recode. */
2758 #define MIME_LINE_LENGTH 76
2760 #define IS_ASCII(Character) \
2762 #define IS_BASE64(Character) \
2763 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
2765 /* Don't use alloca for regions larger than this, lest we overflow
2767 #define MAX_ALLOCA 16*1024
2769 /* Table of characters coding the 64 values. */
2770 static char base64_value_to_char
[64] =
2772 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
2773 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
2774 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
2775 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
2776 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
2777 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
2778 '8', '9', '+', '/' /* 60-63 */
2781 /* Table of base64 values for first 128 characters. */
2782 static short base64_char_to_value
[128] =
2784 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
2785 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
2786 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
2787 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
2788 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
2789 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
2790 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
2791 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
2792 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
2793 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
2794 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
2795 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
2796 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
2799 /* The following diagram shows the logical steps by which three octets
2800 get transformed into four base64 characters.
2802 .--------. .--------. .--------.
2803 |aaaaaabb| |bbbbcccc| |ccdddddd|
2804 `--------' `--------' `--------'
2806 .--------+--------+--------+--------.
2807 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
2808 `--------+--------+--------+--------'
2810 .--------+--------+--------+--------.
2811 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
2812 `--------+--------+--------+--------'
2814 The octets are divided into 6 bit chunks, which are then encoded into
2815 base64 characters. */
2818 static int base64_encode_1
P_ ((const char *, char *, int, int));
2819 static int base64_decode_1
P_ ((const char *, char *, int));
2821 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
2823 "Base64-encode the region between BEG and END.\n\
2824 Return the length of the encoded text.\n\
2825 Optional third argument NO-LINE-BREAK means do not break long lines\n\
2826 into shorter lines.")
2827 (beg
, end
, no_line_break
)
2828 Lisp_Object beg
, end
, no_line_break
;
2831 int allength
, length
;
2832 int ibeg
, iend
, encoded_length
;
2835 validate_region (&beg
, &end
);
2837 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
2838 iend
= CHAR_TO_BYTE (XFASTINT (end
));
2839 move_gap_both (XFASTINT (beg
), ibeg
);
2841 /* We need to allocate enough room for encoding the text.
2842 We need 33 1/3% more space, plus a newline every 76
2843 characters, and then we round up. */
2844 length
= iend
- ibeg
;
2845 allength
= length
+ length
/3 + 1;
2846 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
2848 if (allength
<= MAX_ALLOCA
)
2849 encoded
= (char *) alloca (allength
);
2851 encoded
= (char *) xmalloc (allength
);
2852 encoded_length
= base64_encode_1 (BYTE_POS_ADDR (ibeg
), encoded
, length
,
2853 NILP (no_line_break
));
2854 if (encoded_length
> allength
)
2857 /* Now we have encoded the region, so we insert the new contents
2858 and delete the old. (Insert first in order to preserve markers.) */
2859 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
2860 insert (encoded
, encoded_length
);
2861 if (allength
> MAX_ALLOCA
)
2863 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
2865 /* If point was outside of the region, restore it exactly; else just
2866 move to the beginning of the region. */
2867 if (old_pos
>= XFASTINT (end
))
2868 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
2869 else if (old_pos
> XFASTINT (beg
))
2870 old_pos
= XFASTINT (beg
);
2873 /* We return the length of the encoded text. */
2874 return make_number (encoded_length
);
2877 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
2879 "Base64-encode STRING and return the result.")
2883 int allength
, length
, encoded_length
;
2885 Lisp_Object encoded_string
;
2887 CHECK_STRING (string
, 1);
2889 length
= STRING_BYTES (XSTRING (string
));
2890 allength
= length
+ length
/3 + 1 + 6;
2892 /* We need to allocate enough room for decoding the text. */
2893 if (allength
<= MAX_ALLOCA
)
2894 encoded
= (char *) alloca (allength
);
2896 encoded
= (char *) xmalloc (allength
);
2898 encoded_length
= base64_encode_1 (XSTRING (string
)->data
,
2899 encoded
, length
, 0);
2900 if (encoded_length
> allength
)
2903 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
2904 if (allength
> MAX_ALLOCA
)
2907 return encoded_string
;
2911 base64_encode_1 (from
, to
, length
, line_break
)
2917 int counter
= 0, i
= 0;
2926 /* Wrap line every 76 characters. */
2930 if (counter
< MIME_LINE_LENGTH
/ 4)
2939 /* Process first byte of a triplet. */
2941 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
2942 value
= (0x03 & c
) << 4;
2944 /* Process second byte of a triplet. */
2948 *e
++ = base64_value_to_char
[value
];
2956 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
2957 value
= (0x0f & c
) << 2;
2959 /* Process third byte of a triplet. */
2963 *e
++ = base64_value_to_char
[value
];
2970 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
2971 *e
++ = base64_value_to_char
[0x3f & c
];
2974 /* Complete last partial line. */
2984 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
2986 "Base64-decode the region between BEG and END.\n\
2987 Return the length of the decoded text.\n\
2988 If the region can't be decoded, return nil and don't modify the buffer.")
2990 Lisp_Object beg
, end
;
2992 int ibeg
, iend
, length
;
2998 validate_region (&beg
, &end
);
3000 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3001 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3003 length
= iend
- ibeg
;
3004 /* We need to allocate enough room for decoding the text. */
3005 if (length
<= MAX_ALLOCA
)
3006 decoded
= (char *) alloca (length
);
3008 decoded
= (char *) xmalloc (length
);
3010 move_gap_both (XFASTINT (beg
), ibeg
);
3011 decoded_length
= base64_decode_1 (BYTE_POS_ADDR (ibeg
), decoded
, length
);
3012 if (decoded_length
> length
)
3015 if (decoded_length
< 0)
3016 /* The decoding wasn't possible. */
3019 /* Now we have decoded the region, so we insert the new contents
3020 and delete the old. (Insert first in order to preserve markers.) */
3021 /* We insert two spaces, then insert the decoded text in between
3022 them, at last, delete those extra two spaces. This is to avoid
3023 byte combining while inserting. */
3024 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3025 insert_1_both (" ", 2, 2, 0, 1, 0);
3026 TEMP_SET_PT_BOTH (XFASTINT (beg
) + 1, ibeg
+ 1);
3027 insert (decoded
, decoded_length
);
3028 inserted_chars
= PT
- (XFASTINT (beg
) + 1);
3029 if (length
> MAX_ALLOCA
)
3031 /* At first delete the original text. This never cause byte
3033 del_range_both (PT
+ 1, PT_BYTE
+ 1, XFASTINT (end
) + inserted_chars
+ 2,
3034 iend
+ decoded_length
+ 2, 1);
3035 /* Next delete the extra spaces. This will cause byte combining
3037 del_range_both (PT
, PT_BYTE
, PT
+ 1, PT_BYTE
+ 1, 0);
3038 del_range_both (XFASTINT (beg
), ibeg
, XFASTINT (beg
) + 1, ibeg
+ 1, 0);
3039 inserted_chars
= PT
- XFASTINT (beg
);
3041 /* If point was outside of the region, restore it exactly; else just
3042 move to the beginning of the region. */
3043 if (old_pos
>= XFASTINT (end
))
3044 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3045 else if (old_pos
> XFASTINT (beg
))
3046 old_pos
= XFASTINT (beg
);
3049 return make_number (inserted_chars
);
3052 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3054 "Base64-decode STRING and return the result.")
3059 int length
, decoded_length
;
3060 Lisp_Object decoded_string
;
3062 CHECK_STRING (string
, 1);
3064 length
= STRING_BYTES (XSTRING (string
));
3065 /* We need to allocate enough room for decoding the text. */
3066 if (length
<= MAX_ALLOCA
)
3067 decoded
= (char *) alloca (length
);
3069 decoded
= (char *) xmalloc (length
);
3071 decoded_length
= base64_decode_1 (XSTRING (string
)->data
, decoded
, length
);
3072 if (decoded_length
> length
)
3075 if (decoded_length
< 0)
3078 decoded_string
= make_string (decoded
, decoded_length
);
3079 if (length
> MAX_ALLOCA
)
3082 return decoded_string
;
3086 base64_decode_1 (from
, to
, length
)
3091 int counter
= 0, i
= 0;
3094 unsigned long value
;
3098 /* Accept wrapping lines, reversibly if at each 76 characters. */
3108 if (counter
!= MIME_LINE_LENGTH
/ 4)
3115 /* Process first byte of a quadruplet. */
3119 value
= base64_char_to_value
[c
] << 18;
3121 /* Process second byte of a quadruplet. */
3129 value
|= base64_char_to_value
[c
] << 12;
3131 *e
++ = (unsigned char) (value
>> 16);
3133 /* Process third byte of a quadruplet. */
3149 value
|= base64_char_to_value
[c
] << 6;
3151 *e
++ = (unsigned char) (0xff & value
>> 8);
3153 /* Process fourth byte of a quadruplet. */
3164 value
|= base64_char_to_value
[c
];
3166 *e
++ = (unsigned char) (0xff & value
);
3175 Qstring_lessp
= intern ("string-lessp");
3176 staticpro (&Qstring_lessp
);
3177 Qprovide
= intern ("provide");
3178 staticpro (&Qprovide
);
3179 Qrequire
= intern ("require");
3180 staticpro (&Qrequire
);
3181 Qyes_or_no_p_history
= intern ("yes-or-no-p-history");
3182 staticpro (&Qyes_or_no_p_history
);
3183 Qcursor_in_echo_area
= intern ("cursor-in-echo-area");
3184 staticpro (&Qcursor_in_echo_area
);
3185 Qwidget_type
= intern ("widget-type");
3186 staticpro (&Qwidget_type
);
3188 staticpro (&string_char_byte_cache_string
);
3189 string_char_byte_cache_string
= Qnil
;
3191 Fset (Qyes_or_no_p_history
, Qnil
);
3193 DEFVAR_LISP ("features", &Vfeatures
,
3194 "A list of symbols which are the features of the executing emacs.\n\
3195 Used by `featurep' and `require', and altered by `provide'.");
3198 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box
,
3199 "*Non-nil means mouse commands use dialog boxes to ask questions.\n\
3200 This applies to y-or-n and yes-or-no questions asked by commands\n\
3201 invoked by mouse clicks and mouse menu items.");
3204 defsubr (&Sidentity
);
3207 defsubr (&Ssafe_length
);
3208 defsubr (&Sstring_bytes
);
3209 defsubr (&Sstring_equal
);
3210 defsubr (&Scompare_strings
);
3211 defsubr (&Sstring_lessp
);
3214 defsubr (&Svconcat
);
3215 defsubr (&Scopy_sequence
);
3216 defsubr (&Sstring_make_multibyte
);
3217 defsubr (&Sstring_make_unibyte
);
3218 defsubr (&Sstring_as_multibyte
);
3219 defsubr (&Sstring_as_unibyte
);
3220 defsubr (&Scopy_alist
);
3221 defsubr (&Ssubstring
);
3233 defsubr (&Snreverse
);
3234 defsubr (&Sreverse
);
3236 defsubr (&Splist_get
);
3238 defsubr (&Splist_put
);
3241 defsubr (&Sfillarray
);
3242 defsubr (&Schar_table_subtype
);
3243 defsubr (&Schar_table_parent
);
3244 defsubr (&Sset_char_table_parent
);
3245 defsubr (&Schar_table_extra_slot
);
3246 defsubr (&Sset_char_table_extra_slot
);
3247 defsubr (&Schar_table_range
);
3248 defsubr (&Sset_char_table_range
);
3249 defsubr (&Sset_char_table_default
);
3250 defsubr (&Smap_char_table
);
3253 defsubr (&Smapconcat
);
3254 defsubr (&Sy_or_n_p
);
3255 defsubr (&Syes_or_no_p
);
3256 defsubr (&Sload_average
);
3257 defsubr (&Sfeaturep
);
3258 defsubr (&Srequire
);
3259 defsubr (&Sprovide
);
3260 defsubr (&Swidget_plist_member
);
3261 defsubr (&Swidget_put
);
3262 defsubr (&Swidget_get
);
3263 defsubr (&Swidget_apply
);
3264 defsubr (&Sbase64_encode_region
);
3265 defsubr (&Sbase64_decode_region
);
3266 defsubr (&Sbase64_encode_string
);
3267 defsubr (&Sbase64_decode_string
);