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