(internal_equal): Once again use a switch.
[bpt/emacs.git] / src / fns.c
CommitLineData
7b863bd5 1/* Random utility Lisp functions.
3a22ee35 2 Copyright (C) 1985, 1986, 1987, 1993, 1994 Free Software Foundation, Inc.
7b863bd5
JB
3
4This file is part of GNU Emacs.
5
6GNU Emacs is free software; you can redistribute it and/or modify
7it under the terms of the GNU General Public License as published by
4ff1aed9 8the Free Software Foundation; either version 2, or (at your option)
7b863bd5
JB
9any later version.
10
11GNU Emacs is distributed in the hope that it will be useful,
12but WITHOUT ANY WARRANTY; without even the implied warranty of
13MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14GNU General Public License for more details.
15
16You should have received a copy of the GNU General Public License
17along with GNU Emacs; see the file COPYING. If not, write to
18the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
19
20
18160b98 21#include <config.h>
7b863bd5 22
7b863bd5
JB
23/* Note on some machines this defines `vector' as a typedef,
24 so make sure we don't use that name in this file. */
25#undef vector
26#define vector *****
27
7b863bd5
JB
28#include "lisp.h"
29#include "commands.h"
30
7b863bd5 31#include "buffer.h"
f812877e 32#include "keyboard.h"
ac811a55 33#include "intervals.h"
7b863bd5 34
9309fdb1
KH
35extern Lisp_Object Flookup_key ();
36
68732608 37Lisp_Object Qstring_lessp, Qprovide, Qrequire;
0ce830bc 38Lisp_Object Qyes_or_no_p_history;
7b863bd5 39
6cb9cafb 40static int internal_equal ();
e0f5cf5a 41\f
7b863bd5
JB
42DEFUN ("identity", Fidentity, Sidentity, 1, 1, 0,
43 "Return the argument unchanged.")
44 (arg)
45 Lisp_Object arg;
46{
47 return arg;
48}
49
50DEFUN ("random", Frandom, Srandom, 0, 1, 0,
51 "Return a pseudo-random number.\n\
52On most systems all integers representable in Lisp are equally likely.\n\
53 This is 24 bits' worth.\n\
54With argument N, return random number in interval [0,N).\n\
55With argument t, set the random number seed from the current time and pid.")
ce7385cb
RS
56 (limit)
57 Lisp_Object limit;
7b863bd5
JB
58{
59 int val;
78217ef1 60 unsigned long denominator;
7b863bd5
JB
61 extern long random ();
62 extern srandom ();
63 extern long time ();
64
ce7385cb 65 if (EQ (limit, Qt))
7b863bd5 66 srandom (getpid () + time (0));
7650760e 67 if (INTEGERP (limit) && XINT (limit) > 0)
7b863bd5 68 {
9309fdb1 69 if (XFASTINT (limit) >= 0x40000000)
d1ab4ede 70 /* This case may occur on 64-bit machines. */
9309fdb1 71 val = random () % XFASTINT (limit);
d1ab4ede
RS
72 else
73 {
74 /* Try to take our random number from the higher bits of VAL,
75 not the lower, since (says Gentzel) the low bits of `random'
76 are less random than the higher ones. We do this by using the
77 quotient rather than the remainder. At the high end of the RNG
78 it's possible to get a quotient larger than limit; discarding
79 these values eliminates the bias that would otherwise appear
80 when using a large limit. */
81 denominator = (unsigned long)0x40000000 / XFASTINT (limit);
82 do
83 val = (random () & 0x3fffffff) / denominator;
9309fdb1 84 while (val >= XFASTINT (limit));
d1ab4ede 85 }
7b863bd5 86 }
78217ef1
KH
87 else
88 val = random ();
7b863bd5
JB
89 return make_number (val);
90}
91\f
92/* Random data-structure functions */
93
94DEFUN ("length", Flength, Slength, 1, 1, 0,
95 "Return the length of vector, list or string SEQUENCE.\n\
96A byte-code function object is also allowed.")
97 (obj)
98 register Lisp_Object obj;
99{
100 register Lisp_Object tail, val;
101 register int i;
102
103 retry:
a2ad3e19
KH
104 if (STRINGP (obj))
105 XSETFASTINT (val, XSTRING (obj)->size);
08623493 106 else if (VECTORP (obj))
a2ad3e19 107 XSETFASTINT (val, XVECTOR (obj)->size);
08623493
RS
108 else if (COMPILEDP (obj))
109 XSETFASTINT (val, XVECTOR (obj)->size & PSEUDOVECTOR_SIZE_MASK);
7b863bd5
JB
110 else if (CONSP (obj))
111 {
a2ad3e19 112 for (i = 0, tail = obj; !NILP (tail); i++)
7b863bd5
JB
113 {
114 QUIT;
115 tail = Fcdr (tail);
116 }
117
ad17573a 118 XSETFASTINT (val, i);
7b863bd5 119 }
a2ad3e19
KH
120 else if (NILP (obj))
121 XSETFASTINT (val, 0);
7b863bd5
JB
122 else
123 {
124 obj = wrong_type_argument (Qsequencep, obj);
125 goto retry;
126 }
a2ad3e19 127 return val;
7b863bd5
JB
128}
129
130DEFUN ("string-equal", Fstring_equal, Sstring_equal, 2, 2, 0,
131 "T if two strings have identical contents.\n\
76d0f732 132Case is significant, but text properties are ignored.\n\
7b863bd5
JB
133Symbols are also allowed; their print names are used instead.")
134 (s1, s2)
135 register Lisp_Object s1, s2;
136{
7650760e 137 if (SYMBOLP (s1))
b2791413 138 XSETSTRING (s1, XSYMBOL (s1)->name);
7650760e 139 if (SYMBOLP (s2))
b2791413 140 XSETSTRING (s2, XSYMBOL (s2)->name);
7b863bd5
JB
141 CHECK_STRING (s1, 0);
142 CHECK_STRING (s2, 1);
143
144 if (XSTRING (s1)->size != XSTRING (s2)->size ||
145 bcmp (XSTRING (s1)->data, XSTRING (s2)->data, XSTRING (s1)->size))
146 return Qnil;
147 return Qt;
148}
149
150DEFUN ("string-lessp", Fstring_lessp, Sstring_lessp, 2, 2, 0,
151 "T if first arg string is less than second in lexicographic order.\n\
152Case is significant.\n\
153Symbols are also allowed; their print names are used instead.")
154 (s1, s2)
155 register Lisp_Object s1, s2;
156{
157 register int i;
158 register unsigned char *p1, *p2;
159 register int end;
160
7650760e 161 if (SYMBOLP (s1))
b2791413 162 XSETSTRING (s1, XSYMBOL (s1)->name);
7650760e 163 if (SYMBOLP (s2))
b2791413 164 XSETSTRING (s2, XSYMBOL (s2)->name);
7b863bd5
JB
165 CHECK_STRING (s1, 0);
166 CHECK_STRING (s2, 1);
167
168 p1 = XSTRING (s1)->data;
169 p2 = XSTRING (s2)->data;
170 end = XSTRING (s1)->size;
171 if (end > XSTRING (s2)->size)
172 end = XSTRING (s2)->size;
173
174 for (i = 0; i < end; i++)
175 {
176 if (p1[i] != p2[i])
177 return p1[i] < p2[i] ? Qt : Qnil;
178 }
179 return i < XSTRING (s2)->size ? Qt : Qnil;
180}
181\f
182static Lisp_Object concat ();
183
184/* ARGSUSED */
185Lisp_Object
186concat2 (s1, s2)
187 Lisp_Object s1, s2;
188{
189#ifdef NO_ARG_ARRAY
190 Lisp_Object args[2];
191 args[0] = s1;
192 args[1] = s2;
193 return concat (2, args, Lisp_String, 0);
194#else
195 return concat (2, &s1, Lisp_String, 0);
196#endif /* NO_ARG_ARRAY */
197}
198
d4af3687
RS
199/* ARGSUSED */
200Lisp_Object
201concat3 (s1, s2, s3)
202 Lisp_Object s1, s2, s3;
203{
204#ifdef NO_ARG_ARRAY
205 Lisp_Object args[3];
206 args[0] = s1;
207 args[1] = s2;
208 args[2] = s3;
209 return concat (3, args, Lisp_String, 0);
210#else
211 return concat (3, &s1, Lisp_String, 0);
212#endif /* NO_ARG_ARRAY */
213}
214
7b863bd5
JB
215DEFUN ("append", Fappend, Sappend, 0, MANY, 0,
216 "Concatenate all the arguments and make the result a list.\n\
217The result is a list whose elements are the elements of all the arguments.\n\
218Each argument may be a list, vector or string.\n\
aec1184c 219The last argument is not copied, just used as the tail of the new list.")
7b863bd5
JB
220 (nargs, args)
221 int nargs;
222 Lisp_Object *args;
223{
224 return concat (nargs, args, Lisp_Cons, 1);
225}
226
227DEFUN ("concat", Fconcat, Sconcat, 0, MANY, 0,
228 "Concatenate all the arguments and make the result a string.\n\
229The result is a string whose elements are the elements of all the arguments.\n\
27d0b45a
RS
230Each argument may be a string, a list of characters (integers),\n\
231or a vector of characters (integers).")
7b863bd5
JB
232 (nargs, args)
233 int nargs;
234 Lisp_Object *args;
235{
236 return concat (nargs, args, Lisp_String, 0);
237}
238
239DEFUN ("vconcat", Fvconcat, Svconcat, 0, MANY, 0,
240 "Concatenate all the arguments and make the result a vector.\n\
241The result is a vector whose elements are the elements of all the arguments.\n\
242Each argument may be a list, vector or string.")
243 (nargs, args)
244 int nargs;
245 Lisp_Object *args;
246{
3e7383eb 247 return concat (nargs, args, Lisp_Vectorlike, 0);
7b863bd5
JB
248}
249
250DEFUN ("copy-sequence", Fcopy_sequence, Scopy_sequence, 1, 1, 0,
251 "Return a copy of a list, vector or string.\n\
252The elements of a list or vector are not copied; they are shared\n\
253with the original.")
254 (arg)
255 Lisp_Object arg;
256{
265a9e55 257 if (NILP (arg)) return arg;
7650760e 258 if (!CONSP (arg) && !VECTORP (arg) && !STRINGP (arg))
7b863bd5
JB
259 arg = wrong_type_argument (Qsequencep, arg);
260 return concat (1, &arg, CONSP (arg) ? Lisp_Cons : XTYPE (arg), 0);
261}
262
263static Lisp_Object
264concat (nargs, args, target_type, last_special)
265 int nargs;
266 Lisp_Object *args;
267 enum Lisp_Type target_type;
268 int last_special;
269{
270 Lisp_Object val;
271 Lisp_Object len;
272 register Lisp_Object tail;
273 register Lisp_Object this;
274 int toindex;
275 register int leni;
276 register int argnum;
277 Lisp_Object last_tail;
278 Lisp_Object prev;
279
280 /* In append, the last arg isn't treated like the others */
281 if (last_special && nargs > 0)
282 {
283 nargs--;
284 last_tail = args[nargs];
285 }
286 else
287 last_tail = Qnil;
288
289 for (argnum = 0; argnum < nargs; argnum++)
290 {
291 this = args[argnum];
7650760e
KH
292 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
293 || COMPILEDP (this)))
7b863bd5 294 {
7650760e 295 if (INTEGERP (this))
f2980264 296 args[argnum] = Fnumber_to_string (this);
7b863bd5
JB
297 else
298 args[argnum] = wrong_type_argument (Qsequencep, this);
299 }
300 }
301
302 for (argnum = 0, leni = 0; argnum < nargs; argnum++)
303 {
304 this = args[argnum];
305 len = Flength (this);
306 leni += XFASTINT (len);
307 }
308
ad17573a 309 XSETFASTINT (len, leni);
7b863bd5
JB
310
311 if (target_type == Lisp_Cons)
312 val = Fmake_list (len, Qnil);
3e7383eb 313 else if (target_type == Lisp_Vectorlike)
7b863bd5
JB
314 val = Fmake_vector (len, Qnil);
315 else
316 val = Fmake_string (len, len);
317
318 /* In append, if all but last arg are nil, return last arg */
319 if (target_type == Lisp_Cons && EQ (val, Qnil))
320 return last_tail;
321
322 if (CONSP (val))
323 tail = val, toindex = -1; /* -1 in toindex is flag we are making a list */
324 else
325 toindex = 0;
326
327 prev = Qnil;
328
329 for (argnum = 0; argnum < nargs; argnum++)
330 {
331 Lisp_Object thislen;
332 int thisleni;
333 register int thisindex = 0;
334
335 this = args[argnum];
336 if (!CONSP (this))
337 thislen = Flength (this), thisleni = XINT (thislen);
338
7650760e 339 if (STRINGP (this) && STRINGP (val)
ac811a55
JB
340 && ! NULL_INTERVAL_P (XSTRING (this)->intervals))
341 {
342 copy_text_properties (make_number (0), thislen, this,
343 make_number (toindex), val, Qnil);
344 }
345
7b863bd5
JB
346 while (1)
347 {
348 register Lisp_Object elt;
349
ac811a55
JB
350 /* Fetch next element of `this' arg into `elt', or break if
351 `this' is exhausted. */
265a9e55 352 if (NILP (this)) break;
7b863bd5
JB
353 if (CONSP (this))
354 elt = Fcar (this), this = Fcdr (this);
355 else
356 {
357 if (thisindex >= thisleni) break;
7650760e 358 if (STRINGP (this))
ad17573a 359 XSETFASTINT (elt, XSTRING (this)->data[thisindex++]);
7b863bd5
JB
360 else
361 elt = XVECTOR (this)->contents[thisindex++];
362 }
363
364 /* Store into result */
365 if (toindex < 0)
366 {
367 XCONS (tail)->car = elt;
368 prev = tail;
369 tail = XCONS (tail)->cdr;
370 }
7650760e 371 else if (VECTORP (val))
7b863bd5
JB
372 XVECTOR (val)->contents[toindex++] = elt;
373 else
374 {
7650760e 375 while (!INTEGERP (elt))
7b863bd5
JB
376 elt = wrong_type_argument (Qintegerp, elt);
377 {
378#ifdef MASSC_REGISTER_BUG
379 /* Even removing all "register"s doesn't disable this bug!
380 Nothing simpler than this seems to work. */
381 unsigned char *p = & XSTRING (val)->data[toindex++];
382 *p = XINT (elt);
383#else
384 XSTRING (val)->data[toindex++] = XINT (elt);
385#endif
386 }
387 }
388 }
389 }
265a9e55 390 if (!NILP (prev))
7b863bd5
JB
391 XCONS (prev)->cdr = last_tail;
392
393 return val;
394}
395\f
396DEFUN ("copy-alist", Fcopy_alist, Scopy_alist, 1, 1, 0,
397 "Return a copy of ALIST.\n\
398This is an alist which represents the same mapping from objects to objects,\n\
399but does not share the alist structure with ALIST.\n\
400The objects mapped (cars and cdrs of elements of the alist)\n\
401are shared, however.\n\
402Elements of ALIST that are not conses are also shared.")
403 (alist)
404 Lisp_Object alist;
405{
406 register Lisp_Object tem;
407
408 CHECK_LIST (alist, 0);
265a9e55 409 if (NILP (alist))
7b863bd5
JB
410 return alist;
411 alist = concat (1, &alist, Lisp_Cons, 0);
412 for (tem = alist; CONSP (tem); tem = XCONS (tem)->cdr)
413 {
414 register Lisp_Object car;
415 car = XCONS (tem)->car;
416
417 if (CONSP (car))
418 XCONS (tem)->car = Fcons (XCONS (car)->car, XCONS (car)->cdr);
419 }
420 return alist;
421}
422
423DEFUN ("substring", Fsubstring, Ssubstring, 2, 3, 0,
424 "Return a substring of STRING, starting at index FROM and ending before TO.\n\
425TO may be nil or omitted; then the substring runs to the end of STRING.\n\
426If FROM or TO is negative, it counts from the end.")
427 (string, from, to)
428 Lisp_Object string;
429 register Lisp_Object from, to;
430{
ac811a55
JB
431 Lisp_Object res;
432
7b863bd5
JB
433 CHECK_STRING (string, 0);
434 CHECK_NUMBER (from, 1);
265a9e55 435 if (NILP (to))
7b863bd5
JB
436 to = Flength (string);
437 else
438 CHECK_NUMBER (to, 2);
439
440 if (XINT (from) < 0)
441 XSETINT (from, XINT (from) + XSTRING (string)->size);
442 if (XINT (to) < 0)
443 XSETINT (to, XINT (to) + XSTRING (string)->size);
444 if (!(0 <= XINT (from) && XINT (from) <= XINT (to)
445 && XINT (to) <= XSTRING (string)->size))
446 args_out_of_range_3 (string, from, to);
447
ac811a55
JB
448 res = make_string (XSTRING (string)->data + XINT (from),
449 XINT (to) - XINT (from));
450 copy_text_properties (from, to, string, make_number (0), res, Qnil);
451 return res;
7b863bd5
JB
452}
453\f
454DEFUN ("nthcdr", Fnthcdr, Snthcdr, 2, 2, 0,
455 "Take cdr N times on LIST, returns the result.")
456 (n, list)
457 Lisp_Object n;
458 register Lisp_Object list;
459{
460 register int i, num;
461 CHECK_NUMBER (n, 0);
462 num = XINT (n);
265a9e55 463 for (i = 0; i < num && !NILP (list); i++)
7b863bd5
JB
464 {
465 QUIT;
466 list = Fcdr (list);
467 }
468 return list;
469}
470
471DEFUN ("nth", Fnth, Snth, 2, 2, 0,
472 "Return the Nth element of LIST.\n\
473N counts from zero. If LIST is not that long, nil is returned.")
474 (n, list)
475 Lisp_Object n, list;
476{
477 return Fcar (Fnthcdr (n, list));
478}
479
480DEFUN ("elt", Felt, Selt, 2, 2, 0,
481 "Return element of SEQUENCE at index N.")
482 (seq, n)
483 register Lisp_Object seq, n;
484{
485 CHECK_NUMBER (n, 0);
486 while (1)
487 {
7650760e 488 if (CONSP (seq) || NILP (seq))
7b863bd5 489 return Fcar (Fnthcdr (n, seq));
7650760e 490 else if (STRINGP (seq) || VECTORP (seq))
7b863bd5
JB
491 return Faref (seq, n);
492 else
493 seq = wrong_type_argument (Qsequencep, seq);
494 }
495}
496
497DEFUN ("member", Fmember, Smember, 2, 2, 0,
1d58e36f 498 "Return non-nil if ELT is an element of LIST. Comparison done with `equal'.\n\
7b863bd5
JB
499The value is actually the tail of LIST whose car is ELT.")
500 (elt, list)
501 register Lisp_Object elt;
502 Lisp_Object list;
503{
504 register Lisp_Object tail;
265a9e55 505 for (tail = list; !NILP (tail); tail = Fcdr (tail))
7b863bd5
JB
506 {
507 register Lisp_Object tem;
508 tem = Fcar (tail);
265a9e55 509 if (! NILP (Fequal (elt, tem)))
7b863bd5
JB
510 return tail;
511 QUIT;
512 }
513 return Qnil;
514}
515
516DEFUN ("memq", Fmemq, Smemq, 2, 2, 0,
517 "Return non-nil if ELT is an element of LIST. Comparison done with EQ.\n\
518The value is actually the tail of LIST whose car is ELT.")
519 (elt, list)
520 register Lisp_Object elt;
521 Lisp_Object list;
522{
523 register Lisp_Object tail;
265a9e55 524 for (tail = list; !NILP (tail); tail = Fcdr (tail))
7b863bd5
JB
525 {
526 register Lisp_Object tem;
527 tem = Fcar (tail);
528 if (EQ (elt, tem)) return tail;
529 QUIT;
530 }
531 return Qnil;
532}
533
534DEFUN ("assq", Fassq, Sassq, 2, 2, 0,
3797b4c3
RS
535 "Return non-nil if KEY is `eq' to the car of an element of LIST.\n\
536The value is actually the element of LIST whose car is KEY.\n\
7b863bd5
JB
537Elements of LIST that are not conses are ignored.")
538 (key, list)
539 register Lisp_Object key;
540 Lisp_Object list;
541{
542 register Lisp_Object tail;
265a9e55 543 for (tail = list; !NILP (tail); tail = Fcdr (tail))
7b863bd5
JB
544 {
545 register Lisp_Object elt, tem;
546 elt = Fcar (tail);
547 if (!CONSP (elt)) continue;
548 tem = Fcar (elt);
549 if (EQ (key, tem)) return elt;
550 QUIT;
551 }
552 return Qnil;
553}
554
555/* Like Fassq but never report an error and do not allow quits.
556 Use only on lists known never to be circular. */
557
558Lisp_Object
559assq_no_quit (key, list)
560 register Lisp_Object key;
561 Lisp_Object list;
562{
563 register Lisp_Object tail;
564 for (tail = list; CONSP (tail); tail = Fcdr (tail))
565 {
566 register Lisp_Object elt, tem;
567 elt = Fcar (tail);
568 if (!CONSP (elt)) continue;
569 tem = Fcar (elt);
570 if (EQ (key, tem)) return elt;
571 }
572 return Qnil;
573}
574
575DEFUN ("assoc", Fassoc, Sassoc, 2, 2, 0,
3797b4c3
RS
576 "Return non-nil if KEY is `equal' to the car of an element of LIST.\n\
577The value is actually the element of LIST whose car is KEY.")
7b863bd5
JB
578 (key, list)
579 register Lisp_Object key;
580 Lisp_Object list;
581{
582 register Lisp_Object tail;
265a9e55 583 for (tail = list; !NILP (tail); tail = Fcdr (tail))
7b863bd5
JB
584 {
585 register Lisp_Object elt, tem;
586 elt = Fcar (tail);
587 if (!CONSP (elt)) continue;
588 tem = Fequal (Fcar (elt), key);
265a9e55 589 if (!NILP (tem)) return elt;
7b863bd5
JB
590 QUIT;
591 }
592 return Qnil;
593}
594
595DEFUN ("rassq", Frassq, Srassq, 2, 2, 0,
596 "Return non-nil if ELT is `eq' to the cdr of an element of LIST.\n\
597The value is actually the element of LIST whose cdr is ELT.")
598 (key, list)
599 register Lisp_Object key;
600 Lisp_Object list;
601{
602 register Lisp_Object tail;
265a9e55 603 for (tail = list; !NILP (tail); tail = Fcdr (tail))
7b863bd5
JB
604 {
605 register Lisp_Object elt, tem;
606 elt = Fcar (tail);
607 if (!CONSP (elt)) continue;
608 tem = Fcdr (elt);
609 if (EQ (key, tem)) return elt;
610 QUIT;
611 }
612 return Qnil;
613}
614\f
615DEFUN ("delq", Fdelq, Sdelq, 2, 2, 0,
616 "Delete by side effect any occurrences of ELT as a member of LIST.\n\
617The modified LIST is returned. Comparison is done with `eq'.\n\
618If the first member of LIST is ELT, there is no way to remove it by side effect;\n\
619therefore, write `(setq foo (delq element foo))'\n\
620to be sure of changing the value of `foo'.")
621 (elt, list)
622 register Lisp_Object elt;
623 Lisp_Object list;
624{
625 register Lisp_Object tail, prev;
626 register Lisp_Object tem;
627
628 tail = list;
629 prev = Qnil;
265a9e55 630 while (!NILP (tail))
7b863bd5
JB
631 {
632 tem = Fcar (tail);
633 if (EQ (elt, tem))
634 {
265a9e55 635 if (NILP (prev))
7b863bd5
JB
636 list = Fcdr (tail);
637 else
638 Fsetcdr (prev, Fcdr (tail));
639 }
640 else
641 prev = tail;
642 tail = Fcdr (tail);
643 QUIT;
644 }
645 return list;
646}
647
ca8dd546 648DEFUN ("delete", Fdelete, Sdelete, 2, 2, 0,
1e134a5f
RM
649 "Delete by side effect any occurrences of ELT as a member of LIST.\n\
650The modified LIST is returned. Comparison is done with `equal'.\n\
1d58e36f
RS
651If the first member of LIST is ELT, deleting it is not a side effect;\n\
652it is simply using a different list.\n\
653Therefore, write `(setq foo (delete element foo))'\n\
1e134a5f
RM
654to be sure of changing the value of `foo'.")
655 (elt, list)
656 register Lisp_Object elt;
657 Lisp_Object list;
658{
659 register Lisp_Object tail, prev;
660 register Lisp_Object tem;
661
662 tail = list;
663 prev = Qnil;
265a9e55 664 while (!NILP (tail))
1e134a5f
RM
665 {
666 tem = Fcar (tail);
f812877e 667 if (! NILP (Fequal (elt, tem)))
1e134a5f 668 {
265a9e55 669 if (NILP (prev))
1e134a5f
RM
670 list = Fcdr (tail);
671 else
672 Fsetcdr (prev, Fcdr (tail));
673 }
674 else
675 prev = tail;
676 tail = Fcdr (tail);
677 QUIT;
678 }
679 return list;
680}
681
7b863bd5
JB
682DEFUN ("nreverse", Fnreverse, Snreverse, 1, 1, 0,
683 "Reverse LIST by modifying cdr pointers.\n\
684Returns the beginning of the reversed list.")
685 (list)
686 Lisp_Object list;
687{
688 register Lisp_Object prev, tail, next;
689
265a9e55 690 if (NILP (list)) return list;
7b863bd5
JB
691 prev = Qnil;
692 tail = list;
265a9e55 693 while (!NILP (tail))
7b863bd5
JB
694 {
695 QUIT;
696 next = Fcdr (tail);
697 Fsetcdr (tail, prev);
698 prev = tail;
699 tail = next;
700 }
701 return prev;
702}
703
704DEFUN ("reverse", Freverse, Sreverse, 1, 1, 0,
705 "Reverse LIST, copying. Returns the beginning of the reversed list.\n\
706See also the function `nreverse', which is used more often.")
707 (list)
708 Lisp_Object list;
709{
710 Lisp_Object length;
711 register Lisp_Object *vec;
712 register Lisp_Object tail;
713 register int i;
714
715 length = Flength (list);
716 vec = (Lisp_Object *) alloca (XINT (length) * sizeof (Lisp_Object));
717 for (i = XINT (length) - 1, tail = list; i >= 0; i--, tail = Fcdr (tail))
718 vec[i] = Fcar (tail);
719
720 return Flist (XINT (length), vec);
721}
722\f
723Lisp_Object merge ();
724
725DEFUN ("sort", Fsort, Ssort, 2, 2, 0,
726 "Sort LIST, stably, comparing elements using PREDICATE.\n\
727Returns the sorted list. LIST is modified by side effects.\n\
728PREDICATE is called with two elements of LIST, and should return T\n\
729if the first element is \"less\" than the second.")
730 (list, pred)
731 Lisp_Object list, pred;
732{
733 Lisp_Object front, back;
734 register Lisp_Object len, tem;
735 struct gcpro gcpro1, gcpro2;
736 register int length;
737
738 front = list;
739 len = Flength (list);
740 length = XINT (len);
741 if (length < 2)
742 return list;
743
744 XSETINT (len, (length / 2) - 1);
745 tem = Fnthcdr (len, list);
746 back = Fcdr (tem);
747 Fsetcdr (tem, Qnil);
748
749 GCPRO2 (front, back);
750 front = Fsort (front, pred);
751 back = Fsort (back, pred);
752 UNGCPRO;
753 return merge (front, back, pred);
754}
755
756Lisp_Object
757merge (org_l1, org_l2, pred)
758 Lisp_Object org_l1, org_l2;
759 Lisp_Object pred;
760{
761 Lisp_Object value;
762 register Lisp_Object tail;
763 Lisp_Object tem;
764 register Lisp_Object l1, l2;
765 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
766
767 l1 = org_l1;
768 l2 = org_l2;
769 tail = Qnil;
770 value = Qnil;
771
772 /* It is sufficient to protect org_l1 and org_l2.
773 When l1 and l2 are updated, we copy the new values
774 back into the org_ vars. */
775 GCPRO4 (org_l1, org_l2, pred, value);
776
777 while (1)
778 {
265a9e55 779 if (NILP (l1))
7b863bd5
JB
780 {
781 UNGCPRO;
265a9e55 782 if (NILP (tail))
7b863bd5
JB
783 return l2;
784 Fsetcdr (tail, l2);
785 return value;
786 }
265a9e55 787 if (NILP (l2))
7b863bd5
JB
788 {
789 UNGCPRO;
265a9e55 790 if (NILP (tail))
7b863bd5
JB
791 return l1;
792 Fsetcdr (tail, l1);
793 return value;
794 }
795 tem = call2 (pred, Fcar (l2), Fcar (l1));
265a9e55 796 if (NILP (tem))
7b863bd5
JB
797 {
798 tem = l1;
799 l1 = Fcdr (l1);
800 org_l1 = l1;
801 }
802 else
803 {
804 tem = l2;
805 l2 = Fcdr (l2);
806 org_l2 = l2;
807 }
265a9e55 808 if (NILP (tail))
7b863bd5
JB
809 value = tem;
810 else
811 Fsetcdr (tail, tem);
812 tail = tem;
813 }
814}
815\f
816DEFUN ("get", Fget, Sget, 2, 2, 0,
817 "Return the value of SYMBOL's PROPNAME property.\n\
818This is the last VALUE stored with `(put SYMBOL PROPNAME VALUE)'.")
819 (sym, prop)
820 Lisp_Object sym;
821 register Lisp_Object prop;
822{
823 register Lisp_Object tail;
265a9e55 824 for (tail = Fsymbol_plist (sym); !NILP (tail); tail = Fcdr (Fcdr (tail)))
7b863bd5
JB
825 {
826 register Lisp_Object tem;
827 tem = Fcar (tail);
828 if (EQ (prop, tem))
829 return Fcar (Fcdr (tail));
830 }
831 return Qnil;
832}
833
834DEFUN ("put", Fput, Sput, 3, 3, 0,
835 "Store SYMBOL's PROPNAME property with value VALUE.\n\
836It can be retrieved with `(get SYMBOL PROPNAME)'.")
837 (sym, prop, val)
838 Lisp_Object sym;
839 register Lisp_Object prop;
840 Lisp_Object val;
841{
842 register Lisp_Object tail, prev;
843 Lisp_Object newcell;
844 prev = Qnil;
265a9e55 845 for (tail = Fsymbol_plist (sym); !NILP (tail); tail = Fcdr (Fcdr (tail)))
7b863bd5
JB
846 {
847 register Lisp_Object tem;
848 tem = Fcar (tail);
849 if (EQ (prop, tem))
850 return Fsetcar (Fcdr (tail), val);
851 prev = tail;
852 }
853 newcell = Fcons (prop, Fcons (val, Qnil));
265a9e55 854 if (NILP (prev))
7b863bd5
JB
855 Fsetplist (sym, newcell);
856 else
857 Fsetcdr (Fcdr (prev), newcell);
858 return val;
859}
860
861DEFUN ("equal", Fequal, Sequal, 2, 2, 0,
862 "T if two Lisp objects have similar structure and contents.\n\
863They must have the same data type.\n\
864Conses are compared by comparing the cars and the cdrs.\n\
865Vectors and strings are compared element by element.\n\
d28c4332
RS
866Numbers are compared by value, but integers cannot equal floats.\n\
867 (Use `=' if you want integers and floats to be able to be equal.)\n\
868Symbols must match exactly.")
7b863bd5
JB
869 (o1, o2)
870 register Lisp_Object o1, o2;
871{
6cb9cafb 872 return internal_equal (o1, o2, 0) ? Qt : Qnil;
e0f5cf5a
RS
873}
874
6cb9cafb 875static int
e0f5cf5a
RS
876internal_equal (o1, o2, depth)
877 register Lisp_Object o1, o2;
878 int depth;
879{
880 if (depth > 200)
881 error ("Stack overflow in equal");
4ff1aed9 882
6cb9cafb 883 tail_recurse:
7b863bd5 884 QUIT;
4ff1aed9
RS
885 if (EQ (o1, o2))
886 return 1;
887 if (XTYPE (o1) != XTYPE (o2))
888 return 0;
889
890 switch (XTYPE (o1))
891 {
31ef7f7a 892#ifdef LISP_FLOAT_TYPE
4ff1aed9
RS
893 case Lisp_Float:
894 return (extract_float (o1) == extract_float (o2));
31ef7f7a 895#endif
4ff1aed9
RS
896
897 case Lisp_Cons:
898 {
899 if (!internal_equal (XCONS (o1)->car, XCONS (o2)->car, depth + 1))
900 return 0;
901 o1 = XCONS (o1)->cdr;
902 o2 = XCONS (o2)->cdr;
903 goto tail_recurse;
904 }
905
906 case Lisp_Misc:
907 if (MISCP (o1) && XMISC (o1)->type != XMISC (o2)->type)
6cb9cafb 908 return 0;
4ff1aed9 909 if (OVERLAYP (o1))
7b863bd5 910 {
4ff1aed9
RS
911 if (!internal_equal (OVERLAY_START (o1), OVERLAY_START (o1),
912 depth + 1)
913 || !internal_equal (OVERLAY_END (o1), OVERLAY_END (o1),
914 depth + 1))
6cb9cafb 915 return 0;
4ff1aed9
RS
916 o1 = XOVERLAY (o1)->plist;
917 o2 = XOVERLAY (o2)->plist;
918 goto tail_recurse;
7b863bd5 919 }
4ff1aed9
RS
920 if (MARKERP (o1))
921 {
922 return (XMARKER (o1)->buffer == XMARKER (o2)->buffer
923 && (XMARKER (o1)->buffer == 0
924 || XMARKER (o1)->bufpos == XMARKER (o2)->bufpos));
925 }
926 break;
927
928 case Lisp_Vectorlike:
929 if ((VECTORP (o1) && VECTORP (o2))
930 ||
931 (COMPILEDP (o1) && COMPILEDP (o2)))
932 {
933 register int index;
934 if (XVECTOR (o1)->size != XVECTOR (o2)->size)
935 return 0;
936 for (index = 0; index < XVECTOR (o1)->size; index++)
937 {
938 Lisp_Object v1, v2;
939 v1 = XVECTOR (o1)->contents [index];
940 v2 = XVECTOR (o2)->contents [index];
941 if (!internal_equal (v1, v2, depth + 1))
942 return 0;
943 }
944 return 1;
945 }
946 break;
947
948 case Lisp_String:
949 if (STRINGP (o1))
950 {
951 if (XSTRING (o1)->size != XSTRING (o2)->size)
952 return 0;
953 if (bcmp (XSTRING (o1)->data, XSTRING (o2)->data,
954 XSTRING (o1)->size))
955 return 0;
76d0f732 956#ifdef USE_TEXT_PROPERTIES
4ff1aed9
RS
957 /* If the strings have intervals, verify they match;
958 if not, they are unequal. */
959 if ((XSTRING (o1)->intervals != 0 || XSTRING (o2)->intervals != 0)
960 && ! compare_string_intervals (o1, o2))
961 return 0;
76d0f732 962#endif
4ff1aed9
RS
963 return 1;
964 }
7b863bd5 965 }
6cb9cafb 966 return 0;
7b863bd5
JB
967}
968\f
969DEFUN ("fillarray", Ffillarray, Sfillarray, 2, 2, 0,
970 "Store each element of ARRAY with ITEM. ARRAY is a vector or string.")
971 (array, item)
972 Lisp_Object array, item;
973{
974 register int size, index, charval;
975 retry:
7650760e 976 if (VECTORP (array))
7b863bd5
JB
977 {
978 register Lisp_Object *p = XVECTOR (array)->contents;
979 size = XVECTOR (array)->size;
980 for (index = 0; index < size; index++)
981 p[index] = item;
982 }
7650760e 983 else if (STRINGP (array))
7b863bd5
JB
984 {
985 register unsigned char *p = XSTRING (array)->data;
986 CHECK_NUMBER (item, 1);
987 charval = XINT (item);
988 size = XSTRING (array)->size;
989 for (index = 0; index < size; index++)
990 p[index] = charval;
991 }
992 else
993 {
994 array = wrong_type_argument (Qarrayp, array);
995 goto retry;
996 }
997 return array;
998}
999
1000/* ARGSUSED */
1001Lisp_Object
1002nconc2 (s1, s2)
1003 Lisp_Object s1, s2;
1004{
1005#ifdef NO_ARG_ARRAY
1006 Lisp_Object args[2];
1007 args[0] = s1;
1008 args[1] = s2;
1009 return Fnconc (2, args);
1010#else
1011 return Fnconc (2, &s1);
1012#endif /* NO_ARG_ARRAY */
1013}
1014
1015DEFUN ("nconc", Fnconc, Snconc, 0, MANY, 0,
1016 "Concatenate any number of lists by altering them.\n\
1017Only the last argument is not altered, and need not be a list.")
1018 (nargs, args)
1019 int nargs;
1020 Lisp_Object *args;
1021{
1022 register int argnum;
1023 register Lisp_Object tail, tem, val;
1024
1025 val = Qnil;
1026
1027 for (argnum = 0; argnum < nargs; argnum++)
1028 {
1029 tem = args[argnum];
265a9e55 1030 if (NILP (tem)) continue;
7b863bd5 1031
265a9e55 1032 if (NILP (val))
7b863bd5
JB
1033 val = tem;
1034
1035 if (argnum + 1 == nargs) break;
1036
1037 if (!CONSP (tem))
1038 tem = wrong_type_argument (Qlistp, tem);
1039
1040 while (CONSP (tem))
1041 {
1042 tail = tem;
1043 tem = Fcdr (tail);
1044 QUIT;
1045 }
1046
1047 tem = args[argnum + 1];
1048 Fsetcdr (tail, tem);
265a9e55 1049 if (NILP (tem))
7b863bd5
JB
1050 args[argnum + 1] = tail;
1051 }
1052
1053 return val;
1054}
1055\f
1056/* This is the guts of all mapping functions.
1057 Apply fn to each element of seq, one by one,
1058 storing the results into elements of vals, a C vector of Lisp_Objects.
1059 leni is the length of vals, which should also be the length of seq. */
1060
1061static void
1062mapcar1 (leni, vals, fn, seq)
1063 int leni;
1064 Lisp_Object *vals;
1065 Lisp_Object fn, seq;
1066{
1067 register Lisp_Object tail;
1068 Lisp_Object dummy;
1069 register int i;
1070 struct gcpro gcpro1, gcpro2, gcpro3;
1071
1072 /* Don't let vals contain any garbage when GC happens. */
1073 for (i = 0; i < leni; i++)
1074 vals[i] = Qnil;
1075
1076 GCPRO3 (dummy, fn, seq);
1077 gcpro1.var = vals;
1078 gcpro1.nvars = leni;
1079 /* We need not explicitly protect `tail' because it is used only on lists, and
1080 1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
1081
7650760e 1082 if (VECTORP (seq))
7b863bd5
JB
1083 {
1084 for (i = 0; i < leni; i++)
1085 {
1086 dummy = XVECTOR (seq)->contents[i];
1087 vals[i] = call1 (fn, dummy);
1088 }
1089 }
7650760e 1090 else if (STRINGP (seq))
7b863bd5
JB
1091 {
1092 for (i = 0; i < leni; i++)
1093 {
ad17573a 1094 XSETFASTINT (dummy, XSTRING (seq)->data[i]);
7b863bd5
JB
1095 vals[i] = call1 (fn, dummy);
1096 }
1097 }
1098 else /* Must be a list, since Flength did not get an error */
1099 {
1100 tail = seq;
1101 for (i = 0; i < leni; i++)
1102 {
1103 vals[i] = call1 (fn, Fcar (tail));
1104 tail = Fcdr (tail);
1105 }
1106 }
1107
1108 UNGCPRO;
1109}
1110
1111DEFUN ("mapconcat", Fmapconcat, Smapconcat, 3, 3, 0,
1112 "Apply FN to each element of SEQ, and concat the results as strings.\n\
1113In between each pair of results, stick in SEP.\n\
acbeb206 1114Thus, \" \" as SEP results in spaces between the values returned by FN.")
7b863bd5
JB
1115 (fn, seq, sep)
1116 Lisp_Object fn, seq, sep;
1117{
1118 Lisp_Object len;
1119 register int leni;
1120 int nargs;
1121 register Lisp_Object *args;
1122 register int i;
1123 struct gcpro gcpro1;
1124
1125 len = Flength (seq);
1126 leni = XINT (len);
1127 nargs = leni + leni - 1;
1128 if (nargs < 0) return build_string ("");
1129
1130 args = (Lisp_Object *) alloca (nargs * sizeof (Lisp_Object));
1131
1132 GCPRO1 (sep);
1133 mapcar1 (leni, args, fn, seq);
1134 UNGCPRO;
1135
1136 for (i = leni - 1; i >= 0; i--)
1137 args[i + i] = args[i];
1138
1139 for (i = 1; i < nargs; i += 2)
1140 args[i] = sep;
1141
1142 return Fconcat (nargs, args);
1143}
1144
1145DEFUN ("mapcar", Fmapcar, Smapcar, 2, 2, 0,
1146 "Apply FUNCTION to each element of SEQUENCE, and make a list of the results.\n\
1147The result is a list just as long as SEQUENCE.\n\
1148SEQUENCE may be a list, a vector or a string.")
1149 (fn, seq)
1150 Lisp_Object fn, seq;
1151{
1152 register Lisp_Object len;
1153 register int leni;
1154 register Lisp_Object *args;
1155
1156 len = Flength (seq);
1157 leni = XFASTINT (len);
1158 args = (Lisp_Object *) alloca (leni * sizeof (Lisp_Object));
1159
1160 mapcar1 (leni, args, fn, seq);
1161
1162 return Flist (leni, args);
1163}
1164\f
1165/* Anything that calls this function must protect from GC! */
1166
1167DEFUN ("y-or-n-p", Fy_or_n_p, Sy_or_n_p, 1, 1, 0,
1168 "Ask user a \"y or n\" question. Return t if answer is \"y\".\n\
c763f396
RS
1169Takes one argument, which is the string to display to ask the question.\n\
1170It should end in a space; `y-or-n-p' adds `(y or n) ' to it.\n\
7b863bd5
JB
1171No confirmation of the answer is requested; a single character is enough.\n\
1172Also accepts Space to mean yes, or Delete to mean no.")
1173 (prompt)
1174 Lisp_Object prompt;
1175{
f5313ed9
RS
1176 register Lisp_Object obj, key, def, answer_string, map;
1177 register int answer;
7b863bd5
JB
1178 Lisp_Object xprompt;
1179 Lisp_Object args[2];
1180 int ocech = cursor_in_echo_area;
1181 struct gcpro gcpro1, gcpro2;
1182
f5313ed9
RS
1183 map = Fsymbol_value (intern ("query-replace-map"));
1184
7b863bd5
JB
1185 CHECK_STRING (prompt, 0);
1186 xprompt = prompt;
1187 GCPRO2 (prompt, xprompt);
1188
1189 while (1)
1190 {
dfa89228 1191#ifdef HAVE_X_MENU
588064ce
RS
1192 if ((NILP (last_nonmenu_event) || CONSP (last_nonmenu_event))
1193 && using_x_p ())
1db4cfb2
RS
1194 {
1195 Lisp_Object pane, menu;
a3b14a45 1196 redisplay_preserve_echo_area ();
1db4cfb2
RS
1197 pane = Fcons (Fcons (build_string ("Yes"), Qt),
1198 Fcons (Fcons (build_string ("No"), Qnil),
1199 Qnil));
ec26e1b9 1200 menu = Fcons (prompt, pane);
d2f28f78 1201 obj = Fx_popup_dialog (Qt, menu);
1db4cfb2
RS
1202 answer = !NILP (obj);
1203 break;
1204 }
dfa89228
KH
1205#endif
1206 cursor_in_echo_area = 1;
1207 message ("%s(y or n) ", XSTRING (xprompt)->data);
7b863bd5 1208
dfa89228
KH
1209 obj = read_filtered_event (1, 0, 0);
1210 cursor_in_echo_area = 0;
1211 /* If we need to quit, quit with cursor_in_echo_area = 0. */
1212 QUIT;
a63f658b 1213
f5313ed9
RS
1214 key = Fmake_vector (make_number (1), obj);
1215 def = Flookup_key (map, key);
1216 answer_string = Fsingle_key_description (obj);
7b863bd5 1217
f5313ed9
RS
1218 if (EQ (def, intern ("skip")))
1219 {
1220 answer = 0;
1221 break;
1222 }
1223 else if (EQ (def, intern ("act")))
1224 {
1225 answer = 1;
1226 break;
1227 }
29944b73
RS
1228 else if (EQ (def, intern ("recenter")))
1229 {
1230 Frecenter (Qnil);
1231 xprompt = prompt;
1232 continue;
1233 }
f5313ed9 1234 else if (EQ (def, intern ("quit")))
7b863bd5 1235 Vquit_flag = Qt;
ec63af1b
RS
1236 /* We want to exit this command for exit-prefix,
1237 and this is the only way to do it. */
1238 else if (EQ (def, intern ("exit-prefix")))
1239 Vquit_flag = Qt;
f5313ed9 1240
7b863bd5 1241 QUIT;
20aa96aa
JB
1242
1243 /* If we don't clear this, then the next call to read_char will
1244 return quit_char again, and we'll enter an infinite loop. */
088880f1 1245 Vquit_flag = Qnil;
7b863bd5
JB
1246
1247 Fding (Qnil);
1248 Fdiscard_input ();
1249 if (EQ (xprompt, prompt))
1250 {
1251 args[0] = build_string ("Please answer y or n. ");
1252 args[1] = prompt;
1253 xprompt = Fconcat (2, args);
1254 }
1255 }
1256 UNGCPRO;
6a8a9750 1257
09c95874
RS
1258 if (! noninteractive)
1259 {
1260 cursor_in_echo_area = -1;
1261 message ("%s(y or n) %c", XSTRING (xprompt)->data, answer ? 'y' : 'n');
1262 cursor_in_echo_area = ocech;
1263 }
6a8a9750 1264
f5313ed9 1265 return answer ? Qt : Qnil;
7b863bd5
JB
1266}
1267\f
1268/* This is how C code calls `yes-or-no-p' and allows the user
1269 to redefined it.
1270
1271 Anything that calls this function must protect from GC! */
1272
1273Lisp_Object
1274do_yes_or_no_p (prompt)
1275 Lisp_Object prompt;
1276{
1277 return call1 (intern ("yes-or-no-p"), prompt);
1278}
1279
1280/* Anything that calls this function must protect from GC! */
1281
1282DEFUN ("yes-or-no-p", Fyes_or_no_p, Syes_or_no_p, 1, 1, 0,
c763f396
RS
1283 "Ask user a yes-or-no question. Return t if answer is yes.\n\
1284Takes one argument, which is the string to display to ask the question.\n\
1285It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.\n\
1286The user must confirm the answer with RET,\n\
1287and can edit it until it as been confirmed.")
7b863bd5
JB
1288 (prompt)
1289 Lisp_Object prompt;
1290{
1291 register Lisp_Object ans;
1292 Lisp_Object args[2];
1293 struct gcpro gcpro1;
1db4cfb2 1294 Lisp_Object menu;
7b863bd5
JB
1295
1296 CHECK_STRING (prompt, 0);
1297
dfa89228 1298#ifdef HAVE_X_MENU
588064ce
RS
1299 if ((NILP (last_nonmenu_event) || CONSP (last_nonmenu_event))
1300 && using_x_p ())
1db4cfb2
RS
1301 {
1302 Lisp_Object pane, menu, obj;
a3b14a45 1303 redisplay_preserve_echo_area ();
1db4cfb2
RS
1304 pane = Fcons (Fcons (build_string ("Yes"), Qt),
1305 Fcons (Fcons (build_string ("No"), Qnil),
1306 Qnil));
1307 GCPRO1 (pane);
ec26e1b9 1308 menu = Fcons (prompt, pane);
b5ccb0a9 1309 obj = Fx_popup_dialog (Qt, menu);
1db4cfb2
RS
1310 UNGCPRO;
1311 return obj;
1312 }
dfa89228 1313#endif
1db4cfb2 1314
7b863bd5
JB
1315 args[0] = prompt;
1316 args[1] = build_string ("(yes or no) ");
1317 prompt = Fconcat (2, args);
1318
1319 GCPRO1 (prompt);
1db4cfb2 1320
7b863bd5
JB
1321 while (1)
1322 {
0ce830bc
RS
1323 ans = Fdowncase (Fread_from_minibuffer (prompt, Qnil, Qnil, Qnil,
1324 Qyes_or_no_p_history));
7b863bd5
JB
1325 if (XSTRING (ans)->size == 3 && !strcmp (XSTRING (ans)->data, "yes"))
1326 {
1327 UNGCPRO;
1328 return Qt;
1329 }
1330 if (XSTRING (ans)->size == 2 && !strcmp (XSTRING (ans)->data, "no"))
1331 {
1332 UNGCPRO;
1333 return Qnil;
1334 }
1335
1336 Fding (Qnil);
1337 Fdiscard_input ();
1338 message ("Please answer yes or no.");
99dc4745 1339 Fsleep_for (make_number (2), Qnil);
7b863bd5 1340 }
7b863bd5
JB
1341}
1342\f
7b863bd5
JB
1343DEFUN ("load-average", Fload_average, Sload_average, 0, 0, 0,
1344 "Return list of 1 minute, 5 minute and 15 minute load averages.\n\
1345Each of the three load averages is multiplied by 100,\n\
daa37602
JB
1346then converted to integer.\n\
1347If the 5-minute or 15-minute load averages are not available, return a\n\
1348shortened list, containing only those averages which are available.")
7b863bd5
JB
1349 ()
1350{
daa37602
JB
1351 double load_ave[3];
1352 int loads = getloadavg (load_ave, 3);
1353 Lisp_Object ret;
7b863bd5 1354
daa37602
JB
1355 if (loads < 0)
1356 error ("load-average not implemented for this operating system");
1357
1358 ret = Qnil;
1359 while (loads > 0)
1360 ret = Fcons (make_number ((int) (load_ave[--loads] * 100.0)), ret);
1361
1362 return ret;
1363}
7b863bd5
JB
1364\f
1365Lisp_Object Vfeatures;
1366
1367DEFUN ("featurep", Ffeaturep, Sfeaturep, 1, 1, 0,
1368 "Returns t if FEATURE is present in this Emacs.\n\
1369Use this to conditionalize execution of lisp code based on the presence or\n\
1370absence of emacs or environment extensions.\n\
1371Use `provide' to declare that a feature is available.\n\
1372This function looks at the value of the variable `features'.")
1373 (feature)
1374 Lisp_Object feature;
1375{
1376 register Lisp_Object tem;
1377 CHECK_SYMBOL (feature, 0);
1378 tem = Fmemq (feature, Vfeatures);
265a9e55 1379 return (NILP (tem)) ? Qnil : Qt;
7b863bd5
JB
1380}
1381
1382DEFUN ("provide", Fprovide, Sprovide, 1, 1, 0,
1383 "Announce that FEATURE is a feature of the current Emacs.")
1384 (feature)
1385 Lisp_Object feature;
1386{
1387 register Lisp_Object tem;
1388 CHECK_SYMBOL (feature, 0);
265a9e55 1389 if (!NILP (Vautoload_queue))
7b863bd5
JB
1390 Vautoload_queue = Fcons (Fcons (Vfeatures, Qnil), Vautoload_queue);
1391 tem = Fmemq (feature, Vfeatures);
265a9e55 1392 if (NILP (tem))
7b863bd5 1393 Vfeatures = Fcons (feature, Vfeatures);
68732608 1394 LOADHIST_ATTACH (Fcons (Qprovide, feature));
7b863bd5
JB
1395 return feature;
1396}
1397
1398DEFUN ("require", Frequire, Srequire, 1, 2, 0,
1399 "If feature FEATURE is not loaded, load it from FILENAME.\n\
1400If FEATURE is not a member of the list `features', then the feature\n\
1401is not loaded; so load the file FILENAME.\n\
1402If FILENAME is omitted, the printname of FEATURE is used as the file name.")
1403 (feature, file_name)
1404 Lisp_Object feature, file_name;
1405{
1406 register Lisp_Object tem;
1407 CHECK_SYMBOL (feature, 0);
1408 tem = Fmemq (feature, Vfeatures);
68732608 1409 LOADHIST_ATTACH (Fcons (Qrequire, feature));
265a9e55 1410 if (NILP (tem))
7b863bd5
JB
1411 {
1412 int count = specpdl_ptr - specpdl;
1413
1414 /* Value saved here is to be restored into Vautoload_queue */
1415 record_unwind_protect (un_autoload, Vautoload_queue);
1416 Vautoload_queue = Qt;
1417
265a9e55 1418 Fload (NILP (file_name) ? Fsymbol_name (feature) : file_name,
7b863bd5
JB
1419 Qnil, Qt, Qnil);
1420
1421 tem = Fmemq (feature, Vfeatures);
265a9e55 1422 if (NILP (tem))
7b863bd5
JB
1423 error ("Required feature %s was not provided",
1424 XSYMBOL (feature)->name->data );
1425
1426 /* Once loading finishes, don't undo it. */
1427 Vautoload_queue = Qt;
1428 feature = unbind_to (count, feature);
1429 }
1430 return feature;
1431}
1432\f
1433syms_of_fns ()
1434{
1435 Qstring_lessp = intern ("string-lessp");
1436 staticpro (&Qstring_lessp);
68732608
RS
1437 Qprovide = intern ("provide");
1438 staticpro (&Qprovide);
1439 Qrequire = intern ("require");
1440 staticpro (&Qrequire);
0ce830bc
RS
1441 Qyes_or_no_p_history = intern ("yes-or-no-p-history");
1442 staticpro (&Qyes_or_no_p_history);
7b863bd5
JB
1443
1444 DEFVAR_LISP ("features", &Vfeatures,
1445 "A list of symbols which are the features of the executing emacs.\n\
1446Used by `featurep' and `require', and altered by `provide'.");
1447 Vfeatures = Qnil;
1448
1449 defsubr (&Sidentity);
1450 defsubr (&Srandom);
1451 defsubr (&Slength);
1452 defsubr (&Sstring_equal);
1453 defsubr (&Sstring_lessp);
1454 defsubr (&Sappend);
1455 defsubr (&Sconcat);
1456 defsubr (&Svconcat);
1457 defsubr (&Scopy_sequence);
1458 defsubr (&Scopy_alist);
1459 defsubr (&Ssubstring);
1460 defsubr (&Snthcdr);
1461 defsubr (&Snth);
1462 defsubr (&Selt);
1463 defsubr (&Smember);
1464 defsubr (&Smemq);
1465 defsubr (&Sassq);
1466 defsubr (&Sassoc);
1467 defsubr (&Srassq);
1468 defsubr (&Sdelq);
ca8dd546 1469 defsubr (&Sdelete);
7b863bd5
JB
1470 defsubr (&Snreverse);
1471 defsubr (&Sreverse);
1472 defsubr (&Ssort);
1473 defsubr (&Sget);
1474 defsubr (&Sput);
1475 defsubr (&Sequal);
1476 defsubr (&Sfillarray);
1477 defsubr (&Snconc);
1478 defsubr (&Smapcar);
1479 defsubr (&Smapconcat);
1480 defsubr (&Sy_or_n_p);
1481 defsubr (&Syes_or_no_p);
1482 defsubr (&Sload_average);
1483 defsubr (&Sfeaturep);
1484 defsubr (&Srequire);
1485 defsubr (&Sprovide);
1486}