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