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. */
24 /* Note on some machines this defines `vector' as a typedef,
25 so make sure we don't use that name in this file. */
35 #include "intervals.h"
40 #define NULL (void *)0
43 #define DEFAULT_NONASCII_INSERT_OFFSET 0x800
45 /* Nonzero enables use of dialog boxes for questions
46 asked by mouse commands. */
49 extern Lisp_Object
Flookup_key ();
51 extern int minibuffer_auto_raise
;
52 extern Lisp_Object minibuf_window
;
54 Lisp_Object Qstring_lessp
, Qprovide
, Qrequire
;
55 Lisp_Object Qyes_or_no_p_history
;
56 Lisp_Object Qcursor_in_echo_area
;
57 Lisp_Object Qwidget_type
;
59 static int internal_equal ();
61 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
62 "Return the argument unchanged.")
69 extern long get_random ();
70 extern void seed_random ();
73 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
74 "Return a pseudo-random number.\n\
75 All integers representable in Lisp are equally likely.\n\
76 On most systems, this is 28 bits' worth.\n\
77 With positive integer argument N, return random number in interval [0,N).\n\
78 With argument t, set the random number seed from the current time and pid.")
83 Lisp_Object lispy_val
;
84 unsigned long denominator
;
87 seed_random (getpid () + time (NULL
));
88 if (NATNUMP (n
) && XFASTINT (n
) != 0)
90 /* Try to take our random number from the higher bits of VAL,
91 not the lower, since (says Gentzel) the low bits of `random'
92 are less random than the higher ones. We do this by using the
93 quotient rather than the remainder. At the high end of the RNG
94 it's possible to get a quotient larger than n; discarding
95 these values eliminates the bias that would otherwise appear
96 when using a large n. */
97 denominator
= ((unsigned long)1 << VALBITS
) / XFASTINT (n
);
99 val
= get_random () / denominator
;
100 while (val
>= XFASTINT (n
));
104 XSETINT (lispy_val
, val
);
108 /* Random data-structure functions */
110 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
111 "Return the length of vector, list or string SEQUENCE.\n\
112 A byte-code function object is also allowed.\n\
113 If the string contains multibyte characters, this is not the necessarily\n\
114 the number of characters in the string; it is the number of bytes.\n\
115 To get the number of characters, use `chars-in-string'")
117 register Lisp_Object sequence
;
119 register Lisp_Object tail
, val
;
123 if (STRINGP (sequence
))
124 XSETFASTINT (val
, XSTRING (sequence
)->size
);
125 else if (VECTORP (sequence
))
126 XSETFASTINT (val
, XVECTOR (sequence
)->size
);
127 else if (CHAR_TABLE_P (sequence
))
128 XSETFASTINT (val
, CHAR_TABLE_ORDINARY_SLOTS
);
129 else if (BOOL_VECTOR_P (sequence
))
130 XSETFASTINT (val
, XBOOL_VECTOR (sequence
)->size
);
131 else if (COMPILEDP (sequence
))
132 XSETFASTINT (val
, XVECTOR (sequence
)->size
& PSEUDOVECTOR_SIZE_MASK
);
133 else if (CONSP (sequence
))
135 for (i
= 0, tail
= sequence
; !NILP (tail
); i
++)
141 XSETFASTINT (val
, i
);
143 else if (NILP (sequence
))
144 XSETFASTINT (val
, 0);
147 sequence
= wrong_type_argument (Qsequencep
, sequence
);
153 /* This does not check for quits. That is safe
154 since it must terminate. */
156 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
157 "Return the length of a list, but avoid error or infinite loop.\n\
158 This function never gets an error. If LIST is not really a list,\n\
159 it returns 0. If LIST is circular, it returns a finite value\n\
160 which is at least the number of distinct elements.")
164 Lisp_Object tail
, halftail
, length
;
167 /* halftail is used to detect circular lists. */
169 for (tail
= list
; CONSP (tail
); tail
= XCONS (tail
)->cdr
)
171 if (EQ (tail
, halftail
) && len
!= 0)
175 halftail
= XCONS (halftail
)->cdr
;
178 XSETINT (length
, len
);
182 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
183 "Return t if two strings have identical contents.\n\
184 Case is significant, but text properties are ignored.\n\
185 Symbols are also allowed; their print names are used instead.")
187 register Lisp_Object s1
, s2
;
190 XSETSTRING (s1
, XSYMBOL (s1
)->name
);
192 XSETSTRING (s2
, XSYMBOL (s2
)->name
);
193 CHECK_STRING (s1
, 0);
194 CHECK_STRING (s2
, 1);
196 if (XSTRING (s1
)->size
!= XSTRING (s2
)->size
197 || XSTRING (s1
)->size_byte
!= XSTRING (s2
)->size_byte
198 || bcmp (XSTRING (s1
)->data
, XSTRING (s2
)->data
, XSTRING (s1
)->size_byte
))
203 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
204 "Return t if first arg string is less than second in lexicographic order.\n\
205 Case is significant.\n\
206 Symbols are also allowed; their print names are used instead.")
208 register Lisp_Object s1
, s2
;
211 register int i1
, i1_byte
, i2
, i2_byte
;
214 XSETSTRING (s1
, XSYMBOL (s1
)->name
);
216 XSETSTRING (s2
, XSYMBOL (s2
)->name
);
217 CHECK_STRING (s1
, 0);
218 CHECK_STRING (s2
, 1);
220 i1
= i1_byte
= i2
= i2_byte
= 0;
222 end
= XSTRING (s1
)->size
;
223 if (end
> XSTRING (s2
)->size
)
224 end
= XSTRING (s2
)->size
;
228 /* When we find a mismatch, we must compare the
229 characters, not just the bytes. */
232 if (STRING_MULTIBYTE (s1
))
233 FETCH_STRING_CHAR_ADVANCE (c1
, s1
, i1
, i1_byte
);
235 c1
= XSTRING (s1
)->data
[i1
++];
237 if (STRING_MULTIBYTE (s2
))
238 FETCH_STRING_CHAR_ADVANCE (c2
, s2
, i2
, i2_byte
);
240 c2
= XSTRING (s2
)->data
[i2
++];
243 return c1
< c2
? Qt
: Qnil
;
245 return i1
< XSTRING (s2
)->size
? Qt
: Qnil
;
248 static Lisp_Object
concat ();
259 return concat (2, args
, Lisp_String
, 0);
261 return concat (2, &s1
, Lisp_String
, 0);
262 #endif /* NO_ARG_ARRAY */
268 Lisp_Object s1
, s2
, s3
;
275 return concat (3, args
, Lisp_String
, 0);
277 return concat (3, &s1
, Lisp_String
, 0);
278 #endif /* NO_ARG_ARRAY */
281 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
282 "Concatenate all the arguments and make the result a list.\n\
283 The result is a list whose elements are the elements of all the arguments.\n\
284 Each argument may be a list, vector or string.\n\
285 The last argument is not copied, just used as the tail of the new list.")
290 return concat (nargs
, args
, Lisp_Cons
, 1);
293 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
294 "Concatenate all the arguments and make the result a string.\n\
295 The result is a string whose elements are the elements of all the arguments.\n\
296 Each argument may be a string or a list or vector of characters (integers).\n\
298 Do not use individual integers as arguments!\n\
299 The behavior of `concat' in that case will be changed later!\n\
300 If your program passes an integer as an argument to `concat',\n\
301 you should change it right away not to do so.")
306 return concat (nargs
, args
, Lisp_String
, 0);
309 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
310 "Concatenate all the arguments and make the result a vector.\n\
311 The result is a vector whose elements are the elements of all the arguments.\n\
312 Each argument may be a list, vector or string.")
317 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
320 /* Retrun a copy of a sub char table ARG. The elements except for a
321 nested sub char table are not copied. */
323 copy_sub_char_table (arg
)
326 Lisp_Object copy
= make_sub_char_table (XCHAR_TABLE (arg
)->defalt
);
329 /* Copy all the contents. */
330 bcopy (XCHAR_TABLE (arg
)->contents
, XCHAR_TABLE (copy
)->contents
,
331 SUB_CHAR_TABLE_ORDINARY_SLOTS
* sizeof (Lisp_Object
));
332 /* Recursively copy any sub char-tables in the ordinary slots. */
333 for (i
= 32; i
< SUB_CHAR_TABLE_ORDINARY_SLOTS
; i
++)
334 if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg
)->contents
[i
]))
335 XCHAR_TABLE (copy
)->contents
[i
]
336 = copy_sub_char_table (XCHAR_TABLE (copy
)->contents
[i
]);
342 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
343 "Return a copy of a list, vector or string.\n\
344 The elements of a list or vector are not copied; they are shared\n\
349 if (NILP (arg
)) return arg
;
351 if (CHAR_TABLE_P (arg
))
356 copy
= Fmake_char_table (XCHAR_TABLE (arg
)->purpose
, Qnil
);
357 /* Copy all the slots, including the extra ones. */
358 bcopy (XVECTOR (arg
)->contents
, XVECTOR (copy
)->contents
,
359 ((XCHAR_TABLE (arg
)->size
& PSEUDOVECTOR_SIZE_MASK
)
360 * sizeof (Lisp_Object
)));
362 /* Recursively copy any sub char tables in the ordinary slots
363 for multibyte characters. */
364 for (i
= CHAR_TABLE_SINGLE_BYTE_SLOTS
;
365 i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
366 if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg
)->contents
[i
]))
367 XCHAR_TABLE (copy
)->contents
[i
]
368 = copy_sub_char_table (XCHAR_TABLE (copy
)->contents
[i
]);
373 if (BOOL_VECTOR_P (arg
))
377 = (XBOOL_VECTOR (arg
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
379 val
= Fmake_bool_vector (Flength (arg
), Qnil
);
380 bcopy (XBOOL_VECTOR (arg
)->data
, XBOOL_VECTOR (val
)->data
,
385 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
386 arg
= wrong_type_argument (Qsequencep
, arg
);
387 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
391 concat (nargs
, args
, target_type
, last_special
)
394 enum Lisp_Type target_type
;
398 register Lisp_Object tail
;
399 register Lisp_Object
this;
402 register int result_len
;
403 register int result_len_byte
;
405 Lisp_Object last_tail
;
409 /* In append, the last arg isn't treated like the others */
410 if (last_special
&& nargs
> 0)
413 last_tail
= args
[nargs
];
418 /* Canonicalize each argument. */
419 for (argnum
= 0; argnum
< nargs
; argnum
++)
422 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
423 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
426 args
[argnum
] = Fnumber_to_string (this);
428 args
[argnum
] = wrong_type_argument (Qsequencep
, this);
432 /* Compute total length in chars of arguments in RESULT_LEN.
433 If desired output is a string, also compute length in bytes
434 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
435 whether the result should be a multibyte string. */
439 for (argnum
= 0; argnum
< nargs
; argnum
++)
443 len
= XFASTINT (Flength (this));
444 if (target_type
== Lisp_String
)
446 /* We must count the number of bytes needed in the string
447 as well as the number of characters. */
453 for (i
= 0; i
< len
; i
++)
455 ch
= XVECTOR (this)->contents
[i
];
457 wrong_type_argument (Qintegerp
, ch
);
458 this_len_byte
= XFASTINT (Fchar_bytes (ch
));
459 result_len_byte
+= this_len_byte
;
460 if (this_len_byte
> 1)
463 else if (CONSP (this))
464 for (; CONSP (this); this = XCONS (this)->cdr
)
466 ch
= XCONS (this)->car
;
468 wrong_type_argument (Qintegerp
, ch
);
469 this_len_byte
= XFASTINT (Fchar_bytes (ch
));
470 result_len_byte
+= this_len_byte
;
471 if (this_len_byte
> 1)
474 else if (STRINGP (this))
476 if (STRING_MULTIBYTE (this))
479 result_len_byte
+= XSTRING (this)->size_byte
;
482 result_len_byte
+= count_size_as_multibyte (XSTRING (this)->data
,
483 XSTRING (this)->size
);
490 if (! some_multibyte
)
491 result_len_byte
= result_len
;
493 /* Create the output object. */
494 if (target_type
== Lisp_Cons
)
495 val
= Fmake_list (make_number (result_len
), Qnil
);
496 else if (target_type
== Lisp_Vectorlike
)
497 val
= Fmake_vector (make_number (result_len
), Qnil
);
499 val
= make_uninit_multibyte_string (result_len
, result_len_byte
);
501 /* In `append', if all but last arg are nil, return last arg. */
502 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
505 /* Copy the contents of the args into the result. */
507 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
509 toindex
= 0, toindex_byte
= 0;
513 for (argnum
= 0; argnum
< nargs
; argnum
++)
517 register unsigned int thisindex
= 0;
518 register unsigned int thisindex_byte
= 0;
522 thislen
= Flength (this), thisleni
= XINT (thislen
);
524 if (STRINGP (this) && STRINGP (val
)
525 && ! NULL_INTERVAL_P (XSTRING (this)->intervals
))
526 copy_text_properties (make_number (0), thislen
, this,
527 make_number (toindex
), val
, Qnil
);
529 /* Between strings of the same kind, copy fast. */
530 if (STRINGP (this) && STRINGP (val
)
531 && STRING_MULTIBYTE (this) == some_multibyte
)
533 int thislen_byte
= XSTRING (this)->size_byte
;
534 bcopy (XSTRING (this)->data
, XSTRING (val
)->data
+ toindex_byte
,
535 XSTRING (this)->size_byte
);
536 toindex_byte
+= thislen_byte
;
539 /* Copy a single-byte string to a multibyte string. */
540 else if (STRINGP (this) && STRINGP (val
))
542 toindex_byte
+= copy_text (XSTRING (this)->data
,
543 XSTRING (val
)->data
+ toindex_byte
,
544 XSTRING (this)->size
, 0, 1);
548 /* Copy element by element. */
551 register Lisp_Object elt
;
553 /* Fetch next element of `this' arg into `elt', or break if
554 `this' is exhausted. */
555 if (NILP (this)) break;
557 elt
= XCONS (this)->car
, this = XCONS (this)->cdr
;
560 if (thisindex
>= thisleni
) break;
563 if (STRING_MULTIBYTE (this))
566 FETCH_STRING_CHAR_ADVANCE (c
, this,
569 XSETFASTINT (elt
, c
);
574 XSETFASTINT (elt
, XSTRING (this)->data
[thisindex
++]);
577 unibyte_char_to_multibyte (XINT (elt
)));
580 else if (BOOL_VECTOR_P (this))
583 = ((XBOOL_VECTOR (this)->size
+ BITS_PER_CHAR
- 1)
586 byte
= XBOOL_VECTOR (val
)->data
[thisindex
/ BITS_PER_CHAR
];
587 if (byte
& (1 << (thisindex
% BITS_PER_CHAR
)))
593 elt
= XVECTOR (this)->contents
[thisindex
++];
596 /* Store this element into the result. */
599 XCONS (tail
)->car
= elt
;
601 tail
= XCONS (tail
)->cdr
;
603 else if (VECTORP (val
))
604 XVECTOR (val
)->contents
[toindex
++] = elt
;
607 CHECK_NUMBER (elt
, 0);
608 if (SINGLE_BYTE_CHAR_P (XINT (elt
)))
610 XSTRING (val
)->data
[toindex
++] = XINT (elt
);
614 /* If we have any multibyte characters,
615 we already decided to make a multibyte string. */
618 unsigned char work
[4], *str
;
619 int i
= CHAR_STRING (c
, work
, str
);
621 /* P exists as a variable
622 to avoid a bug on the Masscomp C compiler. */
623 unsigned char *p
= & XSTRING (val
)->data
[toindex_byte
];
632 XCONS (prev
)->cdr
= last_tail
;
637 static Lisp_Object string_char_byte_cache_string
;
638 static int string_char_byte_cache_charpos
;
639 static int string_char_byte_cache_bytepos
;
641 /* Return the character index corresponding to CHAR_INDEX in STRING. */
644 string_char_to_byte (string
, char_index
)
649 int best_below
, best_below_byte
;
650 int best_above
, best_above_byte
;
652 if (! STRING_MULTIBYTE (string
))
655 best_below
= best_below_byte
= 0;
656 best_above
= XSTRING (string
)->size
;
657 best_above_byte
= XSTRING (string
)->size_byte
;
659 if (EQ (string
, string_char_byte_cache_string
))
661 if (string_char_byte_cache_charpos
< char_index
)
663 best_below
= string_char_byte_cache_charpos
;
664 best_below_byte
= string_char_byte_cache_bytepos
;
668 best_above
= string_char_byte_cache_charpos
;
669 best_above_byte
= string_char_byte_cache_bytepos
;
673 if (char_index
- best_below
< best_above
- char_index
)
675 while (best_below
< char_index
)
678 FETCH_STRING_CHAR_ADVANCE (c
, string
, best_below
, best_below_byte
);
681 i_byte
= best_below_byte
;
685 while (best_above
> char_index
)
687 int best_above_byte_saved
= --best_above_byte
;
689 while (best_above_byte
> 0
690 && !CHAR_HEAD_P (XSTRING (string
)->data
[best_above_byte
]))
692 if (XSTRING (string
)->data
[best_above_byte
] < 0x80)
693 best_above_byte
= best_above_byte_saved
;
697 i_byte
= best_above_byte
;
700 string_char_byte_cache_bytepos
= i_byte
;
701 string_char_byte_cache_charpos
= i
;
702 string_char_byte_cache_string
= string
;
707 /* Return the character index corresponding to BYTE_INDEX in STRING. */
710 string_byte_to_char (string
, byte_index
)
715 int best_below
, best_below_byte
;
716 int best_above
, best_above_byte
;
718 if (! STRING_MULTIBYTE (string
))
721 best_below
= best_below_byte
= 0;
722 best_above
= XSTRING (string
)->size
;
723 best_above_byte
= XSTRING (string
)->size_byte
;
725 if (EQ (string
, string_char_byte_cache_string
))
727 if (string_char_byte_cache_bytepos
< byte_index
)
729 best_below
= string_char_byte_cache_charpos
;
730 best_below_byte
= string_char_byte_cache_bytepos
;
734 best_above
= string_char_byte_cache_charpos
;
735 best_above_byte
= string_char_byte_cache_bytepos
;
739 if (byte_index
- best_below_byte
< best_above_byte
- byte_index
)
741 while (best_below_byte
< byte_index
)
744 FETCH_STRING_CHAR_ADVANCE (c
, string
, best_below
, best_below_byte
);
747 i_byte
= best_below_byte
;
751 while (best_above_byte
> byte_index
)
753 int best_above_byte_saved
= --best_above_byte
;
755 while (best_above_byte
> 0
756 && !CHAR_HEAD_P (XSTRING (string
)->data
[best_above_byte
]))
758 if (XSTRING (string
)->data
[best_above_byte
] < 0x80)
759 best_above_byte
= best_above_byte_saved
;
763 i_byte
= best_above_byte
;
766 string_char_byte_cache_bytepos
= i_byte
;
767 string_char_byte_cache_charpos
= i
;
768 string_char_byte_cache_string
= string
;
773 /* Convert STRING to a multibyte string.
774 Single-byte characters 0200 through 0377 are converted
775 by adding nonascii_insert_offset to each. */
778 string_make_multibyte (string
)
784 if (STRING_MULTIBYTE (string
))
787 nbytes
= count_size_as_multibyte (XSTRING (string
)->data
,
788 XSTRING (string
)->size
);
789 buf
= (unsigned char *) alloca (nbytes
);
790 copy_text (XSTRING (string
)->data
, buf
, XSTRING (string
)->size_byte
,
793 return make_multibyte_string (buf
, XSTRING (string
)->size
, nbytes
);
796 /* Convert STRING to a single-byte string. */
799 string_make_unibyte (string
)
804 if (! STRING_MULTIBYTE (string
))
807 buf
= (unsigned char *) alloca (XSTRING (string
)->size
);
809 copy_text (XSTRING (string
)->data
, buf
, XSTRING (string
)->size_byte
,
812 return make_unibyte_string (buf
, XSTRING (string
)->size
);
815 DEFUN ("string-make-multibyte", Fstring_make_multibyte
, Sstring_make_multibyte
,
817 "Return the multibyte equivalent of STRING.")
821 return string_make_multibyte (string
);
824 DEFUN ("string-make-unibyte", Fstring_make_unibyte
, Sstring_make_unibyte
,
826 "Return the unibyte equivalent of STRING.")
830 return string_make_unibyte (string
);
833 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
834 "Return a copy of ALIST.\n\
835 This is an alist which represents the same mapping from objects to objects,\n\
836 but does not share the alist structure with ALIST.\n\
837 The objects mapped (cars and cdrs of elements of the alist)\n\
838 are shared, however.\n\
839 Elements of ALIST that are not conses are also shared.")
843 register Lisp_Object tem
;
845 CHECK_LIST (alist
, 0);
848 alist
= concat (1, &alist
, Lisp_Cons
, 0);
849 for (tem
= alist
; CONSP (tem
); tem
= XCONS (tem
)->cdr
)
851 register Lisp_Object car
;
852 car
= XCONS (tem
)->car
;
855 XCONS (tem
)->car
= Fcons (XCONS (car
)->car
, XCONS (car
)->cdr
);
860 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
861 "Return a substring of STRING, starting at index FROM and ending before TO.\n\
862 TO may be nil or omitted; then the substring runs to the end of STRING.\n\
863 If FROM or TO is negative, it counts from the end.\n\
865 This function allows vectors as well as strings.")
868 register Lisp_Object from
, to
;
873 int from_char
, to_char
;
874 int from_byte
, to_byte
;
876 if (! (STRINGP (string
) || VECTORP (string
)))
877 wrong_type_argument (Qarrayp
, string
);
879 CHECK_NUMBER (from
, 1);
881 if (STRINGP (string
))
883 size
= XSTRING (string
)->size
;
884 size_byte
= XSTRING (string
)->size_byte
;
887 size
= XVECTOR (string
)->size
;
896 CHECK_NUMBER (to
, 2);
902 if (STRINGP (string
))
903 to_byte
= string_char_to_byte (string
, to_char
);
906 from_char
= XINT (from
);
909 if (STRINGP (string
))
910 from_byte
= string_char_to_byte (string
, from_char
);
912 if (!(0 <= from_char
&& from_char
<= to_char
&& to_char
<= size
))
913 args_out_of_range_3 (string
, make_number (from_char
),
914 make_number (to_char
));
916 if (STRINGP (string
))
918 res
= make_multibyte_string (XSTRING (string
)->data
+ from_byte
,
919 to_char
- from_char
, to_byte
- from_byte
);
920 copy_text_properties (from_char
, to_char
, string
,
921 make_number (0), res
, Qnil
);
924 res
= Fvector (to_char
- from_char
,
925 XVECTOR (string
)->contents
+ from_char
);
930 /* Extract a substring of STRING, giving start and end positions
931 both in characters and in bytes. */
934 substring_both (string
, from
, from_byte
, to
, to_byte
)
936 int from
, from_byte
, to
, to_byte
;
942 if (! (STRINGP (string
) || VECTORP (string
)))
943 wrong_type_argument (Qarrayp
, string
);
945 if (STRINGP (string
))
947 size
= XSTRING (string
)->size
;
948 size_byte
= XSTRING (string
)->size_byte
;
951 size
= XVECTOR (string
)->size
;
953 if (!(0 <= from
&& from
<= to
&& to
<= size
))
954 args_out_of_range_3 (string
, make_number (from
), make_number (to
));
956 if (STRINGP (string
))
958 res
= make_multibyte_string (XSTRING (string
)->data
+ from_byte
,
959 to
- from
, to_byte
- from_byte
);
960 copy_text_properties (from
, to
, string
, make_number (0), res
, Qnil
);
963 res
= Fvector (to
- from
,
964 XVECTOR (string
)->contents
+ from
);
969 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
970 "Take cdr N times on LIST, returns the result.")
973 register Lisp_Object list
;
978 for (i
= 0; i
< num
&& !NILP (list
); i
++)
986 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
987 "Return the Nth element of LIST.\n\
988 N counts from zero. If LIST is not that long, nil is returned.")
992 return Fcar (Fnthcdr (n
, list
));
995 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
996 "Return element of SEQUENCE at index N.")
998 register Lisp_Object sequence
, n
;
1000 CHECK_NUMBER (n
, 0);
1003 if (CONSP (sequence
) || NILP (sequence
))
1004 return Fcar (Fnthcdr (n
, sequence
));
1005 else if (STRINGP (sequence
) || VECTORP (sequence
)
1006 || BOOL_VECTOR_P (sequence
) || CHAR_TABLE_P (sequence
))
1007 return Faref (sequence
, n
);
1009 sequence
= wrong_type_argument (Qsequencep
, sequence
);
1013 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
1014 "Return non-nil if ELT is an element of LIST. Comparison done with `equal'.\n\
1015 The value is actually the tail of LIST whose car is ELT.")
1017 register Lisp_Object elt
;
1020 register Lisp_Object tail
;
1021 for (tail
= list
; !NILP (tail
); tail
= XCONS (tail
)->cdr
)
1023 register Lisp_Object tem
;
1025 if (! NILP (Fequal (elt
, tem
)))
1032 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
1033 "Return non-nil if ELT is an element of LIST. Comparison done with EQ.\n\
1034 The value is actually the tail of LIST whose car is ELT.")
1036 register Lisp_Object elt
;
1039 register Lisp_Object tail
;
1040 for (tail
= list
; !NILP (tail
); tail
= XCONS (tail
)->cdr
)
1042 register Lisp_Object tem
;
1044 if (EQ (elt
, tem
)) return tail
;
1050 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
1051 "Return non-nil if KEY is `eq' to the car of an element of LIST.\n\
1052 The value is actually the element of LIST whose car is KEY.\n\
1053 Elements of LIST that are not conses are ignored.")
1055 register Lisp_Object key
;
1058 register Lisp_Object tail
;
1059 for (tail
= list
; !NILP (tail
); tail
= XCONS (tail
)->cdr
)
1061 register Lisp_Object elt
, tem
;
1063 if (!CONSP (elt
)) continue;
1064 tem
= XCONS (elt
)->car
;
1065 if (EQ (key
, tem
)) return elt
;
1071 /* Like Fassq but never report an error and do not allow quits.
1072 Use only on lists known never to be circular. */
1075 assq_no_quit (key
, list
)
1076 register Lisp_Object key
;
1079 register Lisp_Object tail
;
1080 for (tail
= list
; CONSP (tail
); tail
= XCONS (tail
)->cdr
)
1082 register Lisp_Object elt
, tem
;
1084 if (!CONSP (elt
)) continue;
1085 tem
= XCONS (elt
)->car
;
1086 if (EQ (key
, tem
)) return elt
;
1091 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
1092 "Return non-nil if KEY is `equal' to the car of an element of LIST.\n\
1093 The value is actually the element of LIST whose car equals KEY.")
1095 register Lisp_Object key
;
1098 register Lisp_Object tail
;
1099 for (tail
= list
; !NILP (tail
); tail
= XCONS (tail
)->cdr
)
1101 register Lisp_Object elt
, tem
;
1103 if (!CONSP (elt
)) continue;
1104 tem
= Fequal (XCONS (elt
)->car
, key
);
1105 if (!NILP (tem
)) return elt
;
1111 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
1112 "Return non-nil if ELT is `eq' to the cdr of an element of LIST.\n\
1113 The value is actually the element of LIST whose cdr is ELT.")
1115 register Lisp_Object key
;
1118 register Lisp_Object tail
;
1119 for (tail
= list
; !NILP (tail
); tail
= XCONS (tail
)->cdr
)
1121 register Lisp_Object elt
, tem
;
1123 if (!CONSP (elt
)) continue;
1124 tem
= XCONS (elt
)->cdr
;
1125 if (EQ (key
, tem
)) return elt
;
1131 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
1132 "Return non-nil if KEY is `equal' to the cdr of an element of LIST.\n\
1133 The value is actually the element of LIST whose cdr equals KEY.")
1135 register Lisp_Object key
;
1138 register Lisp_Object tail
;
1139 for (tail
= list
; !NILP (tail
); tail
= XCONS (tail
)->cdr
)
1141 register Lisp_Object elt
, tem
;
1143 if (!CONSP (elt
)) continue;
1144 tem
= Fequal (XCONS (elt
)->cdr
, key
);
1145 if (!NILP (tem
)) return elt
;
1151 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
1152 "Delete by side effect any occurrences of ELT as a member of LIST.\n\
1153 The modified LIST is returned. Comparison is done with `eq'.\n\
1154 If the first member of LIST is ELT, there is no way to remove it by side effect;\n\
1155 therefore, write `(setq foo (delq element foo))'\n\
1156 to be sure of changing the value of `foo'.")
1158 register Lisp_Object elt
;
1161 register Lisp_Object tail
, prev
;
1162 register Lisp_Object tem
;
1166 while (!NILP (tail
))
1172 list
= XCONS (tail
)->cdr
;
1174 Fsetcdr (prev
, XCONS (tail
)->cdr
);
1178 tail
= XCONS (tail
)->cdr
;
1184 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
1185 "Delete by side effect any occurrences of ELT as a member of LIST.\n\
1186 The modified LIST is returned. Comparison is done with `equal'.\n\
1187 If the first member of LIST is ELT, deleting it is not a side effect;\n\
1188 it is simply using a different list.\n\
1189 Therefore, write `(setq foo (delete element foo))'\n\
1190 to be sure of changing the value of `foo'.")
1192 register Lisp_Object elt
;
1195 register Lisp_Object tail
, prev
;
1196 register Lisp_Object tem
;
1200 while (!NILP (tail
))
1203 if (! NILP (Fequal (elt
, tem
)))
1206 list
= XCONS (tail
)->cdr
;
1208 Fsetcdr (prev
, XCONS (tail
)->cdr
);
1212 tail
= XCONS (tail
)->cdr
;
1218 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
1219 "Reverse LIST by modifying cdr pointers.\n\
1220 Returns the beginning of the reversed list.")
1224 register Lisp_Object prev
, tail
, next
;
1226 if (NILP (list
)) return list
;
1229 while (!NILP (tail
))
1233 Fsetcdr (tail
, prev
);
1240 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
1241 "Reverse LIST, copying. Returns the beginning of the reversed list.\n\
1242 See also the function `nreverse', which is used more often.")
1248 for (new = Qnil
; CONSP (list
); list
= XCONS (list
)->cdr
)
1249 new = Fcons (XCONS (list
)->car
, new);
1251 wrong_type_argument (Qconsp
, list
);
1255 Lisp_Object
merge ();
1257 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
1258 "Sort LIST, stably, comparing elements using PREDICATE.\n\
1259 Returns the sorted list. LIST is modified by side effects.\n\
1260 PREDICATE is called with two elements of LIST, and should return T\n\
1261 if the first element is \"less\" than the second.")
1263 Lisp_Object list
, predicate
;
1265 Lisp_Object front
, back
;
1266 register Lisp_Object len
, tem
;
1267 struct gcpro gcpro1
, gcpro2
;
1268 register int length
;
1271 len
= Flength (list
);
1272 length
= XINT (len
);
1276 XSETINT (len
, (length
/ 2) - 1);
1277 tem
= Fnthcdr (len
, list
);
1279 Fsetcdr (tem
, Qnil
);
1281 GCPRO2 (front
, back
);
1282 front
= Fsort (front
, predicate
);
1283 back
= Fsort (back
, predicate
);
1285 return merge (front
, back
, predicate
);
1289 merge (org_l1
, org_l2
, pred
)
1290 Lisp_Object org_l1
, org_l2
;
1294 register Lisp_Object tail
;
1296 register Lisp_Object l1
, l2
;
1297 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
1304 /* It is sufficient to protect org_l1 and org_l2.
1305 When l1 and l2 are updated, we copy the new values
1306 back into the org_ vars. */
1307 GCPRO4 (org_l1
, org_l2
, pred
, value
);
1327 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1343 Fsetcdr (tail
, tem
);
1349 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1350 "Extract a value from a property list.\n\
1351 PLIST is a property list, which is a list of the form\n\
1352 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value\n\
1353 corresponding to the given PROP, or nil if PROP is not\n\
1354 one of the properties on the list.")
1357 register Lisp_Object prop
;
1359 register Lisp_Object tail
;
1360 for (tail
= plist
; !NILP (tail
); tail
= Fcdr (XCONS (tail
)->cdr
))
1362 register Lisp_Object tem
;
1365 return Fcar (XCONS (tail
)->cdr
);
1370 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
1371 "Return the value of SYMBOL's PROPNAME property.\n\
1372 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'.")
1374 Lisp_Object symbol
, propname
;
1376 CHECK_SYMBOL (symbol
, 0);
1377 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
1380 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
1381 "Change value in PLIST of PROP to VAL.\n\
1382 PLIST is a property list, which is a list of the form\n\
1383 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.\n\
1384 If PROP is already a property on the list, its value is set to VAL,\n\
1385 otherwise the new PROP VAL pair is added. The new plist is returned;\n\
1386 use `(setq x (plist-put x prop val))' to be sure to use the new value.\n\
1387 The PLIST is modified by side effects.")
1390 register Lisp_Object prop
;
1393 register Lisp_Object tail
, prev
;
1394 Lisp_Object newcell
;
1396 for (tail
= plist
; CONSP (tail
) && CONSP (XCONS (tail
)->cdr
);
1397 tail
= XCONS (XCONS (tail
)->cdr
)->cdr
)
1399 if (EQ (prop
, XCONS (tail
)->car
))
1401 Fsetcar (XCONS (tail
)->cdr
, val
);
1406 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
1410 Fsetcdr (XCONS (prev
)->cdr
, newcell
);
1414 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
1415 "Store SYMBOL's PROPNAME property with value VALUE.\n\
1416 It can be retrieved with `(get SYMBOL PROPNAME)'.")
1417 (symbol
, propname
, value
)
1418 Lisp_Object symbol
, propname
, value
;
1420 CHECK_SYMBOL (symbol
, 0);
1421 XSYMBOL (symbol
)->plist
1422 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
1426 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
1427 "Return t if two Lisp objects have similar structure and contents.\n\
1428 They must have the same data type.\n\
1429 Conses are compared by comparing the cars and the cdrs.\n\
1430 Vectors and strings are compared element by element.\n\
1431 Numbers are compared by value, but integers cannot equal floats.\n\
1432 (Use `=' if you want integers and floats to be able to be equal.)\n\
1433 Symbols must match exactly.")
1435 register Lisp_Object o1
, o2
;
1437 return internal_equal (o1
, o2
, 0) ? Qt
: Qnil
;
1441 internal_equal (o1
, o2
, depth
)
1442 register Lisp_Object o1
, o2
;
1446 error ("Stack overflow in equal");
1452 if (XTYPE (o1
) != XTYPE (o2
))
1457 #ifdef LISP_FLOAT_TYPE
1459 return (extract_float (o1
) == extract_float (o2
));
1463 if (!internal_equal (XCONS (o1
)->car
, XCONS (o2
)->car
, depth
+ 1))
1465 o1
= XCONS (o1
)->cdr
;
1466 o2
= XCONS (o2
)->cdr
;
1470 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
1474 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o1
),
1476 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o1
),
1479 o1
= XOVERLAY (o1
)->plist
;
1480 o2
= XOVERLAY (o2
)->plist
;
1485 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
1486 && (XMARKER (o1
)->buffer
== 0
1487 || XMARKER (o1
)->bytepos
== XMARKER (o2
)->bytepos
));
1491 case Lisp_Vectorlike
:
1493 register int i
, size
;
1494 size
= XVECTOR (o1
)->size
;
1495 /* Pseudovectors have the type encoded in the size field, so this test
1496 actually checks that the objects have the same type as well as the
1498 if (XVECTOR (o2
)->size
!= size
)
1500 /* Boolvectors are compared much like strings. */
1501 if (BOOL_VECTOR_P (o1
))
1504 = (XBOOL_VECTOR (o1
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
1506 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
1508 if (bcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
1514 /* Aside from them, only true vectors, char-tables, and compiled
1515 functions are sensible to compare, so eliminate the others now. */
1516 if (size
& PSEUDOVECTOR_FLAG
)
1518 if (!(size
& (PVEC_COMPILED
| PVEC_CHAR_TABLE
)))
1520 size
&= PSEUDOVECTOR_SIZE_MASK
;
1522 for (i
= 0; i
< size
; i
++)
1525 v1
= XVECTOR (o1
)->contents
[i
];
1526 v2
= XVECTOR (o2
)->contents
[i
];
1527 if (!internal_equal (v1
, v2
, depth
+ 1))
1535 if (XSTRING (o1
)->size
!= XSTRING (o2
)->size
)
1537 if (XSTRING (o1
)->size_byte
!= XSTRING (o2
)->size_byte
)
1539 if (bcmp (XSTRING (o1
)->data
, XSTRING (o2
)->data
,
1540 XSTRING (o1
)->size_byte
))
1547 extern Lisp_Object
Fmake_char_internal ();
1549 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
1550 "Store each element of ARRAY with ITEM.\n\
1551 ARRAY is a vector, string, char-table, or bool-vector.")
1553 Lisp_Object array
, item
;
1555 register int size
, index
, charval
;
1557 if (VECTORP (array
))
1559 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
1560 size
= XVECTOR (array
)->size
;
1561 for (index
= 0; index
< size
; index
++)
1564 else if (CHAR_TABLE_P (array
))
1566 register Lisp_Object
*p
= XCHAR_TABLE (array
)->contents
;
1567 size
= CHAR_TABLE_ORDINARY_SLOTS
;
1568 for (index
= 0; index
< size
; index
++)
1570 XCHAR_TABLE (array
)->defalt
= Qnil
;
1572 else if (STRINGP (array
))
1574 register unsigned char *p
= XSTRING (array
)->data
;
1575 CHECK_NUMBER (item
, 1);
1576 charval
= XINT (item
);
1577 size
= XSTRING (array
)->size
;
1578 for (index
= 0; index
< size
; index
++)
1581 else if (BOOL_VECTOR_P (array
))
1583 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
1585 = (XBOOL_VECTOR (array
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
1587 charval
= (! NILP (item
) ? -1 : 0);
1588 for (index
= 0; index
< size_in_chars
; index
++)
1593 array
= wrong_type_argument (Qarrayp
, array
);
1599 DEFUN ("char-table-subtype", Fchar_table_subtype
, Schar_table_subtype
,
1601 "Return the subtype of char-table CHAR-TABLE. The value is a symbol.")
1603 Lisp_Object char_table
;
1605 CHECK_CHAR_TABLE (char_table
, 0);
1607 return XCHAR_TABLE (char_table
)->purpose
;
1610 DEFUN ("char-table-parent", Fchar_table_parent
, Schar_table_parent
,
1612 "Return the parent char-table of CHAR-TABLE.\n\
1613 The value is either nil or another char-table.\n\
1614 If CHAR-TABLE holds nil for a given character,\n\
1615 then the actual applicable value is inherited from the parent char-table\n\
1616 \(or from its parents, if necessary).")
1618 Lisp_Object char_table
;
1620 CHECK_CHAR_TABLE (char_table
, 0);
1622 return XCHAR_TABLE (char_table
)->parent
;
1625 DEFUN ("set-char-table-parent", Fset_char_table_parent
, Sset_char_table_parent
,
1627 "Set the parent char-table of CHAR-TABLE to PARENT.\n\
1628 PARENT must be either nil or another char-table.")
1629 (char_table
, parent
)
1630 Lisp_Object char_table
, parent
;
1634 CHECK_CHAR_TABLE (char_table
, 0);
1638 CHECK_CHAR_TABLE (parent
, 0);
1640 for (temp
= parent
; !NILP (temp
); temp
= XCHAR_TABLE (temp
)->parent
)
1641 if (EQ (temp
, char_table
))
1642 error ("Attempt to make a chartable be its own parent");
1645 XCHAR_TABLE (char_table
)->parent
= parent
;
1650 DEFUN ("char-table-extra-slot", Fchar_table_extra_slot
, Schar_table_extra_slot
,
1652 "Return the value of CHAR-TABLE's extra-slot number N.")
1654 Lisp_Object char_table
, n
;
1656 CHECK_CHAR_TABLE (char_table
, 1);
1657 CHECK_NUMBER (n
, 2);
1659 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
1660 args_out_of_range (char_table
, n
);
1662 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)];
1665 DEFUN ("set-char-table-extra-slot", Fset_char_table_extra_slot
,
1666 Sset_char_table_extra_slot
,
1668 "Set CHAR-TABLE's extra-slot number N to VALUE.")
1669 (char_table
, n
, value
)
1670 Lisp_Object char_table
, n
, value
;
1672 CHECK_CHAR_TABLE (char_table
, 1);
1673 CHECK_NUMBER (n
, 2);
1675 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
1676 args_out_of_range (char_table
, n
);
1678 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)] = value
;
1681 DEFUN ("char-table-range", Fchar_table_range
, Schar_table_range
,
1683 "Return the value in CHAR-TABLE for a range of characters RANGE.\n\
1684 RANGE should be t (for all characters), nil (for the default value)\n\
1685 a vector which identifies a character set or a row of a character set,\n\
1686 or a character code.")
1688 Lisp_Object char_table
, range
;
1692 CHECK_CHAR_TABLE (char_table
, 0);
1694 if (EQ (range
, Qnil
))
1695 return XCHAR_TABLE (char_table
)->defalt
;
1696 else if (INTEGERP (range
))
1697 return Faref (char_table
, range
);
1698 else if (VECTORP (range
))
1700 if (XVECTOR (range
)->size
== 1)
1701 return Faref (char_table
, XVECTOR (range
)->contents
[0]);
1704 int size
= XVECTOR (range
)->size
;
1705 Lisp_Object
*val
= XVECTOR (range
)->contents
;
1706 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
1707 size
<= 1 ? Qnil
: val
[1],
1708 size
<= 2 ? Qnil
: val
[2]);
1709 return Faref (char_table
, ch
);
1713 error ("Invalid RANGE argument to `char-table-range'");
1716 DEFUN ("set-char-table-range", Fset_char_table_range
, Sset_char_table_range
,
1718 "Set the value in CHAR-TABLE for a range of characters RANGE to VALUE.\n\
1719 RANGE should be t (for all characters), nil (for the default value)\n\
1720 a vector which identifies a character set or a row of a character set,\n\
1721 or a character code.")
1722 (char_table
, range
, value
)
1723 Lisp_Object char_table
, range
, value
;
1727 CHECK_CHAR_TABLE (char_table
, 0);
1730 for (i
= 0; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
1731 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
1732 else if (EQ (range
, Qnil
))
1733 XCHAR_TABLE (char_table
)->defalt
= value
;
1734 else if (INTEGERP (range
))
1735 Faset (char_table
, range
, value
);
1736 else if (VECTORP (range
))
1738 if (XVECTOR (range
)->size
== 1)
1739 return Faset (char_table
, XVECTOR (range
)->contents
[0], value
);
1742 int size
= XVECTOR (range
)->size
;
1743 Lisp_Object
*val
= XVECTOR (range
)->contents
;
1744 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
1745 size
<= 1 ? Qnil
: val
[1],
1746 size
<= 2 ? Qnil
: val
[2]);
1747 return Faset (char_table
, ch
, value
);
1751 error ("Invalid RANGE argument to `set-char-table-range'");
1756 DEFUN ("set-char-table-default", Fset_char_table_default
,
1757 Sset_char_table_default
, 3, 3, 0,
1758 "Set the default value in CHAR-TABLE for a generic character CHAR to VALUE.\n\
1759 The generic character specifies the group of characters.\n\
1760 See also the documentation of make-char.")
1761 (char_table
, ch
, value
)
1762 Lisp_Object char_table
, ch
, value
;
1764 int c
, i
, charset
, code1
, code2
;
1767 CHECK_CHAR_TABLE (char_table
, 0);
1768 CHECK_NUMBER (ch
, 1);
1771 SPLIT_NON_ASCII_CHAR (c
, charset
, code1
, code2
);
1772 if (! CHARSET_DEFINED_P (charset
))
1773 error ("Invalid character: %d", c
);
1775 if (charset
== CHARSET_ASCII
)
1776 return (XCHAR_TABLE (char_table
)->defalt
= value
);
1778 /* Even if C is not a generic char, we had better behave as if a
1779 generic char is specified. */
1780 if (CHARSET_DIMENSION (charset
) == 1)
1782 temp
= XCHAR_TABLE (char_table
)->contents
[charset
+ 128];
1785 if (SUB_CHAR_TABLE_P (temp
))
1786 XCHAR_TABLE (temp
)->defalt
= value
;
1788 XCHAR_TABLE (char_table
)->contents
[charset
+ 128] = value
;
1792 if (! SUB_CHAR_TABLE_P (char_table
))
1793 char_table
= (XCHAR_TABLE (char_table
)->contents
[charset
+ 128]
1794 = make_sub_char_table (temp
));
1795 temp
= XCHAR_TABLE (char_table
)->contents
[code1
];
1796 if (SUB_CHAR_TABLE_P (temp
))
1797 XCHAR_TABLE (temp
)->defalt
= value
;
1799 XCHAR_TABLE (char_table
)->contents
[code1
] = value
;
1803 /* Map C_FUNCTION or FUNCTION over SUBTABLE, calling it for each
1804 character or group of characters that share a value.
1805 DEPTH is the current depth in the originally specified
1806 chartable, and INDICES contains the vector indices
1807 for the levels our callers have descended.
1809 ARG is passed to C_FUNCTION when that is called. */
1812 map_char_table (c_function
, function
, subtable
, arg
, depth
, indices
)
1813 void (*c_function
) P_ ((Lisp_Object
, Lisp_Object
, Lisp_Object
));
1814 Lisp_Object function
, subtable
, arg
, *indices
;
1821 /* At first, handle ASCII and 8-bit European characters. */
1822 for (i
= 0; i
< CHAR_TABLE_SINGLE_BYTE_SLOTS
; i
++)
1824 Lisp_Object elt
= XCHAR_TABLE (subtable
)->contents
[i
];
1826 (*c_function
) (arg
, make_number (i
), elt
);
1828 call2 (function
, make_number (i
), elt
);
1830 #if 0 /* If the char table has entries for higher characters,
1831 we should report them. */
1832 if (NILP (current_buffer
->enable_multibyte_characters
))
1835 to
= CHAR_TABLE_ORDINARY_SLOTS
;
1840 to
= SUB_CHAR_TABLE_ORDINARY_SLOTS
;
1845 Lisp_Object elt
= XCHAR_TABLE (subtable
)->contents
[i
];
1847 XSETFASTINT (indices
[depth
], i
);
1849 if (SUB_CHAR_TABLE_P (elt
))
1852 error ("Too deep char table");
1853 map_char_table (c_function
, function
, elt
, arg
, depth
+ 1, indices
);
1857 int charset
= XFASTINT (indices
[0]) - 128, c1
, c2
, c
;
1859 if (CHARSET_DEFINED_P (charset
))
1861 c1
= depth
>= 1 ? XFASTINT (indices
[1]) : 0;
1862 c2
= depth
>= 2 ? XFASTINT (indices
[2]) : 0;
1863 c
= MAKE_NON_ASCII_CHAR (charset
, c1
, c2
);
1865 (*c_function
) (arg
, make_number (c
), elt
);
1867 call2 (function
, make_number (c
), elt
);
1873 DEFUN ("map-char-table", Fmap_char_table
, Smap_char_table
,
1875 "Call FUNCTION for each (normal and generic) characters in CHAR-TABLE.\n\
1876 FUNCTION is called with two arguments--a key and a value.\n\
1877 The key is always a possible IDX argument to `aref'.")
1878 (function
, char_table
)
1879 Lisp_Object function
, char_table
;
1881 /* The depth of char table is at most 3. */
1882 Lisp_Object indices
[3];
1884 CHECK_CHAR_TABLE (char_table
, 1);
1886 map_char_table (NULL
, function
, char_table
, char_table
, 0, indices
);
1896 Lisp_Object args
[2];
1899 return Fnconc (2, args
);
1901 return Fnconc (2, &s1
);
1902 #endif /* NO_ARG_ARRAY */
1905 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
1906 "Concatenate any number of lists by altering them.\n\
1907 Only the last argument is not altered, and need not be a list.")
1912 register int argnum
;
1913 register Lisp_Object tail
, tem
, val
;
1917 for (argnum
= 0; argnum
< nargs
; argnum
++)
1920 if (NILP (tem
)) continue;
1925 if (argnum
+ 1 == nargs
) break;
1928 tem
= wrong_type_argument (Qlistp
, tem
);
1937 tem
= args
[argnum
+ 1];
1938 Fsetcdr (tail
, tem
);
1940 args
[argnum
+ 1] = tail
;
1946 /* This is the guts of all mapping functions.
1947 Apply FN to each element of SEQ, one by one,
1948 storing the results into elements of VALS, a C vector of Lisp_Objects.
1949 LENI is the length of VALS, which should also be the length of SEQ. */
1952 mapcar1 (leni
, vals
, fn
, seq
)
1955 Lisp_Object fn
, seq
;
1957 register Lisp_Object tail
;
1960 struct gcpro gcpro1
, gcpro2
, gcpro3
;
1962 /* Don't let vals contain any garbage when GC happens. */
1963 for (i
= 0; i
< leni
; i
++)
1966 GCPRO3 (dummy
, fn
, seq
);
1968 gcpro1
.nvars
= leni
;
1969 /* We need not explicitly protect `tail' because it is used only on lists, and
1970 1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
1974 for (i
= 0; i
< leni
; i
++)
1976 dummy
= XVECTOR (seq
)->contents
[i
];
1977 vals
[i
] = call1 (fn
, dummy
);
1980 else if (STRINGP (seq
) && ! STRING_MULTIBYTE (seq
))
1982 /* Single-byte string. */
1983 for (i
= 0; i
< leni
; i
++)
1985 XSETFASTINT (dummy
, XSTRING (seq
)->data
[i
]);
1986 vals
[i
] = call1 (fn
, dummy
);
1989 else if (STRINGP (seq
))
1991 /* Multi-byte string. */
1992 int len_byte
= XSTRING (seq
)->size_byte
;
1995 for (i
= 0, i_byte
= 0; i
< leni
;)
2000 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
);
2001 XSETFASTINT (dummy
, c
);
2002 vals
[i_before
] = call1 (fn
, dummy
);
2005 else /* Must be a list, since Flength did not get an error */
2008 for (i
= 0; i
< leni
; i
++)
2010 vals
[i
] = call1 (fn
, Fcar (tail
));
2011 tail
= XCONS (tail
)->cdr
;
2018 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2019 "Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.\n\
2020 In between each pair of results, stick in SEPARATOR. Thus, \" \" as\n\
2021 SEPARATOR results in spaces between the values returned by FUNCTION.")
2022 (function
, sequence
, separator
)
2023 Lisp_Object function
, sequence
, separator
;
2028 register Lisp_Object
*args
;
2030 struct gcpro gcpro1
;
2032 len
= Flength (sequence
);
2034 nargs
= leni
+ leni
- 1;
2035 if (nargs
< 0) return build_string ("");
2037 args
= (Lisp_Object
*) alloca (nargs
* sizeof (Lisp_Object
));
2040 mapcar1 (leni
, args
, function
, sequence
);
2043 for (i
= leni
- 1; i
>= 0; i
--)
2044 args
[i
+ i
] = args
[i
];
2046 for (i
= 1; i
< nargs
; i
+= 2)
2047 args
[i
] = separator
;
2049 return Fconcat (nargs
, args
);
2052 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2053 "Apply FUNCTION to each element of SEQUENCE, and make a list of the results.\n\
2054 The result is a list just as long as SEQUENCE.\n\
2055 SEQUENCE may be a list, a vector or a string.")
2056 (function
, sequence
)
2057 Lisp_Object function
, sequence
;
2059 register Lisp_Object len
;
2061 register Lisp_Object
*args
;
2063 len
= Flength (sequence
);
2064 leni
= XFASTINT (len
);
2065 args
= (Lisp_Object
*) alloca (leni
* sizeof (Lisp_Object
));
2067 mapcar1 (leni
, args
, function
, sequence
);
2069 return Flist (leni
, args
);
2072 /* Anything that calls this function must protect from GC! */
2074 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
2075 "Ask user a \"y or n\" question. Return t if answer is \"y\".\n\
2076 Takes one argument, which is the string to display to ask the question.\n\
2077 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.\n\
2078 No confirmation of the answer is requested; a single character is enough.\n\
2079 Also accepts Space to mean yes, or Delete to mean no.")
2083 register Lisp_Object obj
, key
, def
, answer_string
, map
;
2084 register int answer
;
2085 Lisp_Object xprompt
;
2086 Lisp_Object args
[2];
2087 struct gcpro gcpro1
, gcpro2
;
2088 int count
= specpdl_ptr
- specpdl
;
2090 specbind (Qcursor_in_echo_area
, Qt
);
2092 map
= Fsymbol_value (intern ("query-replace-map"));
2094 CHECK_STRING (prompt
, 0);
2096 GCPRO2 (prompt
, xprompt
);
2102 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2106 Lisp_Object pane
, menu
;
2107 redisplay_preserve_echo_area ();
2108 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2109 Fcons (Fcons (build_string ("No"), Qnil
),
2111 menu
= Fcons (prompt
, pane
);
2112 obj
= Fx_popup_dialog (Qt
, menu
);
2113 answer
= !NILP (obj
);
2116 #endif /* HAVE_MENUS */
2117 cursor_in_echo_area
= 1;
2118 choose_minibuf_frame ();
2119 message_with_string ("%s(y or n) ", xprompt
, 0);
2121 if (minibuffer_auto_raise
)
2123 Lisp_Object mini_frame
;
2125 mini_frame
= WINDOW_FRAME (XWINDOW (minibuf_window
));
2127 Fraise_frame (mini_frame
);
2130 obj
= read_filtered_event (1, 0, 0);
2131 cursor_in_echo_area
= 0;
2132 /* If we need to quit, quit with cursor_in_echo_area = 0. */
2135 key
= Fmake_vector (make_number (1), obj
);
2136 def
= Flookup_key (map
, key
, Qt
);
2137 answer_string
= Fsingle_key_description (obj
);
2139 if (EQ (def
, intern ("skip")))
2144 else if (EQ (def
, intern ("act")))
2149 else if (EQ (def
, intern ("recenter")))
2155 else if (EQ (def
, intern ("quit")))
2157 /* We want to exit this command for exit-prefix,
2158 and this is the only way to do it. */
2159 else if (EQ (def
, intern ("exit-prefix")))
2164 /* If we don't clear this, then the next call to read_char will
2165 return quit_char again, and we'll enter an infinite loop. */
2170 if (EQ (xprompt
, prompt
))
2172 args
[0] = build_string ("Please answer y or n. ");
2174 xprompt
= Fconcat (2, args
);
2179 if (! noninteractive
)
2181 cursor_in_echo_area
= -1;
2182 message_with_string (answer
? "%s(y or n) y" : "%s(y or n) n",
2186 unbind_to (count
, Qnil
);
2187 return answer
? Qt
: Qnil
;
2190 /* This is how C code calls `yes-or-no-p' and allows the user
2193 Anything that calls this function must protect from GC! */
2196 do_yes_or_no_p (prompt
)
2199 return call1 (intern ("yes-or-no-p"), prompt
);
2202 /* Anything that calls this function must protect from GC! */
2204 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2205 "Ask user a yes-or-no question. Return t if answer is yes.\n\
2206 Takes one argument, which is the string to display to ask the question.\n\
2207 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.\n\
2208 The user must confirm the answer with RET,\n\
2209 and can edit it until it has been confirmed.")
2213 register Lisp_Object ans
;
2214 Lisp_Object args
[2];
2215 struct gcpro gcpro1
;
2218 CHECK_STRING (prompt
, 0);
2221 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2225 Lisp_Object pane
, menu
, obj
;
2226 redisplay_preserve_echo_area ();
2227 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2228 Fcons (Fcons (build_string ("No"), Qnil
),
2231 menu
= Fcons (prompt
, pane
);
2232 obj
= Fx_popup_dialog (Qt
, menu
);
2236 #endif /* HAVE_MENUS */
2239 args
[1] = build_string ("(yes or no) ");
2240 prompt
= Fconcat (2, args
);
2246 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2247 Qyes_or_no_p_history
, Qnil
,
2249 if (XSTRING (ans
)->size
== 3 && !strcmp (XSTRING (ans
)->data
, "yes"))
2254 if (XSTRING (ans
)->size
== 2 && !strcmp (XSTRING (ans
)->data
, "no"))
2262 message ("Please answer yes or no.");
2263 Fsleep_for (make_number (2), Qnil
);
2267 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 0, 0,
2268 "Return list of 1 minute, 5 minute and 15 minute load averages.\n\
2269 Each of the three load averages is multiplied by 100,\n\
2270 then converted to integer.\n\
2271 If the 5-minute or 15-minute load averages are not available, return a\n\
2272 shortened list, containing only those averages which are available.")
2276 int loads
= getloadavg (load_ave
, 3);
2280 error ("load-average not implemented for this operating system");
2284 ret
= Fcons (make_number ((int) (load_ave
[--loads
] * 100.0)), ret
);
2289 Lisp_Object Vfeatures
;
2291 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 1, 0,
2292 "Returns t if FEATURE is present in this Emacs.\n\
2293 Use this to conditionalize execution of lisp code based on the presence or\n\
2294 absence of emacs or environment extensions.\n\
2295 Use `provide' to declare that a feature is available.\n\
2296 This function looks at the value of the variable `features'.")
2298 Lisp_Object feature
;
2300 register Lisp_Object tem
;
2301 CHECK_SYMBOL (feature
, 0);
2302 tem
= Fmemq (feature
, Vfeatures
);
2303 return (NILP (tem
)) ? Qnil
: Qt
;
2306 DEFUN ("provide", Fprovide
, Sprovide
, 1, 1, 0,
2307 "Announce that FEATURE is a feature of the current Emacs.")
2309 Lisp_Object feature
;
2311 register Lisp_Object tem
;
2312 CHECK_SYMBOL (feature
, 0);
2313 if (!NILP (Vautoload_queue
))
2314 Vautoload_queue
= Fcons (Fcons (Vfeatures
, Qnil
), Vautoload_queue
);
2315 tem
= Fmemq (feature
, Vfeatures
);
2317 Vfeatures
= Fcons (feature
, Vfeatures
);
2318 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2322 DEFUN ("require", Frequire
, Srequire
, 1, 2, 0,
2323 "If feature FEATURE is not loaded, load it from FILENAME.\n\
2324 If FEATURE is not a member of the list `features', then the feature\n\
2325 is not loaded; so load the file FILENAME.\n\
2326 If FILENAME is omitted, the printname of FEATURE is used as the file name.")
2327 (feature
, file_name
)
2328 Lisp_Object feature
, file_name
;
2330 register Lisp_Object tem
;
2331 CHECK_SYMBOL (feature
, 0);
2332 tem
= Fmemq (feature
, Vfeatures
);
2333 LOADHIST_ATTACH (Fcons (Qrequire
, feature
));
2336 int count
= specpdl_ptr
- specpdl
;
2338 /* Value saved here is to be restored into Vautoload_queue */
2339 record_unwind_protect (un_autoload
, Vautoload_queue
);
2340 Vautoload_queue
= Qt
;
2342 Fload (NILP (file_name
) ? Fsymbol_name (feature
) : file_name
,
2343 Qnil
, Qt
, Qnil
, (NILP (file_name
) ? Qt
: Qnil
));
2345 tem
= Fmemq (feature
, Vfeatures
);
2347 error ("Required feature %s was not provided",
2348 XSYMBOL (feature
)->name
->data
);
2350 /* Once loading finishes, don't undo it. */
2351 Vautoload_queue
= Qt
;
2352 feature
= unbind_to (count
, feature
);
2357 /* Primitives for work of the "widget" library.
2358 In an ideal world, this section would not have been necessary.
2359 However, lisp function calls being as slow as they are, it turns
2360 out that some functions in the widget library (wid-edit.el) are the
2361 bottleneck of Widget operation. Here is their translation to C,
2362 for the sole reason of efficiency. */
2364 DEFUN ("widget-plist-member", Fwidget_plist_member
, Swidget_plist_member
, 2, 2, 0,
2365 "Return non-nil if PLIST has the property PROP.\n\
2366 PLIST is a property list, which is a list of the form\n\
2367 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.\n\
2368 Unlike `plist-get', this allows you to distinguish between a missing\n\
2369 property and a property with the value nil.\n\
2370 The value is actually the tail of PLIST whose car is PROP.")
2372 Lisp_Object plist
, prop
;
2374 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
2377 plist
= XCDR (plist
);
2378 plist
= CDR (plist
);
2383 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
2384 "In WIDGET, set PROPERTY to VALUE.\n\
2385 The value can later be retrieved with `widget-get'.")
2386 (widget
, property
, value
)
2387 Lisp_Object widget
, property
, value
;
2389 CHECK_CONS (widget
, 1);
2390 XCDR (widget
) = Fplist_put (XCDR (widget
), property
, value
);
2393 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
2394 "In WIDGET, get the value of PROPERTY.\n\
2395 The value could either be specified when the widget was created, or\n\
2396 later with `widget-put'.")
2398 Lisp_Object widget
, property
;
2406 CHECK_CONS (widget
, 1);
2407 tmp
= Fwidget_plist_member (XCDR (widget
), property
);
2413 tmp
= XCAR (widget
);
2416 widget
= Fget (tmp
, Qwidget_type
);
2420 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
2421 "Apply the value of WIDGET's PROPERTY to the widget itself.\n\
2422 ARGS are passed as extra arguments to the function.")
2427 /* This function can GC. */
2428 Lisp_Object newargs
[3];
2429 struct gcpro gcpro1
, gcpro2
;
2432 newargs
[0] = Fwidget_get (args
[0], args
[1]);
2433 newargs
[1] = args
[0];
2434 newargs
[2] = Flist (nargs
- 2, args
+ 2);
2435 GCPRO2 (newargs
[0], newargs
[2]);
2436 result
= Fapply (3, newargs
);
2443 Qstring_lessp
= intern ("string-lessp");
2444 staticpro (&Qstring_lessp
);
2445 Qprovide
= intern ("provide");
2446 staticpro (&Qprovide
);
2447 Qrequire
= intern ("require");
2448 staticpro (&Qrequire
);
2449 Qyes_or_no_p_history
= intern ("yes-or-no-p-history");
2450 staticpro (&Qyes_or_no_p_history
);
2451 Qcursor_in_echo_area
= intern ("cursor-in-echo-area");
2452 staticpro (&Qcursor_in_echo_area
);
2453 Qwidget_type
= intern ("widget-type");
2454 staticpro (&Qwidget_type
);
2456 staticpro (&string_char_byte_cache_string
);
2457 string_char_byte_cache_string
= Qnil
;
2459 Fset (Qyes_or_no_p_history
, Qnil
);
2461 DEFVAR_LISP ("features", &Vfeatures
,
2462 "A list of symbols which are the features of the executing emacs.\n\
2463 Used by `featurep' and `require', and altered by `provide'.");
2466 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box
,
2467 "*Non-nil means mouse commands use dialog boxes to ask questions.\n\
2468 This applies to y-or-n and yes-or-no questions asked by commands\n\
2469 invoked by mouse clicks and mouse menu items.");
2472 defsubr (&Sidentity
);
2475 defsubr (&Ssafe_length
);
2476 defsubr (&Sstring_equal
);
2477 defsubr (&Sstring_lessp
);
2480 defsubr (&Svconcat
);
2481 defsubr (&Scopy_sequence
);
2482 defsubr (&Sstring_make_multibyte
);
2483 defsubr (&Sstring_make_unibyte
);
2484 defsubr (&Scopy_alist
);
2485 defsubr (&Ssubstring
);
2497 defsubr (&Snreverse
);
2498 defsubr (&Sreverse
);
2500 defsubr (&Splist_get
);
2502 defsubr (&Splist_put
);
2505 defsubr (&Sfillarray
);
2506 defsubr (&Schar_table_subtype
);
2507 defsubr (&Schar_table_parent
);
2508 defsubr (&Sset_char_table_parent
);
2509 defsubr (&Schar_table_extra_slot
);
2510 defsubr (&Sset_char_table_extra_slot
);
2511 defsubr (&Schar_table_range
);
2512 defsubr (&Sset_char_table_range
);
2513 defsubr (&Sset_char_table_default
);
2514 defsubr (&Smap_char_table
);
2517 defsubr (&Smapconcat
);
2518 defsubr (&Sy_or_n_p
);
2519 defsubr (&Syes_or_no_p
);
2520 defsubr (&Sload_average
);
2521 defsubr (&Sfeaturep
);
2522 defsubr (&Srequire
);
2523 defsubr (&Sprovide
);
2524 defsubr (&Swidget_plist_member
);
2525 defsubr (&Swidget_put
);
2526 defsubr (&Swidget_get
);
2527 defsubr (&Swidget_apply
);