(current_lock_owner): Don't try to delete lock
[bpt/emacs.git] / src / fns.c
1 /* Random utility Lisp functions.
2 Copyright (C) 1985, 86, 87, 93, 94, 95 Free Software Foundation, Inc.
3
4 This file is part of GNU Emacs.
5
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)
9 any later version.
10
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.
15
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. */
20
21
22 #include <config.h>
23
24 /* Note on some machines this defines `vector' as a typedef,
25 so make sure we don't use that name in this file. */
26 #undef vector
27 #define vector *****
28
29 #include "lisp.h"
30 #include "commands.h"
31 #include "charset.h"
32
33 #include "buffer.h"
34 #include "keyboard.h"
35 #include "intervals.h"
36 #include "frame.h"
37 #include "window.h"
38
39 #ifndef NULL
40 #define NULL (void *)0
41 #endif
42
43 /* Nonzero enables use of dialog boxes for questions
44 asked by mouse commands. */
45 int use_dialog_box;
46
47 extern Lisp_Object Flookup_key ();
48
49 extern int minibuffer_auto_raise;
50 extern Lisp_Object minibuf_window;
51
52 Lisp_Object Qstring_lessp, Qprovide, Qrequire;
53 Lisp_Object Qyes_or_no_p_history;
54 Lisp_Object Qcursor_in_echo_area;
55
56 static int internal_equal ();
57 \f
58 DEFUN ("identity", Fidentity, Sidentity, 1, 1, 0,
59 "Return the argument unchanged.")
60 (arg)
61 Lisp_Object arg;
62 {
63 return arg;
64 }
65
66 extern long get_random ();
67 extern void seed_random ();
68 extern long time ();
69
70 DEFUN ("random", Frandom, Srandom, 0, 1, 0,
71 "Return a pseudo-random number.\n\
72 All integers representable in Lisp are equally likely.\n\
73 On most systems, this is 28 bits' worth.\n\
74 With positive integer argument N, return random number in interval [0,N).\n\
75 With argument t, set the random number seed from the current time and pid.")
76 (n)
77 Lisp_Object n;
78 {
79 EMACS_INT val;
80 Lisp_Object lispy_val;
81 unsigned long denominator;
82
83 if (EQ (n, Qt))
84 seed_random (getpid () + time (NULL));
85 if (NATNUMP (n) && XFASTINT (n) != 0)
86 {
87 /* Try to take our random number from the higher bits of VAL,
88 not the lower, since (says Gentzel) the low bits of `random'
89 are less random than the higher ones. We do this by using the
90 quotient rather than the remainder. At the high end of the RNG
91 it's possible to get a quotient larger than n; discarding
92 these values eliminates the bias that would otherwise appear
93 when using a large n. */
94 denominator = ((unsigned long)1 << VALBITS) / XFASTINT (n);
95 do
96 val = get_random () / denominator;
97 while (val >= XFASTINT (n));
98 }
99 else
100 val = get_random ();
101 XSETINT (lispy_val, val);
102 return lispy_val;
103 }
104 \f
105 /* Random data-structure functions */
106
107 DEFUN ("length", Flength, Slength, 1, 1, 0,
108 "Return the length of vector, list or string SEQUENCE.\n\
109 A byte-code function object is also allowed.")
110 (sequence)
111 register Lisp_Object sequence;
112 {
113 register Lisp_Object tail, val;
114 register int i;
115
116 retry:
117 if (STRINGP (sequence))
118 XSETFASTINT (val, XSTRING (sequence)->size);
119 else if (VECTORP (sequence))
120 XSETFASTINT (val, XVECTOR (sequence)->size);
121 else if (CHAR_TABLE_P (sequence))
122 XSETFASTINT (val, CHAR_TABLE_ORDINARY_SLOTS);
123 else if (BOOL_VECTOR_P (sequence))
124 XSETFASTINT (val, XBOOL_VECTOR (sequence)->size);
125 else if (COMPILEDP (sequence))
126 XSETFASTINT (val, XVECTOR (sequence)->size & PSEUDOVECTOR_SIZE_MASK);
127 else if (CONSP (sequence))
128 {
129 for (i = 0, tail = sequence; !NILP (tail); i++)
130 {
131 QUIT;
132 tail = Fcdr (tail);
133 }
134
135 XSETFASTINT (val, i);
136 }
137 else if (NILP (sequence))
138 XSETFASTINT (val, 0);
139 else
140 {
141 sequence = wrong_type_argument (Qsequencep, sequence);
142 goto retry;
143 }
144 return val;
145 }
146
147 /* This does not check for quits. That is safe
148 since it must terminate. */
149
150 DEFUN ("safe-length", Fsafe_length, Ssafe_length, 1, 1, 0,
151 "Return the length of a list, but avoid error or infinite loop.\n\
152 This function never gets an error. If LIST is not really a list,\n\
153 it returns 0. If LIST is circular, it returns a finite value\n\
154 which is at least the number of distinct elements.")
155 (list)
156 Lisp_Object list;
157 {
158 Lisp_Object tail, halftail, length;
159 int len = 0;
160
161 /* halftail is used to detect circular lists. */
162 halftail = list;
163 for (tail = list; CONSP (tail); tail = XCONS (tail)->cdr)
164 {
165 if (EQ (tail, halftail) && len != 0)
166 break;
167 len++;
168 if ((len & 1) == 0)
169 halftail = XCONS (halftail)->cdr;
170 }
171
172 XSETINT (length, len);
173 return length;
174 }
175
176 DEFUN ("string-equal", Fstring_equal, Sstring_equal, 2, 2, 0,
177 "T if two strings have identical contents.\n\
178 Case is significant, but text properties are ignored.\n\
179 Symbols are also allowed; their print names are used instead.")
180 (s1, s2)
181 register Lisp_Object s1, s2;
182 {
183 if (SYMBOLP (s1))
184 XSETSTRING (s1, XSYMBOL (s1)->name);
185 if (SYMBOLP (s2))
186 XSETSTRING (s2, XSYMBOL (s2)->name);
187 CHECK_STRING (s1, 0);
188 CHECK_STRING (s2, 1);
189
190 if (XSTRING (s1)->size != XSTRING (s2)->size ||
191 bcmp (XSTRING (s1)->data, XSTRING (s2)->data, XSTRING (s1)->size))
192 return Qnil;
193 return Qt;
194 }
195
196 DEFUN ("string-lessp", Fstring_lessp, Sstring_lessp, 2, 2, 0,
197 "T if first arg string is less than second in lexicographic order.\n\
198 Case is significant.\n\
199 Symbols are also allowed; their print names are used instead.")
200 (s1, s2)
201 register Lisp_Object s1, s2;
202 {
203 register int i;
204 register unsigned char *p1, *p2;
205 register int end;
206
207 if (SYMBOLP (s1))
208 XSETSTRING (s1, XSYMBOL (s1)->name);
209 if (SYMBOLP (s2))
210 XSETSTRING (s2, XSYMBOL (s2)->name);
211 CHECK_STRING (s1, 0);
212 CHECK_STRING (s2, 1);
213
214 p1 = XSTRING (s1)->data;
215 p2 = XSTRING (s2)->data;
216 end = XSTRING (s1)->size;
217 if (end > XSTRING (s2)->size)
218 end = XSTRING (s2)->size;
219
220 for (i = 0; i < end; i++)
221 {
222 if (p1[i] != p2[i])
223 return p1[i] < p2[i] ? Qt : Qnil;
224 }
225 return i < XSTRING (s2)->size ? Qt : Qnil;
226 }
227 \f
228 static Lisp_Object concat ();
229
230 /* ARGSUSED */
231 Lisp_Object
232 concat2 (s1, s2)
233 Lisp_Object s1, s2;
234 {
235 #ifdef NO_ARG_ARRAY
236 Lisp_Object args[2];
237 args[0] = s1;
238 args[1] = s2;
239 return concat (2, args, Lisp_String, 0);
240 #else
241 return concat (2, &s1, Lisp_String, 0);
242 #endif /* NO_ARG_ARRAY */
243 }
244
245 /* ARGSUSED */
246 Lisp_Object
247 concat3 (s1, s2, s3)
248 Lisp_Object s1, s2, s3;
249 {
250 #ifdef NO_ARG_ARRAY
251 Lisp_Object args[3];
252 args[0] = s1;
253 args[1] = s2;
254 args[2] = s3;
255 return concat (3, args, Lisp_String, 0);
256 #else
257 return concat (3, &s1, Lisp_String, 0);
258 #endif /* NO_ARG_ARRAY */
259 }
260
261 DEFUN ("append", Fappend, Sappend, 0, MANY, 0,
262 "Concatenate all the arguments and make the result a list.\n\
263 The result is a list whose elements are the elements of all the arguments.\n\
264 Each argument may be a list, vector or string.\n\
265 The last argument is not copied, just used as the tail of the new list.")
266 (nargs, args)
267 int nargs;
268 Lisp_Object *args;
269 {
270 return concat (nargs, args, Lisp_Cons, 1);
271 }
272
273 DEFUN ("concat", Fconcat, Sconcat, 0, MANY, 0,
274 "Concatenate all the arguments and make the result a string.\n\
275 The result is a string whose elements are the elements of all the arguments.\n\
276 Each argument may be a string or a list or vector of characters (integers).\n\
277 \n\
278 Do not use individual integers as arguments!\n\
279 The behavior of `concat' in that case will be changed later!\n\
280 If your program passes an integer as an argument to `concat',\n\
281 you should change it right away not to do so.")
282 (nargs, args)
283 int nargs;
284 Lisp_Object *args;
285 {
286 return concat (nargs, args, Lisp_String, 0);
287 }
288
289 DEFUN ("vconcat", Fvconcat, Svconcat, 0, MANY, 0,
290 "Concatenate all the arguments and make the result a vector.\n\
291 The result is a vector whose elements are the elements of all the arguments.\n\
292 Each argument may be a list, vector or string.")
293 (nargs, args)
294 int nargs;
295 Lisp_Object *args;
296 {
297 return concat (nargs, args, Lisp_Vectorlike, 0);
298 }
299
300 /* Retrun a copy of a sub char table ARG. The elements except for a
301 nested sub char table are not copied. */
302 static Lisp_Object
303 copy_sub_char_table (arg)
304 Lisp_Object arg;
305 {
306 Lisp_Object copy = make_sub_char_table (XCHAR_TABLE (arg)->defalt);
307 int i;
308
309 /* Copy all the contents. */
310 bcopy (XCHAR_TABLE (arg)->contents, XCHAR_TABLE (copy)->contents,
311 SUB_CHAR_TABLE_ORDINARY_SLOTS * sizeof (Lisp_Object));
312 /* Recursively copy any sub char-tables in the ordinary slots. */
313 for (i = 32; i < SUB_CHAR_TABLE_ORDINARY_SLOTS; i++)
314 if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg)->contents[i]))
315 XCHAR_TABLE (copy)->contents[i]
316 = copy_sub_char_table (XCHAR_TABLE (copy)->contents[i]);
317
318 return copy;
319 }
320
321
322 DEFUN ("copy-sequence", Fcopy_sequence, Scopy_sequence, 1, 1, 0,
323 "Return a copy of a list, vector or string.\n\
324 The elements of a list or vector are not copied; they are shared\n\
325 with the original.")
326 (arg)
327 Lisp_Object arg;
328 {
329 if (NILP (arg)) return arg;
330
331 if (CHAR_TABLE_P (arg))
332 {
333 int i;
334 Lisp_Object copy;
335
336 copy = Fmake_char_table (XCHAR_TABLE (arg)->purpose, Qnil);
337 /* Copy all the slots, including the extra ones. */
338 bcopy (XVECTOR (arg)->contents, XVECTOR (copy)->contents,
339 ((XCHAR_TABLE (arg)->size & PSEUDOVECTOR_SIZE_MASK)
340 * sizeof (Lisp_Object)));
341
342 /* Recursively copy any sub char tables in the ordinary slots
343 for multibyte characters. */
344 for (i = CHAR_TABLE_SINGLE_BYTE_SLOTS;
345 i < CHAR_TABLE_ORDINARY_SLOTS; i++)
346 if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg)->contents[i]))
347 XCHAR_TABLE (copy)->contents[i]
348 = copy_sub_char_table (XCHAR_TABLE (copy)->contents[i]);
349
350 return copy;
351 }
352
353 if (BOOL_VECTOR_P (arg))
354 {
355 Lisp_Object val;
356 int size_in_chars
357 = (XBOOL_VECTOR (arg)->size + BITS_PER_CHAR - 1) / BITS_PER_CHAR;
358
359 val = Fmake_bool_vector (Flength (arg), Qnil);
360 bcopy (XBOOL_VECTOR (arg)->data, XBOOL_VECTOR (val)->data,
361 size_in_chars);
362 return val;
363 }
364
365 if (!CONSP (arg) && !VECTORP (arg) && !STRINGP (arg))
366 arg = wrong_type_argument (Qsequencep, arg);
367 return concat (1, &arg, CONSP (arg) ? Lisp_Cons : XTYPE (arg), 0);
368 }
369
370 static Lisp_Object
371 concat (nargs, args, target_type, last_special)
372 int nargs;
373 Lisp_Object *args;
374 enum Lisp_Type target_type;
375 int last_special;
376 {
377 Lisp_Object val;
378 Lisp_Object len;
379 register Lisp_Object tail;
380 register Lisp_Object this;
381 int toindex;
382 register int leni;
383 register int argnum;
384 Lisp_Object last_tail;
385 Lisp_Object prev;
386
387 /* In append, the last arg isn't treated like the others */
388 if (last_special && nargs > 0)
389 {
390 nargs--;
391 last_tail = args[nargs];
392 }
393 else
394 last_tail = Qnil;
395
396 for (argnum = 0; argnum < nargs; argnum++)
397 {
398 this = args[argnum];
399 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
400 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
401 {
402 if (INTEGERP (this))
403 args[argnum] = Fnumber_to_string (this);
404 else
405 args[argnum] = wrong_type_argument (Qsequencep, this);
406 }
407 }
408
409 for (argnum = 0, leni = 0; argnum < nargs; argnum++)
410 {
411 this = args[argnum];
412 len = Flength (this);
413 if (VECTORP (this) && target_type == Lisp_String)
414 {
415 /* We must pay attention to a multibyte character which
416 takes more than one byte in string. */
417 int i;
418 Lisp_Object ch;
419
420 for (i = 0; i < XFASTINT (len); i++)
421 {
422 ch = XVECTOR (this)->contents[i];
423 if (! INTEGERP (ch))
424 wrong_type_argument (Qintegerp, ch);
425 leni += Fchar_bytes (ch);
426 }
427 }
428 else
429 leni += XFASTINT (len);
430 }
431
432 XSETFASTINT (len, leni);
433
434 if (target_type == Lisp_Cons)
435 val = Fmake_list (len, Qnil);
436 else if (target_type == Lisp_Vectorlike)
437 val = Fmake_vector (len, Qnil);
438 else
439 val = Fmake_string (len, len);
440
441 /* In append, if all but last arg are nil, return last arg */
442 if (target_type == Lisp_Cons && EQ (val, Qnil))
443 return last_tail;
444
445 if (CONSP (val))
446 tail = val, toindex = -1; /* -1 in toindex is flag we are making a list */
447 else
448 toindex = 0;
449
450 prev = Qnil;
451
452 for (argnum = 0; argnum < nargs; argnum++)
453 {
454 Lisp_Object thislen;
455 int thisleni;
456 register unsigned int thisindex = 0;
457
458 this = args[argnum];
459 if (!CONSP (this))
460 thislen = Flength (this), thisleni = XINT (thislen);
461
462 if (STRINGP (this) && STRINGP (val)
463 && ! NULL_INTERVAL_P (XSTRING (this)->intervals))
464 {
465 copy_text_properties (make_number (0), thislen, this,
466 make_number (toindex), val, Qnil);
467 }
468
469 while (1)
470 {
471 register Lisp_Object elt;
472
473 /* Fetch next element of `this' arg into `elt', or break if
474 `this' is exhausted. */
475 if (NILP (this)) break;
476 if (CONSP (this))
477 elt = XCONS (this)->car, this = XCONS (this)->cdr;
478 else
479 {
480 if (thisindex >= thisleni) break;
481 if (STRINGP (this))
482 XSETFASTINT (elt, XSTRING (this)->data[thisindex++]);
483 else if (BOOL_VECTOR_P (this))
484 {
485 int size_in_chars
486 = ((XBOOL_VECTOR (this)->size + BITS_PER_CHAR - 1)
487 / BITS_PER_CHAR);
488 int byte;
489 byte = XBOOL_VECTOR (val)->data[thisindex / BITS_PER_CHAR];
490 if (byte & (1 << (thisindex % BITS_PER_CHAR)))
491 elt = Qt;
492 else
493 elt = Qnil;
494 }
495 else
496 elt = XVECTOR (this)->contents[thisindex++];
497 }
498
499 /* Store into result */
500 if (toindex < 0)
501 {
502 XCONS (tail)->car = elt;
503 prev = tail;
504 tail = XCONS (tail)->cdr;
505 }
506 else if (VECTORP (val))
507 XVECTOR (val)->contents[toindex++] = elt;
508 else
509 {
510 while (!INTEGERP (elt))
511 elt = wrong_type_argument (Qintegerp, elt);
512 {
513 int c = XINT (elt);
514 unsigned char work[4], *str;
515 int i = CHAR_STRING (c, work, str);
516
517 #ifdef MASSC_REGISTER_BUG
518 /* Even removing all "register"s doesn't disable this bug!
519 Nothing simpler than this seems to work. */
520 unsigned char *p = & XSTRING (val)->data[toindex];
521 bcopy (str, p, i);
522 #else
523 bcopy (str, & XSTRING (val)->data[toindex], i);
524 #endif
525 toindex += i;
526 }
527 }
528 }
529 }
530 if (!NILP (prev))
531 XCONS (prev)->cdr = last_tail;
532
533 return val;
534 }
535 \f
536 DEFUN ("copy-alist", Fcopy_alist, Scopy_alist, 1, 1, 0,
537 "Return a copy of ALIST.\n\
538 This is an alist which represents the same mapping from objects to objects,\n\
539 but does not share the alist structure with ALIST.\n\
540 The objects mapped (cars and cdrs of elements of the alist)\n\
541 are shared, however.\n\
542 Elements of ALIST that are not conses are also shared.")
543 (alist)
544 Lisp_Object alist;
545 {
546 register Lisp_Object tem;
547
548 CHECK_LIST (alist, 0);
549 if (NILP (alist))
550 return alist;
551 alist = concat (1, &alist, Lisp_Cons, 0);
552 for (tem = alist; CONSP (tem); tem = XCONS (tem)->cdr)
553 {
554 register Lisp_Object car;
555 car = XCONS (tem)->car;
556
557 if (CONSP (car))
558 XCONS (tem)->car = Fcons (XCONS (car)->car, XCONS (car)->cdr);
559 }
560 return alist;
561 }
562
563 DEFUN ("substring", Fsubstring, Ssubstring, 2, 3, 0,
564 "Return a substring of STRING, starting at index FROM and ending before TO.\n\
565 TO may be nil or omitted; then the substring runs to the end of STRING.\n\
566 If FROM or TO is negative, it counts from the end.\n\
567 \n\
568 This function allows vectors as well as strings.")
569 (string, from, to)
570 Lisp_Object string;
571 register Lisp_Object from, to;
572 {
573 Lisp_Object res;
574 int size;
575
576 if (! (STRINGP (string) || VECTORP (string)))
577 wrong_type_argument (Qarrayp, string);
578
579 CHECK_NUMBER (from, 1);
580
581 if (STRINGP (string))
582 size = XSTRING (string)->size;
583 else
584 size = XVECTOR (string)->size;
585
586 if (NILP (to))
587 XSETINT (to, size);
588 else
589 CHECK_NUMBER (to, 2);
590
591 if (XINT (from) < 0)
592 XSETINT (from, XINT (from) + size);
593 if (XINT (to) < 0)
594 XSETINT (to, XINT (to) + size);
595 if (!(0 <= XINT (from) && XINT (from) <= XINT (to)
596 && XINT (to) <= size))
597 args_out_of_range_3 (string, from, to);
598
599 if (STRINGP (string))
600 {
601 res = make_string (XSTRING (string)->data + XINT (from),
602 XINT (to) - XINT (from));
603 copy_text_properties (from, to, string, make_number (0), res, Qnil);
604 }
605 else
606 res = Fvector (XINT (to) - XINT (from),
607 XVECTOR (string)->contents + XINT (from));
608
609 return res;
610 }
611 \f
612 DEFUN ("nthcdr", Fnthcdr, Snthcdr, 2, 2, 0,
613 "Take cdr N times on LIST, returns the result.")
614 (n, list)
615 Lisp_Object n;
616 register Lisp_Object list;
617 {
618 register int i, num;
619 CHECK_NUMBER (n, 0);
620 num = XINT (n);
621 for (i = 0; i < num && !NILP (list); i++)
622 {
623 QUIT;
624 list = Fcdr (list);
625 }
626 return list;
627 }
628
629 DEFUN ("nth", Fnth, Snth, 2, 2, 0,
630 "Return the Nth element of LIST.\n\
631 N counts from zero. If LIST is not that long, nil is returned.")
632 (n, list)
633 Lisp_Object n, list;
634 {
635 return Fcar (Fnthcdr (n, list));
636 }
637
638 DEFUN ("elt", Felt, Selt, 2, 2, 0,
639 "Return element of SEQUENCE at index N.")
640 (sequence, n)
641 register Lisp_Object sequence, n;
642 {
643 CHECK_NUMBER (n, 0);
644 while (1)
645 {
646 if (CONSP (sequence) || NILP (sequence))
647 return Fcar (Fnthcdr (n, sequence));
648 else if (STRINGP (sequence) || VECTORP (sequence)
649 || BOOL_VECTOR_P (sequence) || CHAR_TABLE_P (sequence))
650 return Faref (sequence, n);
651 else
652 sequence = wrong_type_argument (Qsequencep, sequence);
653 }
654 }
655
656 DEFUN ("member", Fmember, Smember, 2, 2, 0,
657 "Return non-nil if ELT is an element of LIST. Comparison done with `equal'.\n\
658 The value is actually the tail of LIST whose car is ELT.")
659 (elt, list)
660 register Lisp_Object elt;
661 Lisp_Object list;
662 {
663 register Lisp_Object tail;
664 for (tail = list; !NILP (tail); tail = XCONS (tail)->cdr)
665 {
666 register Lisp_Object tem;
667 tem = Fcar (tail);
668 if (! NILP (Fequal (elt, tem)))
669 return tail;
670 QUIT;
671 }
672 return Qnil;
673 }
674
675 DEFUN ("memq", Fmemq, Smemq, 2, 2, 0,
676 "Return non-nil if ELT is an element of LIST. Comparison done with EQ.\n\
677 The value is actually the tail of LIST whose car is ELT.")
678 (elt, list)
679 register Lisp_Object elt;
680 Lisp_Object list;
681 {
682 register Lisp_Object tail;
683 for (tail = list; !NILP (tail); tail = XCONS (tail)->cdr)
684 {
685 register Lisp_Object tem;
686 tem = Fcar (tail);
687 if (EQ (elt, tem)) return tail;
688 QUIT;
689 }
690 return Qnil;
691 }
692
693 DEFUN ("assq", Fassq, Sassq, 2, 2, 0,
694 "Return non-nil if KEY is `eq' to the car of an element of LIST.\n\
695 The value is actually the element of LIST whose car is KEY.\n\
696 Elements of LIST that are not conses are ignored.")
697 (key, list)
698 register Lisp_Object key;
699 Lisp_Object list;
700 {
701 register Lisp_Object tail;
702 for (tail = list; !NILP (tail); tail = XCONS (tail)->cdr)
703 {
704 register Lisp_Object elt, tem;
705 elt = Fcar (tail);
706 if (!CONSP (elt)) continue;
707 tem = XCONS (elt)->car;
708 if (EQ (key, tem)) return elt;
709 QUIT;
710 }
711 return Qnil;
712 }
713
714 /* Like Fassq but never report an error and do not allow quits.
715 Use only on lists known never to be circular. */
716
717 Lisp_Object
718 assq_no_quit (key, list)
719 register Lisp_Object key;
720 Lisp_Object list;
721 {
722 register Lisp_Object tail;
723 for (tail = list; CONSP (tail); tail = XCONS (tail)->cdr)
724 {
725 register Lisp_Object elt, tem;
726 elt = Fcar (tail);
727 if (!CONSP (elt)) continue;
728 tem = XCONS (elt)->car;
729 if (EQ (key, tem)) return elt;
730 }
731 return Qnil;
732 }
733
734 DEFUN ("assoc", Fassoc, Sassoc, 2, 2, 0,
735 "Return non-nil if KEY is `equal' to the car of an element of LIST.\n\
736 The value is actually the element of LIST whose car equals KEY.")
737 (key, list)
738 register Lisp_Object key;
739 Lisp_Object list;
740 {
741 register Lisp_Object tail;
742 for (tail = list; !NILP (tail); tail = XCONS (tail)->cdr)
743 {
744 register Lisp_Object elt, tem;
745 elt = Fcar (tail);
746 if (!CONSP (elt)) continue;
747 tem = Fequal (XCONS (elt)->car, key);
748 if (!NILP (tem)) return elt;
749 QUIT;
750 }
751 return Qnil;
752 }
753
754 DEFUN ("rassq", Frassq, Srassq, 2, 2, 0,
755 "Return non-nil if ELT is `eq' to the cdr of an element of LIST.\n\
756 The value is actually the element of LIST whose cdr is ELT.")
757 (key, list)
758 register Lisp_Object key;
759 Lisp_Object list;
760 {
761 register Lisp_Object tail;
762 for (tail = list; !NILP (tail); tail = XCONS (tail)->cdr)
763 {
764 register Lisp_Object elt, tem;
765 elt = Fcar (tail);
766 if (!CONSP (elt)) continue;
767 tem = XCONS (elt)->cdr;
768 if (EQ (key, tem)) return elt;
769 QUIT;
770 }
771 return Qnil;
772 }
773
774 DEFUN ("rassoc", Frassoc, Srassoc, 2, 2, 0,
775 "Return non-nil if KEY is `equal' to the cdr of an element of LIST.\n\
776 The value is actually the element of LIST whose cdr equals KEY.")
777 (key, list)
778 register Lisp_Object key;
779 Lisp_Object list;
780 {
781 register Lisp_Object tail;
782 for (tail = list; !NILP (tail); tail = XCONS (tail)->cdr)
783 {
784 register Lisp_Object elt, tem;
785 elt = Fcar (tail);
786 if (!CONSP (elt)) continue;
787 tem = Fequal (XCONS (elt)->cdr, key);
788 if (!NILP (tem)) return elt;
789 QUIT;
790 }
791 return Qnil;
792 }
793 \f
794 DEFUN ("delq", Fdelq, Sdelq, 2, 2, 0,
795 "Delete by side effect any occurrences of ELT as a member of LIST.\n\
796 The modified LIST is returned. Comparison is done with `eq'.\n\
797 If the first member of LIST is ELT, there is no way to remove it by side effect;\n\
798 therefore, write `(setq foo (delq element foo))'\n\
799 to be sure of changing the value of `foo'.")
800 (elt, list)
801 register Lisp_Object elt;
802 Lisp_Object list;
803 {
804 register Lisp_Object tail, prev;
805 register Lisp_Object tem;
806
807 tail = list;
808 prev = Qnil;
809 while (!NILP (tail))
810 {
811 tem = Fcar (tail);
812 if (EQ (elt, tem))
813 {
814 if (NILP (prev))
815 list = XCONS (tail)->cdr;
816 else
817 Fsetcdr (prev, XCONS (tail)->cdr);
818 }
819 else
820 prev = tail;
821 tail = XCONS (tail)->cdr;
822 QUIT;
823 }
824 return list;
825 }
826
827 DEFUN ("delete", Fdelete, Sdelete, 2, 2, 0,
828 "Delete by side effect any occurrences of ELT as a member of LIST.\n\
829 The modified LIST is returned. Comparison is done with `equal'.\n\
830 If the first member of LIST is ELT, deleting it is not a side effect;\n\
831 it is simply using a different list.\n\
832 Therefore, write `(setq foo (delete element foo))'\n\
833 to be sure of changing the value of `foo'.")
834 (elt, list)
835 register Lisp_Object elt;
836 Lisp_Object list;
837 {
838 register Lisp_Object tail, prev;
839 register Lisp_Object tem;
840
841 tail = list;
842 prev = Qnil;
843 while (!NILP (tail))
844 {
845 tem = Fcar (tail);
846 if (! NILP (Fequal (elt, tem)))
847 {
848 if (NILP (prev))
849 list = XCONS (tail)->cdr;
850 else
851 Fsetcdr (prev, XCONS (tail)->cdr);
852 }
853 else
854 prev = tail;
855 tail = XCONS (tail)->cdr;
856 QUIT;
857 }
858 return list;
859 }
860
861 DEFUN ("nreverse", Fnreverse, Snreverse, 1, 1, 0,
862 "Reverse LIST by modifying cdr pointers.\n\
863 Returns the beginning of the reversed list.")
864 (list)
865 Lisp_Object list;
866 {
867 register Lisp_Object prev, tail, next;
868
869 if (NILP (list)) return list;
870 prev = Qnil;
871 tail = list;
872 while (!NILP (tail))
873 {
874 QUIT;
875 next = Fcdr (tail);
876 Fsetcdr (tail, prev);
877 prev = tail;
878 tail = next;
879 }
880 return prev;
881 }
882
883 DEFUN ("reverse", Freverse, Sreverse, 1, 1, 0,
884 "Reverse LIST, copying. Returns the beginning of the reversed list.\n\
885 See also the function `nreverse', which is used more often.")
886 (list)
887 Lisp_Object list;
888 {
889 Lisp_Object new;
890
891 for (new = Qnil; CONSP (list); list = XCONS (list)->cdr)
892 new = Fcons (XCONS (list)->car, new);
893 if (!NILP (list))
894 wrong_type_argument (Qconsp, list);
895 return new;
896 }
897 \f
898 Lisp_Object merge ();
899
900 DEFUN ("sort", Fsort, Ssort, 2, 2, 0,
901 "Sort LIST, stably, comparing elements using PREDICATE.\n\
902 Returns the sorted list. LIST is modified by side effects.\n\
903 PREDICATE is called with two elements of LIST, and should return T\n\
904 if the first element is \"less\" than the second.")
905 (list, predicate)
906 Lisp_Object list, predicate;
907 {
908 Lisp_Object front, back;
909 register Lisp_Object len, tem;
910 struct gcpro gcpro1, gcpro2;
911 register int length;
912
913 front = list;
914 len = Flength (list);
915 length = XINT (len);
916 if (length < 2)
917 return list;
918
919 XSETINT (len, (length / 2) - 1);
920 tem = Fnthcdr (len, list);
921 back = Fcdr (tem);
922 Fsetcdr (tem, Qnil);
923
924 GCPRO2 (front, back);
925 front = Fsort (front, predicate);
926 back = Fsort (back, predicate);
927 UNGCPRO;
928 return merge (front, back, predicate);
929 }
930
931 Lisp_Object
932 merge (org_l1, org_l2, pred)
933 Lisp_Object org_l1, org_l2;
934 Lisp_Object pred;
935 {
936 Lisp_Object value;
937 register Lisp_Object tail;
938 Lisp_Object tem;
939 register Lisp_Object l1, l2;
940 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
941
942 l1 = org_l1;
943 l2 = org_l2;
944 tail = Qnil;
945 value = Qnil;
946
947 /* It is sufficient to protect org_l1 and org_l2.
948 When l1 and l2 are updated, we copy the new values
949 back into the org_ vars. */
950 GCPRO4 (org_l1, org_l2, pred, value);
951
952 while (1)
953 {
954 if (NILP (l1))
955 {
956 UNGCPRO;
957 if (NILP (tail))
958 return l2;
959 Fsetcdr (tail, l2);
960 return value;
961 }
962 if (NILP (l2))
963 {
964 UNGCPRO;
965 if (NILP (tail))
966 return l1;
967 Fsetcdr (tail, l1);
968 return value;
969 }
970 tem = call2 (pred, Fcar (l2), Fcar (l1));
971 if (NILP (tem))
972 {
973 tem = l1;
974 l1 = Fcdr (l1);
975 org_l1 = l1;
976 }
977 else
978 {
979 tem = l2;
980 l2 = Fcdr (l2);
981 org_l2 = l2;
982 }
983 if (NILP (tail))
984 value = tem;
985 else
986 Fsetcdr (tail, tem);
987 tail = tem;
988 }
989 }
990 \f
991
992 DEFUN ("plist-get", Fplist_get, Splist_get, 2, 2, 0,
993 "Extract a value from a property list.\n\
994 PLIST is a property list, which is a list of the form\n\
995 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value\n\
996 corresponding to the given PROP, or nil if PROP is not\n\
997 one of the properties on the list.")
998 (plist, prop)
999 Lisp_Object plist;
1000 register Lisp_Object prop;
1001 {
1002 register Lisp_Object tail;
1003 for (tail = plist; !NILP (tail); tail = Fcdr (XCONS (tail)->cdr))
1004 {
1005 register Lisp_Object tem;
1006 tem = Fcar (tail);
1007 if (EQ (prop, tem))
1008 return Fcar (XCONS (tail)->cdr);
1009 }
1010 return Qnil;
1011 }
1012
1013 DEFUN ("get", Fget, Sget, 2, 2, 0,
1014 "Return the value of SYMBOL's PROPNAME property.\n\
1015 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'.")
1016 (symbol, propname)
1017 Lisp_Object symbol, propname;
1018 {
1019 CHECK_SYMBOL (symbol, 0);
1020 return Fplist_get (XSYMBOL (symbol)->plist, propname);
1021 }
1022
1023 DEFUN ("plist-put", Fplist_put, Splist_put, 3, 3, 0,
1024 "Change value in PLIST of PROP to VAL.\n\
1025 PLIST is a property list, which is a list of the form\n\
1026 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.\n\
1027 If PROP is already a property on the list, its value is set to VAL,\n\
1028 otherwise the new PROP VAL pair is added. The new plist is returned;\n\
1029 use `(setq x (plist-put x prop val))' to be sure to use the new value.\n\
1030 The PLIST is modified by side effects.")
1031 (plist, prop, val)
1032 Lisp_Object plist;
1033 register Lisp_Object prop;
1034 Lisp_Object val;
1035 {
1036 register Lisp_Object tail, prev;
1037 Lisp_Object newcell;
1038 prev = Qnil;
1039 for (tail = plist; CONSP (tail) && CONSP (XCONS (tail)->cdr);
1040 tail = XCONS (XCONS (tail)->cdr)->cdr)
1041 {
1042 if (EQ (prop, XCONS (tail)->car))
1043 {
1044 Fsetcar (XCONS (tail)->cdr, val);
1045 return plist;
1046 }
1047 prev = tail;
1048 }
1049 newcell = Fcons (prop, Fcons (val, Qnil));
1050 if (NILP (prev))
1051 return newcell;
1052 else
1053 Fsetcdr (XCONS (prev)->cdr, newcell);
1054 return plist;
1055 }
1056
1057 DEFUN ("put", Fput, Sput, 3, 3, 0,
1058 "Store SYMBOL's PROPNAME property with value VALUE.\n\
1059 It can be retrieved with `(get SYMBOL PROPNAME)'.")
1060 (symbol, propname, value)
1061 Lisp_Object symbol, propname, value;
1062 {
1063 CHECK_SYMBOL (symbol, 0);
1064 XSYMBOL (symbol)->plist
1065 = Fplist_put (XSYMBOL (symbol)->plist, propname, value);
1066 return value;
1067 }
1068
1069 DEFUN ("equal", Fequal, Sequal, 2, 2, 0,
1070 "T if two Lisp objects have similar structure and contents.\n\
1071 They must have the same data type.\n\
1072 Conses are compared by comparing the cars and the cdrs.\n\
1073 Vectors and strings are compared element by element.\n\
1074 Numbers are compared by value, but integers cannot equal floats.\n\
1075 (Use `=' if you want integers and floats to be able to be equal.)\n\
1076 Symbols must match exactly.")
1077 (o1, o2)
1078 register Lisp_Object o1, o2;
1079 {
1080 return internal_equal (o1, o2, 0) ? Qt : Qnil;
1081 }
1082
1083 static int
1084 internal_equal (o1, o2, depth)
1085 register Lisp_Object o1, o2;
1086 int depth;
1087 {
1088 if (depth > 200)
1089 error ("Stack overflow in equal");
1090
1091 tail_recurse:
1092 QUIT;
1093 if (EQ (o1, o2))
1094 return 1;
1095 if (XTYPE (o1) != XTYPE (o2))
1096 return 0;
1097
1098 switch (XTYPE (o1))
1099 {
1100 #ifdef LISP_FLOAT_TYPE
1101 case Lisp_Float:
1102 return (extract_float (o1) == extract_float (o2));
1103 #endif
1104
1105 case Lisp_Cons:
1106 if (!internal_equal (XCONS (o1)->car, XCONS (o2)->car, depth + 1))
1107 return 0;
1108 o1 = XCONS (o1)->cdr;
1109 o2 = XCONS (o2)->cdr;
1110 goto tail_recurse;
1111
1112 case Lisp_Misc:
1113 if (XMISCTYPE (o1) != XMISCTYPE (o2))
1114 return 0;
1115 if (OVERLAYP (o1))
1116 {
1117 if (!internal_equal (OVERLAY_START (o1), OVERLAY_START (o1),
1118 depth + 1)
1119 || !internal_equal (OVERLAY_END (o1), OVERLAY_END (o1),
1120 depth + 1))
1121 return 0;
1122 o1 = XOVERLAY (o1)->plist;
1123 o2 = XOVERLAY (o2)->plist;
1124 goto tail_recurse;
1125 }
1126 if (MARKERP (o1))
1127 {
1128 return (XMARKER (o1)->buffer == XMARKER (o2)->buffer
1129 && (XMARKER (o1)->buffer == 0
1130 || XMARKER (o1)->bufpos == XMARKER (o2)->bufpos));
1131 }
1132 break;
1133
1134 case Lisp_Vectorlike:
1135 {
1136 register int i, size;
1137 size = XVECTOR (o1)->size;
1138 /* Pseudovectors have the type encoded in the size field, so this test
1139 actually checks that the objects have the same type as well as the
1140 same size. */
1141 if (XVECTOR (o2)->size != size)
1142 return 0;
1143 /* Boolvectors are compared much like strings. */
1144 if (BOOL_VECTOR_P (o1))
1145 {
1146 int size_in_chars
1147 = (XBOOL_VECTOR (o1)->size + BITS_PER_CHAR - 1) / BITS_PER_CHAR;
1148
1149 if (XBOOL_VECTOR (o1)->size != XBOOL_VECTOR (o2)->size)
1150 return 0;
1151 if (bcmp (XBOOL_VECTOR (o1)->data, XBOOL_VECTOR (o2)->data,
1152 size_in_chars))
1153 return 0;
1154 return 1;
1155 }
1156
1157 /* Aside from them, only true vectors, char-tables, and compiled
1158 functions are sensible to compare, so eliminate the others now. */
1159 if (size & PSEUDOVECTOR_FLAG)
1160 {
1161 if (!(size & (PVEC_COMPILED | PVEC_CHAR_TABLE)))
1162 return 0;
1163 size &= PSEUDOVECTOR_SIZE_MASK;
1164 }
1165 for (i = 0; i < size; i++)
1166 {
1167 Lisp_Object v1, v2;
1168 v1 = XVECTOR (o1)->contents [i];
1169 v2 = XVECTOR (o2)->contents [i];
1170 if (!internal_equal (v1, v2, depth + 1))
1171 return 0;
1172 }
1173 return 1;
1174 }
1175 break;
1176
1177 case Lisp_String:
1178 if (XSTRING (o1)->size != XSTRING (o2)->size)
1179 return 0;
1180 if (bcmp (XSTRING (o1)->data, XSTRING (o2)->data,
1181 XSTRING (o1)->size))
1182 return 0;
1183 return 1;
1184 }
1185 return 0;
1186 }
1187 \f
1188 extern Lisp_Object Fmake_char_internal ();
1189
1190 DEFUN ("fillarray", Ffillarray, Sfillarray, 2, 2, 0,
1191 "Store each element of ARRAY with ITEM.\n\
1192 ARRAY is a vector, string, char-table, or bool-vector.")
1193 (array, item)
1194 Lisp_Object array, item;
1195 {
1196 register int size, index, charval;
1197 retry:
1198 if (VECTORP (array))
1199 {
1200 register Lisp_Object *p = XVECTOR (array)->contents;
1201 size = XVECTOR (array)->size;
1202 for (index = 0; index < size; index++)
1203 p[index] = item;
1204 }
1205 else if (CHAR_TABLE_P (array))
1206 {
1207 register Lisp_Object *p = XCHAR_TABLE (array)->contents;
1208 size = CHAR_TABLE_ORDINARY_SLOTS;
1209 for (index = 0; index < size; index++)
1210 p[index] = item;
1211 XCHAR_TABLE (array)->defalt = Qnil;
1212 }
1213 else if (STRINGP (array))
1214 {
1215 register unsigned char *p = XSTRING (array)->data;
1216 CHECK_NUMBER (item, 1);
1217 charval = XINT (item);
1218 size = XSTRING (array)->size;
1219 for (index = 0; index < size; index++)
1220 p[index] = charval;
1221 }
1222 else if (BOOL_VECTOR_P (array))
1223 {
1224 register unsigned char *p = XBOOL_VECTOR (array)->data;
1225 int size_in_chars
1226 = (XBOOL_VECTOR (array)->size + BITS_PER_CHAR - 1) / BITS_PER_CHAR;
1227
1228 charval = (! NILP (item) ? -1 : 0);
1229 for (index = 0; index < size_in_chars; index++)
1230 p[index] = charval;
1231 }
1232 else
1233 {
1234 array = wrong_type_argument (Qarrayp, array);
1235 goto retry;
1236 }
1237 return array;
1238 }
1239
1240 DEFUN ("char-table-subtype", Fchar_table_subtype, Schar_table_subtype,
1241 1, 1, 0,
1242 "Return the subtype of char-table CHAR-TABLE. The value is a symbol.")
1243 (char_table)
1244 Lisp_Object char_table;
1245 {
1246 CHECK_CHAR_TABLE (char_table, 0);
1247
1248 return XCHAR_TABLE (char_table)->purpose;
1249 }
1250
1251 DEFUN ("char-table-parent", Fchar_table_parent, Schar_table_parent,
1252 1, 1, 0,
1253 "Return the parent char-table of CHAR-TABLE.\n\
1254 The value is either nil or another char-table.\n\
1255 If CHAR-TABLE holds nil for a given character,\n\
1256 then the actual applicable value is inherited from the parent char-table\n\
1257 \(or from its parents, if necessary).")
1258 (char_table)
1259 Lisp_Object char_table;
1260 {
1261 CHECK_CHAR_TABLE (char_table, 0);
1262
1263 return XCHAR_TABLE (char_table)->parent;
1264 }
1265
1266 DEFUN ("set-char-table-parent", Fset_char_table_parent, Sset_char_table_parent,
1267 2, 2, 0,
1268 "Set the parent char-table of CHAR-TABLE to PARENT.\n\
1269 PARENT must be either nil or another char-table.")
1270 (char_table, parent)
1271 Lisp_Object char_table, parent;
1272 {
1273 Lisp_Object temp;
1274
1275 CHECK_CHAR_TABLE (char_table, 0);
1276
1277 if (!NILP (parent))
1278 {
1279 CHECK_CHAR_TABLE (parent, 0);
1280
1281 for (temp = parent; !NILP (temp); temp = XCHAR_TABLE (temp)->parent)
1282 if (EQ (temp, char_table))
1283 error ("Attempt to make a chartable be its own parent");
1284 }
1285
1286 XCHAR_TABLE (char_table)->parent = parent;
1287
1288 return parent;
1289 }
1290
1291 DEFUN ("char-table-extra-slot", Fchar_table_extra_slot, Schar_table_extra_slot,
1292 2, 2, 0,
1293 "Return the value of CHAR-TABLE's extra-slot number N.")
1294 (char_table, n)
1295 Lisp_Object char_table, n;
1296 {
1297 CHECK_CHAR_TABLE (char_table, 1);
1298 CHECK_NUMBER (n, 2);
1299 if (XINT (n) < 0
1300 || XINT (n) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table)))
1301 args_out_of_range (char_table, n);
1302
1303 return XCHAR_TABLE (char_table)->extras[XINT (n)];
1304 }
1305
1306 DEFUN ("set-char-table-extra-slot", Fset_char_table_extra_slot,
1307 Sset_char_table_extra_slot,
1308 3, 3, 0,
1309 "Set CHAR-TABLE's extra-slot number N to VALUE.")
1310 (char_table, n, value)
1311 Lisp_Object char_table, n, value;
1312 {
1313 CHECK_CHAR_TABLE (char_table, 1);
1314 CHECK_NUMBER (n, 2);
1315 if (XINT (n) < 0
1316 || XINT (n) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table)))
1317 args_out_of_range (char_table, n);
1318
1319 return XCHAR_TABLE (char_table)->extras[XINT (n)] = value;
1320 }
1321
1322 DEFUN ("char-table-range", Fchar_table_range, Schar_table_range,
1323 2, 2, 0,
1324 "Return the value in CHAR-TABLE for a range of characters RANGE.\n\
1325 RANGE should be t (for all characters), nil (for the default value)\n\
1326 a vector which identifies a character set or a row of a character set,\n\
1327 or a character code.")
1328 (char_table, range)
1329 Lisp_Object char_table, range;
1330 {
1331 int i;
1332
1333 CHECK_CHAR_TABLE (char_table, 0);
1334
1335 if (EQ (range, Qnil))
1336 return XCHAR_TABLE (char_table)->defalt;
1337 else if (INTEGERP (range))
1338 return Faref (char_table, range);
1339 else if (VECTORP (range))
1340 {
1341 if (XVECTOR (range)->size == 1)
1342 return Faref (char_table, XVECTOR (range)->contents[0]);
1343 else
1344 {
1345 int size = XVECTOR (range)->size;
1346 Lisp_Object *val = XVECTOR (range)->contents;
1347 Lisp_Object ch = Fmake_char_internal (size <= 0 ? Qnil : val[0],
1348 size <= 1 ? Qnil : val[1],
1349 size <= 2 ? Qnil : val[2]);
1350 return Faref (char_table, ch);
1351 }
1352 }
1353 else
1354 error ("Invalid RANGE argument to `char-table-range'");
1355 }
1356
1357 DEFUN ("set-char-table-range", Fset_char_table_range, Sset_char_table_range,
1358 3, 3, 0,
1359 "Set the value in CHAR-TABLE for a range of characters RANGE to VALUE.\n\
1360 RANGE should be t (for all characters), nil (for the default value)\n\
1361 a vector which identifies a character set or a row of a character set,\n\
1362 or a character code.")
1363 (char_table, range, value)
1364 Lisp_Object char_table, range, value;
1365 {
1366 int i;
1367
1368 CHECK_CHAR_TABLE (char_table, 0);
1369
1370 if (EQ (range, Qt))
1371 for (i = 0; i < CHAR_TABLE_ORDINARY_SLOTS; i++)
1372 XCHAR_TABLE (char_table)->contents[i] = value;
1373 else if (EQ (range, Qnil))
1374 XCHAR_TABLE (char_table)->defalt = value;
1375 else if (INTEGERP (range))
1376 Faset (char_table, range, value);
1377 else if (VECTORP (range))
1378 {
1379 if (XVECTOR (range)->size == 1)
1380 return Faset (char_table, XVECTOR (range)->contents[0], value);
1381 else
1382 {
1383 int size = XVECTOR (range)->size;
1384 Lisp_Object *val = XVECTOR (range)->contents;
1385 Lisp_Object ch = Fmake_char_internal (size <= 0 ? Qnil : val[0],
1386 size <= 1 ? Qnil : val[1],
1387 size <= 2 ? Qnil : val[2]);
1388 return Faset (char_table, ch, value);
1389 }
1390 }
1391 else
1392 error ("Invalid RANGE argument to `set-char-table-range'");
1393
1394 return value;
1395 }
1396
1397 DEFUN ("set-char-table-default", Fset_char_table_default,
1398 Sset_char_table_default, 3, 3, 0,
1399 "Set the default value in CHAR-TABLE for a generic character CHAR to VALUE.\n\
1400 The generic character specifies the group of characters.\n\
1401 See also the documentation of make-char.")
1402 (char_table, ch, value)
1403 Lisp_Object char_table, ch, value;
1404 {
1405 int c, i, charset, code1, code2;
1406 Lisp_Object temp;
1407
1408 CHECK_CHAR_TABLE (char_table, 0);
1409 CHECK_NUMBER (ch, 1);
1410
1411 c = XINT (ch);
1412 SPLIT_NON_ASCII_CHAR (c, charset, code1, code2);
1413 if (! CHARSET_DEFINED_P (charset))
1414 error ("Invalid character: %d", c);
1415
1416 if (charset == CHARSET_ASCII)
1417 return (XCHAR_TABLE (char_table)->defalt = value);
1418
1419 /* Even if C is not a generic char, we had better behave as if a
1420 generic char is specified. */
1421 if (CHARSET_DIMENSION (charset) == 1)
1422 code1 = 0;
1423 temp = XCHAR_TABLE (char_table)->contents[charset + 128];
1424 if (!code1)
1425 {
1426 if (SUB_CHAR_TABLE_P (temp))
1427 XCHAR_TABLE (temp)->defalt = value;
1428 else
1429 XCHAR_TABLE (char_table)->contents[charset + 128] = value;
1430 return value;
1431 }
1432 char_table = temp;
1433 if (! SUB_CHAR_TABLE_P (char_table))
1434 char_table = (XCHAR_TABLE (char_table)->contents[charset + 128]
1435 = make_sub_char_table (temp));
1436 temp = XCHAR_TABLE (char_table)->contents[code1];
1437 if (SUB_CHAR_TABLE_P (temp))
1438 XCHAR_TABLE (temp)->defalt = value;
1439 else
1440 XCHAR_TABLE (char_table)->contents[code1] = value;
1441 return value;
1442 }
1443
1444 \f
1445 /* Map C_FUNCTION or FUNCTION over SUBTABLE, calling it for each
1446 character or group of characters that share a value.
1447 DEPTH is the current depth in the originally specified
1448 chartable, and INDICES contains the vector indices
1449 for the levels our callers have descended.
1450
1451 ARG is passed to C_FUNCTION when that is called. */
1452
1453 void
1454 map_char_table (c_function, function, subtable, arg, depth, indices)
1455 Lisp_Object (*c_function) (), function, subtable, arg, *indices;
1456 int depth;
1457 {
1458 int i, to;
1459
1460 if (depth == 0)
1461 {
1462 /* At first, handle ASCII and 8-bit European characters. */
1463 for (i = 0; i < CHAR_TABLE_SINGLE_BYTE_SLOTS; i++)
1464 {
1465 Lisp_Object elt = XCHAR_TABLE (subtable)->contents[i];
1466 if (c_function)
1467 (*c_function) (arg, make_number (i), elt);
1468 else
1469 call2 (function, make_number (i), elt);
1470 }
1471 to = CHAR_TABLE_ORDINARY_SLOTS;
1472 }
1473 else
1474 {
1475 i = 0;
1476 to = SUB_CHAR_TABLE_ORDINARY_SLOTS;
1477 }
1478
1479 for (; i < to; i++)
1480 {
1481 Lisp_Object elt = XCHAR_TABLE (subtable)->contents[i];
1482
1483 XSETFASTINT (indices[depth], i);
1484
1485 if (SUB_CHAR_TABLE_P (elt))
1486 {
1487 if (depth >= 3)
1488 error ("Too deep char table");
1489 map_char_table (c_function, function, elt, arg, depth + 1, indices);
1490 }
1491 else
1492 {
1493 int charset = XFASTINT (indices[0]) - 128, c1, c2, c;
1494
1495 if (CHARSET_DEFINED_P (charset))
1496 {
1497 c1 = depth >= 1 ? XFASTINT (indices[1]) : 0;
1498 c2 = depth >= 2 ? XFASTINT (indices[2]) : 0;
1499 c = MAKE_NON_ASCII_CHAR (charset, c1, c2);
1500 if (c_function)
1501 (*c_function) (arg, make_number (c), elt);
1502 else
1503 call2 (function, make_number (c), elt);
1504 }
1505 }
1506 }
1507 }
1508
1509 DEFUN ("map-char-table", Fmap_char_table, Smap_char_table,
1510 2, 2, 0,
1511 "Call FUNCTION for each (normal and generic) characters in CHAR-TABLE.\n\
1512 FUNCTION is called with two arguments--a key and a value.\n\
1513 The key is always a possible IDX argument to `aref'.")
1514 (function, char_table)
1515 Lisp_Object function, char_table;
1516 {
1517 /* The depth of char table is at most 3. */
1518 Lisp_Object indices[3];
1519
1520 CHECK_CHAR_TABLE (char_table, 1);
1521
1522 map_char_table (NULL, function, char_table, char_table, 0, indices);
1523 return Qnil;
1524 }
1525 \f
1526 /* ARGSUSED */
1527 Lisp_Object
1528 nconc2 (s1, s2)
1529 Lisp_Object s1, s2;
1530 {
1531 #ifdef NO_ARG_ARRAY
1532 Lisp_Object args[2];
1533 args[0] = s1;
1534 args[1] = s2;
1535 return Fnconc (2, args);
1536 #else
1537 return Fnconc (2, &s1);
1538 #endif /* NO_ARG_ARRAY */
1539 }
1540
1541 DEFUN ("nconc", Fnconc, Snconc, 0, MANY, 0,
1542 "Concatenate any number of lists by altering them.\n\
1543 Only the last argument is not altered, and need not be a list.")
1544 (nargs, args)
1545 int nargs;
1546 Lisp_Object *args;
1547 {
1548 register int argnum;
1549 register Lisp_Object tail, tem, val;
1550
1551 val = Qnil;
1552
1553 for (argnum = 0; argnum < nargs; argnum++)
1554 {
1555 tem = args[argnum];
1556 if (NILP (tem)) continue;
1557
1558 if (NILP (val))
1559 val = tem;
1560
1561 if (argnum + 1 == nargs) break;
1562
1563 if (!CONSP (tem))
1564 tem = wrong_type_argument (Qlistp, tem);
1565
1566 while (CONSP (tem))
1567 {
1568 tail = tem;
1569 tem = Fcdr (tail);
1570 QUIT;
1571 }
1572
1573 tem = args[argnum + 1];
1574 Fsetcdr (tail, tem);
1575 if (NILP (tem))
1576 args[argnum + 1] = tail;
1577 }
1578
1579 return val;
1580 }
1581 \f
1582 /* This is the guts of all mapping functions.
1583 Apply fn to each element of seq, one by one,
1584 storing the results into elements of vals, a C vector of Lisp_Objects.
1585 leni is the length of vals, which should also be the length of seq. */
1586
1587 static void
1588 mapcar1 (leni, vals, fn, seq)
1589 int leni;
1590 Lisp_Object *vals;
1591 Lisp_Object fn, seq;
1592 {
1593 register Lisp_Object tail;
1594 Lisp_Object dummy;
1595 register int i;
1596 struct gcpro gcpro1, gcpro2, gcpro3;
1597
1598 /* Don't let vals contain any garbage when GC happens. */
1599 for (i = 0; i < leni; i++)
1600 vals[i] = Qnil;
1601
1602 GCPRO3 (dummy, fn, seq);
1603 gcpro1.var = vals;
1604 gcpro1.nvars = leni;
1605 /* We need not explicitly protect `tail' because it is used only on lists, and
1606 1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
1607
1608 if (VECTORP (seq))
1609 {
1610 for (i = 0; i < leni; i++)
1611 {
1612 dummy = XVECTOR (seq)->contents[i];
1613 vals[i] = call1 (fn, dummy);
1614 }
1615 }
1616 else if (STRINGP (seq))
1617 {
1618 for (i = 0; i < leni; i++)
1619 {
1620 XSETFASTINT (dummy, XSTRING (seq)->data[i]);
1621 vals[i] = call1 (fn, dummy);
1622 }
1623 }
1624 else /* Must be a list, since Flength did not get an error */
1625 {
1626 tail = seq;
1627 for (i = 0; i < leni; i++)
1628 {
1629 vals[i] = call1 (fn, Fcar (tail));
1630 tail = XCONS (tail)->cdr;
1631 }
1632 }
1633
1634 UNGCPRO;
1635 }
1636
1637 DEFUN ("mapconcat", Fmapconcat, Smapconcat, 3, 3, 0,
1638 "Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.\n\
1639 In between each pair of results, stick in SEPARATOR. Thus, \" \" as\n\
1640 SEPARATOR results in spaces between the values returned by FUNCTION.")
1641 (function, sequence, separator)
1642 Lisp_Object function, sequence, separator;
1643 {
1644 Lisp_Object len;
1645 register int leni;
1646 int nargs;
1647 register Lisp_Object *args;
1648 register int i;
1649 struct gcpro gcpro1;
1650
1651 len = Flength (sequence);
1652 leni = XINT (len);
1653 nargs = leni + leni - 1;
1654 if (nargs < 0) return build_string ("");
1655
1656 args = (Lisp_Object *) alloca (nargs * sizeof (Lisp_Object));
1657
1658 GCPRO1 (separator);
1659 mapcar1 (leni, args, function, sequence);
1660 UNGCPRO;
1661
1662 for (i = leni - 1; i >= 0; i--)
1663 args[i + i] = args[i];
1664
1665 for (i = 1; i < nargs; i += 2)
1666 args[i] = separator;
1667
1668 return Fconcat (nargs, args);
1669 }
1670
1671 DEFUN ("mapcar", Fmapcar, Smapcar, 2, 2, 0,
1672 "Apply FUNCTION to each element of SEQUENCE, and make a list of the results.\n\
1673 The result is a list just as long as SEQUENCE.\n\
1674 SEQUENCE may be a list, a vector or a string.")
1675 (function, sequence)
1676 Lisp_Object function, sequence;
1677 {
1678 register Lisp_Object len;
1679 register int leni;
1680 register Lisp_Object *args;
1681
1682 len = Flength (sequence);
1683 leni = XFASTINT (len);
1684 args = (Lisp_Object *) alloca (leni * sizeof (Lisp_Object));
1685
1686 mapcar1 (leni, args, function, sequence);
1687
1688 return Flist (leni, args);
1689 }
1690 \f
1691 /* Anything that calls this function must protect from GC! */
1692
1693 DEFUN ("y-or-n-p", Fy_or_n_p, Sy_or_n_p, 1, 1, 0,
1694 "Ask user a \"y or n\" question. Return t if answer is \"y\".\n\
1695 Takes one argument, which is the string to display to ask the question.\n\
1696 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.\n\
1697 No confirmation of the answer is requested; a single character is enough.\n\
1698 Also accepts Space to mean yes, or Delete to mean no.")
1699 (prompt)
1700 Lisp_Object prompt;
1701 {
1702 register Lisp_Object obj, key, def, answer_string, map;
1703 register int answer;
1704 Lisp_Object xprompt;
1705 Lisp_Object args[2];
1706 struct gcpro gcpro1, gcpro2;
1707 int count = specpdl_ptr - specpdl;
1708
1709 specbind (Qcursor_in_echo_area, Qt);
1710
1711 map = Fsymbol_value (intern ("query-replace-map"));
1712
1713 CHECK_STRING (prompt, 0);
1714 xprompt = prompt;
1715 GCPRO2 (prompt, xprompt);
1716
1717 while (1)
1718 {
1719
1720
1721 #ifdef HAVE_MENUS
1722 if ((NILP (last_nonmenu_event) || CONSP (last_nonmenu_event))
1723 && use_dialog_box
1724 && have_menus_p ())
1725 {
1726 Lisp_Object pane, menu;
1727 redisplay_preserve_echo_area ();
1728 pane = Fcons (Fcons (build_string ("Yes"), Qt),
1729 Fcons (Fcons (build_string ("No"), Qnil),
1730 Qnil));
1731 menu = Fcons (prompt, pane);
1732 obj = Fx_popup_dialog (Qt, menu);
1733 answer = !NILP (obj);
1734 break;
1735 }
1736 #endif /* HAVE_MENUS */
1737 cursor_in_echo_area = 1;
1738 choose_minibuf_frame ();
1739 message_nolog ("%s(y or n) ", XSTRING (xprompt)->data);
1740
1741 if (minibuffer_auto_raise)
1742 {
1743 Lisp_Object mini_frame;
1744
1745 mini_frame = WINDOW_FRAME (XWINDOW (minibuf_window));
1746
1747 Fraise_frame (mini_frame);
1748 }
1749
1750 obj = read_filtered_event (1, 0, 0);
1751 cursor_in_echo_area = 0;
1752 /* If we need to quit, quit with cursor_in_echo_area = 0. */
1753 QUIT;
1754
1755 key = Fmake_vector (make_number (1), obj);
1756 def = Flookup_key (map, key, Qt);
1757 answer_string = Fsingle_key_description (obj);
1758
1759 if (EQ (def, intern ("skip")))
1760 {
1761 answer = 0;
1762 break;
1763 }
1764 else if (EQ (def, intern ("act")))
1765 {
1766 answer = 1;
1767 break;
1768 }
1769 else if (EQ (def, intern ("recenter")))
1770 {
1771 Frecenter (Qnil);
1772 xprompt = prompt;
1773 continue;
1774 }
1775 else if (EQ (def, intern ("quit")))
1776 Vquit_flag = Qt;
1777 /* We want to exit this command for exit-prefix,
1778 and this is the only way to do it. */
1779 else if (EQ (def, intern ("exit-prefix")))
1780 Vquit_flag = Qt;
1781
1782 QUIT;
1783
1784 /* If we don't clear this, then the next call to read_char will
1785 return quit_char again, and we'll enter an infinite loop. */
1786 Vquit_flag = Qnil;
1787
1788 Fding (Qnil);
1789 Fdiscard_input ();
1790 if (EQ (xprompt, prompt))
1791 {
1792 args[0] = build_string ("Please answer y or n. ");
1793 args[1] = prompt;
1794 xprompt = Fconcat (2, args);
1795 }
1796 }
1797 UNGCPRO;
1798
1799 if (! noninteractive)
1800 {
1801 cursor_in_echo_area = -1;
1802 message_nolog ("%s(y or n) %c",
1803 XSTRING (xprompt)->data, answer ? 'y' : 'n');
1804 }
1805
1806 unbind_to (count, Qnil);
1807 return answer ? Qt : Qnil;
1808 }
1809 \f
1810 /* This is how C code calls `yes-or-no-p' and allows the user
1811 to redefined it.
1812
1813 Anything that calls this function must protect from GC! */
1814
1815 Lisp_Object
1816 do_yes_or_no_p (prompt)
1817 Lisp_Object prompt;
1818 {
1819 return call1 (intern ("yes-or-no-p"), prompt);
1820 }
1821
1822 /* Anything that calls this function must protect from GC! */
1823
1824 DEFUN ("yes-or-no-p", Fyes_or_no_p, Syes_or_no_p, 1, 1, 0,
1825 "Ask user a yes-or-no question. Return t if answer is yes.\n\
1826 Takes one argument, which is the string to display to ask the question.\n\
1827 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.\n\
1828 The user must confirm the answer with RET,\n\
1829 and can edit it until it has been confirmed.")
1830 (prompt)
1831 Lisp_Object prompt;
1832 {
1833 register Lisp_Object ans;
1834 Lisp_Object args[2];
1835 struct gcpro gcpro1;
1836 Lisp_Object menu;
1837
1838 CHECK_STRING (prompt, 0);
1839
1840 #ifdef HAVE_MENUS
1841 if ((NILP (last_nonmenu_event) || CONSP (last_nonmenu_event))
1842 && use_dialog_box
1843 && have_menus_p ())
1844 {
1845 Lisp_Object pane, menu, obj;
1846 redisplay_preserve_echo_area ();
1847 pane = Fcons (Fcons (build_string ("Yes"), Qt),
1848 Fcons (Fcons (build_string ("No"), Qnil),
1849 Qnil));
1850 GCPRO1 (pane);
1851 menu = Fcons (prompt, pane);
1852 obj = Fx_popup_dialog (Qt, menu);
1853 UNGCPRO;
1854 return obj;
1855 }
1856 #endif /* HAVE_MENUS */
1857
1858 args[0] = prompt;
1859 args[1] = build_string ("(yes or no) ");
1860 prompt = Fconcat (2, args);
1861
1862 GCPRO1 (prompt);
1863
1864 while (1)
1865 {
1866 ans = Fdowncase (Fread_from_minibuffer (prompt, Qnil, Qnil, Qnil,
1867 Qyes_or_no_p_history, Qnil));
1868 if (XSTRING (ans)->size == 3 && !strcmp (XSTRING (ans)->data, "yes"))
1869 {
1870 UNGCPRO;
1871 return Qt;
1872 }
1873 if (XSTRING (ans)->size == 2 && !strcmp (XSTRING (ans)->data, "no"))
1874 {
1875 UNGCPRO;
1876 return Qnil;
1877 }
1878
1879 Fding (Qnil);
1880 Fdiscard_input ();
1881 message ("Please answer yes or no.");
1882 Fsleep_for (make_number (2), Qnil);
1883 }
1884 }
1885 \f
1886 DEFUN ("load-average", Fload_average, Sload_average, 0, 0, 0,
1887 "Return list of 1 minute, 5 minute and 15 minute load averages.\n\
1888 Each of the three load averages is multiplied by 100,\n\
1889 then converted to integer.\n\
1890 If the 5-minute or 15-minute load averages are not available, return a\n\
1891 shortened list, containing only those averages which are available.")
1892 ()
1893 {
1894 double load_ave[3];
1895 int loads = getloadavg (load_ave, 3);
1896 Lisp_Object ret;
1897
1898 if (loads < 0)
1899 error ("load-average not implemented for this operating system");
1900
1901 ret = Qnil;
1902 while (loads > 0)
1903 ret = Fcons (make_number ((int) (load_ave[--loads] * 100.0)), ret);
1904
1905 return ret;
1906 }
1907 \f
1908 Lisp_Object Vfeatures;
1909
1910 DEFUN ("featurep", Ffeaturep, Sfeaturep, 1, 1, 0,
1911 "Returns t if FEATURE is present in this Emacs.\n\
1912 Use this to conditionalize execution of lisp code based on the presence or\n\
1913 absence of emacs or environment extensions.\n\
1914 Use `provide' to declare that a feature is available.\n\
1915 This function looks at the value of the variable `features'.")
1916 (feature)
1917 Lisp_Object feature;
1918 {
1919 register Lisp_Object tem;
1920 CHECK_SYMBOL (feature, 0);
1921 tem = Fmemq (feature, Vfeatures);
1922 return (NILP (tem)) ? Qnil : Qt;
1923 }
1924
1925 DEFUN ("provide", Fprovide, Sprovide, 1, 1, 0,
1926 "Announce that FEATURE is a feature of the current Emacs.")
1927 (feature)
1928 Lisp_Object feature;
1929 {
1930 register Lisp_Object tem;
1931 CHECK_SYMBOL (feature, 0);
1932 if (!NILP (Vautoload_queue))
1933 Vautoload_queue = Fcons (Fcons (Vfeatures, Qnil), Vautoload_queue);
1934 tem = Fmemq (feature, Vfeatures);
1935 if (NILP (tem))
1936 Vfeatures = Fcons (feature, Vfeatures);
1937 LOADHIST_ATTACH (Fcons (Qprovide, feature));
1938 return feature;
1939 }
1940
1941 DEFUN ("require", Frequire, Srequire, 1, 2, 0,
1942 "If feature FEATURE is not loaded, load it from FILENAME.\n\
1943 If FEATURE is not a member of the list `features', then the feature\n\
1944 is not loaded; so load the file FILENAME.\n\
1945 If FILENAME is omitted, the printname of FEATURE is used as the file name.")
1946 (feature, file_name)
1947 Lisp_Object feature, file_name;
1948 {
1949 register Lisp_Object tem;
1950 CHECK_SYMBOL (feature, 0);
1951 tem = Fmemq (feature, Vfeatures);
1952 LOADHIST_ATTACH (Fcons (Qrequire, feature));
1953 if (NILP (tem))
1954 {
1955 int count = specpdl_ptr - specpdl;
1956
1957 /* Value saved here is to be restored into Vautoload_queue */
1958 record_unwind_protect (un_autoload, Vautoload_queue);
1959 Vautoload_queue = Qt;
1960
1961 Fload (NILP (file_name) ? Fsymbol_name (feature) : file_name,
1962 Qnil, Qt, Qnil);
1963
1964 tem = Fmemq (feature, Vfeatures);
1965 if (NILP (tem))
1966 error ("Required feature %s was not provided",
1967 XSYMBOL (feature)->name->data );
1968
1969 /* Once loading finishes, don't undo it. */
1970 Vautoload_queue = Qt;
1971 feature = unbind_to (count, feature);
1972 }
1973 return feature;
1974 }
1975 \f
1976 syms_of_fns ()
1977 {
1978 Qstring_lessp = intern ("string-lessp");
1979 staticpro (&Qstring_lessp);
1980 Qprovide = intern ("provide");
1981 staticpro (&Qprovide);
1982 Qrequire = intern ("require");
1983 staticpro (&Qrequire);
1984 Qyes_or_no_p_history = intern ("yes-or-no-p-history");
1985 staticpro (&Qyes_or_no_p_history);
1986 Qcursor_in_echo_area = intern ("cursor-in-echo-area");
1987 staticpro (&Qcursor_in_echo_area);
1988
1989 Fset (Qyes_or_no_p_history, Qnil);
1990
1991 DEFVAR_LISP ("features", &Vfeatures,
1992 "A list of symbols which are the features of the executing emacs.\n\
1993 Used by `featurep' and `require', and altered by `provide'.");
1994 Vfeatures = Qnil;
1995
1996 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box,
1997 "*Non-nil means mouse commands use dialog boxes to ask questions.\n\
1998 This applies to y-or-n and yes-or-no questions asked by commands\n\
1999 invoked by mouse clicks and mouse menu items.");
2000 use_dialog_box = 1;
2001
2002 defsubr (&Sidentity);
2003 defsubr (&Srandom);
2004 defsubr (&Slength);
2005 defsubr (&Ssafe_length);
2006 defsubr (&Sstring_equal);
2007 defsubr (&Sstring_lessp);
2008 defsubr (&Sappend);
2009 defsubr (&Sconcat);
2010 defsubr (&Svconcat);
2011 defsubr (&Scopy_sequence);
2012 defsubr (&Scopy_alist);
2013 defsubr (&Ssubstring);
2014 defsubr (&Snthcdr);
2015 defsubr (&Snth);
2016 defsubr (&Selt);
2017 defsubr (&Smember);
2018 defsubr (&Smemq);
2019 defsubr (&Sassq);
2020 defsubr (&Sassoc);
2021 defsubr (&Srassq);
2022 defsubr (&Srassoc);
2023 defsubr (&Sdelq);
2024 defsubr (&Sdelete);
2025 defsubr (&Snreverse);
2026 defsubr (&Sreverse);
2027 defsubr (&Ssort);
2028 defsubr (&Splist_get);
2029 defsubr (&Sget);
2030 defsubr (&Splist_put);
2031 defsubr (&Sput);
2032 defsubr (&Sequal);
2033 defsubr (&Sfillarray);
2034 defsubr (&Schar_table_subtype);
2035 defsubr (&Schar_table_parent);
2036 defsubr (&Sset_char_table_parent);
2037 defsubr (&Schar_table_extra_slot);
2038 defsubr (&Sset_char_table_extra_slot);
2039 defsubr (&Schar_table_range);
2040 defsubr (&Sset_char_table_range);
2041 defsubr (&Sset_char_table_default);
2042 defsubr (&Smap_char_table);
2043 defsubr (&Snconc);
2044 defsubr (&Smapcar);
2045 defsubr (&Smapconcat);
2046 defsubr (&Sy_or_n_p);
2047 defsubr (&Syes_or_no_p);
2048 defsubr (&Sload_average);
2049 defsubr (&Sfeaturep);
2050 defsubr (&Srequire);
2051 defsubr (&Sprovide);
2052 }