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
;)
1998 FETCH_STRING_CHAR_ADVANCE (c
, seq
, i
, i_byte
)
1999 XSETFASTINT (dummy
, c
);
2000 vals
[i
] = call1 (fn
, dummy
);
2003 else /* Must be a list, since Flength did not get an error */
2006 for (i
= 0; i
< leni
; i
++)
2008 vals
[i
] = call1 (fn
, Fcar (tail
));
2009 tail
= XCONS (tail
)->cdr
;
2016 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
2017 "Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.\n\
2018 In between each pair of results, stick in SEPARATOR. Thus, \" \" as\n\
2019 SEPARATOR results in spaces between the values returned by FUNCTION.")
2020 (function
, sequence
, separator
)
2021 Lisp_Object function
, sequence
, separator
;
2026 register Lisp_Object
*args
;
2028 struct gcpro gcpro1
;
2030 len
= Flength (sequence
);
2032 nargs
= leni
+ leni
- 1;
2033 if (nargs
< 0) return build_string ("");
2035 args
= (Lisp_Object
*) alloca (nargs
* sizeof (Lisp_Object
));
2038 mapcar1 (leni
, args
, function
, sequence
);
2041 for (i
= leni
- 1; i
>= 0; i
--)
2042 args
[i
+ i
] = args
[i
];
2044 for (i
= 1; i
< nargs
; i
+= 2)
2045 args
[i
] = separator
;
2047 return Fconcat (nargs
, args
);
2050 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
2051 "Apply FUNCTION to each element of SEQUENCE, and make a list of the results.\n\
2052 The result is a list just as long as SEQUENCE.\n\
2053 SEQUENCE may be a list, a vector or a string.")
2054 (function
, sequence
)
2055 Lisp_Object function
, sequence
;
2057 register Lisp_Object len
;
2059 register Lisp_Object
*args
;
2061 len
= Flength (sequence
);
2062 leni
= XFASTINT (len
);
2063 args
= (Lisp_Object
*) alloca (leni
* sizeof (Lisp_Object
));
2065 mapcar1 (leni
, args
, function
, sequence
);
2067 return Flist (leni
, args
);
2070 /* Anything that calls this function must protect from GC! */
2072 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
2073 "Ask user a \"y or n\" question. Return t if answer is \"y\".\n\
2074 Takes one argument, which is the string to display to ask the question.\n\
2075 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.\n\
2076 No confirmation of the answer is requested; a single character is enough.\n\
2077 Also accepts Space to mean yes, or Delete to mean no.")
2081 register Lisp_Object obj
, key
, def
, answer_string
, map
;
2082 register int answer
;
2083 Lisp_Object xprompt
;
2084 Lisp_Object args
[2];
2085 struct gcpro gcpro1
, gcpro2
;
2086 int count
= specpdl_ptr
- specpdl
;
2088 specbind (Qcursor_in_echo_area
, Qt
);
2090 map
= Fsymbol_value (intern ("query-replace-map"));
2092 CHECK_STRING (prompt
, 0);
2094 GCPRO2 (prompt
, xprompt
);
2100 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2104 Lisp_Object pane
, menu
;
2105 redisplay_preserve_echo_area ();
2106 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2107 Fcons (Fcons (build_string ("No"), Qnil
),
2109 menu
= Fcons (prompt
, pane
);
2110 obj
= Fx_popup_dialog (Qt
, menu
);
2111 answer
= !NILP (obj
);
2114 #endif /* HAVE_MENUS */
2115 cursor_in_echo_area
= 1;
2116 choose_minibuf_frame ();
2117 message_with_string ("%s(y or n) ", xprompt
, 0);
2119 if (minibuffer_auto_raise
)
2121 Lisp_Object mini_frame
;
2123 mini_frame
= WINDOW_FRAME (XWINDOW (minibuf_window
));
2125 Fraise_frame (mini_frame
);
2128 obj
= read_filtered_event (1, 0, 0);
2129 cursor_in_echo_area
= 0;
2130 /* If we need to quit, quit with cursor_in_echo_area = 0. */
2133 key
= Fmake_vector (make_number (1), obj
);
2134 def
= Flookup_key (map
, key
, Qt
);
2135 answer_string
= Fsingle_key_description (obj
);
2137 if (EQ (def
, intern ("skip")))
2142 else if (EQ (def
, intern ("act")))
2147 else if (EQ (def
, intern ("recenter")))
2153 else if (EQ (def
, intern ("quit")))
2155 /* We want to exit this command for exit-prefix,
2156 and this is the only way to do it. */
2157 else if (EQ (def
, intern ("exit-prefix")))
2162 /* If we don't clear this, then the next call to read_char will
2163 return quit_char again, and we'll enter an infinite loop. */
2168 if (EQ (xprompt
, prompt
))
2170 args
[0] = build_string ("Please answer y or n. ");
2172 xprompt
= Fconcat (2, args
);
2177 if (! noninteractive
)
2179 cursor_in_echo_area
= -1;
2180 message_with_string (answer
? "%s(y or n) y" : "%s(y or n) n",
2184 unbind_to (count
, Qnil
);
2185 return answer
? Qt
: Qnil
;
2188 /* This is how C code calls `yes-or-no-p' and allows the user
2191 Anything that calls this function must protect from GC! */
2194 do_yes_or_no_p (prompt
)
2197 return call1 (intern ("yes-or-no-p"), prompt
);
2200 /* Anything that calls this function must protect from GC! */
2202 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
2203 "Ask user a yes-or-no question. Return t if answer is yes.\n\
2204 Takes one argument, which is the string to display to ask the question.\n\
2205 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.\n\
2206 The user must confirm the answer with RET,\n\
2207 and can edit it until it has been confirmed.")
2211 register Lisp_Object ans
;
2212 Lisp_Object args
[2];
2213 struct gcpro gcpro1
;
2216 CHECK_STRING (prompt
, 0);
2219 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
2223 Lisp_Object pane
, menu
, obj
;
2224 redisplay_preserve_echo_area ();
2225 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
2226 Fcons (Fcons (build_string ("No"), Qnil
),
2229 menu
= Fcons (prompt
, pane
);
2230 obj
= Fx_popup_dialog (Qt
, menu
);
2234 #endif /* HAVE_MENUS */
2237 args
[1] = build_string ("(yes or no) ");
2238 prompt
= Fconcat (2, args
);
2244 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
2245 Qyes_or_no_p_history
, Qnil
,
2247 if (XSTRING (ans
)->size
== 3 && !strcmp (XSTRING (ans
)->data
, "yes"))
2252 if (XSTRING (ans
)->size
== 2 && !strcmp (XSTRING (ans
)->data
, "no"))
2260 message ("Please answer yes or no.");
2261 Fsleep_for (make_number (2), Qnil
);
2265 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 0, 0,
2266 "Return list of 1 minute, 5 minute and 15 minute load averages.\n\
2267 Each of the three load averages is multiplied by 100,\n\
2268 then converted to integer.\n\
2269 If the 5-minute or 15-minute load averages are not available, return a\n\
2270 shortened list, containing only those averages which are available.")
2274 int loads
= getloadavg (load_ave
, 3);
2278 error ("load-average not implemented for this operating system");
2282 ret
= Fcons (make_number ((int) (load_ave
[--loads
] * 100.0)), ret
);
2287 Lisp_Object Vfeatures
;
2289 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 1, 0,
2290 "Returns t if FEATURE is present in this Emacs.\n\
2291 Use this to conditionalize execution of lisp code based on the presence or\n\
2292 absence of emacs or environment extensions.\n\
2293 Use `provide' to declare that a feature is available.\n\
2294 This function looks at the value of the variable `features'.")
2296 Lisp_Object feature
;
2298 register Lisp_Object tem
;
2299 CHECK_SYMBOL (feature
, 0);
2300 tem
= Fmemq (feature
, Vfeatures
);
2301 return (NILP (tem
)) ? Qnil
: Qt
;
2304 DEFUN ("provide", Fprovide
, Sprovide
, 1, 1, 0,
2305 "Announce that FEATURE is a feature of the current Emacs.")
2307 Lisp_Object feature
;
2309 register Lisp_Object tem
;
2310 CHECK_SYMBOL (feature
, 0);
2311 if (!NILP (Vautoload_queue
))
2312 Vautoload_queue
= Fcons (Fcons (Vfeatures
, Qnil
), Vautoload_queue
);
2313 tem
= Fmemq (feature
, Vfeatures
);
2315 Vfeatures
= Fcons (feature
, Vfeatures
);
2316 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
2320 DEFUN ("require", Frequire
, Srequire
, 1, 2, 0,
2321 "If feature FEATURE is not loaded, load it from FILENAME.\n\
2322 If FEATURE is not a member of the list `features', then the feature\n\
2323 is not loaded; so load the file FILENAME.\n\
2324 If FILENAME is omitted, the printname of FEATURE is used as the file name.")
2325 (feature
, file_name
)
2326 Lisp_Object feature
, file_name
;
2328 register Lisp_Object tem
;
2329 CHECK_SYMBOL (feature
, 0);
2330 tem
= Fmemq (feature
, Vfeatures
);
2331 LOADHIST_ATTACH (Fcons (Qrequire
, feature
));
2334 int count
= specpdl_ptr
- specpdl
;
2336 /* Value saved here is to be restored into Vautoload_queue */
2337 record_unwind_protect (un_autoload
, Vautoload_queue
);
2338 Vautoload_queue
= Qt
;
2340 Fload (NILP (file_name
) ? Fsymbol_name (feature
) : file_name
,
2341 Qnil
, Qt
, Qnil
, (NILP (file_name
) ? Qt
: Qnil
));
2343 tem
= Fmemq (feature
, Vfeatures
);
2345 error ("Required feature %s was not provided",
2346 XSYMBOL (feature
)->name
->data
);
2348 /* Once loading finishes, don't undo it. */
2349 Vautoload_queue
= Qt
;
2350 feature
= unbind_to (count
, feature
);
2355 /* Primitives for work of the "widget" library.
2356 In an ideal world, this section would not have been necessary.
2357 However, lisp function calls being as slow as they are, it turns
2358 out that some functions in the widget library (wid-edit.el) are the
2359 bottleneck of Widget operation. Here is their translation to C,
2360 for the sole reason of efficiency. */
2362 DEFUN ("widget-plist-member", Fwidget_plist_member
, Swidget_plist_member
, 2, 2, 0,
2363 "Return non-nil if PLIST has the property PROP.\n\
2364 PLIST is a property list, which is a list of the form\n\
2365 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.\n\
2366 Unlike `plist-get', this allows you to distinguish between a missing\n\
2367 property and a property with the value nil.\n\
2368 The value is actually the tail of PLIST whose car is PROP.")
2370 Lisp_Object plist
, prop
;
2372 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
2375 plist
= XCDR (plist
);
2376 plist
= CDR (plist
);
2381 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
2382 "In WIDGET, set PROPERTY to VALUE.\n\
2383 The value can later be retrieved with `widget-get'.")
2384 (widget
, property
, value
)
2385 Lisp_Object widget
, property
, value
;
2387 CHECK_CONS (widget
, 1);
2388 XCDR (widget
) = Fplist_put (XCDR (widget
), property
, value
);
2391 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
2392 "In WIDGET, get the value of PROPERTY.\n\
2393 The value could either be specified when the widget was created, or\n\
2394 later with `widget-put'.")
2396 Lisp_Object widget
, property
;
2404 CHECK_CONS (widget
, 1);
2405 tmp
= Fwidget_plist_member (XCDR (widget
), property
);
2411 tmp
= XCAR (widget
);
2414 widget
= Fget (tmp
, Qwidget_type
);
2418 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
2419 "Apply the value of WIDGET's PROPERTY to the widget itself.\n\
2420 ARGS are passed as extra arguments to the function.")
2425 /* This function can GC. */
2426 Lisp_Object newargs
[3];
2427 struct gcpro gcpro1
, gcpro2
;
2430 newargs
[0] = Fwidget_get (args
[0], args
[1]);
2431 newargs
[1] = args
[0];
2432 newargs
[2] = Flist (nargs
- 2, args
+ 2);
2433 GCPRO2 (newargs
[0], newargs
[2]);
2434 result
= Fapply (3, newargs
);
2441 Qstring_lessp
= intern ("string-lessp");
2442 staticpro (&Qstring_lessp
);
2443 Qprovide
= intern ("provide");
2444 staticpro (&Qprovide
);
2445 Qrequire
= intern ("require");
2446 staticpro (&Qrequire
);
2447 Qyes_or_no_p_history
= intern ("yes-or-no-p-history");
2448 staticpro (&Qyes_or_no_p_history
);
2449 Qcursor_in_echo_area
= intern ("cursor-in-echo-area");
2450 staticpro (&Qcursor_in_echo_area
);
2451 Qwidget_type
= intern ("widget-type");
2452 staticpro (&Qwidget_type
);
2454 staticpro (&string_char_byte_cache_string
);
2455 string_char_byte_cache_string
= Qnil
;
2457 Fset (Qyes_or_no_p_history
, Qnil
);
2459 DEFVAR_LISP ("features", &Vfeatures
,
2460 "A list of symbols which are the features of the executing emacs.\n\
2461 Used by `featurep' and `require', and altered by `provide'.");
2464 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box
,
2465 "*Non-nil means mouse commands use dialog boxes to ask questions.\n\
2466 This applies to y-or-n and yes-or-no questions asked by commands\n\
2467 invoked by mouse clicks and mouse menu items.");
2470 defsubr (&Sidentity
);
2473 defsubr (&Ssafe_length
);
2474 defsubr (&Sstring_equal
);
2475 defsubr (&Sstring_lessp
);
2478 defsubr (&Svconcat
);
2479 defsubr (&Scopy_sequence
);
2480 defsubr (&Sstring_make_multibyte
);
2481 defsubr (&Sstring_make_unibyte
);
2482 defsubr (&Scopy_alist
);
2483 defsubr (&Ssubstring
);
2495 defsubr (&Snreverse
);
2496 defsubr (&Sreverse
);
2498 defsubr (&Splist_get
);
2500 defsubr (&Splist_put
);
2503 defsubr (&Sfillarray
);
2504 defsubr (&Schar_table_subtype
);
2505 defsubr (&Schar_table_parent
);
2506 defsubr (&Sset_char_table_parent
);
2507 defsubr (&Schar_table_extra_slot
);
2508 defsubr (&Sset_char_table_extra_slot
);
2509 defsubr (&Schar_table_range
);
2510 defsubr (&Sset_char_table_range
);
2511 defsubr (&Sset_char_table_default
);
2512 defsubr (&Smap_char_table
);
2515 defsubr (&Smapconcat
);
2516 defsubr (&Sy_or_n_p
);
2517 defsubr (&Syes_or_no_p
);
2518 defsubr (&Sload_average
);
2519 defsubr (&Sfeaturep
);
2520 defsubr (&Srequire
);
2521 defsubr (&Sprovide
);
2522 defsubr (&Swidget_plist_member
);
2523 defsubr (&Swidget_put
);
2524 defsubr (&Swidget_get
);
2525 defsubr (&Swidget_apply
);