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 (XSTRING (string
)->data
[best_above_byte
] < 0x80)
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 (XSTRING (string
)->data
[best_above_byte
] < 0x80)
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 If STRING is multibyte, the result is STRING itself.\n\
1007 Otherwise it is a newly created string, with no text properties.")
1011 CHECK_STRING (string
, 0);
1013 if (STRING_MULTIBYTE (string
))
1015 string
= Fcopy_sequence (string
);
1016 XSTRING (string
)->size
= STRING_BYTES (XSTRING (string
));
1017 XSTRING (string
)->intervals
= NULL_INTERVAL
;
1018 SET_STRING_BYTES (XSTRING (string
), -1);
1023 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1025 "Return a multibyte string with the same individual bytes as STRING.\n\
1026 If STRING is multibyte, the result is STRING itself.\n\
1027 Otherwise it is a newly created string, with no text properties.")
1031 CHECK_STRING (string
, 0);
1033 if (! STRING_MULTIBYTE (string
))
1035 int nbytes
= STRING_BYTES (XSTRING (string
));
1036 int newlen
= multibyte_chars_in_text (XSTRING (string
)->data
, nbytes
);
1038 string
= Fcopy_sequence (string
);
1039 XSTRING (string
)->size
= newlen
;
1040 XSTRING (string
)->size_byte
= nbytes
;
1041 XSTRING (string
)->intervals
= NULL_INTERVAL
;
1046 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1047 "Return a copy of ALIST.\n\
1048 This is an alist which represents the same mapping from objects to objects,\n\
1049 but does not share the alist structure with ALIST.\n\
1050 The objects mapped (cars and cdrs of elements of the alist)\n\
1051 are shared, however.\n\
1052 Elements of ALIST that are not conses are also shared.")
1056 register Lisp_Object tem
;
1058 CHECK_LIST (alist
, 0);
1061 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1062 for (tem
= alist
; CONSP (tem
); tem
= XCONS (tem
)->cdr
)
1064 register Lisp_Object car
;
1065 car
= XCONS (tem
)->car
;
1068 XCONS (tem
)->car
= Fcons (XCONS (car
)->car
, XCONS (car
)->cdr
);
1073 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
1074 "Return a substring of STRING, starting at index FROM and ending before TO.\n\
1075 TO may be nil or omitted; then the substring runs to the end of STRING.\n\
1076 If FROM or TO is negative, it counts from the end.\n\
1078 This function allows vectors as well as strings.")
1081 register Lisp_Object from
, to
;
1086 int from_char
, to_char
;
1087 int from_byte
, to_byte
;
1089 if (! (STRINGP (string
) || VECTORP (string
)))
1090 wrong_type_argument (Qarrayp
, string
);
1092 CHECK_NUMBER (from
, 1);
1094 if (STRINGP (string
))
1096 size
= XSTRING (string
)->size
;
1097 size_byte
= STRING_BYTES (XSTRING (string
));
1100 size
= XVECTOR (string
)->size
;
1105 to_byte
= size_byte
;
1109 CHECK_NUMBER (to
, 2);
1111 to_char
= XINT (to
);
1115 if (STRINGP (string
))
1116 to_byte
= string_char_to_byte (string
, to_char
);
1119 from_char
= XINT (from
);
1122 if (STRINGP (string
))
1123 from_byte
= string_char_to_byte (string
, from_char
);
1125 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1126 args_out_of_range_3 (string
, make_number (from_char
),
1127 make_number (to_char
));
1129 if (STRINGP (string
))
1131 res
= make_specified_string (XSTRING (string
)->data
+ from_byte
,
1132 to_char
- from_char
, to_byte
- from_byte
,
1133 STRING_MULTIBYTE (string
));
1134 copy_text_properties (make_number (from_char
), make_number (to_char
),
1135 string
, make_number (0), res
, Qnil
);
1138 res
= Fvector (to_char
- from_char
,
1139 XVECTOR (string
)->contents
+ from_char
);
1144 /* Extract a substring of STRING, giving start and end positions
1145 both in characters and in bytes. */
1148 substring_both (string
, from
, from_byte
, to
, to_byte
)
1150 int from
, from_byte
, to
, to_byte
;
1156 if (! (STRINGP (string
) || VECTORP (string
)))
1157 wrong_type_argument (Qarrayp
, string
);
1159 if (STRINGP (string
))
1161 size
= XSTRING (string
)->size
;
1162 size_byte
= STRING_BYTES (XSTRING (string
));
1165 size
= XVECTOR (string
)->size
;
1167 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1168 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1170 if (STRINGP (string
))
1172 res
= make_specified_string (XSTRING (string
)->data
+ from_byte
,
1173 to
- from
, to_byte
- from_byte
,
1174 STRING_MULTIBYTE (string
));
1175 copy_text_properties (make_number (from
), make_number (to
),
1176 string
, make_number (0), res
, Qnil
);
1179 res
= Fvector (to
- from
,
1180 XVECTOR (string
)->contents
+ from
);
1185 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1186 "Take cdr N times on LIST, returns the result.")
1189 register Lisp_Object list
;
1191 register int i
, num
;
1192 CHECK_NUMBER (n
, 0);
1194 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1202 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1203 "Return the Nth element of LIST.\n\
1204 N counts from zero. If LIST is not that long, nil is returned.")
1206 Lisp_Object n
, list
;
1208 return Fcar (Fnthcdr (n
, list
));
1211 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1212 "Return element of SEQUENCE at index N.")
1214 register Lisp_Object sequence
, n
;
1216 CHECK_NUMBER (n
, 0);
1219 if (CONSP (sequence
) || NILP (sequence
))
1220 return Fcar (Fnthcdr (n
, sequence
));
1221 else if (STRINGP (sequence
) || VECTORP (sequence
)
1222 || BOOL_VECTOR_P (sequence
) || CHAR_TABLE_P (sequence
))
1223 return Faref (sequence
, n
);
1225 sequence
= wrong_type_argument (Qsequencep
, sequence
);
1229 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1230 "Return non-nil if ELT is an element of LIST. Comparison done with `equal'.\n\
1231 The value is actually the tail of LIST whose car is ELT.")
1233 register Lisp_Object elt
;
1236 register Lisp_Object tail
;
1237 for (tail
= list
; !NILP (tail
); tail
= XCONS (tail
)->cdr
)
1239 register Lisp_Object tem
;
1241 if (! NILP (Fequal (elt
, tem
)))
1248 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1249 "Return non-nil if ELT is an element of LIST. Comparison done with EQ.\n\
1250 The value is actually the tail of LIST whose car is ELT.")
1252 register Lisp_Object elt
;
1255 register Lisp_Object tail
;
1256 for (tail
= list
; !NILP (tail
); tail
= XCONS (tail
)->cdr
)
1258 register Lisp_Object tem
;
1260 if (EQ (elt
, tem
)) return tail
;
1266 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1267 "Return non-nil if KEY is `eq' to the car of an element of LIST.\n\
1268 The value is actually the element of LIST whose car is KEY.\n\
1269 Elements of LIST that are not conses are ignored.")
1271 register Lisp_Object key
;
1274 register Lisp_Object tail
;
1275 for (tail
= list
; !NILP (tail
); tail
= XCONS (tail
)->cdr
)
1277 register Lisp_Object elt
, tem
;
1279 if (!CONSP (elt
)) continue;
1280 tem
= XCONS (elt
)->car
;
1281 if (EQ (key
, tem
)) return elt
;
1287 /* Like Fassq but never report an error and do not allow quits.
1288 Use only on lists known never to be circular. */
1291 assq_no_quit (key
, list
)
1292 register Lisp_Object key
;
1295 register Lisp_Object tail
;
1296 for (tail
= list
; CONSP (tail
); tail
= XCONS (tail
)->cdr
)
1298 register Lisp_Object elt
, tem
;
1300 if (!CONSP (elt
)) continue;
1301 tem
= XCONS (elt
)->car
;
1302 if (EQ (key
, tem
)) return elt
;
1307 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1308 "Return non-nil if KEY is `equal' to the car of an element of LIST.\n\
1309 The value is actually the element of LIST whose car equals KEY.")
1311 register Lisp_Object key
;
1314 register Lisp_Object tail
;
1315 for (tail
= list
; !NILP (tail
); tail
= XCONS (tail
)->cdr
)
1317 register Lisp_Object elt
, tem
;
1319 if (!CONSP (elt
)) continue;
1320 tem
= Fequal (XCONS (elt
)->car
, key
);
1321 if (!NILP (tem
)) return elt
;
1327 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1328 "Return non-nil if ELT is `eq' to the cdr of an element of LIST.\n\
1329 The value is actually the element of LIST whose cdr is ELT.")
1331 register Lisp_Object key
;
1334 register Lisp_Object tail
;
1335 for (tail
= list
; !NILP (tail
); tail
= XCONS (tail
)->cdr
)
1337 register Lisp_Object elt
, tem
;
1339 if (!CONSP (elt
)) continue;
1340 tem
= XCONS (elt
)->cdr
;
1341 if (EQ (key
, tem
)) return elt
;
1347 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1348 "Return non-nil if KEY is `equal' to the cdr of an element of LIST.\n\
1349 The value is actually the element of LIST whose cdr equals KEY.")
1351 register Lisp_Object key
;
1354 register Lisp_Object tail
;
1355 for (tail
= list
; !NILP (tail
); tail
= XCONS (tail
)->cdr
)
1357 register Lisp_Object elt
, tem
;
1359 if (!CONSP (elt
)) continue;
1360 tem
= Fequal (XCONS (elt
)->cdr
, key
);
1361 if (!NILP (tem
)) return elt
;
1367 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1368 "Delete by side effect any occurrences of ELT as a member of LIST.\n\
1369 The modified LIST is returned. Comparison is done with `eq'.\n\
1370 If the first member of LIST is ELT, there is no way to remove it by side effect;\n\
1371 therefore, write `(setq foo (delq element foo))'\n\
1372 to be sure of changing the value of `foo'.")
1374 register Lisp_Object elt
;
1377 register Lisp_Object tail
, prev
;
1378 register Lisp_Object tem
;
1382 while (!NILP (tail
))
1388 list
= XCONS (tail
)->cdr
;
1390 Fsetcdr (prev
, XCONS (tail
)->cdr
);
1394 tail
= XCONS (tail
)->cdr
;
1400 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1401 "Delete by side effect any occurrences of ELT as a member of LIST.\n\
1402 The modified LIST is returned. Comparison is done with `equal'.\n\
1403 If the first member of LIST is ELT, deleting it is not a side effect;\n\
1404 it is simply using a different list.\n\
1405 Therefore, write `(setq foo (delete element foo))'\n\
1406 to be sure of changing the value of `foo'.")
1408 register Lisp_Object elt
;
1411 register Lisp_Object tail
, prev
;
1412 register Lisp_Object tem
;
1416 while (!NILP (tail
))
1419 if (! NILP (Fequal (elt
, tem
)))
1422 list
= XCONS (tail
)->cdr
;
1424 Fsetcdr (prev
, XCONS (tail
)->cdr
);
1428 tail
= XCONS (tail
)->cdr
;
1434 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1435 "Reverse LIST by modifying cdr pointers.\n\
1436 Returns the beginning of the reversed list.")
1440 register Lisp_Object prev
, tail
, next
;
1442 if (NILP (list
)) return list
;
1445 while (!NILP (tail
))
1449 Fsetcdr (tail
, prev
);
1456 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1457 "Reverse LIST, copying. Returns the beginning of the reversed list.\n\
1458 See also the function `nreverse', which is used more often.")
1464 for (new = Qnil
; CONSP (list
); list
= XCONS (list
)->cdr
)
1465 new = Fcons (XCONS (list
)->car
, new);
1467 wrong_type_argument (Qconsp
, list
);
1471 Lisp_Object
merge ();
1473 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1474 "Sort LIST, stably, comparing elements using PREDICATE.\n\
1475 Returns the sorted list. LIST is modified by side effects.\n\
1476 PREDICATE is called with two elements of LIST, and should return T\n\
1477 if the first element is \"less\" than the second.")
1479 Lisp_Object list
, predicate
;
1481 Lisp_Object front
, back
;
1482 register Lisp_Object len
, tem
;
1483 struct gcpro gcpro1
, gcpro2
;
1484 register int length
;
1487 len
= Flength (list
);
1488 length
= XINT (len
);
1492 XSETINT (len
, (length
/ 2) - 1);
1493 tem
= Fnthcdr (len
, list
);
1495 Fsetcdr (tem
, Qnil
);
1497 GCPRO2 (front
, back
);
1498 front
= Fsort (front
, predicate
);
1499 back
= Fsort (back
, predicate
);
1501 return merge (front
, back
, predicate
);
1505 merge (org_l1
, org_l2
, pred
)
1506 Lisp_Object org_l1
, org_l2
;
1510 register Lisp_Object tail
;
1512 register Lisp_Object l1
, l2
;
1513 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1520 /* It is sufficient to protect org_l1 and org_l2.
1521 When l1 and l2 are updated, we copy the new values
1522 back into the org_ vars. */
1523 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1543 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1559 Fsetcdr (tail
, tem
);
1565 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1566 "Extract a value from a property list.\n\
1567 PLIST is a property list, which is a list of the form\n\
1568 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value\n\
1569 corresponding to the given PROP, or nil if PROP is not\n\
1570 one of the properties on the list.")
1573 register Lisp_Object prop
;
1575 register Lisp_Object tail
;
1576 for (tail
= plist
; !NILP (tail
); tail
= Fcdr (XCONS (tail
)->cdr
))
1578 register Lisp_Object tem
;
1581 return Fcar (XCONS (tail
)->cdr
);
1586 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
1587 "Return the value of SYMBOL's PROPNAME property.\n\
1588 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'.")
1590 Lisp_Object symbol
, propname
;
1592 CHECK_SYMBOL (symbol
, 0);
1593 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
1596 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
1597 "Change value in PLIST of PROP to VAL.\n\
1598 PLIST is a property list, which is a list of the form\n\
1599 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.\n\
1600 If PROP is already a property on the list, its value is set to VAL,\n\
1601 otherwise the new PROP VAL pair is added. The new plist is returned;\n\
1602 use `(setq x (plist-put x prop val))' to be sure to use the new value.\n\
1603 The PLIST is modified by side effects.")
1606 register Lisp_Object prop
;
1609 register Lisp_Object tail
, prev
;
1610 Lisp_Object newcell
;
1612 for (tail
= plist
; CONSP (tail
) && CONSP (XCONS (tail
)->cdr
);
1613 tail
= XCONS (XCONS (tail
)->cdr
)->cdr
)
1615 if (EQ (prop
, XCONS (tail
)->car
))
1617 Fsetcar (XCONS (tail
)->cdr
, val
);
1622 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
1626 Fsetcdr (XCONS (prev
)->cdr
, newcell
);
1630 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
1631 "Store SYMBOL's PROPNAME property with value VALUE.\n\
1632 It can be retrieved with `(get SYMBOL PROPNAME)'.")
1633 (symbol
, propname
, value
)
1634 Lisp_Object symbol
, propname
, value
;
1636 CHECK_SYMBOL (symbol
, 0);
1637 XSYMBOL (symbol
)->plist
1638 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
1642 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
1643 "Return t if two Lisp objects have similar structure and contents.\n\
1644 They must have the same data type.\n\
1645 Conses are compared by comparing the cars and the cdrs.\n\
1646 Vectors and strings are compared element by element.\n\
1647 Numbers are compared by value, but integers cannot equal floats.\n\
1648 (Use `=' if you want integers and floats to be able to be equal.)\n\
1649 Symbols must match exactly.")
1651 register Lisp_Object o1
, o2
;
1653 return internal_equal (o1
, o2
, 0) ? Qt
: Qnil
;
1657 internal_equal (o1
, o2
, depth
)
1658 register Lisp_Object o1
, o2
;
1662 error ("Stack overflow in equal");
1668 if (XTYPE (o1
) != XTYPE (o2
))
1673 #ifdef LISP_FLOAT_TYPE
1675 return (extract_float (o1
) == extract_float (o2
));
1679 if (!internal_equal (XCONS (o1
)->car
, XCONS (o2
)->car
, depth
+ 1))
1681 o1
= XCONS (o1
)->cdr
;
1682 o2
= XCONS (o2
)->cdr
;
1686 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
1690 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o1
),
1692 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o1
),
1695 o1
= XOVERLAY (o1
)->plist
;
1696 o2
= XOVERLAY (o2
)->plist
;
1701 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
1702 && (XMARKER (o1
)->buffer
== 0
1703 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
1707 case Lisp_Vectorlike
:
1709 register int i
, size
;
1710 size
= XVECTOR (o1
)->size
;
1711 /* Pseudovectors have the type encoded in the size field, so this test
1712 actually checks that the objects have the same type as well as the
1714 if (XVECTOR (o2
)->size
!= size
)
1716 /* Boolvectors are compared much like strings. */
1717 if (BOOL_VECTOR_P (o1
))
1720 = (XBOOL_VECTOR (o1
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
1722 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
1724 if (bcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
1729 if (WINDOW_CONFIGURATIONP (o1
))
1730 return compare_window_configurations (o1
, o2
, 0);
1732 /* Aside from them, only true vectors, char-tables, and compiled
1733 functions are sensible to compare, so eliminate the others now. */
1734 if (size
& PSEUDOVECTOR_FLAG
)
1736 if (!(size
& (PVEC_COMPILED
| PVEC_CHAR_TABLE
)))
1738 size
&= PSEUDOVECTOR_SIZE_MASK
;
1740 for (i
= 0; i
< size
; i
++)
1743 v1
= XVECTOR (o1
)->contents
[i
];
1744 v2
= XVECTOR (o2
)->contents
[i
];
1745 if (!internal_equal (v1
, v2
, depth
+ 1))
1753 if (XSTRING (o1
)->size
!= XSTRING (o2
)->size
)
1755 if (STRING_BYTES (XSTRING (o1
)) != STRING_BYTES (XSTRING (o2
)))
1757 if (bcmp (XSTRING (o1
)->data
, XSTRING (o2
)->data
,
1758 STRING_BYTES (XSTRING (o1
))))
1765 extern Lisp_Object
Fmake_char_internal ();
1767 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
1768 "Store each element of ARRAY with ITEM.\n\
1769 ARRAY is a vector, string, char-table, or bool-vector.")
1771 Lisp_Object array
, item
;
1773 register int size
, index
, charval
;
1775 if (VECTORP (array
))
1777 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
1778 size
= XVECTOR (array
)->size
;
1779 for (index
= 0; index
< size
; index
++)
1782 else if (CHAR_TABLE_P (array
))
1784 register Lisp_Object
*p
= XCHAR_TABLE (array
)->contents
;
1785 size
= CHAR_TABLE_ORDINARY_SLOTS
;
1786 for (index
= 0; index
< size
; index
++)
1788 XCHAR_TABLE (array
)->defalt
= Qnil
;
1790 else if (STRINGP (array
))
1792 register unsigned char *p
= XSTRING (array
)->data
;
1793 CHECK_NUMBER (item
, 1);
1794 charval
= XINT (item
);
1795 size
= XSTRING (array
)->size
;
1796 if (STRING_MULTIBYTE (array
))
1798 unsigned char workbuf
[4], *str
;
1799 int len
= CHAR_STRING (charval
, workbuf
, str
);
1800 int size_byte
= STRING_BYTES (XSTRING (array
));
1801 unsigned char *p1
= p
, *endp
= p
+ size_byte
;
1804 if (size
!= size_byte
)
1807 int this_len
= MULTIBYTE_FORM_LENGTH (p1
, endp
- p1
);
1808 if (len
!= this_len
)
1809 error ("Attempt to change byte length of a string");
1812 for (i
= 0; i
< size_byte
; i
++)
1813 *p
++ = str
[i
% len
];
1816 for (index
= 0; index
< size
; index
++)
1819 else if (BOOL_VECTOR_P (array
))
1821 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
1823 = (XBOOL_VECTOR (array
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
1825 charval
= (! NILP (item
) ? -1 : 0);
1826 for (index
= 0; index
< size_in_chars
; index
++)
1831 array
= wrong_type_argument (Qarrayp
, array
);
1837 DEFUN ("char-table-subtype", Fchar_table_subtype
, Schar_table_subtype
,
1839 "Return the subtype of char-table CHAR-TABLE. The value is a symbol.")
1841 Lisp_Object char_table
;
1843 CHECK_CHAR_TABLE (char_table
, 0);
1845 return XCHAR_TABLE (char_table
)->purpose
;
1848 DEFUN ("char-table-parent", Fchar_table_parent
, Schar_table_parent
,
1850 "Return the parent char-table of CHAR-TABLE.\n\
1851 The value is either nil or another char-table.\n\
1852 If CHAR-TABLE holds nil for a given character,\n\
1853 then the actual applicable value is inherited from the parent char-table\n\
1854 \(or from its parents, if necessary).")
1856 Lisp_Object char_table
;
1858 CHECK_CHAR_TABLE (char_table
, 0);
1860 return XCHAR_TABLE (char_table
)->parent
;
1863 DEFUN ("set-char-table-parent", Fset_char_table_parent
, Sset_char_table_parent
,
1865 "Set the parent char-table of CHAR-TABLE to PARENT.\n\
1866 PARENT must be either nil or another char-table.")
1867 (char_table
, parent
)
1868 Lisp_Object char_table
, parent
;
1872 CHECK_CHAR_TABLE (char_table
, 0);
1876 CHECK_CHAR_TABLE (parent
, 0);
1878 for (temp
= parent
; !NILP (temp
); temp
= XCHAR_TABLE (temp
)->parent
)
1879 if (EQ (temp
, char_table
))
1880 error ("Attempt to make a chartable be its own parent");
1883 XCHAR_TABLE (char_table
)->parent
= parent
;
1888 DEFUN ("char-table-extra-slot", Fchar_table_extra_slot
, Schar_table_extra_slot
,
1890 "Return the value of CHAR-TABLE's extra-slot number N.")
1892 Lisp_Object char_table
, n
;
1894 CHECK_CHAR_TABLE (char_table
, 1);
1895 CHECK_NUMBER (n
, 2);
1897 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
1898 args_out_of_range (char_table
, n
);
1900 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)];
1903 DEFUN ("set-char-table-extra-slot", Fset_char_table_extra_slot
,
1904 Sset_char_table_extra_slot
,
1906 "Set CHAR-TABLE's extra-slot number N to VALUE.")
1907 (char_table
, n
, value
)
1908 Lisp_Object char_table
, n
, value
;
1910 CHECK_CHAR_TABLE (char_table
, 1);
1911 CHECK_NUMBER (n
, 2);
1913 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
1914 args_out_of_range (char_table
, n
);
1916 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)] = value
;
1919 DEFUN ("char-table-range", Fchar_table_range
, Schar_table_range
,
1921 "Return the value in CHAR-TABLE for a range of characters RANGE.\n\
1922 RANGE should be nil (for the default value)\n\
1923 a vector which identifies a character set or a row of a character set,\n\
1924 a character set name, or a character code.")
1926 Lisp_Object char_table
, range
;
1930 CHECK_CHAR_TABLE (char_table
, 0);
1932 if (EQ (range
, Qnil
))
1933 return XCHAR_TABLE (char_table
)->defalt
;
1934 else if (INTEGERP (range
))
1935 return Faref (char_table
, range
);
1936 else if (SYMBOLP (range
))
1938 Lisp_Object charset_info
;
1940 charset_info
= Fget (range
, Qcharset
);
1941 CHECK_VECTOR (charset_info
, 0);
1943 return Faref (char_table
,
1944 make_number (XINT (XVECTOR (charset_info
)->contents
[0])
1947 else if (VECTORP (range
))
1949 if (XVECTOR (range
)->size
== 1)
1950 return Faref (char_table
,
1951 make_number (XINT (XVECTOR (range
)->contents
[0]) + 128));
1954 int size
= XVECTOR (range
)->size
;
1955 Lisp_Object
*val
= XVECTOR (range
)->contents
;
1956 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
1957 size
<= 1 ? Qnil
: val
[1],
1958 size
<= 2 ? Qnil
: val
[2]);
1959 return Faref (char_table
, ch
);
1963 error ("Invalid RANGE argument to `char-table-range'");
1966 DEFUN ("set-char-table-range", Fset_char_table_range
, Sset_char_table_range
,
1968 "Set the value in CHAR-TABLE for a range of characters RANGE to VALUE.\n\
1969 RANGE should be t (for all characters), nil (for the default value)\n\
1970 a vector which identifies a character set or a row of a character set,\n\
1971 a coding system, or a character code.")
1972 (char_table
, range
, value
)
1973 Lisp_Object char_table
, range
, value
;
1977 CHECK_CHAR_TABLE (char_table
, 0);
1980 for (i
= 0; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
1981 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
1982 else if (EQ (range
, Qnil
))
1983 XCHAR_TABLE (char_table
)->defalt
= value
;
1984 else if (SYMBOLP (range
))
1986 Lisp_Object charset_info
;
1988 charset_info
= Fget (range
, Qcharset
);
1989 CHECK_VECTOR (charset_info
, 0);
1991 return Faset (char_table
,
1992 make_number (XINT (XVECTOR (charset_info
)->contents
[0])
1996 else if (INTEGERP (range
))
1997 Faset (char_table
, range
, value
);
1998 else if (VECTORP (range
))
2000 if (XVECTOR (range
)->size
== 1)
2001 return Faset (char_table
,
2002 make_number (XINT (XVECTOR (range
)->contents
[0]) + 128),
2006 int size
= XVECTOR (range
)->size
;
2007 Lisp_Object
*val
= XVECTOR (range
)->contents
;
2008 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
2009 size
<= 1 ? Qnil
: val
[1],
2010 size
<= 2 ? Qnil
: val
[2]);
2011 return Faset (char_table
, ch
, value
);
2015 error ("Invalid RANGE argument to `set-char-table-range'");
2020 DEFUN ("set-char-table-default", Fset_char_table_default
,
2021 Sset_char_table_default
, 3, 3, 0,
2022 "Set the default value in CHAR-TABLE for a generic character CHAR to VALUE.\n\
2023 The generic character specifies the group of characters.\n\
2024 See also the documentation of make-char.")
2025 (char_table
, ch
, value
)
2026 Lisp_Object char_table
, ch
, value
;
2028 int c
, i
, charset
, code1
, code2
;
2031 CHECK_CHAR_TABLE (char_table
, 0);
2032 CHECK_NUMBER (ch
, 1);
2035 SPLIT_NON_ASCII_CHAR (c
, charset
, code1
, code2
);
2037 /* Since we may want to set the default value for a character set
2038 not yet defined, we check only if the character set is in the
2039 valid range or not, instead of it is already defined or not. */
2040 if (! CHARSET_VALID_P (charset
))
2041 invalid_character (c
);
2043 if (charset
== CHARSET_ASCII
)
2044 return (XCHAR_TABLE (char_table
)->defalt
= value
);
2046 /* Even if C is not a generic char, we had better behave as if a
2047 generic char is specified. */
2048 if (charset
== CHARSET_COMPOSITION
|| CHARSET_DIMENSION (charset
) == 1)
2050 temp
= XCHAR_TABLE (char_table
)->contents
[charset
+ 128];
2053 if (SUB_CHAR_TABLE_P (temp
))
2054 XCHAR_TABLE (temp
)->defalt
= value
;
2056 XCHAR_TABLE (char_table
)->contents
[charset
+ 128] = value
;
2060 if (! SUB_CHAR_TABLE_P (char_table
))
2061 char_table
= (XCHAR_TABLE (char_table
)->contents
[charset
+ 128]
2062 = make_sub_char_table (temp
));
2063 temp
= XCHAR_TABLE (char_table
)->contents
[code1
];
2064 if (SUB_CHAR_TABLE_P (temp
))
2065 XCHAR_TABLE (temp
)->defalt
= value
;
2067 XCHAR_TABLE (char_table
)->contents
[code1
] = value
;
2071 /* Look up the element in TABLE at index CH,
2072 and return it as an integer.
2073 If the element is nil, return CH itself.
2074 (Actually we do that for any non-integer.) */
2077 char_table_translate (table
, ch
)
2082 value
= Faref (table
, make_number (ch
));
2083 if (! INTEGERP (value
))
2085 return XINT (value
);
2088 /* Map C_FUNCTION or FUNCTION over SUBTABLE, calling it for each
2089 character or group of characters that share a value.
2090 DEPTH is the current depth in the originally specified
2091 chartable, and INDICES contains the vector indices
2092 for the levels our callers have descended.
2094 ARG is passed to C_FUNCTION when that is called. */
2097 map_char_table (c_function
, function
, subtable
, arg
, depth
, indices
)
2098 void (*c_function
) P_ ((Lisp_Object
, Lisp_Object
, Lisp_Object
));
2099 Lisp_Object function
, subtable
, arg
, *indices
;
2106 /* At first, handle ASCII and 8-bit European characters. */
2107 for (i
= 0; i
< CHAR_TABLE_SINGLE_BYTE_SLOTS
; i
++)
2109 Lisp_Object elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2111 (*c_function
) (arg
, make_number (i
), elt
);
2113 call2 (function
, make_number (i
), elt
);
2115 #if 0 /* If the char table has entries for higher characters,
2116 we should report them. */
2117 if (NILP (current_buffer
->enable_multibyte_characters
))
2120 to
= CHAR_TABLE_ORDINARY_SLOTS
;
2125 to
= SUB_CHAR_TABLE_ORDINARY_SLOTS
;
2130 Lisp_Object elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2132 XSETFASTINT (indices
[depth
], i
);
2134 if (SUB_CHAR_TABLE_P (elt
))
2137 error ("Too deep char table");
2138 map_char_table (c_function
, function
, elt
, arg
, depth
+ 1, indices
);
2142 int charset
= XFASTINT (indices
[0]) - 128, c1
, c2
, c
;
2144 if (CHARSET_DEFINED_P (charset
))
2146 c1
= depth
>= 1 ? XFASTINT (indices
[1]) : 0;
2147 c2
= depth
>= 2 ? XFASTINT (indices
[2]) : 0;
2148 c
= MAKE_NON_ASCII_CHAR (charset
, c1
, c2
);
2150 (*c_function
) (arg
, make_number (c
), elt
);
2152 call2 (function
, make_number (c
), elt
);
2158 DEFUN ("map-char-table", Fmap_char_table
, Smap_char_table
,
2160 "Call FUNCTION for each (normal and generic) characters in CHAR-TABLE.\n\
2161 FUNCTION is called with two arguments--a key and a value.\n\
2162 The key is always a possible IDX argument to `aref'.")
2163 (function
, char_table
)
2164 Lisp_Object function
, char_table
;
2166 /* The depth of char table is at most 3. */
2167 Lisp_Object indices
[3];
2169 CHECK_CHAR_TABLE (char_table
, 1);
2171 map_char_table (NULL
, function
, char_table
, char_table
, 0, indices
);
2181 Lisp_Object args
[2];
2184 return Fnconc (2, args
);
2186 return Fnconc (2, &s1
);
2187 #endif /* NO_ARG_ARRAY */
2190 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2191 "Concatenate any number of lists by altering them.\n\
2192 Only the last argument is not altered, and need not be a list.")
2197 register int argnum
;
2198 register Lisp_Object tail
, tem
, val
;
2202 for (argnum
= 0; argnum
< nargs
; argnum
++)
2205 if (NILP (tem
)) continue;
2210 if (argnum
+ 1 == nargs
) break;
2213 tem
= wrong_type_argument (Qlistp
, tem
);
2222 tem
= args
[argnum
+ 1];
2223 Fsetcdr (tail
, tem
);
2225 args
[argnum
+ 1] = tail
;
2231 /* This is the guts of all mapping functions.
2232 Apply FN to each element of SEQ, one by one,
2233 storing the results into elements of VALS, a C vector of Lisp_Objects.
2234 LENI is the length of VALS, which should also be the length of SEQ. */
2237 mapcar1 (leni
, vals
, fn
, seq
)
2240 Lisp_Object fn
, seq
;
2242 register Lisp_Object tail
;
2245 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2247 /* Don't let vals contain any garbage when GC happens. */
2248 for (i
= 0; i
< leni
; i
++)
2251 GCPRO3 (dummy
, fn
, seq
);
2253 gcpro1
.nvars
= leni
;
2254 /* We need not explicitly protect `tail' because it is used only on lists, and
2255 1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
2259 for (i
= 0; i
< leni
; i
++)
2261 dummy
= XVECTOR (seq
)->contents
[i
];
2262 vals
[i
] = call1 (fn
, dummy
);
2265 else if (BOOL_VECTOR_P (seq
))
2267 for (i
= 0; i
< leni
; i
++)
2270 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BITS_PER_CHAR
];
2271 if (byte
& (1 << (i
% BITS_PER_CHAR
)))
2276 vals
[i
] = call1 (fn
, dummy
);
2279 else if (STRINGP (seq
) && ! STRING_MULTIBYTE (seq
))
2281 /* Single-byte string. */
2282 for (i
= 0; i
< leni
; i
++)
2284 XSETFASTINT (dummy
, XSTRING (seq
)->data
[i
]);
2285 vals
[i
] = call1 (fn
, dummy
);
2288 else if (STRINGP (seq
))
2290 /* Multi-byte string. */
2291 int len_byte
= STRING_BYTES (XSTRING (seq
));
2294 for (i
= 0, i_byte
= 0; i
< leni
;)
2299 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2300 XSETFASTINT (dummy
, c
);
2301 vals
[i_before
] = call1 (fn
, dummy
);
2304 else /* Must be a list, since Flength did not get an error */
2307 for (i
= 0; i
< leni
; i
++)
2309 vals
[i
] = call1 (fn
, Fcar (tail
));
2310 tail
= XCONS (tail
)->cdr
;
2317 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2318 "Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.\n\
2319 In between each pair of results, stick in SEPARATOR. Thus, \" \" as\n\
2320 SEPARATOR results in spaces between the values returned by FUNCTION.\n\
2321 SEQUENCE may be a list, a vector, a bool-vector, or a string.")
2322 (function
, sequence
, separator
)
2323 Lisp_Object function
, sequence
, separator
;
2328 register Lisp_Object
*args
;
2330 struct gcpro gcpro1
;
2332 len
= Flength (sequence
);
2334 nargs
= leni
+ leni
- 1;
2335 if (nargs
< 0) return build_string ("");
2337 args
= (Lisp_Object
*) alloca (nargs
* sizeof (Lisp_Object
));
2340 mapcar1 (leni
, args
, function
, sequence
);
2343 for (i
= leni
- 1; i
>= 0; i
--)
2344 args
[i
+ i
] = args
[i
];
2346 for (i
= 1; i
< nargs
; i
+= 2)
2347 args
[i
] = separator
;
2349 return Fconcat (nargs
, args
);
2352 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2353 "Apply FUNCTION to each element of SEQUENCE, and make a list of the results.\n\
2354 The result is a list just as long as SEQUENCE.\n\
2355 SEQUENCE may be a list, a vector, a bool-vector, or a string.")
2356 (function
, sequence
)
2357 Lisp_Object function
, sequence
;
2359 register Lisp_Object len
;
2361 register Lisp_Object
*args
;
2363 len
= Flength (sequence
);
2364 leni
= XFASTINT (len
);
2365 args
= (Lisp_Object
*) alloca (leni
* sizeof (Lisp_Object
));
2367 mapcar1 (leni
, args
, function
, sequence
);
2369 return Flist (leni
, args
);
2372 /* Anything that calls this function must protect from GC! */
2374 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
2375 "Ask user a \"y or n\" question. Return t if answer is \"y\".\n\
2376 Takes one argument, which is the string to display to ask the question.\n\
2377 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.\n\
2378 No confirmation of the answer is requested; a single character is enough.\n\
2379 Also accepts Space to mean yes, or Delete to mean no.")
2383 register Lisp_Object obj
, key
, def
, answer_string
, map
;
2384 register int answer
;
2385 Lisp_Object xprompt
;
2386 Lisp_Object args
[2];
2387 struct gcpro gcpro1
, gcpro2
;
2388 int count
= specpdl_ptr
- specpdl
;
2390 specbind (Qcursor_in_echo_area
, Qt
);
2392 map
= Fsymbol_value (intern ("query-replace-map"));
2394 CHECK_STRING (prompt
, 0);
2396 GCPRO2 (prompt
, xprompt
);
2402 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2406 Lisp_Object pane
, menu
;
2407 redisplay_preserve_echo_area ();
2408 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2409 Fcons (Fcons (build_string ("No"), Qnil
),
2411 menu
= Fcons (prompt
, pane
);
2412 obj
= Fx_popup_dialog (Qt
, menu
);
2413 answer
= !NILP (obj
);
2416 #endif /* HAVE_MENUS */
2417 cursor_in_echo_area
= 1;
2418 choose_minibuf_frame ();
2419 message_with_string ("%s(y or n) ", xprompt
, 0);
2421 if (minibuffer_auto_raise
)
2423 Lisp_Object mini_frame
;
2425 mini_frame
= WINDOW_FRAME (XWINDOW (minibuf_window
));
2427 Fraise_frame (mini_frame
);
2430 obj
= read_filtered_event (1, 0, 0, 0);
2431 cursor_in_echo_area
= 0;
2432 /* If we need to quit, quit with cursor_in_echo_area = 0. */
2435 key
= Fmake_vector (make_number (1), obj
);
2436 def
= Flookup_key (map
, key
, Qt
);
2437 answer_string
= Fsingle_key_description (obj
);
2439 if (EQ (def
, intern ("skip")))
2444 else if (EQ (def
, intern ("act")))
2449 else if (EQ (def
, intern ("recenter")))
2455 else if (EQ (def
, intern ("quit")))
2457 /* We want to exit this command for exit-prefix,
2458 and this is the only way to do it. */
2459 else if (EQ (def
, intern ("exit-prefix")))
2464 /* If we don't clear this, then the next call to read_char will
2465 return quit_char again, and we'll enter an infinite loop. */
2470 if (EQ (xprompt
, prompt
))
2472 args
[0] = build_string ("Please answer y or n. ");
2474 xprompt
= Fconcat (2, args
);
2479 if (! noninteractive
)
2481 cursor_in_echo_area
= -1;
2482 message_with_string (answer
? "%s(y or n) y" : "%s(y or n) n",
2486 unbind_to (count
, Qnil
);
2487 return answer
? Qt
: Qnil
;
2490 /* This is how C code calls `yes-or-no-p' and allows the user
2493 Anything that calls this function must protect from GC! */
2496 do_yes_or_no_p (prompt
)
2499 return call1 (intern ("yes-or-no-p"), prompt
);
2502 /* Anything that calls this function must protect from GC! */
2504 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2505 "Ask user a yes-or-no question. Return t if answer is yes.\n\
2506 Takes one argument, which is the string to display to ask the question.\n\
2507 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.\n\
2508 The user must confirm the answer with RET,\n\
2509 and can edit it until it has been confirmed.")
2513 register Lisp_Object ans
;
2514 Lisp_Object args
[2];
2515 struct gcpro gcpro1
;
2518 CHECK_STRING (prompt
, 0);
2521 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2525 Lisp_Object pane
, menu
, obj
;
2526 redisplay_preserve_echo_area ();
2527 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2528 Fcons (Fcons (build_string ("No"), Qnil
),
2531 menu
= Fcons (prompt
, pane
);
2532 obj
= Fx_popup_dialog (Qt
, menu
);
2536 #endif /* HAVE_MENUS */
2539 args
[1] = build_string ("(yes or no) ");
2540 prompt
= Fconcat (2, args
);
2546 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2547 Qyes_or_no_p_history
, Qnil
,
2549 if (XSTRING (ans
)->size
== 3 && !strcmp (XSTRING (ans
)->data
, "yes"))
2554 if (XSTRING (ans
)->size
== 2 && !strcmp (XSTRING (ans
)->data
, "no"))
2562 message ("Please answer yes or no.");
2563 Fsleep_for (make_number (2), Qnil
);
2567 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2568 "Return list of 1 minute, 5 minute and 15 minute load averages.\n\
2569 Each of the three load averages is multiplied by 100,\n\
2570 then converted to integer.\n\
2571 When USE-FLOATS is non-nil, floats will be used instead of integers.\n\
2572 These floats are not multiplied by 100.\n\n\
2573 If the 5-minute or 15-minute load averages are not available, return a\n\
2574 shortened list, containing only those averages which are available.")
2576 Lisp_Object use_floats
;
2579 int loads
= getloadavg (load_ave
, 3);
2580 Lisp_Object ret
= Qnil
;
2583 error ("load-average not implemented for this operating system");
2587 Lisp_Object load
= (NILP (use_floats
) ?
2588 make_number ((int) (100.0 * load_ave
[loads
]))
2589 : make_float (load_ave
[loads
]));
2590 ret
= Fcons (load
, ret
);
2596 Lisp_Object Vfeatures
;
2598 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 1, 0,
2599 "Returns t if FEATURE is present in this Emacs.\n\
2600 Use this to conditionalize execution of lisp code based on the presence or\n\
2601 absence of emacs or environment extensions.\n\
2602 Use `provide' to declare that a feature is available.\n\
2603 This function looks at the value of the variable `features'.")
2605 Lisp_Object feature
;
2607 register Lisp_Object tem
;
2608 CHECK_SYMBOL (feature
, 0);
2609 tem
= Fmemq (feature
, Vfeatures
);
2610 return (NILP (tem
)) ? Qnil
: Qt
;
2613 DEFUN ("provide", Fprovide
, Sprovide
, 1, 1, 0,
2614 "Announce that FEATURE is a feature of the current Emacs.")
2616 Lisp_Object feature
;
2618 register Lisp_Object tem
;
2619 CHECK_SYMBOL (feature
, 0);
2620 if (!NILP (Vautoload_queue
))
2621 Vautoload_queue
= Fcons (Fcons (Vfeatures
, Qnil
), Vautoload_queue
);
2622 tem
= Fmemq (feature
, Vfeatures
);
2624 Vfeatures
= Fcons (feature
, Vfeatures
);
2625 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2629 DEFUN ("require", Frequire
, Srequire
, 1, 3, 0,
2630 "If feature FEATURE is not loaded, load it from FILENAME.\n\
2631 If FEATURE is not a member of the list `features', then the feature\n\
2632 is not loaded; so load the file FILENAME.\n\
2633 If FILENAME is omitted, the printname of FEATURE is used as the file name,\n\
2634 but in this case `load' insists on adding the suffix `.el' or `.elc'.\n\
2635 If the optional third argument NOERROR is non-nil,\n\
2636 then return nil if the file is not found.\n\
2637 Normally the return value is FEATURE.")
2638 (feature
, file_name
, noerror
)
2639 Lisp_Object feature
, file_name
, noerror
;
2641 register Lisp_Object tem
;
2642 CHECK_SYMBOL (feature
, 0);
2643 tem
= Fmemq (feature
, Vfeatures
);
2644 LOADHIST_ATTACH (Fcons (Qrequire
, feature
));
2647 int count
= specpdl_ptr
- specpdl
;
2649 /* Value saved here is to be restored into Vautoload_queue */
2650 record_unwind_protect (un_autoload
, Vautoload_queue
);
2651 Vautoload_queue
= Qt
;
2653 tem
= Fload (NILP (file_name
) ? Fsymbol_name (feature
) : file_name
,
2654 noerror
, Qt
, Qnil
, (NILP (file_name
) ? Qt
: Qnil
));
2655 /* If load failed entirely, return nil. */
2659 tem
= Fmemq (feature
, Vfeatures
);
2661 error ("Required feature %s was not provided",
2662 XSYMBOL (feature
)->name
->data
);
2664 /* Once loading finishes, don't undo it. */
2665 Vautoload_queue
= Qt
;
2666 feature
= unbind_to (count
, feature
);
2671 /* Primitives for work of the "widget" library.
2672 In an ideal world, this section would not have been necessary.
2673 However, lisp function calls being as slow as they are, it turns
2674 out that some functions in the widget library (wid-edit.el) are the
2675 bottleneck of Widget operation. Here is their translation to C,
2676 for the sole reason of efficiency. */
2678 DEFUN ("widget-plist-member", Fwidget_plist_member
, Swidget_plist_member
, 2, 2, 0,
2679 "Return non-nil if PLIST has the property PROP.\n\
2680 PLIST is a property list, which is a list of the form\n\
2681 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.\n\
2682 Unlike `plist-get', this allows you to distinguish between a missing\n\
2683 property and a property with the value nil.\n\
2684 The value is actually the tail of PLIST whose car is PROP.")
2686 Lisp_Object plist
, prop
;
2688 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
2691 plist
= XCDR (plist
);
2692 plist
= CDR (plist
);
2697 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
2698 "In WIDGET, set PROPERTY to VALUE.\n\
2699 The value can later be retrieved with `widget-get'.")
2700 (widget
, property
, value
)
2701 Lisp_Object widget
, property
, value
;
2703 CHECK_CONS (widget
, 1);
2704 XCDR (widget
) = Fplist_put (XCDR (widget
), property
, value
);
2708 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
2709 "In WIDGET, get the value of PROPERTY.\n\
2710 The value could either be specified when the widget was created, or\n\
2711 later with `widget-put'.")
2713 Lisp_Object widget
, property
;
2721 CHECK_CONS (widget
, 1);
2722 tmp
= Fwidget_plist_member (XCDR (widget
), property
);
2728 tmp
= XCAR (widget
);
2731 widget
= Fget (tmp
, Qwidget_type
);
2735 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
2736 "Apply the value of WIDGET's PROPERTY to the widget itself.\n\
2737 ARGS are passed as extra arguments to the function.")
2742 /* This function can GC. */
2743 Lisp_Object newargs
[3];
2744 struct gcpro gcpro1
, gcpro2
;
2747 newargs
[0] = Fwidget_get (args
[0], args
[1]);
2748 newargs
[1] = args
[0];
2749 newargs
[2] = Flist (nargs
- 2, args
+ 2);
2750 GCPRO2 (newargs
[0], newargs
[2]);
2751 result
= Fapply (3, newargs
);
2756 /* base64 encode/decode functions.
2757 Based on code from GNU recode. */
2759 #define MIME_LINE_LENGTH 76
2761 #define IS_ASCII(Character) \
2763 #define IS_BASE64(Character) \
2764 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
2766 /* Don't use alloca for regions larger than this, lest we overflow
2768 #define MAX_ALLOCA 16*1024
2770 /* Table of characters coding the 64 values. */
2771 static char base64_value_to_char
[64] =
2773 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
2774 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
2775 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
2776 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
2777 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
2778 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
2779 '8', '9', '+', '/' /* 60-63 */
2782 /* Table of base64 values for first 128 characters. */
2783 static short base64_char_to_value
[128] =
2785 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
2786 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
2787 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
2788 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
2789 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
2790 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
2791 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
2792 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
2793 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
2794 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
2795 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
2796 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
2797 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
2800 /* The following diagram shows the logical steps by which three octets
2801 get transformed into four base64 characters.
2803 .--------. .--------. .--------.
2804 |aaaaaabb| |bbbbcccc| |ccdddddd|
2805 `--------' `--------' `--------'
2807 .--------+--------+--------+--------.
2808 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
2809 `--------+--------+--------+--------'
2811 .--------+--------+--------+--------.
2812 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
2813 `--------+--------+--------+--------'
2815 The octets are divided into 6 bit chunks, which are then encoded into
2816 base64 characters. */
2819 static int base64_encode_1
P_ ((const char *, char *, int, int));
2820 static int base64_decode_1
P_ ((const char *, char *, int));
2822 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
2824 "Base64-encode the region between BEG and END.\n\
2825 Return the length of the encoded text.\n\
2826 Optional third argument NO-LINE-BREAK means do not break long lines\n\
2827 into shorter lines.")
2828 (beg
, end
, no_line_break
)
2829 Lisp_Object beg
, end
, no_line_break
;
2832 int allength
, length
;
2833 int ibeg
, iend
, encoded_length
;
2836 validate_region (&beg
, &end
);
2838 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
2839 iend
= CHAR_TO_BYTE (XFASTINT (end
));
2840 move_gap_both (XFASTINT (beg
), ibeg
);
2842 /* We need to allocate enough room for encoding the text.
2843 We need 33 1/3% more space, plus a newline every 76
2844 characters, and then we round up. */
2845 length
= iend
- ibeg
;
2846 allength
= length
+ length
/3 + 1;
2847 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
2849 if (allength
<= MAX_ALLOCA
)
2850 encoded
= (char *) alloca (allength
);
2852 encoded
= (char *) xmalloc (allength
);
2853 encoded_length
= base64_encode_1 (BYTE_POS_ADDR (ibeg
), encoded
, length
,
2854 NILP (no_line_break
));
2855 if (encoded_length
> allength
)
2858 /* Now we have encoded the region, so we insert the new contents
2859 and delete the old. (Insert first in order to preserve markers.) */
2860 SET_PT_BOTH (XFASTINT (beg
), ibeg
);
2861 insert (encoded
, encoded_length
);
2862 if (allength
> MAX_ALLOCA
)
2864 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
2866 /* If point was outside of the region, restore it exactly; else just
2867 move to the beginning of the region. */
2868 if (old_pos
>= XFASTINT (end
))
2869 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
2870 else if (old_pos
> XFASTINT (beg
))
2871 old_pos
= XFASTINT (beg
);
2874 /* We return the length of the encoded text. */
2875 return make_number (encoded_length
);
2878 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
2880 "Base64-encode STRING and return the result.")
2884 int allength
, length
, encoded_length
;
2886 Lisp_Object encoded_string
;
2888 CHECK_STRING (string
, 1);
2890 length
= STRING_BYTES (XSTRING (string
));
2891 allength
= length
+ length
/3 + 1 + 6;
2893 /* We need to allocate enough room for decoding the text. */
2894 if (allength
<= MAX_ALLOCA
)
2895 encoded
= (char *) alloca (allength
);
2897 encoded
= (char *) xmalloc (allength
);
2899 encoded_length
= base64_encode_1 (XSTRING (string
)->data
,
2900 encoded
, length
, 0);
2901 if (encoded_length
> allength
)
2904 encoded_string
= make_unibyte_string (encoded
, encoded_length
);
2905 if (allength
> MAX_ALLOCA
)
2908 return encoded_string
;
2912 base64_encode_1 (from
, to
, length
, line_break
)
2918 int counter
= 0, i
= 0;
2927 /* Wrap line every 76 characters. */
2931 if (counter
< MIME_LINE_LENGTH
/ 4)
2940 /* Process first byte of a triplet. */
2942 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
2943 value
= (0x03 & c
) << 4;
2945 /* Process second byte of a triplet. */
2949 *e
++ = base64_value_to_char
[value
];
2957 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
2958 value
= (0x0f & c
) << 2;
2960 /* Process third byte of a triplet. */
2964 *e
++ = base64_value_to_char
[value
];
2971 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
2972 *e
++ = base64_value_to_char
[0x3f & c
];
2975 /* Complete last partial line. */
2985 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
2987 "Base64-decode the region between BEG and END.\n\
2988 Return the length of the decoded text.\n\
2989 If the region can't be decoded, return nil and don't modify the buffer.")
2991 Lisp_Object beg
, end
;
2993 int ibeg
, iend
, length
;
2999 validate_region (&beg
, &end
);
3001 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
3002 iend
= CHAR_TO_BYTE (XFASTINT (end
));
3004 length
= iend
- ibeg
;
3005 /* We need to allocate enough room for decoding the text. */
3006 if (length
<= MAX_ALLOCA
)
3007 decoded
= (char *) alloca (length
);
3009 decoded
= (char *) xmalloc (length
);
3011 move_gap_both (XFASTINT (beg
), ibeg
);
3012 decoded_length
= base64_decode_1 (BYTE_POS_ADDR (ibeg
), decoded
, length
);
3013 if (decoded_length
> length
)
3016 if (decoded_length
< 0)
3017 /* The decoding wasn't possible. */
3020 /* Now we have decoded the region, so we insert the new contents
3021 and delete the old. (Insert first in order to preserve markers.) */
3022 /* We insert two spaces, then insert the decoded text in between
3023 them, at last, delete those extra two spaces. This is to avoid
3024 byte combining while inserting. */
3025 TEMP_SET_PT_BOTH (XFASTINT (beg
), ibeg
);
3026 insert_1_both (" ", 2, 2, 0, 1, 0);
3027 TEMP_SET_PT_BOTH (XFASTINT (beg
) + 1, ibeg
+ 1);
3028 insert (decoded
, decoded_length
);
3029 inserted_chars
= PT
- (XFASTINT (beg
) + 1);
3030 if (length
> MAX_ALLOCA
)
3032 /* At first delete the original text. This never cause byte
3034 del_range_both (PT
+ 1, PT_BYTE
+ 1, XFASTINT (end
) + inserted_chars
+ 2,
3035 iend
+ decoded_length
+ 2, 1);
3036 /* Next delete the extra spaces. This will cause byte combining
3038 del_range_both (PT
, PT_BYTE
, PT
+ 1, PT_BYTE
+ 1, 0);
3039 del_range_both (XFASTINT (beg
), ibeg
, XFASTINT (beg
) + 1, ibeg
+ 1, 0);
3040 inserted_chars
= PT
- XFASTINT (beg
);
3042 /* If point was outside of the region, restore it exactly; else just
3043 move to the beginning of the region. */
3044 if (old_pos
>= XFASTINT (end
))
3045 old_pos
+= inserted_chars
- (XFASTINT (end
) - XFASTINT (beg
));
3046 else if (old_pos
> XFASTINT (beg
))
3047 old_pos
= XFASTINT (beg
);
3050 return make_number (inserted_chars
);
3053 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3055 "Base64-decode STRING and return the result.")
3060 int length
, decoded_length
;
3061 Lisp_Object decoded_string
;
3063 CHECK_STRING (string
, 1);
3065 length
= STRING_BYTES (XSTRING (string
));
3066 /* We need to allocate enough room for decoding the text. */
3067 if (length
<= MAX_ALLOCA
)
3068 decoded
= (char *) alloca (length
);
3070 decoded
= (char *) xmalloc (length
);
3072 decoded_length
= base64_decode_1 (XSTRING (string
)->data
, decoded
, length
);
3073 if (decoded_length
> length
)
3076 if (decoded_length
< 0)
3079 decoded_string
= make_string (decoded
, decoded_length
);
3080 if (length
> MAX_ALLOCA
)
3083 return decoded_string
;
3087 base64_decode_1 (from
, to
, length
)
3092 int counter
= 0, i
= 0;
3095 unsigned long value
;
3099 /* Accept wrapping lines, reversibly if at each 76 characters. */
3109 if (counter
!= MIME_LINE_LENGTH
/ 4)
3116 /* Process first byte of a quadruplet. */
3120 value
= base64_char_to_value
[c
] << 18;
3122 /* Process second byte of a quadruplet. */
3130 value
|= base64_char_to_value
[c
] << 12;
3132 *e
++ = (unsigned char) (value
>> 16);
3134 /* Process third byte of a quadruplet. */
3150 value
|= base64_char_to_value
[c
] << 6;
3152 *e
++ = (unsigned char) (0xff & value
>> 8);
3154 /* Process fourth byte of a quadruplet. */
3165 value
|= base64_char_to_value
[c
];
3167 *e
++ = (unsigned char) (0xff & value
);
3176 Qstring_lessp
= intern ("string-lessp");
3177 staticpro (&Qstring_lessp
);
3178 Qprovide
= intern ("provide");
3179 staticpro (&Qprovide
);
3180 Qrequire
= intern ("require");
3181 staticpro (&Qrequire
);
3182 Qyes_or_no_p_history
= intern ("yes-or-no-p-history");
3183 staticpro (&Qyes_or_no_p_history
);
3184 Qcursor_in_echo_area
= intern ("cursor-in-echo-area");
3185 staticpro (&Qcursor_in_echo_area
);
3186 Qwidget_type
= intern ("widget-type");
3187 staticpro (&Qwidget_type
);
3189 staticpro (&string_char_byte_cache_string
);
3190 string_char_byte_cache_string
= Qnil
;
3192 Fset (Qyes_or_no_p_history
, Qnil
);
3194 DEFVAR_LISP ("features", &Vfeatures
,
3195 "A list of symbols which are the features of the executing emacs.\n\
3196 Used by `featurep' and `require', and altered by `provide'.");
3199 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box
,
3200 "*Non-nil means mouse commands use dialog boxes to ask questions.\n\
3201 This applies to y-or-n and yes-or-no questions asked by commands\n\
3202 invoked by mouse clicks and mouse menu items.");
3205 defsubr (&Sidentity
);
3208 defsubr (&Ssafe_length
);
3209 defsubr (&Sstring_bytes
);
3210 defsubr (&Sstring_equal
);
3211 defsubr (&Scompare_strings
);
3212 defsubr (&Sstring_lessp
);
3215 defsubr (&Svconcat
);
3216 defsubr (&Scopy_sequence
);
3217 defsubr (&Sstring_make_multibyte
);
3218 defsubr (&Sstring_make_unibyte
);
3219 defsubr (&Sstring_as_multibyte
);
3220 defsubr (&Sstring_as_unibyte
);
3221 defsubr (&Scopy_alist
);
3222 defsubr (&Ssubstring
);
3234 defsubr (&Snreverse
);
3235 defsubr (&Sreverse
);
3237 defsubr (&Splist_get
);
3239 defsubr (&Splist_put
);
3242 defsubr (&Sfillarray
);
3243 defsubr (&Schar_table_subtype
);
3244 defsubr (&Schar_table_parent
);
3245 defsubr (&Sset_char_table_parent
);
3246 defsubr (&Schar_table_extra_slot
);
3247 defsubr (&Sset_char_table_extra_slot
);
3248 defsubr (&Schar_table_range
);
3249 defsubr (&Sset_char_table_range
);
3250 defsubr (&Sset_char_table_default
);
3251 defsubr (&Smap_char_table
);
3254 defsubr (&Smapconcat
);
3255 defsubr (&Sy_or_n_p
);
3256 defsubr (&Syes_or_no_p
);
3257 defsubr (&Sload_average
);
3258 defsubr (&Sfeaturep
);
3259 defsubr (&Srequire
);
3260 defsubr (&Sprovide
);
3261 defsubr (&Swidget_plist_member
);
3262 defsubr (&Swidget_put
);
3263 defsubr (&Swidget_get
);
3264 defsubr (&Swidget_apply
);
3265 defsubr (&Sbase64_encode_region
);
3266 defsubr (&Sbase64_decode_region
);
3267 defsubr (&Sbase64_encode_string
);
3268 defsubr (&Sbase64_decode_string
);