src/fns.c

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