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