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.")
1009 CHECK_STRING (string
, 0);
1011 if (STRING_MULTIBYTE (string
))
1013 string
= Fcopy_sequence (string
);
1014 XSTRING (string
)->size
= STRING_BYTES (XSTRING (string
));
1015 SET_STRING_BYTES (XSTRING (string
), -1);
1020 DEFUN ("string-as-multibyte", Fstring_as_multibyte
, Sstring_as_multibyte
,
1022 "Return a multibyte string with the same individual bytes as STRING.\n\
1023 If STRING is multibyte, the result is STRING itself.")
1027 CHECK_STRING (string
, 0);
1029 if (! STRING_MULTIBYTE (string
))
1031 int nbytes
= STRING_BYTES (XSTRING (string
));
1032 int newlen
= multibyte_chars_in_text (XSTRING (string
)->data
, nbytes
);
1034 string
= Fcopy_sequence (string
);
1035 XSTRING (string
)->size
= newlen
;
1036 XSTRING (string
)->size_byte
= nbytes
;
1041 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
1042 "Return a copy of ALIST.\n\
1043 This is an alist which represents the same mapping from objects to objects,\n\
1044 but does not share the alist structure with ALIST.\n\
1045 The objects mapped (cars and cdrs of elements of the alist)\n\
1046 are shared, however.\n\
1047 Elements of ALIST that are not conses are also shared.")
1051 register Lisp_Object tem
;
1053 CHECK_LIST (alist
, 0);
1056 alist
= concat (1, &alist
, Lisp_Cons
, 0);
1057 for (tem
= alist
; CONSP (tem
); tem
= XCONS (tem
)->cdr
)
1059 register Lisp_Object car
;
1060 car
= XCONS (tem
)->car
;
1063 XCONS (tem
)->car
= Fcons (XCONS (car
)->car
, XCONS (car
)->cdr
);
1068 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
1069 "Return a substring of STRING, starting at index FROM and ending before TO.\n\
1070 TO may be nil or omitted; then the substring runs to the end of STRING.\n\
1071 If FROM or TO is negative, it counts from the end.\n\
1073 This function allows vectors as well as strings.")
1076 register Lisp_Object from
, to
;
1081 int from_char
, to_char
;
1082 int from_byte
, to_byte
;
1084 if (! (STRINGP (string
) || VECTORP (string
)))
1085 wrong_type_argument (Qarrayp
, string
);
1087 CHECK_NUMBER (from
, 1);
1089 if (STRINGP (string
))
1091 size
= XSTRING (string
)->size
;
1092 size_byte
= STRING_BYTES (XSTRING (string
));
1095 size
= XVECTOR (string
)->size
;
1100 to_byte
= size_byte
;
1104 CHECK_NUMBER (to
, 2);
1106 to_char
= XINT (to
);
1110 if (STRINGP (string
))
1111 to_byte
= string_char_to_byte (string
, to_char
);
1114 from_char
= XINT (from
);
1117 if (STRINGP (string
))
1118 from_byte
= string_char_to_byte (string
, from_char
);
1120 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
1121 args_out_of_range_3 (string
, make_number (from_char
),
1122 make_number (to_char
));
1124 if (STRINGP (string
))
1126 res
= make_specified_string (XSTRING (string
)->data
+ from_byte
,
1127 to_char
- from_char
, to_byte
- from_byte
,
1128 STRING_MULTIBYTE (string
));
1129 copy_text_properties (make_number (from_char
), make_number (to_char
),
1130 string
, make_number (0), res
, Qnil
);
1133 res
= Fvector (to_char
- from_char
,
1134 XVECTOR (string
)->contents
+ from_char
);
1139 /* Extract a substring of STRING, giving start and end positions
1140 both in characters and in bytes. */
1143 substring_both (string
, from
, from_byte
, to
, to_byte
)
1145 int from
, from_byte
, to
, to_byte
;
1151 if (! (STRINGP (string
) || VECTORP (string
)))
1152 wrong_type_argument (Qarrayp
, string
);
1154 if (STRINGP (string
))
1156 size
= XSTRING (string
)->size
;
1157 size_byte
= STRING_BYTES (XSTRING (string
));
1160 size
= XVECTOR (string
)->size
;
1162 if (!(0 <= from
&& from
<= to
&& to
<= size
))
1163 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
1165 if (STRINGP (string
))
1167 res
= make_specified_string (XSTRING (string
)->data
+ from_byte
,
1168 to
- from
, to_byte
- from_byte
,
1169 STRING_MULTIBYTE (string
));
1170 copy_text_properties (make_number (from
), make_number (to
),
1171 string
, make_number (0), res
, Qnil
);
1174 res
= Fvector (to
- from
,
1175 XVECTOR (string
)->contents
+ from
);
1180 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
1181 "Take cdr N times on LIST, returns the result.")
1184 register Lisp_Object list
;
1186 register int i
, num
;
1187 CHECK_NUMBER (n
, 0);
1189 for (i
= 0; i
< num
&& !NILP (list
); i
++)
1197 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
1198 "Return the Nth element of LIST.\n\
1199 N counts from zero. If LIST is not that long, nil is returned.")
1201 Lisp_Object n
, list
;
1203 return Fcar (Fnthcdr (n
, list
));
1206 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
1207 "Return element of SEQUENCE at index N.")
1209 register Lisp_Object sequence
, n
;
1211 CHECK_NUMBER (n
, 0);
1214 if (CONSP (sequence
) || NILP (sequence
))
1215 return Fcar (Fnthcdr (n
, sequence
));
1216 else if (STRINGP (sequence
) || VECTORP (sequence
)
1217 || BOOL_VECTOR_P (sequence
) || CHAR_TABLE_P (sequence
))
1218 return Faref (sequence
, n
);
1220 sequence
= wrong_type_argument (Qsequencep
, sequence
);
1224 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1225 "Return non-nil if ELT is an element of LIST. Comparison done with `equal'.\n\
1226 The value is actually the tail of LIST whose car is ELT.")
1228 register Lisp_Object elt
;
1231 register Lisp_Object tail
;
1232 for (tail
= list
; !NILP (tail
); tail
= XCONS (tail
)->cdr
)
1234 register Lisp_Object tem
;
1236 if (! NILP (Fequal (elt
, tem
)))
1243 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1244 "Return non-nil if ELT is an element of LIST. Comparison done with EQ.\n\
1245 The value is actually the tail of LIST whose car is ELT.")
1247 register Lisp_Object elt
;
1250 register Lisp_Object tail
;
1251 for (tail
= list
; !NILP (tail
); tail
= XCONS (tail
)->cdr
)
1253 register Lisp_Object tem
;
1255 if (EQ (elt
, tem
)) return tail
;
1261 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1262 "Return non-nil if KEY is `eq' to the car of an element of LIST.\n\
1263 The value is actually the element of LIST whose car is KEY.\n\
1264 Elements of LIST that are not conses are ignored.")
1266 register Lisp_Object key
;
1269 register Lisp_Object tail
;
1270 for (tail
= list
; !NILP (tail
); tail
= XCONS (tail
)->cdr
)
1272 register Lisp_Object elt
, tem
;
1274 if (!CONSP (elt
)) continue;
1275 tem
= XCONS (elt
)->car
;
1276 if (EQ (key
, tem
)) return elt
;
1282 /* Like Fassq but never report an error and do not allow quits.
1283 Use only on lists known never to be circular. */
1286 assq_no_quit (key
, list
)
1287 register Lisp_Object key
;
1290 register Lisp_Object tail
;
1291 for (tail
= list
; CONSP (tail
); tail
= XCONS (tail
)->cdr
)
1293 register Lisp_Object elt
, tem
;
1295 if (!CONSP (elt
)) continue;
1296 tem
= XCONS (elt
)->car
;
1297 if (EQ (key
, tem
)) return elt
;
1302 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1303 "Return non-nil if KEY is `equal' to the car of an element of LIST.\n\
1304 The value is actually the element of LIST whose car equals KEY.")
1306 register Lisp_Object key
;
1309 register Lisp_Object tail
;
1310 for (tail
= list
; !NILP (tail
); tail
= XCONS (tail
)->cdr
)
1312 register Lisp_Object elt
, tem
;
1314 if (!CONSP (elt
)) continue;
1315 tem
= Fequal (XCONS (elt
)->car
, key
);
1316 if (!NILP (tem
)) return elt
;
1322 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1323 "Return non-nil if ELT is `eq' to the cdr of an element of LIST.\n\
1324 The value is actually the element of LIST whose cdr is ELT.")
1326 register Lisp_Object key
;
1329 register Lisp_Object tail
;
1330 for (tail
= list
; !NILP (tail
); tail
= XCONS (tail
)->cdr
)
1332 register Lisp_Object elt
, tem
;
1334 if (!CONSP (elt
)) continue;
1335 tem
= XCONS (elt
)->cdr
;
1336 if (EQ (key
, tem
)) return elt
;
1342 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1343 "Return non-nil if KEY is `equal' to the cdr of an element of LIST.\n\
1344 The value is actually the element of LIST whose cdr equals KEY.")
1346 register Lisp_Object key
;
1349 register Lisp_Object tail
;
1350 for (tail
= list
; !NILP (tail
); tail
= XCONS (tail
)->cdr
)
1352 register Lisp_Object elt
, tem
;
1354 if (!CONSP (elt
)) continue;
1355 tem
= Fequal (XCONS (elt
)->cdr
, key
);
1356 if (!NILP (tem
)) return elt
;
1362 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1363 "Delete by side effect any occurrences of ELT as a member of LIST.\n\
1364 The modified LIST is returned. Comparison is done with `eq'.\n\
1365 If the first member of LIST is ELT, there is no way to remove it by side effect;\n\
1366 therefore, write `(setq foo (delq element foo))'\n\
1367 to be sure of changing the value of `foo'.")
1369 register Lisp_Object elt
;
1372 register Lisp_Object tail
, prev
;
1373 register Lisp_Object tem
;
1377 while (!NILP (tail
))
1383 list
= XCONS (tail
)->cdr
;
1385 Fsetcdr (prev
, XCONS (tail
)->cdr
);
1389 tail
= XCONS (tail
)->cdr
;
1395 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1396 "Delete by side effect any occurrences of ELT as a member of LIST.\n\
1397 The modified LIST is returned. Comparison is done with `equal'.\n\
1398 If the first member of LIST is ELT, deleting it is not a side effect;\n\
1399 it is simply using a different list.\n\
1400 Therefore, write `(setq foo (delete element foo))'\n\
1401 to be sure of changing the value of `foo'.")
1403 register Lisp_Object elt
;
1406 register Lisp_Object tail
, prev
;
1407 register Lisp_Object tem
;
1411 while (!NILP (tail
))
1414 if (! NILP (Fequal (elt
, tem
)))
1417 list
= XCONS (tail
)->cdr
;
1419 Fsetcdr (prev
, XCONS (tail
)->cdr
);
1423 tail
= XCONS (tail
)->cdr
;
1429 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1430 "Reverse LIST by modifying cdr pointers.\n\
1431 Returns the beginning of the reversed list.")
1435 register Lisp_Object prev
, tail
, next
;
1437 if (NILP (list
)) return list
;
1440 while (!NILP (tail
))
1444 Fsetcdr (tail
, prev
);
1451 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1452 "Reverse LIST, copying. Returns the beginning of the reversed list.\n\
1453 See also the function `nreverse', which is used more often.")
1459 for (new = Qnil
; CONSP (list
); list
= XCONS (list
)->cdr
)
1460 new = Fcons (XCONS (list
)->car
, new);
1462 wrong_type_argument (Qconsp
, list
);
1466 Lisp_Object
merge ();
1468 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1469 "Sort LIST, stably, comparing elements using PREDICATE.\n\
1470 Returns the sorted list. LIST is modified by side effects.\n\
1471 PREDICATE is called with two elements of LIST, and should return T\n\
1472 if the first element is \"less\" than the second.")
1474 Lisp_Object list
, predicate
;
1476 Lisp_Object front
, back
;
1477 register Lisp_Object len
, tem
;
1478 struct gcpro gcpro1
, gcpro2
;
1479 register int length
;
1482 len
= Flength (list
);
1483 length
= XINT (len
);
1487 XSETINT (len
, (length
/ 2) - 1);
1488 tem
= Fnthcdr (len
, list
);
1490 Fsetcdr (tem
, Qnil
);
1492 GCPRO2 (front
, back
);
1493 front
= Fsort (front
, predicate
);
1494 back
= Fsort (back
, predicate
);
1496 return merge (front
, back
, predicate
);
1500 merge (org_l1
, org_l2
, pred
)
1501 Lisp_Object org_l1
, org_l2
;
1505 register Lisp_Object tail
;
1507 register Lisp_Object l1
, l2
;
1508 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1515 /* It is sufficient to protect org_l1 and org_l2.
1516 When l1 and l2 are updated, we copy the new values
1517 back into the org_ vars. */
1518 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1538 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1554 Fsetcdr (tail
, tem
);
1560 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1561 "Extract a value from a property list.\n\
1562 PLIST is a property list, which is a list of the form\n\
1563 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value\n\
1564 corresponding to the given PROP, or nil if PROP is not\n\
1565 one of the properties on the list.")
1568 register Lisp_Object prop
;
1570 register Lisp_Object tail
;
1571 for (tail
= plist
; !NILP (tail
); tail
= Fcdr (XCONS (tail
)->cdr
))
1573 register Lisp_Object tem
;
1576 return Fcar (XCONS (tail
)->cdr
);
1581 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
1582 "Return the value of SYMBOL's PROPNAME property.\n\
1583 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'.")
1585 Lisp_Object symbol
, propname
;
1587 CHECK_SYMBOL (symbol
, 0);
1588 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
1591 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
1592 "Change value in PLIST of PROP to VAL.\n\
1593 PLIST is a property list, which is a list of the form\n\
1594 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.\n\
1595 If PROP is already a property on the list, its value is set to VAL,\n\
1596 otherwise the new PROP VAL pair is added. The new plist is returned;\n\
1597 use `(setq x (plist-put x prop val))' to be sure to use the new value.\n\
1598 The PLIST is modified by side effects.")
1601 register Lisp_Object prop
;
1604 register Lisp_Object tail
, prev
;
1605 Lisp_Object newcell
;
1607 for (tail
= plist
; CONSP (tail
) && CONSP (XCONS (tail
)->cdr
);
1608 tail
= XCONS (XCONS (tail
)->cdr
)->cdr
)
1610 if (EQ (prop
, XCONS (tail
)->car
))
1612 Fsetcar (XCONS (tail
)->cdr
, val
);
1617 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
1621 Fsetcdr (XCONS (prev
)->cdr
, newcell
);
1625 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
1626 "Store SYMBOL's PROPNAME property with value VALUE.\n\
1627 It can be retrieved with `(get SYMBOL PROPNAME)'.")
1628 (symbol
, propname
, value
)
1629 Lisp_Object symbol
, propname
, value
;
1631 CHECK_SYMBOL (symbol
, 0);
1632 XSYMBOL (symbol
)->plist
1633 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
1637 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
1638 "Return t if two Lisp objects have similar structure and contents.\n\
1639 They must have the same data type.\n\
1640 Conses are compared by comparing the cars and the cdrs.\n\
1641 Vectors and strings are compared element by element.\n\
1642 Numbers are compared by value, but integers cannot equal floats.\n\
1643 (Use `=' if you want integers and floats to be able to be equal.)\n\
1644 Symbols must match exactly.")
1646 register Lisp_Object o1
, o2
;
1648 return internal_equal (o1
, o2
, 0) ? Qt
: Qnil
;
1652 internal_equal (o1
, o2
, depth
)
1653 register Lisp_Object o1
, o2
;
1657 error ("Stack overflow in equal");
1663 if (XTYPE (o1
) != XTYPE (o2
))
1668 #ifdef LISP_FLOAT_TYPE
1670 return (extract_float (o1
) == extract_float (o2
));
1674 if (!internal_equal (XCONS (o1
)->car
, XCONS (o2
)->car
, depth
+ 1))
1676 o1
= XCONS (o1
)->cdr
;
1677 o2
= XCONS (o2
)->cdr
;
1681 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
1685 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o1
),
1687 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o1
),
1690 o1
= XOVERLAY (o1
)->plist
;
1691 o2
= XOVERLAY (o2
)->plist
;
1696 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
1697 && (XMARKER (o1
)->buffer
== 0
1698 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
1702 case Lisp_Vectorlike
:
1704 register int i
, size
;
1705 size
= XVECTOR (o1
)->size
;
1706 /* Pseudovectors have the type encoded in the size field, so this test
1707 actually checks that the objects have the same type as well as the
1709 if (XVECTOR (o2
)->size
!= size
)
1711 /* Boolvectors are compared much like strings. */
1712 if (BOOL_VECTOR_P (o1
))
1715 = (XBOOL_VECTOR (o1
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
1717 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
1719 if (bcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
1724 if (WINDOW_CONFIGURATIONP (o1
))
1725 return compare_window_configurations (o1
, o2
, 0);
1727 /* Aside from them, only true vectors, char-tables, and compiled
1728 functions are sensible to compare, so eliminate the others now. */
1729 if (size
& PSEUDOVECTOR_FLAG
)
1731 if (!(size
& (PVEC_COMPILED
| PVEC_CHAR_TABLE
)))
1733 size
&= PSEUDOVECTOR_SIZE_MASK
;
1735 for (i
= 0; i
< size
; i
++)
1738 v1
= XVECTOR (o1
)->contents
[i
];
1739 v2
= XVECTOR (o2
)->contents
[i
];
1740 if (!internal_equal (v1
, v2
, depth
+ 1))
1748 if (XSTRING (o1
)->size
!= XSTRING (o2
)->size
)
1750 if (STRING_BYTES (XSTRING (o1
)) != STRING_BYTES (XSTRING (o2
)))
1752 if (bcmp (XSTRING (o1
)->data
, XSTRING (o2
)->data
,
1753 STRING_BYTES (XSTRING (o1
))))
1760 extern Lisp_Object
Fmake_char_internal ();
1762 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
1763 "Store each element of ARRAY with ITEM.\n\
1764 ARRAY is a vector, string, char-table, or bool-vector.")
1766 Lisp_Object array
, item
;
1768 register int size
, index
, charval
;
1770 if (VECTORP (array
))
1772 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
1773 size
= XVECTOR (array
)->size
;
1774 for (index
= 0; index
< size
; index
++)
1777 else if (CHAR_TABLE_P (array
))
1779 register Lisp_Object
*p
= XCHAR_TABLE (array
)->contents
;
1780 size
= CHAR_TABLE_ORDINARY_SLOTS
;
1781 for (index
= 0; index
< size
; index
++)
1783 XCHAR_TABLE (array
)->defalt
= Qnil
;
1785 else if (STRINGP (array
))
1787 register unsigned char *p
= XSTRING (array
)->data
;
1788 CHECK_NUMBER (item
, 1);
1789 charval
= XINT (item
);
1790 size
= XSTRING (array
)->size
;
1791 if (STRING_MULTIBYTE (array
))
1793 unsigned char workbuf
[4], *str
;
1794 int len
= CHAR_STRING (charval
, workbuf
, str
);
1795 int size_byte
= STRING_BYTES (XSTRING (array
));
1796 unsigned char *p1
= p
, *endp
= p
+ size_byte
;
1799 if (size
!= size_byte
)
1802 int this_len
= MULTIBYTE_FORM_LENGTH (p1
, endp
- p1
);
1803 if (len
!= this_len
)
1804 error ("Attempt to change byte length of a string");
1807 for (i
= 0; i
< size_byte
; i
++)
1808 *p
++ = str
[i
% len
];
1811 for (index
= 0; index
< size
; index
++)
1814 else if (BOOL_VECTOR_P (array
))
1816 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
1818 = (XBOOL_VECTOR (array
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
1820 charval
= (! NILP (item
) ? -1 : 0);
1821 for (index
= 0; index
< size_in_chars
; index
++)
1826 array
= wrong_type_argument (Qarrayp
, array
);
1832 DEFUN ("char-table-subtype", Fchar_table_subtype
, Schar_table_subtype
,
1834 "Return the subtype of char-table CHAR-TABLE. The value is a symbol.")
1836 Lisp_Object char_table
;
1838 CHECK_CHAR_TABLE (char_table
, 0);
1840 return XCHAR_TABLE (char_table
)->purpose
;
1843 DEFUN ("char-table-parent", Fchar_table_parent
, Schar_table_parent
,
1845 "Return the parent char-table of CHAR-TABLE.\n\
1846 The value is either nil or another char-table.\n\
1847 If CHAR-TABLE holds nil for a given character,\n\
1848 then the actual applicable value is inherited from the parent char-table\n\
1849 \(or from its parents, if necessary).")
1851 Lisp_Object char_table
;
1853 CHECK_CHAR_TABLE (char_table
, 0);
1855 return XCHAR_TABLE (char_table
)->parent
;
1858 DEFUN ("set-char-table-parent", Fset_char_table_parent
, Sset_char_table_parent
,
1860 "Set the parent char-table of CHAR-TABLE to PARENT.\n\
1861 PARENT must be either nil or another char-table.")
1862 (char_table
, parent
)
1863 Lisp_Object char_table
, parent
;
1867 CHECK_CHAR_TABLE (char_table
, 0);
1871 CHECK_CHAR_TABLE (parent
, 0);
1873 for (temp
= parent
; !NILP (temp
); temp
= XCHAR_TABLE (temp
)->parent
)
1874 if (EQ (temp
, char_table
))
1875 error ("Attempt to make a chartable be its own parent");
1878 XCHAR_TABLE (char_table
)->parent
= parent
;
1883 DEFUN ("char-table-extra-slot", Fchar_table_extra_slot
, Schar_table_extra_slot
,
1885 "Return the value of CHAR-TABLE's extra-slot number N.")
1887 Lisp_Object char_table
, n
;
1889 CHECK_CHAR_TABLE (char_table
, 1);
1890 CHECK_NUMBER (n
, 2);
1892 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
1893 args_out_of_range (char_table
, n
);
1895 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)];
1898 DEFUN ("set-char-table-extra-slot", Fset_char_table_extra_slot
,
1899 Sset_char_table_extra_slot
,
1901 "Set CHAR-TABLE's extra-slot number N to VALUE.")
1902 (char_table
, n
, value
)
1903 Lisp_Object char_table
, n
, value
;
1905 CHECK_CHAR_TABLE (char_table
, 1);
1906 CHECK_NUMBER (n
, 2);
1908 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
1909 args_out_of_range (char_table
, n
);
1911 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)] = value
;
1914 DEFUN ("char-table-range", Fchar_table_range
, Schar_table_range
,
1916 "Return the value in CHAR-TABLE for a range of characters RANGE.\n\
1917 RANGE should be nil (for the default value)\n\
1918 a vector which identifies a character set or a row of a character set,\n\
1919 a character set name, or a character code.")
1921 Lisp_Object char_table
, range
;
1925 CHECK_CHAR_TABLE (char_table
, 0);
1927 if (EQ (range
, Qnil
))
1928 return XCHAR_TABLE (char_table
)->defalt
;
1929 else if (INTEGERP (range
))
1930 return Faref (char_table
, range
);
1931 else if (SYMBOLP (range
))
1933 Lisp_Object charset_info
;
1935 charset_info
= Fget (range
, Qcharset
);
1936 CHECK_VECTOR (charset_info
, 0);
1938 return Faref (char_table
,
1939 make_number (XINT (XVECTOR (charset_info
)->contents
[0])
1942 else if (VECTORP (range
))
1944 if (XVECTOR (range
)->size
== 1)
1945 return Faref (char_table
,
1946 make_number (XINT (XVECTOR (range
)->contents
[0]) + 128));
1949 int size
= XVECTOR (range
)->size
;
1950 Lisp_Object
*val
= XVECTOR (range
)->contents
;
1951 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
1952 size
<= 1 ? Qnil
: val
[1],
1953 size
<= 2 ? Qnil
: val
[2]);
1954 return Faref (char_table
, ch
);
1958 error ("Invalid RANGE argument to `char-table-range'");
1961 DEFUN ("set-char-table-range", Fset_char_table_range
, Sset_char_table_range
,
1963 "Set the value in CHAR-TABLE for a range of characters RANGE to VALUE.\n\
1964 RANGE should be t (for all characters), nil (for the default value)\n\
1965 a vector which identifies a character set or a row of a character set,\n\
1966 a coding system, or a character code.")
1967 (char_table
, range
, value
)
1968 Lisp_Object char_table
, range
, value
;
1972 CHECK_CHAR_TABLE (char_table
, 0);
1975 for (i
= 0; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
1976 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
1977 else if (EQ (range
, Qnil
))
1978 XCHAR_TABLE (char_table
)->defalt
= value
;
1979 else if (SYMBOLP (range
))
1981 Lisp_Object charset_info
;
1983 charset_info
= Fget (range
, Qcharset
);
1984 CHECK_VECTOR (charset_info
, 0);
1986 return Faset (char_table
,
1987 make_number (XINT (XVECTOR (charset_info
)->contents
[0])
1991 else if (INTEGERP (range
))
1992 Faset (char_table
, range
, value
);
1993 else if (VECTORP (range
))
1995 if (XVECTOR (range
)->size
== 1)
1996 return Faset (char_table
,
1997 make_number (XINT (XVECTOR (range
)->contents
[0]) + 128),
2001 int size
= XVECTOR (range
)->size
;
2002 Lisp_Object
*val
= XVECTOR (range
)->contents
;
2003 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
2004 size
<= 1 ? Qnil
: val
[1],
2005 size
<= 2 ? Qnil
: val
[2]);
2006 return Faset (char_table
, ch
, value
);
2010 error ("Invalid RANGE argument to `set-char-table-range'");
2015 DEFUN ("set-char-table-default", Fset_char_table_default
,
2016 Sset_char_table_default
, 3, 3, 0,
2017 "Set the default value in CHAR-TABLE for a generic character CHAR to VALUE.\n\
2018 The generic character specifies the group of characters.\n\
2019 See also the documentation of make-char.")
2020 (char_table
, ch
, value
)
2021 Lisp_Object char_table
, ch
, value
;
2023 int c
, i
, charset
, code1
, code2
;
2026 CHECK_CHAR_TABLE (char_table
, 0);
2027 CHECK_NUMBER (ch
, 1);
2030 SPLIT_NON_ASCII_CHAR (c
, charset
, code1
, code2
);
2032 /* Since we may want to set the default value for a character set
2033 not yet defined, we check only if the character set is in the
2034 valid range or not, instead of it is already defined or not. */
2035 if (! CHARSET_VALID_P (charset
))
2036 invalid_character (c
);
2038 if (charset
== CHARSET_ASCII
)
2039 return (XCHAR_TABLE (char_table
)->defalt
= value
);
2041 /* Even if C is not a generic char, we had better behave as if a
2042 generic char is specified. */
2043 if (charset
== CHARSET_COMPOSITION
|| CHARSET_DIMENSION (charset
) == 1)
2045 temp
= XCHAR_TABLE (char_table
)->contents
[charset
+ 128];
2048 if (SUB_CHAR_TABLE_P (temp
))
2049 XCHAR_TABLE (temp
)->defalt
= value
;
2051 XCHAR_TABLE (char_table
)->contents
[charset
+ 128] = value
;
2055 if (! SUB_CHAR_TABLE_P (char_table
))
2056 char_table
= (XCHAR_TABLE (char_table
)->contents
[charset
+ 128]
2057 = make_sub_char_table (temp
));
2058 temp
= XCHAR_TABLE (char_table
)->contents
[code1
];
2059 if (SUB_CHAR_TABLE_P (temp
))
2060 XCHAR_TABLE (temp
)->defalt
= value
;
2062 XCHAR_TABLE (char_table
)->contents
[code1
] = value
;
2066 /* Look up the element in TABLE at index CH,
2067 and return it as an integer.
2068 If the element is nil, return CH itself.
2069 (Actually we do that for any non-integer.) */
2072 char_table_translate (table
, ch
)
2077 value
= Faref (table
, make_number (ch
));
2078 if (! INTEGERP (value
))
2080 return XINT (value
);
2083 /* Map C_FUNCTION or FUNCTION over SUBTABLE, calling it for each
2084 character or group of characters that share a value.
2085 DEPTH is the current depth in the originally specified
2086 chartable, and INDICES contains the vector indices
2087 for the levels our callers have descended.
2089 ARG is passed to C_FUNCTION when that is called. */
2092 map_char_table (c_function
, function
, subtable
, arg
, depth
, indices
)
2093 void (*c_function
) P_ ((Lisp_Object
, Lisp_Object
, Lisp_Object
));
2094 Lisp_Object function
, subtable
, arg
, *indices
;
2101 /* At first, handle ASCII and 8-bit European characters. */
2102 for (i
= 0; i
< CHAR_TABLE_SINGLE_BYTE_SLOTS
; i
++)
2104 Lisp_Object elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2106 (*c_function
) (arg
, make_number (i
), elt
);
2108 call2 (function
, make_number (i
), elt
);
2110 #if 0 /* If the char table has entries for higher characters,
2111 we should report them. */
2112 if (NILP (current_buffer
->enable_multibyte_characters
))
2115 to
= CHAR_TABLE_ORDINARY_SLOTS
;
2120 to
= SUB_CHAR_TABLE_ORDINARY_SLOTS
;
2125 Lisp_Object elt
= XCHAR_TABLE (subtable
)->contents
[i
];
2127 XSETFASTINT (indices
[depth
], i
);
2129 if (SUB_CHAR_TABLE_P (elt
))
2132 error ("Too deep char table");
2133 map_char_table (c_function
, function
, elt
, arg
, depth
+ 1, indices
);
2137 int charset
= XFASTINT (indices
[0]) - 128, c1
, c2
, c
;
2139 if (CHARSET_DEFINED_P (charset
))
2141 c1
= depth
>= 1 ? XFASTINT (indices
[1]) : 0;
2142 c2
= depth
>= 2 ? XFASTINT (indices
[2]) : 0;
2143 c
= MAKE_NON_ASCII_CHAR (charset
, c1
, c2
);
2145 (*c_function
) (arg
, make_number (c
), elt
);
2147 call2 (function
, make_number (c
), elt
);
2153 DEFUN ("map-char-table", Fmap_char_table
, Smap_char_table
,
2155 "Call FUNCTION for each (normal and generic) characters in CHAR-TABLE.\n\
2156 FUNCTION is called with two arguments--a key and a value.\n\
2157 The key is always a possible IDX argument to `aref'.")
2158 (function
, char_table
)
2159 Lisp_Object function
, char_table
;
2161 /* The depth of char table is at most 3. */
2162 Lisp_Object indices
[3];
2164 CHECK_CHAR_TABLE (char_table
, 1);
2166 map_char_table (NULL
, function
, char_table
, char_table
, 0, indices
);
2176 Lisp_Object args
[2];
2179 return Fnconc (2, args
);
2181 return Fnconc (2, &s1
);
2182 #endif /* NO_ARG_ARRAY */
2185 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
2186 "Concatenate any number of lists by altering them.\n\
2187 Only the last argument is not altered, and need not be a list.")
2192 register int argnum
;
2193 register Lisp_Object tail
, tem
, val
;
2197 for (argnum
= 0; argnum
< nargs
; argnum
++)
2200 if (NILP (tem
)) continue;
2205 if (argnum
+ 1 == nargs
) break;
2208 tem
= wrong_type_argument (Qlistp
, tem
);
2217 tem
= args
[argnum
+ 1];
2218 Fsetcdr (tail
, tem
);
2220 args
[argnum
+ 1] = tail
;
2226 /* This is the guts of all mapping functions.
2227 Apply FN to each element of SEQ, one by one,
2228 storing the results into elements of VALS, a C vector of Lisp_Objects.
2229 LENI is the length of VALS, which should also be the length of SEQ. */
2232 mapcar1 (leni
, vals
, fn
, seq
)
2235 Lisp_Object fn
, seq
;
2237 register Lisp_Object tail
;
2240 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2242 /* Don't let vals contain any garbage when GC happens. */
2243 for (i
= 0; i
< leni
; i
++)
2246 GCPRO3 (dummy
, fn
, seq
);
2248 gcpro1
.nvars
= leni
;
2249 /* We need not explicitly protect `tail' because it is used only on lists, and
2250 1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
2254 for (i
= 0; i
< leni
; i
++)
2256 dummy
= XVECTOR (seq
)->contents
[i
];
2257 vals
[i
] = call1 (fn
, dummy
);
2260 else if (BOOL_VECTOR_P (seq
))
2262 for (i
= 0; i
< leni
; i
++)
2265 byte
= XBOOL_VECTOR (seq
)->data
[i
/ BITS_PER_CHAR
];
2266 if (byte
& (1 << (i
% BITS_PER_CHAR
)))
2271 vals
[i
] = call1 (fn
, dummy
);
2274 else if (STRINGP (seq
) && ! STRING_MULTIBYTE (seq
))
2276 /* Single-byte string. */
2277 for (i
= 0; i
< leni
; i
++)
2279 XSETFASTINT (dummy
, XSTRING (seq
)->data
[i
]);
2280 vals
[i
] = call1 (fn
, dummy
);
2283 else if (STRINGP (seq
))
2285 /* Multi-byte string. */
2286 int len_byte
= STRING_BYTES (XSTRING (seq
));
2289 for (i
= 0, i_byte
= 0; i
< leni
;)
2294 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2295 XSETFASTINT (dummy
, c
);
2296 vals
[i_before
] = call1 (fn
, dummy
);
2299 else /* Must be a list, since Flength did not get an error */
2302 for (i
= 0; i
< leni
; i
++)
2304 vals
[i
] = call1 (fn
, Fcar (tail
));
2305 tail
= XCONS (tail
)->cdr
;
2312 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2313 "Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.\n\
2314 In between each pair of results, stick in SEPARATOR. Thus, \" \" as\n\
2315 SEPARATOR results in spaces between the values returned by FUNCTION.\n\
2316 SEQUENCE may be a list, a vector, a bool-vector, or a string.")
2317 (function
, sequence
, separator
)
2318 Lisp_Object function
, sequence
, separator
;
2323 register Lisp_Object
*args
;
2325 struct gcpro gcpro1
;
2327 len
= Flength (sequence
);
2329 nargs
= leni
+ leni
- 1;
2330 if (nargs
< 0) return build_string ("");
2332 args
= (Lisp_Object
*) alloca (nargs
* sizeof (Lisp_Object
));
2335 mapcar1 (leni
, args
, function
, sequence
);
2338 for (i
= leni
- 1; i
>= 0; i
--)
2339 args
[i
+ i
] = args
[i
];
2341 for (i
= 1; i
< nargs
; i
+= 2)
2342 args
[i
] = separator
;
2344 return Fconcat (nargs
, args
);
2347 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2348 "Apply FUNCTION to each element of SEQUENCE, and make a list of the results.\n\
2349 The result is a list just as long as SEQUENCE.\n\
2350 SEQUENCE may be a list, a vector, a bool-vector, or a string.")
2351 (function
, sequence
)
2352 Lisp_Object function
, sequence
;
2354 register Lisp_Object len
;
2356 register Lisp_Object
*args
;
2358 len
= Flength (sequence
);
2359 leni
= XFASTINT (len
);
2360 args
= (Lisp_Object
*) alloca (leni
* sizeof (Lisp_Object
));
2362 mapcar1 (leni
, args
, function
, sequence
);
2364 return Flist (leni
, args
);
2367 /* Anything that calls this function must protect from GC! */
2369 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
2370 "Ask user a \"y or n\" question. Return t if answer is \"y\".\n\
2371 Takes one argument, which is the string to display to ask the question.\n\
2372 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.\n\
2373 No confirmation of the answer is requested; a single character is enough.\n\
2374 Also accepts Space to mean yes, or Delete to mean no.")
2378 register Lisp_Object obj
, key
, def
, answer_string
, map
;
2379 register int answer
;
2380 Lisp_Object xprompt
;
2381 Lisp_Object args
[2];
2382 struct gcpro gcpro1
, gcpro2
;
2383 int count
= specpdl_ptr
- specpdl
;
2385 specbind (Qcursor_in_echo_area
, Qt
);
2387 map
= Fsymbol_value (intern ("query-replace-map"));
2389 CHECK_STRING (prompt
, 0);
2391 GCPRO2 (prompt
, xprompt
);
2397 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2401 Lisp_Object pane
, menu
;
2402 redisplay_preserve_echo_area ();
2403 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2404 Fcons (Fcons (build_string ("No"), Qnil
),
2406 menu
= Fcons (prompt
, pane
);
2407 obj
= Fx_popup_dialog (Qt
, menu
);
2408 answer
= !NILP (obj
);
2411 #endif /* HAVE_MENUS */
2412 cursor_in_echo_area
= 1;
2413 choose_minibuf_frame ();
2414 message_with_string ("%s(y or n) ", xprompt
, 0);
2416 if (minibuffer_auto_raise
)
2418 Lisp_Object mini_frame
;
2420 mini_frame
= WINDOW_FRAME (XWINDOW (minibuf_window
));
2422 Fraise_frame (mini_frame
);
2425 obj
= read_filtered_event (1, 0, 0, 0);
2426 cursor_in_echo_area
= 0;
2427 /* If we need to quit, quit with cursor_in_echo_area = 0. */
2430 key
= Fmake_vector (make_number (1), obj
);
2431 def
= Flookup_key (map
, key
, Qt
);
2432 answer_string
= Fsingle_key_description (obj
);
2434 if (EQ (def
, intern ("skip")))
2439 else if (EQ (def
, intern ("act")))
2444 else if (EQ (def
, intern ("recenter")))
2450 else if (EQ (def
, intern ("quit")))
2452 /* We want to exit this command for exit-prefix,
2453 and this is the only way to do it. */
2454 else if (EQ (def
, intern ("exit-prefix")))
2459 /* If we don't clear this, then the next call to read_char will
2460 return quit_char again, and we'll enter an infinite loop. */
2465 if (EQ (xprompt
, prompt
))
2467 args
[0] = build_string ("Please answer y or n. ");
2469 xprompt
= Fconcat (2, args
);
2474 if (! noninteractive
)
2476 cursor_in_echo_area
= -1;
2477 message_with_string (answer
? "%s(y or n) y" : "%s(y or n) n",
2481 unbind_to (count
, Qnil
);
2482 return answer
? Qt
: Qnil
;
2485 /* This is how C code calls `yes-or-no-p' and allows the user
2488 Anything that calls this function must protect from GC! */
2491 do_yes_or_no_p (prompt
)
2494 return call1 (intern ("yes-or-no-p"), prompt
);
2497 /* Anything that calls this function must protect from GC! */
2499 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2500 "Ask user a yes-or-no question. Return t if answer is yes.\n\
2501 Takes one argument, which is the string to display to ask the question.\n\
2502 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.\n\
2503 The user must confirm the answer with RET,\n\
2504 and can edit it until it has been confirmed.")
2508 register Lisp_Object ans
;
2509 Lisp_Object args
[2];
2510 struct gcpro gcpro1
;
2513 CHECK_STRING (prompt
, 0);
2516 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2520 Lisp_Object pane
, menu
, obj
;
2521 redisplay_preserve_echo_area ();
2522 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2523 Fcons (Fcons (build_string ("No"), Qnil
),
2526 menu
= Fcons (prompt
, pane
);
2527 obj
= Fx_popup_dialog (Qt
, menu
);
2531 #endif /* HAVE_MENUS */
2534 args
[1] = build_string ("(yes or no) ");
2535 prompt
= Fconcat (2, args
);
2541 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2542 Qyes_or_no_p_history
, Qnil
,
2544 if (XSTRING (ans
)->size
== 3 && !strcmp (XSTRING (ans
)->data
, "yes"))
2549 if (XSTRING (ans
)->size
== 2 && !strcmp (XSTRING (ans
)->data
, "no"))
2557 message ("Please answer yes or no.");
2558 Fsleep_for (make_number (2), Qnil
);
2562 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 1, 0,
2563 "Return list of 1 minute, 5 minute and 15 minute load averages.\n\
2564 Each of the three load averages is multiplied by 100,\n\
2565 then converted to integer.\n\
2566 When USE-FLOATS is non-nil, floats will be used instead of integers.\n\
2567 These floats are not multiplied by 100.\n\n\
2568 If the 5-minute or 15-minute load averages are not available, return a\n\
2569 shortened list, containing only those averages which are available.")
2571 Lisp_Object use_floats
;
2574 int loads
= getloadavg (load_ave
, 3);
2575 Lisp_Object ret
= Qnil
;
2578 error ("load-average not implemented for this operating system");
2582 Lisp_Object load
= (NILP (use_floats
) ?
2583 make_number ((int) (100.0 * load_ave
[loads
]))
2584 : make_float (load_ave
[loads
]));
2585 ret
= Fcons (load
, ret
);
2591 Lisp_Object Vfeatures
;
2593 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 1, 0,
2594 "Returns t if FEATURE is present in this Emacs.\n\
2595 Use this to conditionalize execution of lisp code based on the presence or\n\
2596 absence of emacs or environment extensions.\n\
2597 Use `provide' to declare that a feature is available.\n\
2598 This function looks at the value of the variable `features'.")
2600 Lisp_Object feature
;
2602 register Lisp_Object tem
;
2603 CHECK_SYMBOL (feature
, 0);
2604 tem
= Fmemq (feature
, Vfeatures
);
2605 return (NILP (tem
)) ? Qnil
: Qt
;
2608 DEFUN ("provide", Fprovide
, Sprovide
, 1, 1, 0,
2609 "Announce that FEATURE is a feature of the current Emacs.")
2611 Lisp_Object feature
;
2613 register Lisp_Object tem
;
2614 CHECK_SYMBOL (feature
, 0);
2615 if (!NILP (Vautoload_queue
))
2616 Vautoload_queue
= Fcons (Fcons (Vfeatures
, Qnil
), Vautoload_queue
);
2617 tem
= Fmemq (feature
, Vfeatures
);
2619 Vfeatures
= Fcons (feature
, Vfeatures
);
2620 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2624 DEFUN ("require", Frequire
, Srequire
, 1, 2, 0,
2625 "If feature FEATURE is not loaded, load it from FILENAME.\n\
2626 If FEATURE is not a member of the list `features', then the feature\n\
2627 is not loaded; so load the file FILENAME.\n\
2628 If FILENAME is omitted, the printname of FEATURE is used as the file name,\n\
2629 but in this case `load' insists on adding the suffix `.el' or `.elc'.")
2630 (feature
, file_name
)
2631 Lisp_Object feature
, file_name
;
2633 register Lisp_Object tem
;
2634 CHECK_SYMBOL (feature
, 0);
2635 tem
= Fmemq (feature
, Vfeatures
);
2636 LOADHIST_ATTACH (Fcons (Qrequire
, feature
));
2639 int count
= specpdl_ptr
- specpdl
;
2641 /* Value saved here is to be restored into Vautoload_queue */
2642 record_unwind_protect (un_autoload
, Vautoload_queue
);
2643 Vautoload_queue
= Qt
;
2645 Fload (NILP (file_name
) ? Fsymbol_name (feature
) : file_name
,
2646 Qnil
, Qt
, Qnil
, (NILP (file_name
) ? Qt
: Qnil
));
2648 tem
= Fmemq (feature
, Vfeatures
);
2650 error ("Required feature %s was not provided",
2651 XSYMBOL (feature
)->name
->data
);
2653 /* Once loading finishes, don't undo it. */
2654 Vautoload_queue
= Qt
;
2655 feature
= unbind_to (count
, feature
);
2660 /* Primitives for work of the "widget" library.
2661 In an ideal world, this section would not have been necessary.
2662 However, lisp function calls being as slow as they are, it turns
2663 out that some functions in the widget library (wid-edit.el) are the
2664 bottleneck of Widget operation. Here is their translation to C,
2665 for the sole reason of efficiency. */
2667 DEFUN ("widget-plist-member", Fwidget_plist_member
, Swidget_plist_member
, 2, 2, 0,
2668 "Return non-nil if PLIST has the property PROP.\n\
2669 PLIST is a property list, which is a list of the form\n\
2670 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.\n\
2671 Unlike `plist-get', this allows you to distinguish between a missing\n\
2672 property and a property with the value nil.\n\
2673 The value is actually the tail of PLIST whose car is PROP.")
2675 Lisp_Object plist
, prop
;
2677 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
2680 plist
= XCDR (plist
);
2681 plist
= CDR (plist
);
2686 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
2687 "In WIDGET, set PROPERTY to VALUE.\n\
2688 The value can later be retrieved with `widget-get'.")
2689 (widget
, property
, value
)
2690 Lisp_Object widget
, property
, value
;
2692 CHECK_CONS (widget
, 1);
2693 XCDR (widget
) = Fplist_put (XCDR (widget
), property
, value
);
2697 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
2698 "In WIDGET, get the value of PROPERTY.\n\
2699 The value could either be specified when the widget was created, or\n\
2700 later with `widget-put'.")
2702 Lisp_Object widget
, property
;
2710 CHECK_CONS (widget
, 1);
2711 tmp
= Fwidget_plist_member (XCDR (widget
), property
);
2717 tmp
= XCAR (widget
);
2720 widget
= Fget (tmp
, Qwidget_type
);
2724 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
2725 "Apply the value of WIDGET's PROPERTY to the widget itself.\n\
2726 ARGS are passed as extra arguments to the function.")
2731 /* This function can GC. */
2732 Lisp_Object newargs
[3];
2733 struct gcpro gcpro1
, gcpro2
;
2736 newargs
[0] = Fwidget_get (args
[0], args
[1]);
2737 newargs
[1] = args
[0];
2738 newargs
[2] = Flist (nargs
- 2, args
+ 2);
2739 GCPRO2 (newargs
[0], newargs
[2]);
2740 result
= Fapply (3, newargs
);
2745 /* base64 encode/decode functions.
2746 Based on code from GNU recode. */
2748 #define MIME_LINE_LENGTH 76
2750 #define IS_ASCII(Character) \
2752 #define IS_BASE64(Character) \
2753 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
2755 /* Table of characters coding the 64 values. */
2756 static char base64_value_to_char
[64] =
2758 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
2759 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
2760 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
2761 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
2762 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
2763 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
2764 '8', '9', '+', '/' /* 60-63 */
2767 /* Table of base64 values for first 128 characters. */
2768 static short base64_char_to_value
[128] =
2770 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
2771 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
2772 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
2773 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
2774 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
2775 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
2776 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
2777 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
2778 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
2779 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
2780 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
2781 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
2782 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
2785 /* The following diagram shows the logical steps by which three octets
2786 get transformed into four base64 characters.
2788 .--------. .--------. .--------.
2789 |aaaaaabb| |bbbbcccc| |ccdddddd|
2790 `--------' `--------' `--------'
2792 .--------+--------+--------+--------.
2793 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
2794 `--------+--------+--------+--------'
2796 .--------+--------+--------+--------.
2797 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
2798 `--------+--------+--------+--------'
2800 The octets are divided into 6 bit chunks, which are then encoded into
2801 base64 characters. */
2804 static int base64_encode_1
P_ ((const char *, char *, int, int));
2805 static int base64_decode_1
P_ ((const char *, char *, int));
2807 DEFUN ("base64-encode-region", Fbase64_encode_region
, Sbase64_encode_region
,
2809 "base64 encode the region between BEG and END.\n\
2810 Return the length of the encoded text.
2811 Optional third argument NO-LINE-BREAK means do not break long lines\n\
2812 into shorter lines.")
2813 (beg
, end
, no_line_break
)
2814 Lisp_Object beg
, end
, no_line_break
;
2817 int allength
, length
;
2818 int ibeg
, iend
, encoded_length
;
2821 validate_region (&beg
, &end
);
2823 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
2824 iend
= CHAR_TO_BYTE (XFASTINT (end
));
2825 move_gap_both (XFASTINT (beg
), ibeg
);
2827 /* We need to allocate enough room for encoding the text.
2828 We need 33 1/3% more space, plus a newline every 76
2829 characters, and then we round up. */
2830 length
= iend
- ibeg
;
2831 allength
= length
+ length
/3 + 1;
2832 allength
+= allength
/ MIME_LINE_LENGTH
+ 1 + 6;
2834 encoded
= (char *) alloca (allength
);
2835 encoded_length
= base64_encode_1 (BYTE_POS_ADDR (ibeg
), encoded
, length
,
2836 NILP (no_line_break
));
2837 if (encoded_length
> allength
)
2840 /* Now we have encoded the region, so we insert the new contents
2841 and delete the old. (Insert first in order to preserve markers.) */
2843 insert (encoded
, encoded_length
);
2844 del_range_byte (ibeg
+ encoded_length
, iend
+ encoded_length
, 1);
2846 /* If point was outside of the region, restore it exactly; else just
2847 move to the beginning of the region. */
2848 if (old_pos
>= XFASTINT (end
))
2849 old_pos
+= encoded_length
- (XFASTINT (end
) - XFASTINT (beg
));
2850 else if (old_pos
> beg
)
2854 /* We return the length of the encoded text. */
2855 return make_number (encoded_length
);
2858 DEFUN ("base64-encode-string", Fbase64_encode_string
, Sbase64_encode_string
,
2860 "base64 encode STRING and return the result.")
2864 int allength
, length
, encoded_length
;
2867 CHECK_STRING (string
, 1);
2869 length
= STRING_BYTES (XSTRING (string
));
2870 allength
= length
+ length
/3 + 1 + 6;
2872 /* We need to allocate enough room for decoding the text. */
2873 encoded
= (char *) alloca (allength
);
2875 encoded_length
= base64_encode_1 (XSTRING (string
)->data
,
2876 encoded
, length
, 0);
2877 if (encoded_length
> allength
)
2880 return make_unibyte_string (encoded
, encoded_length
);
2884 base64_encode_1 (from
, to
, length
, line_break
)
2890 int counter
= 0, i
= 0;
2899 /* Wrap line every 76 characters. */
2903 if (counter
< MIME_LINE_LENGTH
/ 4)
2912 /* Process first byte of a triplet. */
2914 *e
++ = base64_value_to_char
[0x3f & c
>> 2];
2915 value
= (0x03 & c
) << 4;
2917 /* Process second byte of a triplet. */
2921 *e
++ = base64_value_to_char
[value
];
2929 *e
++ = base64_value_to_char
[value
| (0x0f & c
>> 4)];
2930 value
= (0x0f & c
) << 2;
2932 /* Process third byte of a triplet. */
2936 *e
++ = base64_value_to_char
[value
];
2943 *e
++ = base64_value_to_char
[value
| (0x03 & c
>> 6)];
2944 *e
++ = base64_value_to_char
[0x3f & c
];
2947 /* Complete last partial line. */
2957 DEFUN ("base64-decode-region", Fbase64_decode_region
, Sbase64_decode_region
,
2959 "base64 decode the region between BEG and END.\n\
2960 Return the length of the decoded text.
2961 If the region can't be decoded, return nil and don't modify the buffer.")
2963 Lisp_Object beg
, end
;
2965 int ibeg
, iend
, length
;
2970 validate_region (&beg
, &end
);
2972 ibeg
= CHAR_TO_BYTE (XFASTINT (beg
));
2973 iend
= CHAR_TO_BYTE (XFASTINT (end
));
2975 length
= iend
- ibeg
;
2976 /* We need to allocate enough room for decoding the text. */
2977 decoded
= (char *) alloca (length
);
2979 move_gap_both (XFASTINT (beg
), ibeg
);
2980 decoded_length
= base64_decode_1 (BYTE_POS_ADDR (ibeg
), decoded
, length
);
2981 if (decoded_length
> length
)
2984 if (decoded_length
< 0)
2985 /* The decoding wasn't possible. */
2988 /* Now we have decoded the region, so we insert the new contents
2989 and delete the old. (Insert first in order to preserve markers.) */
2991 insert (decoded
, decoded_length
);
2992 del_range_byte (ibeg
+ decoded_length
, iend
+ decoded_length
, 1);
2994 /* If point was outside of the region, restore it exactly; else just
2995 move to the beginning of the region. */
2996 if (old_pos
>= XFASTINT (end
))
2997 old_pos
+= decoded_length
- length
;
2998 else if (old_pos
> beg
)
3002 return make_number (decoded_length
);
3005 DEFUN ("base64-decode-string", Fbase64_decode_string
, Sbase64_decode_string
,
3007 "base64 decode STRING and return the result.")
3012 int length
, decoded_length
;
3014 CHECK_STRING (string
, 1);
3016 length
= STRING_BYTES (XSTRING (string
));
3017 /* We need to allocate enough room for decoding the text. */
3018 decoded
= (char *) alloca (length
);
3020 decoded_length
= base64_decode_1 (XSTRING (string
)->data
, decoded
, length
);
3021 if (decoded_length
> length
)
3024 if (decoded_length
< 0)
3027 return make_string (decoded
, decoded_length
);
3031 base64_decode_1 (from
, to
, length
)
3036 int counter
= 0, i
= 0;
3039 unsigned long value
;
3043 /* Accept wrapping lines, reversibly if at each 76 characters. */
3053 if (counter
!= MIME_LINE_LENGTH
/ 4)
3060 /* Process first byte of a quadruplet. */
3064 value
= base64_char_to_value
[c
] << 18;
3066 /* Process second byte of a quadruplet. */
3074 value
|= base64_char_to_value
[c
] << 12;
3076 *e
++ = (unsigned char) (value
>> 16);
3078 /* Process third byte of a quadruplet. */
3094 value
|= base64_char_to_value
[c
] << 6;
3096 *e
++ = (unsigned char) (0xff & value
>> 8);
3098 /* Process fourth byte of a quadruplet. */
3109 value
|= base64_char_to_value
[c
];
3111 *e
++ = (unsigned char) (0xff & value
);
3120 Qstring_lessp
= intern ("string-lessp");
3121 staticpro (&Qstring_lessp
);
3122 Qprovide
= intern ("provide");
3123 staticpro (&Qprovide
);
3124 Qrequire
= intern ("require");
3125 staticpro (&Qrequire
);
3126 Qyes_or_no_p_history
= intern ("yes-or-no-p-history");
3127 staticpro (&Qyes_or_no_p_history
);
3128 Qcursor_in_echo_area
= intern ("cursor-in-echo-area");
3129 staticpro (&Qcursor_in_echo_area
);
3130 Qwidget_type
= intern ("widget-type");
3131 staticpro (&Qwidget_type
);
3133 staticpro (&string_char_byte_cache_string
);
3134 string_char_byte_cache_string
= Qnil
;
3136 Fset (Qyes_or_no_p_history
, Qnil
);
3138 DEFVAR_LISP ("features", &Vfeatures
,
3139 "A list of symbols which are the features of the executing emacs.\n\
3140 Used by `featurep' and `require', and altered by `provide'.");
3143 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box
,
3144 "*Non-nil means mouse commands use dialog boxes to ask questions.\n\
3145 This applies to y-or-n and yes-or-no questions asked by commands\n\
3146 invoked by mouse clicks and mouse menu items.");
3149 defsubr (&Sidentity
);
3152 defsubr (&Ssafe_length
);
3153 defsubr (&Sstring_bytes
);
3154 defsubr (&Sstring_equal
);
3155 defsubr (&Scompare_strings
);
3156 defsubr (&Sstring_lessp
);
3159 defsubr (&Svconcat
);
3160 defsubr (&Scopy_sequence
);
3161 defsubr (&Sstring_make_multibyte
);
3162 defsubr (&Sstring_make_unibyte
);
3163 defsubr (&Sstring_as_multibyte
);
3164 defsubr (&Sstring_as_unibyte
);
3165 defsubr (&Scopy_alist
);
3166 defsubr (&Ssubstring
);
3178 defsubr (&Snreverse
);
3179 defsubr (&Sreverse
);
3181 defsubr (&Splist_get
);
3183 defsubr (&Splist_put
);
3186 defsubr (&Sfillarray
);
3187 defsubr (&Schar_table_subtype
);
3188 defsubr (&Schar_table_parent
);
3189 defsubr (&Sset_char_table_parent
);
3190 defsubr (&Schar_table_extra_slot
);
3191 defsubr (&Sset_char_table_extra_slot
);
3192 defsubr (&Schar_table_range
);
3193 defsubr (&Sset_char_table_range
);
3194 defsubr (&Sset_char_table_default
);
3195 defsubr (&Smap_char_table
);
3198 defsubr (&Smapconcat
);
3199 defsubr (&Sy_or_n_p
);
3200 defsubr (&Syes_or_no_p
);
3201 defsubr (&Sload_average
);
3202 defsubr (&Sfeaturep
);
3203 defsubr (&Srequire
);
3204 defsubr (&Sprovide
);
3205 defsubr (&Swidget_plist_member
);
3206 defsubr (&Swidget_put
);
3207 defsubr (&Swidget_get
);
3208 defsubr (&Swidget_apply
);
3209 defsubr (&Sbase64_encode_region
);
3210 defsubr (&Sbase64_decode_region
);
3211 defsubr (&Sbase64_encode_string
);
3212 defsubr (&Sbase64_decode_string
);