1 /* Random utility Lisp functions.
2 Copyright (C) 1985, 86, 87, 93, 94, 95 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 /* Nonzero enables use of dialog boxes for questions
44 asked by mouse commands. */
47 extern Lisp_Object
Flookup_key ();
49 extern int minibuffer_auto_raise
;
50 extern Lisp_Object minibuf_window
;
52 Lisp_Object Qstring_lessp
, Qprovide
, Qrequire
;
53 Lisp_Object Qyes_or_no_p_history
;
54 Lisp_Object Qcursor_in_echo_area
;
55 Lisp_Object Qwidget_type
;
57 static int internal_equal ();
59 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
60 "Return the argument unchanged.")
67 extern long get_random ();
68 extern void seed_random ();
71 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
72 "Return a pseudo-random number.\n\
73 All integers representable in Lisp are equally likely.\n\
74 On most systems, this is 28 bits' worth.\n\
75 With positive integer argument N, return random number in interval [0,N).\n\
76 With argument t, set the random number seed from the current time and pid.")
81 Lisp_Object lispy_val
;
82 unsigned long denominator
;
85 seed_random (getpid () + time (NULL
));
86 if (NATNUMP (n
) && XFASTINT (n
) != 0)
88 /* Try to take our random number from the higher bits of VAL,
89 not the lower, since (says Gentzel) the low bits of `random'
90 are less random than the higher ones. We do this by using the
91 quotient rather than the remainder. At the high end of the RNG
92 it's possible to get a quotient larger than n; discarding
93 these values eliminates the bias that would otherwise appear
94 when using a large n. */
95 denominator
= ((unsigned long)1 << VALBITS
) / XFASTINT (n
);
97 val
= get_random () / denominator
;
98 while (val
>= XFASTINT (n
));
102 XSETINT (lispy_val
, val
);
106 /* Random data-structure functions */
108 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
109 "Return the length of vector, list or string SEQUENCE.\n\
110 A byte-code function object is also allowed.\n\
111 If the string contains multibyte characters, this is not the necessarily\n\
112 the number of characters in the string; it is the number of bytes.\n\
113 To get the number of characters, use `chars-in-string'")
115 register Lisp_Object sequence
;
117 register Lisp_Object tail
, val
;
121 if (STRINGP (sequence
))
122 XSETFASTINT (val
, XSTRING (sequence
)->size
);
123 else if (VECTORP (sequence
))
124 XSETFASTINT (val
, XVECTOR (sequence
)->size
);
125 else if (CHAR_TABLE_P (sequence
))
126 XSETFASTINT (val
, CHAR_TABLE_ORDINARY_SLOTS
);
127 else if (BOOL_VECTOR_P (sequence
))
128 XSETFASTINT (val
, XBOOL_VECTOR (sequence
)->size
);
129 else if (COMPILEDP (sequence
))
130 XSETFASTINT (val
, XVECTOR (sequence
)->size
& PSEUDOVECTOR_SIZE_MASK
);
131 else if (CONSP (sequence
))
133 for (i
= 0, tail
= sequence
; !NILP (tail
); i
++)
139 XSETFASTINT (val
, i
);
141 else if (NILP (sequence
))
142 XSETFASTINT (val
, 0);
145 sequence
= wrong_type_argument (Qsequencep
, sequence
);
151 /* This does not check for quits. That is safe
152 since it must terminate. */
154 DEFUN ("safe-length", Fsafe_length
, Ssafe_length
, 1, 1, 0,
155 "Return the length of a list, but avoid error or infinite loop.\n\
156 This function never gets an error. If LIST is not really a list,\n\
157 it returns 0. If LIST is circular, it returns a finite value\n\
158 which is at least the number of distinct elements.")
162 Lisp_Object tail
, halftail
, length
;
165 /* halftail is used to detect circular lists. */
167 for (tail
= list
; CONSP (tail
); tail
= XCONS (tail
)->cdr
)
169 if (EQ (tail
, halftail
) && len
!= 0)
173 halftail
= XCONS (halftail
)->cdr
;
176 XSETINT (length
, len
);
180 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
181 "T if two strings have identical contents.\n\
182 Case is significant, but text properties are ignored.\n\
183 Symbols are also allowed; their print names are used instead.")
185 register Lisp_Object s1
, s2
;
188 XSETSTRING (s1
, XSYMBOL (s1
)->name
);
190 XSETSTRING (s2
, XSYMBOL (s2
)->name
);
191 CHECK_STRING (s1
, 0);
192 CHECK_STRING (s2
, 1);
194 if (XSTRING (s1
)->size
!= XSTRING (s2
)->size
||
195 bcmp (XSTRING (s1
)->data
, XSTRING (s2
)->data
, XSTRING (s1
)->size
))
200 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
201 "T if first arg string is less than second in lexicographic order.\n\
202 Case is significant.\n\
203 Symbols are also allowed; their print names are used instead.")
205 register Lisp_Object s1
, s2
;
208 register unsigned char *p1
, *p2
;
212 XSETSTRING (s1
, XSYMBOL (s1
)->name
);
214 XSETSTRING (s2
, XSYMBOL (s2
)->name
);
215 CHECK_STRING (s1
, 0);
216 CHECK_STRING (s2
, 1);
218 p1
= XSTRING (s1
)->data
;
219 p2
= XSTRING (s2
)->data
;
220 end
= XSTRING (s1
)->size
;
221 if (end
> XSTRING (s2
)->size
)
222 end
= XSTRING (s2
)->size
;
224 for (i
= 0; i
< end
; i
++)
227 return p1
[i
] < p2
[i
] ? Qt
: Qnil
;
229 return i
< XSTRING (s2
)->size
? Qt
: Qnil
;
232 static Lisp_Object
concat ();
243 return concat (2, args
, Lisp_String
, 0);
245 return concat (2, &s1
, Lisp_String
, 0);
246 #endif /* NO_ARG_ARRAY */
252 Lisp_Object s1
, s2
, s3
;
259 return concat (3, args
, Lisp_String
, 0);
261 return concat (3, &s1
, Lisp_String
, 0);
262 #endif /* NO_ARG_ARRAY */
265 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
266 "Concatenate all the arguments and make the result a list.\n\
267 The result is a list whose elements are the elements of all the arguments.\n\
268 Each argument may be a list, vector or string.\n\
269 The last argument is not copied, just used as the tail of the new list.")
274 return concat (nargs
, args
, Lisp_Cons
, 1);
277 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
278 "Concatenate all the arguments and make the result a string.\n\
279 The result is a string whose elements are the elements of all the arguments.\n\
280 Each argument may be a string or a list or vector of characters (integers).\n\
282 Do not use individual integers as arguments!\n\
283 The behavior of `concat' in that case will be changed later!\n\
284 If your program passes an integer as an argument to `concat',\n\
285 you should change it right away not to do so.")
290 return concat (nargs
, args
, Lisp_String
, 0);
293 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
294 "Concatenate all the arguments and make the result a vector.\n\
295 The result is a vector whose elements are the elements of all the arguments.\n\
296 Each argument may be a list, vector or string.")
301 return concat (nargs
, args
, Lisp_Vectorlike
, 0);
304 /* Retrun a copy of a sub char table ARG. The elements except for a
305 nested sub char table are not copied. */
307 copy_sub_char_table (arg
)
310 Lisp_Object copy
= make_sub_char_table (XCHAR_TABLE (arg
)->defalt
);
313 /* Copy all the contents. */
314 bcopy (XCHAR_TABLE (arg
)->contents
, XCHAR_TABLE (copy
)->contents
,
315 SUB_CHAR_TABLE_ORDINARY_SLOTS
* sizeof (Lisp_Object
));
316 /* Recursively copy any sub char-tables in the ordinary slots. */
317 for (i
= 32; i
< SUB_CHAR_TABLE_ORDINARY_SLOTS
; i
++)
318 if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg
)->contents
[i
]))
319 XCHAR_TABLE (copy
)->contents
[i
]
320 = copy_sub_char_table (XCHAR_TABLE (copy
)->contents
[i
]);
326 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
327 "Return a copy of a list, vector or string.\n\
328 The elements of a list or vector are not copied; they are shared\n\
333 if (NILP (arg
)) return arg
;
335 if (CHAR_TABLE_P (arg
))
340 copy
= Fmake_char_table (XCHAR_TABLE (arg
)->purpose
, Qnil
);
341 /* Copy all the slots, including the extra ones. */
342 bcopy (XVECTOR (arg
)->contents
, XVECTOR (copy
)->contents
,
343 ((XCHAR_TABLE (arg
)->size
& PSEUDOVECTOR_SIZE_MASK
)
344 * sizeof (Lisp_Object
)));
346 /* Recursively copy any sub char tables in the ordinary slots
347 for multibyte characters. */
348 for (i
= CHAR_TABLE_SINGLE_BYTE_SLOTS
;
349 i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
350 if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg
)->contents
[i
]))
351 XCHAR_TABLE (copy
)->contents
[i
]
352 = copy_sub_char_table (XCHAR_TABLE (copy
)->contents
[i
]);
357 if (BOOL_VECTOR_P (arg
))
361 = (XBOOL_VECTOR (arg
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
363 val
= Fmake_bool_vector (Flength (arg
), Qnil
);
364 bcopy (XBOOL_VECTOR (arg
)->data
, XBOOL_VECTOR (val
)->data
,
369 if (!CONSP (arg
) && !VECTORP (arg
) && !STRINGP (arg
))
370 arg
= wrong_type_argument (Qsequencep
, arg
);
371 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
375 concat (nargs
, args
, target_type
, last_special
)
378 enum Lisp_Type target_type
;
383 register Lisp_Object tail
;
384 register Lisp_Object
this;
388 Lisp_Object last_tail
;
391 /* In append, the last arg isn't treated like the others */
392 if (last_special
&& nargs
> 0)
395 last_tail
= args
[nargs
];
400 for (argnum
= 0; argnum
< nargs
; argnum
++)
403 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
404 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
407 args
[argnum
] = Fnumber_to_string (this);
409 args
[argnum
] = wrong_type_argument (Qsequencep
, this);
413 for (argnum
= 0, leni
= 0; argnum
< nargs
; argnum
++)
416 len
= Flength (this);
417 if ((VECTORP (this) || CONSP (this)) && target_type
== Lisp_String
)
420 /* We must pay attention to a multibyte character which
421 takes more than one byte in string. */
426 for (i
= 0; i
< XFASTINT (len
); i
++)
428 ch
= XVECTOR (this)->contents
[i
];
430 wrong_type_argument (Qintegerp
, ch
);
431 leni
+= XFASTINT (Fchar_bytes (ch
));
434 for (; CONSP (this); this = XCONS (this)->cdr
)
436 ch
= XCONS (this)->car
;
438 wrong_type_argument (Qintegerp
, ch
);
439 leni
+= XFASTINT (Fchar_bytes (ch
));
443 leni
+= XFASTINT (len
);
446 XSETFASTINT (len
, leni
);
448 if (target_type
== Lisp_Cons
)
449 val
= Fmake_list (len
, Qnil
);
450 else if (target_type
== Lisp_Vectorlike
)
451 val
= Fmake_vector (len
, Qnil
);
453 val
= Fmake_string (len
, len
);
455 /* In append, if all but last arg are nil, return last arg */
456 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
460 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
466 for (argnum
= 0; argnum
< nargs
; argnum
++)
470 register unsigned int thisindex
= 0;
474 thislen
= Flength (this), thisleni
= XINT (thislen
);
476 if (STRINGP (this) && STRINGP (val
)
477 && ! NULL_INTERVAL_P (XSTRING (this)->intervals
))
479 copy_text_properties (make_number (0), thislen
, this,
480 make_number (toindex
), val
, Qnil
);
485 register Lisp_Object elt
;
487 /* Fetch next element of `this' arg into `elt', or break if
488 `this' is exhausted. */
489 if (NILP (this)) break;
491 elt
= XCONS (this)->car
, this = XCONS (this)->cdr
;
494 if (thisindex
>= thisleni
) break;
496 XSETFASTINT (elt
, XSTRING (this)->data
[thisindex
++]);
497 else if (BOOL_VECTOR_P (this))
500 = ((XBOOL_VECTOR (this)->size
+ BITS_PER_CHAR
- 1)
503 byte
= XBOOL_VECTOR (val
)->data
[thisindex
/ BITS_PER_CHAR
];
504 if (byte
& (1 << (thisindex
% BITS_PER_CHAR
)))
510 elt
= XVECTOR (this)->contents
[thisindex
++];
513 /* Store into result */
516 XCONS (tail
)->car
= elt
;
518 tail
= XCONS (tail
)->cdr
;
520 else if (VECTORP (val
))
521 XVECTOR (val
)->contents
[toindex
++] = elt
;
524 while (!INTEGERP (elt
))
525 elt
= wrong_type_argument (Qintegerp
, elt
);
528 unsigned char work
[4], *str
;
529 int i
= CHAR_STRING (c
, work
, str
);
531 #ifdef MASSC_REGISTER_BUG
532 /* Even removing all "register"s doesn't disable this bug!
533 Nothing simpler than this seems to work. */
534 unsigned char *p
= & XSTRING (val
)->data
[toindex
];
537 bcopy (str
, & XSTRING (val
)->data
[toindex
], i
);
545 XCONS (prev
)->cdr
= last_tail
;
550 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
551 "Return a copy of ALIST.\n\
552 This is an alist which represents the same mapping from objects to objects,\n\
553 but does not share the alist structure with ALIST.\n\
554 The objects mapped (cars and cdrs of elements of the alist)\n\
555 are shared, however.\n\
556 Elements of ALIST that are not conses are also shared.")
560 register Lisp_Object tem
;
562 CHECK_LIST (alist
, 0);
565 alist
= concat (1, &alist
, Lisp_Cons
, 0);
566 for (tem
= alist
; CONSP (tem
); tem
= XCONS (tem
)->cdr
)
568 register Lisp_Object car
;
569 car
= XCONS (tem
)->car
;
572 XCONS (tem
)->car
= Fcons (XCONS (car
)->car
, XCONS (car
)->cdr
);
577 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
578 "Return a substring of STRING, starting at index FROM and ending before TO.\n\
579 TO may be nil or omitted; then the substring runs to the end of STRING.\n\
580 If FROM or TO is negative, it counts from the end.\n\
582 This function allows vectors as well as strings.")
585 register Lisp_Object from
, to
;
590 if (! (STRINGP (string
) || VECTORP (string
)))
591 wrong_type_argument (Qarrayp
, string
);
593 CHECK_NUMBER (from
, 1);
595 if (STRINGP (string
))
596 size
= XSTRING (string
)->size
;
598 size
= XVECTOR (string
)->size
;
603 CHECK_NUMBER (to
, 2);
606 XSETINT (from
, XINT (from
) + size
);
608 XSETINT (to
, XINT (to
) + size
);
609 if (!(0 <= XINT (from
) && XINT (from
) <= XINT (to
)
610 && XINT (to
) <= size
))
611 args_out_of_range_3 (string
, from
, to
);
613 if (STRINGP (string
))
615 res
= make_string (XSTRING (string
)->data
+ XINT (from
),
616 XINT (to
) - XINT (from
));
617 copy_text_properties (from
, to
, string
, make_number (0), res
, Qnil
);
620 res
= Fvector (XINT (to
) - XINT (from
),
621 XVECTOR (string
)->contents
+ XINT (from
));
626 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
627 "Take cdr N times on LIST, returns the result.")
630 register Lisp_Object list
;
635 for (i
= 0; i
< num
&& !NILP (list
); i
++)
643 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
644 "Return the Nth element of LIST.\n\
645 N counts from zero. If LIST is not that long, nil is returned.")
649 return Fcar (Fnthcdr (n
, list
));
652 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
653 "Return element of SEQUENCE at index N.")
655 register Lisp_Object sequence
, n
;
660 if (CONSP (sequence
) || NILP (sequence
))
661 return Fcar (Fnthcdr (n
, sequence
));
662 else if (STRINGP (sequence
) || VECTORP (sequence
)
663 || BOOL_VECTOR_P (sequence
) || CHAR_TABLE_P (sequence
))
664 return Faref (sequence
, n
);
666 sequence
= wrong_type_argument (Qsequencep
, sequence
);
670 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
671 "Return non-nil if ELT is an element of LIST. Comparison done with `equal'.\n\
672 The value is actually the tail of LIST whose car is ELT.")
674 register Lisp_Object elt
;
677 register Lisp_Object tail
;
678 for (tail
= list
; !NILP (tail
); tail
= XCONS (tail
)->cdr
)
680 register Lisp_Object tem
;
682 if (! NILP (Fequal (elt
, tem
)))
689 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
690 "Return non-nil if ELT is an element of LIST. Comparison done with EQ.\n\
691 The value is actually the tail of LIST whose car is ELT.")
693 register Lisp_Object elt
;
696 register Lisp_Object tail
;
697 for (tail
= list
; !NILP (tail
); tail
= XCONS (tail
)->cdr
)
699 register Lisp_Object tem
;
701 if (EQ (elt
, tem
)) return tail
;
707 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
708 "Return non-nil if KEY is `eq' to the car of an element of LIST.\n\
709 The value is actually the element of LIST whose car is KEY.\n\
710 Elements of LIST that are not conses are ignored.")
712 register Lisp_Object key
;
715 register Lisp_Object tail
;
716 for (tail
= list
; !NILP (tail
); tail
= XCONS (tail
)->cdr
)
718 register Lisp_Object elt
, tem
;
720 if (!CONSP (elt
)) continue;
721 tem
= XCONS (elt
)->car
;
722 if (EQ (key
, tem
)) return elt
;
728 /* Like Fassq but never report an error and do not allow quits.
729 Use only on lists known never to be circular. */
732 assq_no_quit (key
, list
)
733 register Lisp_Object key
;
736 register Lisp_Object tail
;
737 for (tail
= list
; CONSP (tail
); tail
= XCONS (tail
)->cdr
)
739 register Lisp_Object elt
, tem
;
741 if (!CONSP (elt
)) continue;
742 tem
= XCONS (elt
)->car
;
743 if (EQ (key
, tem
)) return elt
;
748 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
749 "Return non-nil if KEY is `equal' to the car of an element of LIST.\n\
750 The value is actually the element of LIST whose car equals KEY.")
752 register Lisp_Object key
;
755 register Lisp_Object tail
;
756 for (tail
= list
; !NILP (tail
); tail
= XCONS (tail
)->cdr
)
758 register Lisp_Object elt
, tem
;
760 if (!CONSP (elt
)) continue;
761 tem
= Fequal (XCONS (elt
)->car
, key
);
762 if (!NILP (tem
)) return elt
;
768 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
769 "Return non-nil if ELT is `eq' to the cdr of an element of LIST.\n\
770 The value is actually the element of LIST whose cdr is ELT.")
772 register Lisp_Object key
;
775 register Lisp_Object tail
;
776 for (tail
= list
; !NILP (tail
); tail
= XCONS (tail
)->cdr
)
778 register Lisp_Object elt
, tem
;
780 if (!CONSP (elt
)) continue;
781 tem
= XCONS (elt
)->cdr
;
782 if (EQ (key
, tem
)) return elt
;
788 DEFUN ("rassoc", Frassoc
, Srassoc
, 2, 2, 0,
789 "Return non-nil if KEY is `equal' to the cdr of an element of LIST.\n\
790 The value is actually the element of LIST whose cdr equals KEY.")
792 register Lisp_Object key
;
795 register Lisp_Object tail
;
796 for (tail
= list
; !NILP (tail
); tail
= XCONS (tail
)->cdr
)
798 register Lisp_Object elt
, tem
;
800 if (!CONSP (elt
)) continue;
801 tem
= Fequal (XCONS (elt
)->cdr
, key
);
802 if (!NILP (tem
)) return elt
;
808 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
809 "Delete by side effect any occurrences of ELT as a member of LIST.\n\
810 The modified LIST is returned. Comparison is done with `eq'.\n\
811 If the first member of LIST is ELT, there is no way to remove it by side effect;\n\
812 therefore, write `(setq foo (delq element foo))'\n\
813 to be sure of changing the value of `foo'.")
815 register Lisp_Object elt
;
818 register Lisp_Object tail
, prev
;
819 register Lisp_Object tem
;
829 list
= XCONS (tail
)->cdr
;
831 Fsetcdr (prev
, XCONS (tail
)->cdr
);
835 tail
= XCONS (tail
)->cdr
;
841 DEFUN ("delete", Fdelete
, Sdelete
, 2, 2, 0,
842 "Delete by side effect any occurrences of ELT as a member of LIST.\n\
843 The modified LIST is returned. Comparison is done with `equal'.\n\
844 If the first member of LIST is ELT, deleting it is not a side effect;\n\
845 it is simply using a different list.\n\
846 Therefore, write `(setq foo (delete element foo))'\n\
847 to be sure of changing the value of `foo'.")
849 register Lisp_Object elt
;
852 register Lisp_Object tail
, prev
;
853 register Lisp_Object tem
;
860 if (! NILP (Fequal (elt
, tem
)))
863 list
= XCONS (tail
)->cdr
;
865 Fsetcdr (prev
, XCONS (tail
)->cdr
);
869 tail
= XCONS (tail
)->cdr
;
875 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
876 "Reverse LIST by modifying cdr pointers.\n\
877 Returns the beginning of the reversed list.")
881 register Lisp_Object prev
, tail
, next
;
883 if (NILP (list
)) return list
;
890 Fsetcdr (tail
, prev
);
897 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
898 "Reverse LIST, copying. Returns the beginning of the reversed list.\n\
899 See also the function `nreverse', which is used more often.")
905 for (new = Qnil
; CONSP (list
); list
= XCONS (list
)->cdr
)
906 new = Fcons (XCONS (list
)->car
, new);
908 wrong_type_argument (Qconsp
, list
);
912 Lisp_Object
merge ();
914 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
915 "Sort LIST, stably, comparing elements using PREDICATE.\n\
916 Returns the sorted list. LIST is modified by side effects.\n\
917 PREDICATE is called with two elements of LIST, and should return T\n\
918 if the first element is \"less\" than the second.")
920 Lisp_Object list
, predicate
;
922 Lisp_Object front
, back
;
923 register Lisp_Object len
, tem
;
924 struct gcpro gcpro1
, gcpro2
;
928 len
= Flength (list
);
933 XSETINT (len
, (length
/ 2) - 1);
934 tem
= Fnthcdr (len
, list
);
938 GCPRO2 (front
, back
);
939 front
= Fsort (front
, predicate
);
940 back
= Fsort (back
, predicate
);
942 return merge (front
, back
, predicate
);
946 merge (org_l1
, org_l2
, pred
)
947 Lisp_Object org_l1
, org_l2
;
951 register Lisp_Object tail
;
953 register Lisp_Object l1
, l2
;
954 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
961 /* It is sufficient to protect org_l1 and org_l2.
962 When l1 and l2 are updated, we copy the new values
963 back into the org_ vars. */
964 GCPRO4 (org_l1
, org_l2
, pred
, value
);
984 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
1000 Fsetcdr (tail
, tem
);
1006 DEFUN ("plist-get", Fplist_get
, Splist_get
, 2, 2, 0,
1007 "Extract a value from a property list.\n\
1008 PLIST is a property list, which is a list of the form\n\
1009 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value\n\
1010 corresponding to the given PROP, or nil if PROP is not\n\
1011 one of the properties on the list.")
1014 register Lisp_Object prop
;
1016 register Lisp_Object tail
;
1017 for (tail
= plist
; !NILP (tail
); tail
= Fcdr (XCONS (tail
)->cdr
))
1019 register Lisp_Object tem
;
1022 return Fcar (XCONS (tail
)->cdr
);
1027 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
1028 "Return the value of SYMBOL's PROPNAME property.\n\
1029 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'.")
1031 Lisp_Object symbol
, propname
;
1033 CHECK_SYMBOL (symbol
, 0);
1034 return Fplist_get (XSYMBOL (symbol
)->plist
, propname
);
1037 DEFUN ("plist-put", Fplist_put
, Splist_put
, 3, 3, 0,
1038 "Change value in PLIST of PROP to VAL.\n\
1039 PLIST is a property list, which is a list of the form\n\
1040 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.\n\
1041 If PROP is already a property on the list, its value is set to VAL,\n\
1042 otherwise the new PROP VAL pair is added. The new plist is returned;\n\
1043 use `(setq x (plist-put x prop val))' to be sure to use the new value.\n\
1044 The PLIST is modified by side effects.")
1047 register Lisp_Object prop
;
1050 register Lisp_Object tail
, prev
;
1051 Lisp_Object newcell
;
1053 for (tail
= plist
; CONSP (tail
) && CONSP (XCONS (tail
)->cdr
);
1054 tail
= XCONS (XCONS (tail
)->cdr
)->cdr
)
1056 if (EQ (prop
, XCONS (tail
)->car
))
1058 Fsetcar (XCONS (tail
)->cdr
, val
);
1063 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
1067 Fsetcdr (XCONS (prev
)->cdr
, newcell
);
1071 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
1072 "Store SYMBOL's PROPNAME property with value VALUE.\n\
1073 It can be retrieved with `(get SYMBOL PROPNAME)'.")
1074 (symbol
, propname
, value
)
1075 Lisp_Object symbol
, propname
, value
;
1077 CHECK_SYMBOL (symbol
, 0);
1078 XSYMBOL (symbol
)->plist
1079 = Fplist_put (XSYMBOL (symbol
)->plist
, propname
, value
);
1083 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
1084 "T if two Lisp objects have similar structure and contents.\n\
1085 They must have the same data type.\n\
1086 Conses are compared by comparing the cars and the cdrs.\n\
1087 Vectors and strings are compared element by element.\n\
1088 Numbers are compared by value, but integers cannot equal floats.\n\
1089 (Use `=' if you want integers and floats to be able to be equal.)\n\
1090 Symbols must match exactly.")
1092 register Lisp_Object o1
, o2
;
1094 return internal_equal (o1
, o2
, 0) ? Qt
: Qnil
;
1098 internal_equal (o1
, o2
, depth
)
1099 register Lisp_Object o1
, o2
;
1103 error ("Stack overflow in equal");
1109 if (XTYPE (o1
) != XTYPE (o2
))
1114 #ifdef LISP_FLOAT_TYPE
1116 return (extract_float (o1
) == extract_float (o2
));
1120 if (!internal_equal (XCONS (o1
)->car
, XCONS (o2
)->car
, depth
+ 1))
1122 o1
= XCONS (o1
)->cdr
;
1123 o2
= XCONS (o2
)->cdr
;
1127 if (XMISCTYPE (o1
) != XMISCTYPE (o2
))
1131 if (!internal_equal (OVERLAY_START (o1
), OVERLAY_START (o1
),
1133 || !internal_equal (OVERLAY_END (o1
), OVERLAY_END (o1
),
1136 o1
= XOVERLAY (o1
)->plist
;
1137 o2
= XOVERLAY (o2
)->plist
;
1142 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
1143 && (XMARKER (o1
)->buffer
== 0
1144 || XMARKER (o1
)->bufpos
== XMARKER (o2
)->bufpos
));
1148 case Lisp_Vectorlike
:
1150 register int i
, size
;
1151 size
= XVECTOR (o1
)->size
;
1152 /* Pseudovectors have the type encoded in the size field, so this test
1153 actually checks that the objects have the same type as well as the
1155 if (XVECTOR (o2
)->size
!= size
)
1157 /* Boolvectors are compared much like strings. */
1158 if (BOOL_VECTOR_P (o1
))
1161 = (XBOOL_VECTOR (o1
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
1163 if (XBOOL_VECTOR (o1
)->size
!= XBOOL_VECTOR (o2
)->size
)
1165 if (bcmp (XBOOL_VECTOR (o1
)->data
, XBOOL_VECTOR (o2
)->data
,
1171 /* Aside from them, only true vectors, char-tables, and compiled
1172 functions are sensible to compare, so eliminate the others now. */
1173 if (size
& PSEUDOVECTOR_FLAG
)
1175 if (!(size
& (PVEC_COMPILED
| PVEC_CHAR_TABLE
)))
1177 size
&= PSEUDOVECTOR_SIZE_MASK
;
1179 for (i
= 0; i
< size
; i
++)
1182 v1
= XVECTOR (o1
)->contents
[i
];
1183 v2
= XVECTOR (o2
)->contents
[i
];
1184 if (!internal_equal (v1
, v2
, depth
+ 1))
1192 if (XSTRING (o1
)->size
!= XSTRING (o2
)->size
)
1194 if (bcmp (XSTRING (o1
)->data
, XSTRING (o2
)->data
,
1195 XSTRING (o1
)->size
))
1202 extern Lisp_Object
Fmake_char_internal ();
1204 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
1205 "Store each element of ARRAY with ITEM.\n\
1206 ARRAY is a vector, string, char-table, or bool-vector.")
1208 Lisp_Object array
, item
;
1210 register int size
, index
, charval
;
1212 if (VECTORP (array
))
1214 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
1215 size
= XVECTOR (array
)->size
;
1216 for (index
= 0; index
< size
; index
++)
1219 else if (CHAR_TABLE_P (array
))
1221 register Lisp_Object
*p
= XCHAR_TABLE (array
)->contents
;
1222 size
= CHAR_TABLE_ORDINARY_SLOTS
;
1223 for (index
= 0; index
< size
; index
++)
1225 XCHAR_TABLE (array
)->defalt
= Qnil
;
1227 else if (STRINGP (array
))
1229 register unsigned char *p
= XSTRING (array
)->data
;
1230 CHECK_NUMBER (item
, 1);
1231 charval
= XINT (item
);
1232 size
= XSTRING (array
)->size
;
1233 for (index
= 0; index
< size
; index
++)
1236 else if (BOOL_VECTOR_P (array
))
1238 register unsigned char *p
= XBOOL_VECTOR (array
)->data
;
1240 = (XBOOL_VECTOR (array
)->size
+ BITS_PER_CHAR
- 1) / BITS_PER_CHAR
;
1242 charval
= (! NILP (item
) ? -1 : 0);
1243 for (index
= 0; index
< size_in_chars
; index
++)
1248 array
= wrong_type_argument (Qarrayp
, array
);
1254 DEFUN ("char-table-subtype", Fchar_table_subtype
, Schar_table_subtype
,
1256 "Return the subtype of char-table CHAR-TABLE. The value is a symbol.")
1258 Lisp_Object char_table
;
1260 CHECK_CHAR_TABLE (char_table
, 0);
1262 return XCHAR_TABLE (char_table
)->purpose
;
1265 DEFUN ("char-table-parent", Fchar_table_parent
, Schar_table_parent
,
1267 "Return the parent char-table of CHAR-TABLE.\n\
1268 The value is either nil or another char-table.\n\
1269 If CHAR-TABLE holds nil for a given character,\n\
1270 then the actual applicable value is inherited from the parent char-table\n\
1271 \(or from its parents, if necessary).")
1273 Lisp_Object char_table
;
1275 CHECK_CHAR_TABLE (char_table
, 0);
1277 return XCHAR_TABLE (char_table
)->parent
;
1280 DEFUN ("set-char-table-parent", Fset_char_table_parent
, Sset_char_table_parent
,
1282 "Set the parent char-table of CHAR-TABLE to PARENT.\n\
1283 PARENT must be either nil or another char-table.")
1284 (char_table
, parent
)
1285 Lisp_Object char_table
, parent
;
1289 CHECK_CHAR_TABLE (char_table
, 0);
1293 CHECK_CHAR_TABLE (parent
, 0);
1295 for (temp
= parent
; !NILP (temp
); temp
= XCHAR_TABLE (temp
)->parent
)
1296 if (EQ (temp
, char_table
))
1297 error ("Attempt to make a chartable be its own parent");
1300 XCHAR_TABLE (char_table
)->parent
= parent
;
1305 DEFUN ("char-table-extra-slot", Fchar_table_extra_slot
, Schar_table_extra_slot
,
1307 "Return the value of CHAR-TABLE's extra-slot number N.")
1309 Lisp_Object char_table
, n
;
1311 CHECK_CHAR_TABLE (char_table
, 1);
1312 CHECK_NUMBER (n
, 2);
1314 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
1315 args_out_of_range (char_table
, n
);
1317 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)];
1320 DEFUN ("set-char-table-extra-slot", Fset_char_table_extra_slot
,
1321 Sset_char_table_extra_slot
,
1323 "Set CHAR-TABLE's extra-slot number N to VALUE.")
1324 (char_table
, n
, value
)
1325 Lisp_Object char_table
, n
, value
;
1327 CHECK_CHAR_TABLE (char_table
, 1);
1328 CHECK_NUMBER (n
, 2);
1330 || XINT (n
) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table
)))
1331 args_out_of_range (char_table
, n
);
1333 return XCHAR_TABLE (char_table
)->extras
[XINT (n
)] = value
;
1336 DEFUN ("char-table-range", Fchar_table_range
, Schar_table_range
,
1338 "Return the value in CHAR-TABLE for a range of characters RANGE.\n\
1339 RANGE should be t (for all characters), nil (for the default value)\n\
1340 a vector which identifies a character set or a row of a character set,\n\
1341 or a character code.")
1343 Lisp_Object char_table
, range
;
1347 CHECK_CHAR_TABLE (char_table
, 0);
1349 if (EQ (range
, Qnil
))
1350 return XCHAR_TABLE (char_table
)->defalt
;
1351 else if (INTEGERP (range
))
1352 return Faref (char_table
, range
);
1353 else if (VECTORP (range
))
1355 if (XVECTOR (range
)->size
== 1)
1356 return Faref (char_table
, XVECTOR (range
)->contents
[0]);
1359 int size
= XVECTOR (range
)->size
;
1360 Lisp_Object
*val
= XVECTOR (range
)->contents
;
1361 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
1362 size
<= 1 ? Qnil
: val
[1],
1363 size
<= 2 ? Qnil
: val
[2]);
1364 return Faref (char_table
, ch
);
1368 error ("Invalid RANGE argument to `char-table-range'");
1371 DEFUN ("set-char-table-range", Fset_char_table_range
, Sset_char_table_range
,
1373 "Set the value in CHAR-TABLE for a range of characters RANGE to VALUE.\n\
1374 RANGE should be t (for all characters), nil (for the default value)\n\
1375 a vector which identifies a character set or a row of a character set,\n\
1376 or a character code.")
1377 (char_table
, range
, value
)
1378 Lisp_Object char_table
, range
, value
;
1382 CHECK_CHAR_TABLE (char_table
, 0);
1385 for (i
= 0; i
< CHAR_TABLE_ORDINARY_SLOTS
; i
++)
1386 XCHAR_TABLE (char_table
)->contents
[i
] = value
;
1387 else if (EQ (range
, Qnil
))
1388 XCHAR_TABLE (char_table
)->defalt
= value
;
1389 else if (INTEGERP (range
))
1390 Faset (char_table
, range
, value
);
1391 else if (VECTORP (range
))
1393 if (XVECTOR (range
)->size
== 1)
1394 return Faset (char_table
, XVECTOR (range
)->contents
[0], value
);
1397 int size
= XVECTOR (range
)->size
;
1398 Lisp_Object
*val
= XVECTOR (range
)->contents
;
1399 Lisp_Object ch
= Fmake_char_internal (size
<= 0 ? Qnil
: val
[0],
1400 size
<= 1 ? Qnil
: val
[1],
1401 size
<= 2 ? Qnil
: val
[2]);
1402 return Faset (char_table
, ch
, value
);
1406 error ("Invalid RANGE argument to `set-char-table-range'");
1411 DEFUN ("set-char-table-default", Fset_char_table_default
,
1412 Sset_char_table_default
, 3, 3, 0,
1413 "Set the default value in CHAR-TABLE for a generic character CHAR to VALUE.\n\
1414 The generic character specifies the group of characters.\n\
1415 See also the documentation of make-char.")
1416 (char_table
, ch
, value
)
1417 Lisp_Object char_table
, ch
, value
;
1419 int c
, i
, charset
, code1
, code2
;
1422 CHECK_CHAR_TABLE (char_table
, 0);
1423 CHECK_NUMBER (ch
, 1);
1426 SPLIT_NON_ASCII_CHAR (c
, charset
, code1
, code2
);
1427 if (! CHARSET_DEFINED_P (charset
))
1428 error ("Invalid character: %d", c
);
1430 if (charset
== CHARSET_ASCII
)
1431 return (XCHAR_TABLE (char_table
)->defalt
= value
);
1433 /* Even if C is not a generic char, we had better behave as if a
1434 generic char is specified. */
1435 if (CHARSET_DIMENSION (charset
) == 1)
1437 temp
= XCHAR_TABLE (char_table
)->contents
[charset
+ 128];
1440 if (SUB_CHAR_TABLE_P (temp
))
1441 XCHAR_TABLE (temp
)->defalt
= value
;
1443 XCHAR_TABLE (char_table
)->contents
[charset
+ 128] = value
;
1447 if (! SUB_CHAR_TABLE_P (char_table
))
1448 char_table
= (XCHAR_TABLE (char_table
)->contents
[charset
+ 128]
1449 = make_sub_char_table (temp
));
1450 temp
= XCHAR_TABLE (char_table
)->contents
[code1
];
1451 if (SUB_CHAR_TABLE_P (temp
))
1452 XCHAR_TABLE (temp
)->defalt
= value
;
1454 XCHAR_TABLE (char_table
)->contents
[code1
] = value
;
1459 /* Map C_FUNCTION or FUNCTION over SUBTABLE, calling it for each
1460 character or group of characters that share a value.
1461 DEPTH is the current depth in the originally specified
1462 chartable, and INDICES contains the vector indices
1463 for the levels our callers have descended.
1465 ARG is passed to C_FUNCTION when that is called. */
1468 map_char_table (c_function
, function
, subtable
, arg
, depth
, indices
)
1469 void (*c_function
) P_ ((Lisp_Object
, Lisp_Object
, Lisp_Object
));
1470 Lisp_Object function
, subtable
, arg
, *indices
;
1477 /* At first, handle ASCII and 8-bit European characters. */
1478 for (i
= 0; i
< CHAR_TABLE_SINGLE_BYTE_SLOTS
; i
++)
1480 Lisp_Object elt
= XCHAR_TABLE (subtable
)->contents
[i
];
1482 (*c_function
) (arg
, make_number (i
), elt
);
1484 call2 (function
, make_number (i
), elt
);
1486 if (NILP (current_buffer
->enable_multibyte_characters
))
1488 to
= CHAR_TABLE_ORDINARY_SLOTS
;
1493 to
= SUB_CHAR_TABLE_ORDINARY_SLOTS
;
1498 Lisp_Object elt
= XCHAR_TABLE (subtable
)->contents
[i
];
1500 XSETFASTINT (indices
[depth
], i
);
1502 if (SUB_CHAR_TABLE_P (elt
))
1505 error ("Too deep char table");
1506 map_char_table (c_function
, function
, elt
, arg
, depth
+ 1, indices
);
1510 int charset
= XFASTINT (indices
[0]) - 128, c1
, c2
, c
;
1512 if (CHARSET_DEFINED_P (charset
))
1514 c1
= depth
>= 1 ? XFASTINT (indices
[1]) : 0;
1515 c2
= depth
>= 2 ? XFASTINT (indices
[2]) : 0;
1516 c
= MAKE_NON_ASCII_CHAR (charset
, c1
, c2
);
1518 (*c_function
) (arg
, make_number (c
), elt
);
1520 call2 (function
, make_number (c
), elt
);
1526 DEFUN ("map-char-table", Fmap_char_table
, Smap_char_table
,
1528 "Call FUNCTION for each (normal and generic) characters in CHAR-TABLE.\n\
1529 FUNCTION is called with two arguments--a key and a value.\n\
1530 The key is always a possible IDX argument to `aref'.")
1531 (function
, char_table
)
1532 Lisp_Object function
, char_table
;
1534 /* The depth of char table is at most 3. */
1535 Lisp_Object indices
[3];
1537 CHECK_CHAR_TABLE (char_table
, 1);
1539 map_char_table (NULL
, function
, char_table
, char_table
, 0, indices
);
1549 Lisp_Object args
[2];
1552 return Fnconc (2, args
);
1554 return Fnconc (2, &s1
);
1555 #endif /* NO_ARG_ARRAY */
1558 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
1559 "Concatenate any number of lists by altering them.\n\
1560 Only the last argument is not altered, and need not be a list.")
1565 register int argnum
;
1566 register Lisp_Object tail
, tem
, val
;
1570 for (argnum
= 0; argnum
< nargs
; argnum
++)
1573 if (NILP (tem
)) continue;
1578 if (argnum
+ 1 == nargs
) break;
1581 tem
= wrong_type_argument (Qlistp
, tem
);
1590 tem
= args
[argnum
+ 1];
1591 Fsetcdr (tail
, tem
);
1593 args
[argnum
+ 1] = tail
;
1599 /* This is the guts of all mapping functions.
1600 Apply fn to each element of seq, one by one,
1601 storing the results into elements of vals, a C vector of Lisp_Objects.
1602 leni is the length of vals, which should also be the length of seq. */
1605 mapcar1 (leni
, vals
, fn
, seq
)
1608 Lisp_Object fn
, seq
;
1610 register Lisp_Object tail
;
1613 struct gcpro gcpro1
, gcpro2
, gcpro3
;
1615 /* Don't let vals contain any garbage when GC happens. */
1616 for (i
= 0; i
< leni
; i
++)
1619 GCPRO3 (dummy
, fn
, seq
);
1621 gcpro1
.nvars
= leni
;
1622 /* We need not explicitly protect `tail' because it is used only on lists, and
1623 1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
1627 for (i
= 0; i
< leni
; i
++)
1629 dummy
= XVECTOR (seq
)->contents
[i
];
1630 vals
[i
] = call1 (fn
, dummy
);
1633 else if (STRINGP (seq
))
1635 for (i
= 0; i
< leni
; i
++)
1637 XSETFASTINT (dummy
, XSTRING (seq
)->data
[i
]);
1638 vals
[i
] = call1 (fn
, dummy
);
1641 else /* Must be a list, since Flength did not get an error */
1644 for (i
= 0; i
< leni
; i
++)
1646 vals
[i
] = call1 (fn
, Fcar (tail
));
1647 tail
= XCONS (tail
)->cdr
;
1654 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
1655 "Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.\n\
1656 In between each pair of results, stick in SEPARATOR. Thus, \" \" as\n\
1657 SEPARATOR results in spaces between the values returned by FUNCTION.")
1658 (function
, sequence
, separator
)
1659 Lisp_Object function
, sequence
, separator
;
1664 register Lisp_Object
*args
;
1666 struct gcpro gcpro1
;
1668 len
= Flength (sequence
);
1670 nargs
= leni
+ leni
- 1;
1671 if (nargs
< 0) return build_string ("");
1673 args
= (Lisp_Object
*) alloca (nargs
* sizeof (Lisp_Object
));
1676 mapcar1 (leni
, args
, function
, sequence
);
1679 for (i
= leni
- 1; i
>= 0; i
--)
1680 args
[i
+ i
] = args
[i
];
1682 for (i
= 1; i
< nargs
; i
+= 2)
1683 args
[i
] = separator
;
1685 return Fconcat (nargs
, args
);
1688 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
1689 "Apply FUNCTION to each element of SEQUENCE, and make a list of the results.\n\
1690 The result is a list just as long as SEQUENCE.\n\
1691 SEQUENCE may be a list, a vector or a string.")
1692 (function
, sequence
)
1693 Lisp_Object function
, sequence
;
1695 register Lisp_Object len
;
1697 register Lisp_Object
*args
;
1699 len
= Flength (sequence
);
1700 leni
= XFASTINT (len
);
1701 args
= (Lisp_Object
*) alloca (leni
* sizeof (Lisp_Object
));
1703 mapcar1 (leni
, args
, function
, sequence
);
1705 return Flist (leni
, args
);
1708 /* Anything that calls this function must protect from GC! */
1710 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
1711 "Ask user a \"y or n\" question. Return t if answer is \"y\".\n\
1712 Takes one argument, which is the string to display to ask the question.\n\
1713 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.\n\
1714 No confirmation of the answer is requested; a single character is enough.\n\
1715 Also accepts Space to mean yes, or Delete to mean no.")
1719 register Lisp_Object obj
, key
, def
, answer_string
, map
;
1720 register int answer
;
1721 Lisp_Object xprompt
;
1722 Lisp_Object args
[2];
1723 struct gcpro gcpro1
, gcpro2
;
1724 int count
= specpdl_ptr
- specpdl
;
1726 specbind (Qcursor_in_echo_area
, Qt
);
1728 map
= Fsymbol_value (intern ("query-replace-map"));
1730 CHECK_STRING (prompt
, 0);
1732 GCPRO2 (prompt
, xprompt
);
1738 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
1742 Lisp_Object pane
, menu
;
1743 redisplay_preserve_echo_area ();
1744 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
1745 Fcons (Fcons (build_string ("No"), Qnil
),
1747 menu
= Fcons (prompt
, pane
);
1748 obj
= Fx_popup_dialog (Qt
, menu
);
1749 answer
= !NILP (obj
);
1752 #endif /* HAVE_MENUS */
1753 cursor_in_echo_area
= 1;
1754 choose_minibuf_frame ();
1755 message_nolog ("%s(y or n) ", XSTRING (xprompt
)->data
);
1757 if (minibuffer_auto_raise
)
1759 Lisp_Object mini_frame
;
1761 mini_frame
= WINDOW_FRAME (XWINDOW (minibuf_window
));
1763 Fraise_frame (mini_frame
);
1766 obj
= read_filtered_event (1, 0, 0);
1767 cursor_in_echo_area
= 0;
1768 /* If we need to quit, quit with cursor_in_echo_area = 0. */
1771 key
= Fmake_vector (make_number (1), obj
);
1772 def
= Flookup_key (map
, key
, Qt
);
1773 answer_string
= Fsingle_key_description (obj
);
1775 if (EQ (def
, intern ("skip")))
1780 else if (EQ (def
, intern ("act")))
1785 else if (EQ (def
, intern ("recenter")))
1791 else if (EQ (def
, intern ("quit")))
1793 /* We want to exit this command for exit-prefix,
1794 and this is the only way to do it. */
1795 else if (EQ (def
, intern ("exit-prefix")))
1800 /* If we don't clear this, then the next call to read_char will
1801 return quit_char again, and we'll enter an infinite loop. */
1806 if (EQ (xprompt
, prompt
))
1808 args
[0] = build_string ("Please answer y or n. ");
1810 xprompt
= Fconcat (2, args
);
1815 if (! noninteractive
)
1817 cursor_in_echo_area
= -1;
1818 message_nolog ("%s(y or n) %c",
1819 XSTRING (xprompt
)->data
, answer
? 'y' : 'n');
1822 unbind_to (count
, Qnil
);
1823 return answer
? Qt
: Qnil
;
1826 /* This is how C code calls `yes-or-no-p' and allows the user
1829 Anything that calls this function must protect from GC! */
1832 do_yes_or_no_p (prompt
)
1835 return call1 (intern ("yes-or-no-p"), prompt
);
1838 /* Anything that calls this function must protect from GC! */
1840 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
1841 "Ask user a yes-or-no question. Return t if answer is yes.\n\
1842 Takes one argument, which is the string to display to ask the question.\n\
1843 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.\n\
1844 The user must confirm the answer with RET,\n\
1845 and can edit it until it has been confirmed.")
1849 register Lisp_Object ans
;
1850 Lisp_Object args
[2];
1851 struct gcpro gcpro1
;
1854 CHECK_STRING (prompt
, 0);
1857 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
1861 Lisp_Object pane
, menu
, obj
;
1862 redisplay_preserve_echo_area ();
1863 pane
= Fcons (Fcons (build_string ("Yes"), Qt
),
1864 Fcons (Fcons (build_string ("No"), Qnil
),
1867 menu
= Fcons (prompt
, pane
);
1868 obj
= Fx_popup_dialog (Qt
, menu
);
1872 #endif /* HAVE_MENUS */
1875 args
[1] = build_string ("(yes or no) ");
1876 prompt
= Fconcat (2, args
);
1882 ans
= Fdowncase (Fread_from_minibuffer (prompt
, Qnil
, Qnil
, Qnil
,
1883 Qyes_or_no_p_history
, Qnil
,
1885 if (XSTRING (ans
)->size
== 3 && !strcmp (XSTRING (ans
)->data
, "yes"))
1890 if (XSTRING (ans
)->size
== 2 && !strcmp (XSTRING (ans
)->data
, "no"))
1898 message ("Please answer yes or no.");
1899 Fsleep_for (make_number (2), Qnil
);
1903 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 0, 0,
1904 "Return list of 1 minute, 5 minute and 15 minute load averages.\n\
1905 Each of the three load averages is multiplied by 100,\n\
1906 then converted to integer.\n\
1907 If the 5-minute or 15-minute load averages are not available, return a\n\
1908 shortened list, containing only those averages which are available.")
1912 int loads
= getloadavg (load_ave
, 3);
1916 error ("load-average not implemented for this operating system");
1920 ret
= Fcons (make_number ((int) (load_ave
[--loads
] * 100.0)), ret
);
1925 Lisp_Object Vfeatures
;
1927 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 1, 0,
1928 "Returns t if FEATURE is present in this Emacs.\n\
1929 Use this to conditionalize execution of lisp code based on the presence or\n\
1930 absence of emacs or environment extensions.\n\
1931 Use `provide' to declare that a feature is available.\n\
1932 This function looks at the value of the variable `features'.")
1934 Lisp_Object feature
;
1936 register Lisp_Object tem
;
1937 CHECK_SYMBOL (feature
, 0);
1938 tem
= Fmemq (feature
, Vfeatures
);
1939 return (NILP (tem
)) ? Qnil
: Qt
;
1942 DEFUN ("provide", Fprovide
, Sprovide
, 1, 1, 0,
1943 "Announce that FEATURE is a feature of the current Emacs.")
1945 Lisp_Object feature
;
1947 register Lisp_Object tem
;
1948 CHECK_SYMBOL (feature
, 0);
1949 if (!NILP (Vautoload_queue
))
1950 Vautoload_queue
= Fcons (Fcons (Vfeatures
, Qnil
), Vautoload_queue
);
1951 tem
= Fmemq (feature
, Vfeatures
);
1953 Vfeatures
= Fcons (feature
, Vfeatures
);
1954 LOADHIST_ATTACH (Fcons (Qprovide
, feature
));
1958 DEFUN ("require", Frequire
, Srequire
, 1, 2, 0,
1959 "If feature FEATURE is not loaded, load it from FILENAME.\n\
1960 If FEATURE is not a member of the list `features', then the feature\n\
1961 is not loaded; so load the file FILENAME.\n\
1962 If FILENAME is omitted, the printname of FEATURE is used as the file name.")
1963 (feature
, file_name
)
1964 Lisp_Object feature
, file_name
;
1966 register Lisp_Object tem
;
1967 CHECK_SYMBOL (feature
, 0);
1968 tem
= Fmemq (feature
, Vfeatures
);
1969 LOADHIST_ATTACH (Fcons (Qrequire
, feature
));
1972 int count
= specpdl_ptr
- specpdl
;
1974 /* Value saved here is to be restored into Vautoload_queue */
1975 record_unwind_protect (un_autoload
, Vautoload_queue
);
1976 Vautoload_queue
= Qt
;
1978 Fload (NILP (file_name
) ? Fsymbol_name (feature
) : file_name
,
1979 Qnil
, Qt
, Qnil
, (NILP (file_name
) ? Qt
: Qnil
));
1981 tem
= Fmemq (feature
, Vfeatures
);
1983 error ("Required feature %s was not provided",
1984 XSYMBOL (feature
)->name
->data
);
1986 /* Once loading finishes, don't undo it. */
1987 Vautoload_queue
= Qt
;
1988 feature
= unbind_to (count
, feature
);
1993 /* Primitives for work of the "widget" library.
1994 In an ideal world, this section would not have been necessary.
1995 However, lisp function calls being as slow as they are, it turns
1996 out that some functions in the widget library (wid-edit.el) are the
1997 bottleneck of Widget operation. Here is their translation to C,
1998 for the sole reason of efficiency. */
2000 DEFUN ("widget-plist-member", Fwidget_plist_member
, Swidget_plist_member
, 2, 2, 0,
2001 "Return non-nil if PLIST has the property PROP.\n\
2002 PLIST is a property list, which is a list of the form\n\
2003 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.\n\
2004 Unlike `plist-get', this allows you to distinguish between a missing\n\
2005 property and a property with the value nil.\n\
2006 The value is actually the tail of PLIST whose car is PROP.")
2008 Lisp_Object plist
, prop
;
2010 while (CONSP (plist
) && !EQ (XCAR (plist
), prop
))
2013 plist
= XCDR (plist
);
2014 plist
= CDR (plist
);
2019 DEFUN ("widget-put", Fwidget_put
, Swidget_put
, 3, 3, 0,
2020 "In WIDGET, set PROPERTY to VALUE.\n\
2021 The value can later be retrieved with `widget-get'.")
2022 (widget
, property
, value
)
2023 Lisp_Object widget
, property
, value
;
2025 CHECK_CONS (widget
, 1);
2026 XCDR (widget
) = Fplist_put (XCDR (widget
), property
, value
);
2029 DEFUN ("widget-get", Fwidget_get
, Swidget_get
, 2, 2, 0,
2030 "In WIDGET, get the value of PROPERTY.\n\
2031 The value could either be specified when the widget was created, or\n\
2032 later with `widget-put'.")
2034 Lisp_Object widget
, property
;
2042 CHECK_CONS (widget
, 1);
2043 tmp
= Fwidget_plist_member (XCDR (widget
), property
);
2049 tmp
= XCAR (widget
);
2052 widget
= Fget (tmp
, Qwidget_type
);
2056 DEFUN ("widget-apply", Fwidget_apply
, Swidget_apply
, 2, MANY
, 0,
2057 "Apply the value of WIDGET's PROPERTY to the widget itself.\n\
2058 ARGS are passed as extra arguments to the function.")
2063 /* This function can GC. */
2064 Lisp_Object newargs
[3];
2065 struct gcpro gcpro1
, gcpro2
;
2068 newargs
[0] = Fwidget_get (args
[0], args
[1]);
2069 newargs
[1] = args
[0];
2070 newargs
[2] = Flist (nargs
- 2, args
+ 2);
2071 GCPRO2 (newargs
[0], newargs
[2]);
2072 result
= Fapply (3, newargs
);
2079 Qstring_lessp
= intern ("string-lessp");
2080 staticpro (&Qstring_lessp
);
2081 Qprovide
= intern ("provide");
2082 staticpro (&Qprovide
);
2083 Qrequire
= intern ("require");
2084 staticpro (&Qrequire
);
2085 Qyes_or_no_p_history
= intern ("yes-or-no-p-history");
2086 staticpro (&Qyes_or_no_p_history
);
2087 Qcursor_in_echo_area
= intern ("cursor-in-echo-area");
2088 staticpro (&Qcursor_in_echo_area
);
2089 Qwidget_type
= intern ("widget-type");
2090 staticpro (&Qwidget_type
);
2092 Fset (Qyes_or_no_p_history
, Qnil
);
2094 DEFVAR_LISP ("features", &Vfeatures
,
2095 "A list of symbols which are the features of the executing emacs.\n\
2096 Used by `featurep' and `require', and altered by `provide'.");
2099 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box
,
2100 "*Non-nil means mouse commands use dialog boxes to ask questions.\n\
2101 This applies to y-or-n and yes-or-no questions asked by commands\n\
2102 invoked by mouse clicks and mouse menu items.");
2105 defsubr (&Sidentity
);
2108 defsubr (&Ssafe_length
);
2109 defsubr (&Sstring_equal
);
2110 defsubr (&Sstring_lessp
);
2113 defsubr (&Svconcat
);
2114 defsubr (&Scopy_sequence
);
2115 defsubr (&Scopy_alist
);
2116 defsubr (&Ssubstring
);
2128 defsubr (&Snreverse
);
2129 defsubr (&Sreverse
);
2131 defsubr (&Splist_get
);
2133 defsubr (&Splist_put
);
2136 defsubr (&Sfillarray
);
2137 defsubr (&Schar_table_subtype
);
2138 defsubr (&Schar_table_parent
);
2139 defsubr (&Sset_char_table_parent
);
2140 defsubr (&Schar_table_extra_slot
);
2141 defsubr (&Sset_char_table_extra_slot
);
2142 defsubr (&Schar_table_range
);
2143 defsubr (&Sset_char_table_range
);
2144 defsubr (&Sset_char_table_default
);
2145 defsubr (&Smap_char_table
);
2148 defsubr (&Smapconcat
);
2149 defsubr (&Sy_or_n_p
);
2150 defsubr (&Syes_or_no_p
);
2151 defsubr (&Sload_average
);
2152 defsubr (&Sfeaturep
);
2153 defsubr (&Srequire
);
2154 defsubr (&Sprovide
);
2155 defsubr (&Swidget_plist_member
);
2156 defsubr (&Swidget_put
);
2157 defsubr (&Swidget_get
);
2158 defsubr (&Swidget_apply
);