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; !NILP (tail); tail = Fcdr (Fcdr (tail)))
 884     {
 885       register Lisp_Object tem;
 886       tem = Fcar (tail);
 887       if (EQ (prop, tem))
 888         {
 889           Fsetcar (Fcdr (tail), val);
 890           return plist;
 891         }
 892       prev = tail;
 893     }
 894   newcell = Fcons (prop, Fcons (val, Qnil));
 895   if (NILP (prev))
 896     return newcell;
 897   else
 898     Fsetcdr (Fcdr (prev), newcell);
 899   return plist;
 900 }
 901
 902 DEFUN ("put", Fput, Sput, 3, 3, 0,
 903   "Store SYMBOL's PROPNAME property with value VALUE.\n\
 904 It can be retrieved with `(get SYMBOL PROPNAME)'.")
 905   (symbol, propname, value)
 906      Lisp_Object symbol, propname, value;
 907 {
 908   CHECK_SYMBOL (symbol, 0);
 909   XSYMBOL (symbol)->plist
 910     = Fplist_put (XSYMBOL (symbol)->plist, propname, value);
 911   return value;
 912 }
 913
 914 DEFUN ("equal", Fequal, Sequal, 2, 2, 0,
 915   "T if two Lisp objects have similar structure and contents.\n\
 916 They must have the same data type.\n\
 917 Conses are compared by comparing the cars and the cdrs.\n\
 918 Vectors and strings are compared element by element.\n\
 919 Numbers are compared by value, but integers cannot equal floats.\n\
 920  (Use `=' if you want integers and floats to be able to be equal.)\n\
 921 Symbols must match exactly.")
 922   (o1, o2)
 923      register Lisp_Object o1, o2;
 924 {
 925   return internal_equal (o1, o2, 0) ? Qt : Qnil;
 926 }
 927
 928 static int
 929 internal_equal (o1, o2, depth)
 930      register Lisp_Object o1, o2;
 931      int depth;
 932 {
 933   if (depth > 200)
 934     error ("Stack overflow in equal");
 935
 936  tail_recurse:
 937   QUIT;
 938   if (EQ (o1, o2))
 939     return 1;
 940   if (XTYPE (o1) != XTYPE (o2))
 941     return 0;
 942
 943   switch (XTYPE (o1))
 944     {
 945 #ifdef LISP_FLOAT_TYPE
 946     case Lisp_Float:
 947       return (extract_float (o1) == extract_float (o2));
 948 #endif
 949
 950     case Lisp_Cons:
 951       if (!internal_equal (XCONS (o1)->car, XCONS (o2)->car, depth + 1))
 952         return 0;
 953       o1 = XCONS (o1)->cdr;
 954       o2 = XCONS (o2)->cdr;
 955       goto tail_recurse;
 956
 957     case Lisp_Misc:
 958       if (XMISC (o1)->type != XMISC (o2)->type)
 959         return 0;
 960       if (OVERLAYP (o1))
 961         {
 962           if (!internal_equal (OVERLAY_START (o1), OVERLAY_START (o1),
 963                                depth + 1)
 964               || !internal_equal (OVERLAY_END (o1), OVERLAY_END (o1),
 965                                   depth + 1))
 966             return 0;
 967           o1 = XOVERLAY (o1)->plist;
 968           o2 = XOVERLAY (o2)->plist;
 969           goto tail_recurse;
 970         }
 971       if (MARKERP (o1))
 972         {
 973           return (XMARKER (o1)->buffer == XMARKER (o2)->buffer
 974                   && (XMARKER (o1)->buffer == 0
 975                       || XMARKER (o1)->bufpos == XMARKER (o2)->bufpos));
 976         }
 977       break;
 978
 979     case Lisp_Vectorlike:
 980       {
 981         register int i, size;
 982         size = XVECTOR (o1)->size;
 983         /* Pseudovectors have the type encoded in the size field, so this test
 984            actually checks that the objects have the same type as well as the
 985            same size.  */
 986         if (XVECTOR (o2)->size != size)
 987           return 0;
 988         /* But only true vectors and compiled functions are actually sensible
 989            to compare, so eliminate the others now.  */
 990         if (size & PSEUDOVECTOR_FLAG)
 991           {
 992             if (!(size & PVEC_COMPILED))
 993               return 0;
 994             size &= PSEUDOVECTOR_SIZE_MASK;
 995           }
 996         for (i = 0; i < size; i++)
 997           {
 998             Lisp_Object v1, v2;
 999             v1 = XVECTOR (o1)->contents [i];
1000             v2 = XVECTOR (o2)->contents [i];
1001             if (!internal_equal (v1, v2, depth + 1))
1002               return 0;
1003           }
1004         return 1;
1005       }
1006       break;
1007
1008     case Lisp_String:
1009       if (XSTRING (o1)->size != XSTRING (o2)->size)
1010         return 0;
1011       if (bcmp (XSTRING (o1)->data, XSTRING (o2)->data,
1012                 XSTRING (o1)->size))
1013         return 0;
1014 #ifdef USE_TEXT_PROPERTIES
1015       /* If the strings have intervals, verify they match;
1016          if not, they are unequal.  */
1017       if ((XSTRING (o1)->intervals != 0 || XSTRING (o2)->intervals != 0)
1018           && ! compare_string_intervals (o1, o2))
1019         return 0;
1020 #endif
1021       return 1;
1022     }
1023   return 0;
1024 }
1025 \f
1026 DEFUN ("fillarray", Ffillarray, Sfillarray, 2, 2, 0,
1027   "Store each element of ARRAY with ITEM.  ARRAY is a vector or string.")
1028   (array, item)
1029      Lisp_Object array, item;
1030 {
1031   register int size, index, charval;
1032  retry:
1033   if (VECTORP (array))
1034     {
1035       register Lisp_Object *p = XVECTOR (array)->contents;
1036       size = XVECTOR (array)->size;
1037       for (index = 0; index < size; index++)
1038         p[index] = item;
1039     }
1040   else if (STRINGP (array))
1041     {
1042       register unsigned char *p = XSTRING (array)->data;
1043       CHECK_NUMBER (item, 1);
1044       charval = XINT (item);
1045       size = XSTRING (array)->size;
1046       for (index = 0; index < size; index++)
1047         p[index] = charval;
1048     }
1049   else
1050     {
1051       array = wrong_type_argument (Qarrayp, array);
1052       goto retry;
1053     }
1054   return array;
1055 }
1056
1057 /* ARGSUSED */
1058 Lisp_Object
1059 nconc2 (s1, s2)
1060      Lisp_Object s1, s2;
1061 {
1062 #ifdef NO_ARG_ARRAY
1063   Lisp_Object args[2];
1064   args[0] = s1;
1065   args[1] = s2;
1066   return Fnconc (2, args);
1067 #else
1068   return Fnconc (2, &s1);
1069 #endif /* NO_ARG_ARRAY */
1070 }
1071
1072 DEFUN ("nconc", Fnconc, Snconc, 0, MANY, 0,
1073   "Concatenate any number of lists by altering them.\n\
1074 Only the last argument is not altered, and need not be a list.")
1075   (nargs, args)
1076      int nargs;
1077      Lisp_Object *args;
1078 {
1079   register int argnum;
1080   register Lisp_Object tail, tem, val;
1081
1082   val = Qnil;
1083
1084   for (argnum = 0; argnum < nargs; argnum++)
1085     {
1086       tem = args[argnum];
1087       if (NILP (tem)) continue;
1088
1089       if (NILP (val))
1090         val = tem;
1091
1092       if (argnum + 1 == nargs) break;
1093
1094       if (!CONSP (tem))
1095         tem = wrong_type_argument (Qlistp, tem);
1096
1097       while (CONSP (tem))
1098         {
1099           tail = tem;
1100           tem = Fcdr (tail);
1101           QUIT;
1102         }
1103
1104       tem = args[argnum + 1];
1105       Fsetcdr (tail, tem);
1106       if (NILP (tem))
1107         args[argnum + 1] = tail;
1108     }
1109
1110   return val;
1111 }
1112 \f
1113 /* This is the guts of all mapping functions.
1114  Apply fn to each element of seq, one by one,
1115  storing the results into elements of vals, a C vector of Lisp_Objects.
1116  leni is the length of vals, which should also be the length of seq. */
1117
1118 static void
1119 mapcar1 (leni, vals, fn, seq)
1120      int leni;
1121      Lisp_Object *vals;
1122      Lisp_Object fn, seq;
1123 {
1124   register Lisp_Object tail;
1125   Lisp_Object dummy;
1126   register int i;
1127   struct gcpro gcpro1, gcpro2, gcpro3;
1128
1129   /* Don't let vals contain any garbage when GC happens.  */
1130   for (i = 0; i < leni; i++)
1131     vals[i] = Qnil;
1132
1133   GCPRO3 (dummy, fn, seq);
1134   gcpro1.var = vals;
1135   gcpro1.nvars = leni;
1136   /* We need not explicitly protect `tail' because it is used only on lists, and
1137     1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
1138
1139   if (VECTORP (seq))
1140     {
1141       for (i = 0; i < leni; i++)
1142         {
1143           dummy = XVECTOR (seq)->contents[i];
1144           vals[i] = call1 (fn, dummy);
1145         }
1146     }
1147   else if (STRINGP (seq))
1148     {
1149       for (i = 0; i < leni; i++)
1150         {
1151           XSETFASTINT (dummy, XSTRING (seq)->data[i]);
1152           vals[i] = call1 (fn, dummy);
1153         }
1154     }
1155   else   /* Must be a list, since Flength did not get an error */
1156     {
1157       tail = seq;
1158       for (i = 0; i < leni; i++)
1159         {
1160           vals[i] = call1 (fn, Fcar (tail));
1161           tail = Fcdr (tail);
1162         }
1163     }
1164
1165   UNGCPRO;
1166 }
1167
1168 DEFUN ("mapconcat", Fmapconcat, Smapconcat, 3, 3, 0,
1169   "Apply FN to each element of SEQ, and concat the results as strings.\n\
1170 In between each pair of results, stick in SEP.\n\
1171 Thus, \" \" as SEP results in spaces between the values returned by FN.")
1172   (fn, seq, sep)
1173      Lisp_Object fn, seq, sep;
1174 {
1175   Lisp_Object len;
1176   register int leni;
1177   int nargs;
1178   register Lisp_Object *args;
1179   register int i;
1180   struct gcpro gcpro1;
1181
1182   len = Flength (seq);
1183   leni = XINT (len);
1184   nargs = leni + leni - 1;
1185   if (nargs < 0) return build_string ("");
1186
1187   args = (Lisp_Object *) alloca (nargs * sizeof (Lisp_Object));
1188
1189   GCPRO1 (sep);
1190   mapcar1 (leni, args, fn, seq);
1191   UNGCPRO;
1192
1193   for (i = leni - 1; i >= 0; i--)
1194     args[i + i] = args[i];
1195
1196   for (i = 1; i < nargs; i += 2)
1197     args[i] = sep;
1198
1199   return Fconcat (nargs, args);
1200 }
1201
1202 DEFUN ("mapcar", Fmapcar, Smapcar, 2, 2, 0,
1203   "Apply FUNCTION to each element of SEQUENCE, and make a list of the results.\n\
1204 The result is a list just as long as SEQUENCE.\n\
1205 SEQUENCE may be a list, a vector or a string.")
1206   (fn, seq)
1207      Lisp_Object fn, seq;
1208 {
1209   register Lisp_Object len;
1210   register int leni;
1211   register Lisp_Object *args;
1212
1213   len = Flength (seq);
1214   leni = XFASTINT (len);
1215   args = (Lisp_Object *) alloca (leni * sizeof (Lisp_Object));
1216
1217   mapcar1 (leni, args, fn, seq);
1218
1219   return Flist (leni, args);
1220 }
1221 \f
1222 /* Anything that calls this function must protect from GC!  */
1223
1224 DEFUN ("y-or-n-p", Fy_or_n_p, Sy_or_n_p, 1, 1, 0,
1225   "Ask user a \"y or n\" question.  Return t if answer is \"y\".\n\
1226 Takes one argument, which is the string to display to ask the question.\n\
1227 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.\n\
1228 No confirmation of the answer is requested; a single character is enough.\n\
1229 Also accepts Space to mean yes, or Delete to mean no.")
1230   (prompt)
1231      Lisp_Object prompt;
1232 {
1233   register Lisp_Object obj, key, def, answer_string, map;
1234   register int answer;
1235   Lisp_Object xprompt;
1236   Lisp_Object args[2];
1237   int ocech = cursor_in_echo_area;
1238   struct gcpro gcpro1, gcpro2;
1239
1240   map = Fsymbol_value (intern ("query-replace-map"));
1241
1242   CHECK_STRING (prompt, 0);
1243   xprompt = prompt;
1244   GCPRO2 (prompt, xprompt);
1245
1246   while (1)
1247     {
1248 #ifdef HAVE_X_MENU
1249       if ((NILP (last_nonmenu_event) || CONSP (last_nonmenu_event))
1250           && using_x_p ())
1251         {
1252           Lisp_Object pane, menu;
1253           redisplay_preserve_echo_area ();
1254           pane = Fcons (Fcons (build_string ("Yes"), Qt),
1255                         Fcons (Fcons (build_string ("No"), Qnil),
1256                                Qnil));
1257           menu = Fcons (prompt, pane);
1258           obj = Fx_popup_dialog (Qt, menu);
1259           answer = !NILP (obj);
1260           break;
1261         }
1262 #endif
1263       cursor_in_echo_area = 1;
1264       message_nolog ("%s(y or n) ", XSTRING (xprompt)->data);
1265
1266       obj = read_filtered_event (1, 0, 0);
1267       cursor_in_echo_area = 0;
1268       /* If we need to quit, quit with cursor_in_echo_area = 0.  */
1269       QUIT;
1270
1271       key = Fmake_vector (make_number (1), obj);
1272       def = Flookup_key (map, key);
1273       answer_string = Fsingle_key_description (obj);
1274
1275       if (EQ (def, intern ("skip")))
1276         {
1277           answer = 0;
1278           break;
1279         }
1280       else if (EQ (def, intern ("act")))
1281         {
1282           answer = 1;
1283           break;
1284         }
1285       else if (EQ (def, intern ("recenter")))
1286         {
1287           Frecenter (Qnil);
1288           xprompt = prompt;
1289           continue;
1290         }
1291       else if (EQ (def, intern ("quit")))
1292         Vquit_flag = Qt;
1293       /* We want to exit this command for exit-prefix,
1294          and this is the only way to do it.  */
1295       else if (EQ (def, intern ("exit-prefix")))
1296         Vquit_flag = Qt;
1297
1298       QUIT;
1299
1300       /* If we don't clear this, then the next call to read_char will
1301          return quit_char again, and we'll enter an infinite loop.  */
1302       Vquit_flag = Qnil;
1303
1304       Fding (Qnil);
1305       Fdiscard_input ();
1306       if (EQ (xprompt, prompt))
1307         {
1308           args[0] = build_string ("Please answer y or n.  ");
1309           args[1] = prompt;
1310           xprompt = Fconcat (2, args);
1311         }
1312     }
1313   UNGCPRO;
1314
1315   if (! noninteractive)
1316     {
1317       cursor_in_echo_area = -1;
1318       message_nolog ("%s(y or n) %c",
1319                      XSTRING (xprompt)->data, answer ? 'y' : 'n');
1320       cursor_in_echo_area = ocech;
1321     }
1322
1323   return answer ? Qt : Qnil;
1324 }
1325 \f
1326 /* This is how C code calls `yes-or-no-p' and allows the user
1327    to redefined it.
1328
1329    Anything that calls this function must protect from GC!  */
1330
1331 Lisp_Object
1332 do_yes_or_no_p (prompt)
1333      Lisp_Object prompt;
1334 {
1335   return call1 (intern ("yes-or-no-p"), prompt);
1336 }
1337
1338 /* Anything that calls this function must protect from GC!  */
1339
1340 DEFUN ("yes-or-no-p", Fyes_or_no_p, Syes_or_no_p, 1, 1, 0,
1341   "Ask user a yes-or-no question.  Return t if answer is yes.\n\
1342 Takes one argument, which is the string to display to ask the question.\n\
1343 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.\n\
1344 The user must confirm the answer with RET,\n\
1345 and can edit it until it has been confirmed.")
1346   (prompt)
1347      Lisp_Object prompt;
1348 {
1349   register Lisp_Object ans;
1350   Lisp_Object args[2];
1351   struct gcpro gcpro1;
1352   Lisp_Object menu;
1353
1354   CHECK_STRING (prompt, 0);
1355
1356 #ifdef HAVE_X_MENU
1357   if ((NILP (last_nonmenu_event) || CONSP (last_nonmenu_event))
1358       && using_x_p ())
1359     {
1360       Lisp_Object pane, menu, obj;
1361       redisplay_preserve_echo_area ();
1362       pane = Fcons (Fcons (build_string ("Yes"), Qt),
1363                     Fcons (Fcons (build_string ("No"), Qnil),
1364                            Qnil));
1365       GCPRO1 (pane);
1366       menu = Fcons (prompt, pane);
1367       obj = Fx_popup_dialog (Qt, menu);
1368       UNGCPRO;
1369       return obj;
1370     }
1371 #endif
1372
1373   args[0] = prompt;
1374   args[1] = build_string ("(yes or no) ");
1375   prompt = Fconcat (2, args);
1376
1377   GCPRO1 (prompt);
1378
1379   while (1)
1380     {
1381       ans = Fdowncase (Fread_from_minibuffer (prompt, Qnil, Qnil, Qnil,
1382                                               Qyes_or_no_p_history));
1383       if (XSTRING (ans)->size == 3 && !strcmp (XSTRING (ans)->data, "yes"))
1384         {
1385           UNGCPRO;
1386           return Qt;
1387         }
1388       if (XSTRING (ans)->size == 2 && !strcmp (XSTRING (ans)->data, "no"))
1389         {
1390           UNGCPRO;
1391           return Qnil;
1392         }
1393
1394       Fding (Qnil);
1395       Fdiscard_input ();
1396       message ("Please answer yes or no.");
1397       Fsleep_for (make_number (2), Qnil);
1398     }
1399 }
1400 \f
1401 DEFUN ("load-average", Fload_average, Sload_average, 0, 0, 0,
1402   "Return list of 1 minute, 5 minute and 15 minute load averages.\n\
1403 Each of the three load averages is multiplied by 100,\n\
1404 then converted to integer.\n\
1405 If the 5-minute or 15-minute load averages are not available, return a\n\
1406 shortened list, containing only those averages which are available.")
1407   ()
1408 {
1409   double load_ave[3];
1410   int loads = getloadavg (load_ave, 3);
1411   Lisp_Object ret;
1412
1413   if (loads < 0)
1414     error ("load-average not implemented for this operating system");
1415
1416   ret = Qnil;
1417   while (loads > 0)
1418     ret = Fcons (make_number ((int) (load_ave[--loads] * 100.0)), ret);
1419
1420   return ret;
1421 }
1422 \f
1423 Lisp_Object Vfeatures;
1424
1425 DEFUN ("featurep", Ffeaturep, Sfeaturep, 1, 1, 0,
1426   "Returns t if FEATURE is present in this Emacs.\n\
1427 Use this to conditionalize execution of lisp code based on the presence or\n\
1428 absence of emacs or environment extensions.\n\
1429 Use `provide' to declare that a feature is available.\n\
1430 This function looks at the value of the variable `features'.")
1431      (feature)
1432      Lisp_Object feature;
1433 {
1434   register Lisp_Object tem;
1435   CHECK_SYMBOL (feature, 0);
1436   tem = Fmemq (feature, Vfeatures);
1437   return (NILP (tem)) ? Qnil : Qt;
1438 }
1439
1440 DEFUN ("provide", Fprovide, Sprovide, 1, 1, 0,
1441   "Announce that FEATURE is a feature of the current Emacs.")
1442      (feature)
1443      Lisp_Object feature;
1444 {
1445   register Lisp_Object tem;
1446   CHECK_SYMBOL (feature, 0);
1447   if (!NILP (Vautoload_queue))
1448     Vautoload_queue = Fcons (Fcons (Vfeatures, Qnil), Vautoload_queue);
1449   tem = Fmemq (feature, Vfeatures);
1450   if (NILP (tem))
1451     Vfeatures = Fcons (feature, Vfeatures);
1452   LOADHIST_ATTACH (Fcons (Qprovide, feature));
1453   return feature;
1454 }
1455
1456 DEFUN ("require", Frequire, Srequire, 1, 2, 0,
1457   "If feature FEATURE is not loaded, load it from FILENAME.\n\
1458 If FEATURE is not a member of the list `features', then the feature\n\
1459 is not loaded; so load the file FILENAME.\n\
1460 If FILENAME is omitted, the printname of FEATURE is used as the file name.")
1461      (feature, file_name)
1462      Lisp_Object feature, file_name;
1463 {
1464   register Lisp_Object tem;
1465   CHECK_SYMBOL (feature, 0);
1466   tem = Fmemq (feature, Vfeatures);
1467   LOADHIST_ATTACH (Fcons (Qrequire, feature));
1468   if (NILP (tem))
1469     {
1470       int count = specpdl_ptr - specpdl;
1471
1472       /* Value saved here is to be restored into Vautoload_queue */
1473       record_unwind_protect (un_autoload, Vautoload_queue);
1474       Vautoload_queue = Qt;
1475
1476       Fload (NILP (file_name) ? Fsymbol_name (feature) : file_name,
1477              Qnil, Qt, Qnil);
1478
1479       tem = Fmemq (feature, Vfeatures);
1480       if (NILP (tem))
1481         error ("Required feature %s was not provided",
1482                XSYMBOL (feature)->name->data );
1483
1484       /* Once loading finishes, don't undo it.  */
1485       Vautoload_queue = Qt;
1486       feature = unbind_to (count, feature);
1487     }
1488   return feature;
1489 }
1490 \f
1491 syms_of_fns ()
1492 {
1493   Qstring_lessp = intern ("string-lessp");
1494   staticpro (&Qstring_lessp);
1495   Qprovide = intern ("provide");
1496   staticpro (&Qprovide);
1497   Qrequire = intern ("require");
1498   staticpro (&Qrequire);
1499   Qyes_or_no_p_history = intern ("yes-or-no-p-history");
1500   staticpro (&Qyes_or_no_p_history);
1501
1502   DEFVAR_LISP ("features", &Vfeatures,
1503     "A list of symbols which are the features of the executing emacs.\n\
1504 Used by `featurep' and `require', and altered by `provide'.");
1505   Vfeatures = Qnil;
1506
1507   defsubr (&Sidentity);
1508   defsubr (&Srandom);
1509   defsubr (&Slength);
1510   defsubr (&Sstring_equal);
1511   defsubr (&Sstring_lessp);
1512   defsubr (&Sappend);
1513   defsubr (&Sconcat);
1514   defsubr (&Svconcat);
1515   defsubr (&Scopy_sequence);
1516   defsubr (&Scopy_alist);
1517   defsubr (&Ssubstring);
1518   defsubr (&Snthcdr);
1519   defsubr (&Snth);
1520   defsubr (&Selt);
1521   defsubr (&Smember);
1522   defsubr (&Smemq);
1523   defsubr (&Sassq);
1524   defsubr (&Sassoc);
1525   defsubr (&Srassq);
1526   defsubr (&Srassoc);
1527   defsubr (&Sdelq);
1528   defsubr (&Sdelete);
1529   defsubr (&Snreverse);
1530   defsubr (&Sreverse);
1531   defsubr (&Ssort);
1532   defsubr (&Splist_get);
1533   defsubr (&Sget);
1534   defsubr (&Splist_put);
1535   defsubr (&Sput);
1536   defsubr (&Sequal);
1537   defsubr (&Sfillarray);
1538   defsubr (&Snconc);
1539   defsubr (&Smapcar);
1540   defsubr (&Smapconcat);
1541   defsubr (&Sy_or_n_p);
1542   defsubr (&Syes_or_no_p);
1543   defsubr (&Sload_average);
1544   defsubr (&Sfeaturep);
1545   defsubr (&Srequire);
1546   defsubr (&Sprovide);
1547 }