src/fns.c

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