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 (EQ (o1, o2)) return Qt;
 840 #ifdef LISP_FLOAT_TYPE
 841   if (NUMBERP (o1) && NUMBERP (o2))
 842     {
 843       return (extract_float (o1) == extract_float (o2)) ? Qt : Qnil;
 844     }
 845 #endif
 846   if (XTYPE (o1) != XTYPE (o2)) return Qnil;
 847   if (XTYPE (o1) == Lisp_Cons)
 848     {
 849       Lisp_Object v1;
 850       v1 = internal_equal (Fcar (o1), Fcar (o2), depth + 1);
 851       if (NILP (v1))
 852         return v1;
 853       o1 = Fcdr (o1), o2 = Fcdr (o2);
 854       goto do_cdr;
 855     }
 856   if (XTYPE (o1) == Lisp_Marker)
 857     {
 858       return (XMARKER (o1)->buffer == XMARKER (o2)->buffer
 859               && XMARKER (o1)->bufpos == XMARKER (o2)->bufpos)
 860         ? Qt : Qnil;
 861     }
 862   if (XTYPE (o1) == Lisp_Vector
 863       || XTYPE (o1) == Lisp_Compiled)
 864     {
 865       register int index;
 866       if (XVECTOR (o1)->size != XVECTOR (o2)->size)
 867         return Qnil;
 868       for (index = 0; index < XVECTOR (o1)->size; index++)
 869         {
 870           Lisp_Object v, v1, v2;
 871           v1 = XVECTOR (o1)->contents [index];
 872           v2 = XVECTOR (o2)->contents [index];
 873           v = internal_equal (v1, v2, depth + 1);
 874           if (NILP (v)) return v;
 875         }
 876       return Qt;
 877     }
 878   if (XTYPE (o1) == Lisp_String)
 879     {
 880       if (XSTRING (o1)->size != XSTRING (o2)->size)
 881         return Qnil;
 882       if (bcmp (XSTRING (o1)->data, XSTRING (o2)->data, XSTRING (o1)->size))
 883         return Qnil;
 884       return Qt;
 885     }
 886   return Qnil;
 887 }
 888 \f
 889 DEFUN ("fillarray", Ffillarray, Sfillarray, 2, 2, 0,
 890   "Store each element of ARRAY with ITEM.  ARRAY is a vector or string.")
 891   (array, item)
 892      Lisp_Object array, item;
 893 {
 894   register int size, index, charval;
 895  retry:
 896   if (XTYPE (array) == Lisp_Vector)
 897     {
 898       register Lisp_Object *p = XVECTOR (array)->contents;
 899       size = XVECTOR (array)->size;
 900       for (index = 0; index < size; index++)
 901         p[index] = item;
 902     }
 903   else if (XTYPE (array) == Lisp_String)
 904     {
 905       register unsigned char *p = XSTRING (array)->data;
 906       CHECK_NUMBER (item, 1);
 907       charval = XINT (item);
 908       size = XSTRING (array)->size;
 909       for (index = 0; index < size; index++)
 910         p[index] = charval;
 911     }
 912   else
 913     {
 914       array = wrong_type_argument (Qarrayp, array);
 915       goto retry;
 916     }
 917   return array;
 918 }
 919
 920 /* ARGSUSED */
 921 Lisp_Object
 922 nconc2 (s1, s2)
 923      Lisp_Object s1, s2;
 924 {
 925 #ifdef NO_ARG_ARRAY
 926   Lisp_Object args[2];
 927   args[0] = s1;
 928   args[1] = s2;
 929   return Fnconc (2, args);
 930 #else
 931   return Fnconc (2, &s1);
 932 #endif /* NO_ARG_ARRAY */
 933 }
 934
 935 DEFUN ("nconc", Fnconc, Snconc, 0, MANY, 0,
 936   "Concatenate any number of lists by altering them.\n\
 937 Only the last argument is not altered, and need not be a list.")
 938   (nargs, args)
 939      int nargs;
 940      Lisp_Object *args;
 941 {
 942   register int argnum;
 943   register Lisp_Object tail, tem, val;
 944
 945   val = Qnil;
 946
 947   for (argnum = 0; argnum < nargs; argnum++)
 948     {
 949       tem = args[argnum];
 950       if (NILP (tem)) continue;
 951
 952       if (NILP (val))
 953         val = tem;
 954
 955       if (argnum + 1 == nargs) break;
 956
 957       if (!CONSP (tem))
 958         tem = wrong_type_argument (Qlistp, tem);
 959
 960       while (CONSP (tem))
 961         {
 962           tail = tem;
 963           tem = Fcdr (tail);
 964           QUIT;
 965         }
 966
 967       tem = args[argnum + 1];
 968       Fsetcdr (tail, tem);
 969       if (NILP (tem))
 970         args[argnum + 1] = tail;
 971     }
 972
 973   return val;
 974 }
 975 \f
 976 /* This is the guts of all mapping functions.
 977  Apply fn to each element of seq, one by one,
 978  storing the results into elements of vals, a C vector of Lisp_Objects.
 979  leni is the length of vals, which should also be the length of seq. */
 980
 981 static void
 982 mapcar1 (leni, vals, fn, seq)
 983      int leni;
 984      Lisp_Object *vals;
 985      Lisp_Object fn, seq;
 986 {
 987   register Lisp_Object tail;
 988   Lisp_Object dummy;
 989   register int i;
 990   struct gcpro gcpro1, gcpro2, gcpro3;
 991
 992   /* Don't let vals contain any garbage when GC happens.  */
 993   for (i = 0; i < leni; i++)
 994     vals[i] = Qnil;
 995
 996   GCPRO3 (dummy, fn, seq);
 997   gcpro1.var = vals;
 998   gcpro1.nvars = leni;
 999   /* We need not explicitly protect `tail' because it is used only on lists, and
1000     1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
1001
1002   if (XTYPE (seq) == Lisp_Vector)
1003     {
1004       for (i = 0; i < leni; i++)
1005         {
1006           dummy = XVECTOR (seq)->contents[i];
1007           vals[i] = call1 (fn, dummy);
1008         }
1009     }
1010   else if (XTYPE (seq) == Lisp_String)
1011     {
1012       for (i = 0; i < leni; i++)
1013         {
1014           XFASTINT (dummy) = XSTRING (seq)->data[i];
1015           vals[i] = call1 (fn, dummy);
1016         }
1017     }
1018   else   /* Must be a list, since Flength did not get an error */
1019     {
1020       tail = seq;
1021       for (i = 0; i < leni; i++)
1022         {
1023           vals[i] = call1 (fn, Fcar (tail));
1024           tail = Fcdr (tail);
1025         }
1026     }
1027
1028   UNGCPRO;
1029 }
1030
1031 DEFUN ("mapconcat", Fmapconcat, Smapconcat, 3, 3, 0,
1032   "Apply FN to each element of SEQ, and concat the results as strings.\n\
1033 In between each pair of results, stick in SEP.\n\
1034 Thus, \" \" as SEP results in spaces between the values return by FN.")
1035   (fn, seq, sep)
1036      Lisp_Object fn, seq, sep;
1037 {
1038   Lisp_Object len;
1039   register int leni;
1040   int nargs;
1041   register Lisp_Object *args;
1042   register int i;
1043   struct gcpro gcpro1;
1044
1045   len = Flength (seq);
1046   leni = XINT (len);
1047   nargs = leni + leni - 1;
1048   if (nargs < 0) return build_string ("");
1049
1050   args = (Lisp_Object *) alloca (nargs * sizeof (Lisp_Object));
1051
1052   GCPRO1 (sep);
1053   mapcar1 (leni, args, fn, seq);
1054   UNGCPRO;
1055
1056   for (i = leni - 1; i >= 0; i--)
1057     args[i + i] = args[i];
1058
1059   for (i = 1; i < nargs; i += 2)
1060     args[i] = sep;
1061
1062   return Fconcat (nargs, args);
1063 }
1064
1065 DEFUN ("mapcar", Fmapcar, Smapcar, 2, 2, 0,
1066   "Apply FUNCTION to each element of SEQUENCE, and make a list of the results.\n\
1067 The result is a list just as long as SEQUENCE.\n\
1068 SEQUENCE may be a list, a vector or a string.")
1069   (fn, seq)
1070      Lisp_Object fn, seq;
1071 {
1072   register Lisp_Object len;
1073   register int leni;
1074   register Lisp_Object *args;
1075
1076   len = Flength (seq);
1077   leni = XFASTINT (len);
1078   args = (Lisp_Object *) alloca (leni * sizeof (Lisp_Object));
1079
1080   mapcar1 (leni, args, fn, seq);
1081
1082   return Flist (leni, args);
1083 }
1084 \f
1085 /* Anything that calls this function must protect from GC!  */
1086
1087 DEFUN ("y-or-n-p", Fy_or_n_p, Sy_or_n_p, 1, 1, 0,
1088   "Ask user a \"y or n\" question.  Return t if answer is \"y\".\n\
1089 Takes one argument, which is the string to display to ask the question.\n\
1090 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.\n\
1091 No confirmation of the answer is requested; a single character is enough.\n\
1092 Also accepts Space to mean yes, or Delete to mean no.")
1093   (prompt)
1094      Lisp_Object prompt;
1095 {
1096   register Lisp_Object obj;
1097   register int ans;
1098   Lisp_Object xprompt;
1099   Lisp_Object args[2];
1100   int ocech = cursor_in_echo_area;
1101   struct gcpro gcpro1, gcpro2;
1102
1103   CHECK_STRING (prompt, 0);
1104   xprompt = prompt;
1105   GCPRO2 (prompt, xprompt);
1106
1107   while (1)
1108     {
1109       message ("%s(y or n) ", XSTRING (xprompt)->data);
1110       cursor_in_echo_area = 1;
1111
1112       obj = read_char (0, 0, 0, Qnil, 0);
1113       if (XTYPE (obj) == Lisp_Int)
1114         ans = XINT (obj);
1115       else
1116         continue;
1117
1118       cursor_in_echo_area = -1;
1119       message ("%s(y or n) %c", XSTRING (xprompt)->data, ans);
1120       cursor_in_echo_area = ocech;
1121       /* Accept a C-g or C-] (abort-recursive-edit) as quit requests.  */
1122       if (ans == 7 || ans == '\035')
1123         Vquit_flag = Qt;
1124       QUIT;
1125
1126       /* If we don't clear this, then the next call to read_char will
1127          return quit_char again, and we'll enter an infinite loop.  */
1128       Vquit_flag = Qnil;
1129       if (ans >= 0)
1130         ans = DOWNCASE (ans);
1131       if (ans == 'y' || ans == ' ')
1132         { ans = 'y'; break; }
1133       if (ans == 'n' || ans == 127)
1134         break;
1135
1136       Fding (Qnil);
1137       Fdiscard_input ();
1138       if (EQ (xprompt, prompt))
1139         {
1140           args[0] = build_string ("Please answer y or n.  ");
1141           args[1] = prompt;
1142           xprompt = Fconcat (2, args);
1143         }
1144     }
1145   UNGCPRO;
1146   return (ans == 'y' ? Qt : Qnil);
1147 }
1148 \f
1149 /* This is how C code calls `yes-or-no-p' and allows the user
1150    to redefined it.
1151
1152    Anything that calls this function must protect from GC!  */
1153
1154 Lisp_Object
1155 do_yes_or_no_p (prompt)
1156      Lisp_Object prompt;
1157 {
1158   return call1 (intern ("yes-or-no-p"), prompt);
1159 }
1160
1161 /* Anything that calls this function must protect from GC!  */
1162
1163 DEFUN ("yes-or-no-p", Fyes_or_no_p, Syes_or_no_p, 1, 1, 0,
1164   "Ask user a yes-or-no question.  Return t if answer is yes.\n\
1165 Takes one argument, which is the string to display to ask the question.\n\
1166 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.\n\
1167 The user must confirm the answer with RET,\n\
1168 and can edit it until it as been confirmed.")
1169   (prompt)
1170      Lisp_Object prompt;
1171 {
1172   register Lisp_Object ans;
1173   Lisp_Object args[2];
1174   struct gcpro gcpro1;
1175
1176   CHECK_STRING (prompt, 0);
1177
1178   args[0] = prompt;
1179   args[1] = build_string ("(yes or no) ");
1180   prompt = Fconcat (2, args);
1181
1182   GCPRO1 (prompt);
1183   while (1)
1184     {
1185       ans = Fdowncase (Fread_string (prompt, Qnil));
1186       if (XSTRING (ans)->size == 3 && !strcmp (XSTRING (ans)->data, "yes"))
1187         {
1188           UNGCPRO;
1189           return Qt;
1190         }
1191       if (XSTRING (ans)->size == 2 && !strcmp (XSTRING (ans)->data, "no"))
1192         {
1193           UNGCPRO;
1194           return Qnil;
1195         }
1196
1197       Fding (Qnil);
1198       Fdiscard_input ();
1199       message ("Please answer yes or no.");
1200       Fsleep_for (make_number (2), Qnil);
1201     }
1202   UNGCPRO;
1203 }
1204 \f
1205 DEFUN ("load-average", Fload_average, Sload_average, 0, 0, 0,
1206   "Return list of 1 minute, 5 minute and 15 minute load averages.\n\
1207 Each of the three load averages is multiplied by 100,\n\
1208 then converted to integer.\n\
1209 If the 5-minute or 15-minute load averages are not available, return a\n\
1210 shortened list, containing only those averages which are available.")
1211   ()
1212 {
1213   double load_ave[3];
1214   int loads = getloadavg (load_ave, 3);
1215   Lisp_Object ret;
1216
1217   if (loads < 0)
1218     error ("load-average not implemented for this operating system");
1219
1220   ret = Qnil;
1221   while (loads > 0)
1222     ret = Fcons (make_number ((int) (load_ave[--loads] * 100.0)), ret);
1223
1224   return ret;
1225 }
1226 \f
1227 Lisp_Object Vfeatures;
1228
1229 DEFUN ("featurep", Ffeaturep, Sfeaturep, 1, 1, 0,
1230   "Returns t if FEATURE is present in this Emacs.\n\
1231 Use this to conditionalize execution of lisp code based on the presence or\n\
1232 absence of emacs or environment extensions.\n\
1233 Use `provide' to declare that a feature is available.\n\
1234 This function looks at the value of the variable `features'.")
1235      (feature)
1236      Lisp_Object feature;
1237 {
1238   register Lisp_Object tem;
1239   CHECK_SYMBOL (feature, 0);
1240   tem = Fmemq (feature, Vfeatures);
1241   return (NILP (tem)) ? Qnil : Qt;
1242 }
1243
1244 DEFUN ("provide", Fprovide, Sprovide, 1, 1, 0,
1245   "Announce that FEATURE is a feature of the current Emacs.")
1246      (feature)
1247      Lisp_Object feature;
1248 {
1249   register Lisp_Object tem;
1250   CHECK_SYMBOL (feature, 0);
1251   if (!NILP (Vautoload_queue))
1252     Vautoload_queue = Fcons (Fcons (Vfeatures, Qnil), Vautoload_queue);
1253   tem = Fmemq (feature, Vfeatures);
1254   if (NILP (tem))
1255     Vfeatures = Fcons (feature, Vfeatures);
1256   return feature;
1257 }
1258
1259 DEFUN ("require", Frequire, Srequire, 1, 2, 0,
1260   "If feature FEATURE is not loaded, load it from FILENAME.\n\
1261 If FEATURE is not a member of the list `features', then the feature\n\
1262 is not loaded; so load the file FILENAME.\n\
1263 If FILENAME is omitted, the printname of FEATURE is used as the file name.")
1264      (feature, file_name)
1265      Lisp_Object feature, file_name;
1266 {
1267   register Lisp_Object tem;
1268   CHECK_SYMBOL (feature, 0);
1269   tem = Fmemq (feature, Vfeatures);
1270   if (NILP (tem))
1271     {
1272       int count = specpdl_ptr - specpdl;
1273
1274       /* Value saved here is to be restored into Vautoload_queue */
1275       record_unwind_protect (un_autoload, Vautoload_queue);
1276       Vautoload_queue = Qt;
1277
1278       Fload (NILP (file_name) ? Fsymbol_name (feature) : file_name,
1279              Qnil, Qt, Qnil);
1280
1281       tem = Fmemq (feature, Vfeatures);
1282       if (NILP (tem))
1283         error ("Required feature %s was not provided",
1284                XSYMBOL (feature)->name->data );
1285
1286       /* Once loading finishes, don't undo it.  */
1287       Vautoload_queue = Qt;
1288       feature = unbind_to (count, feature);
1289     }
1290   return feature;
1291 }
1292 \f
1293 syms_of_fns ()
1294 {
1295   Qstring_lessp = intern ("string-lessp");
1296   staticpro (&Qstring_lessp);
1297
1298   DEFVAR_LISP ("features", &Vfeatures,
1299     "A list of symbols which are the features of the executing emacs.\n\
1300 Used by `featurep' and `require', and altered by `provide'.");
1301   Vfeatures = Qnil;
1302
1303   defsubr (&Sidentity);
1304   defsubr (&Srandom);
1305   defsubr (&Slength);
1306   defsubr (&Sstring_equal);
1307   defsubr (&Sstring_lessp);
1308   defsubr (&Sappend);
1309   defsubr (&Sconcat);
1310   defsubr (&Svconcat);
1311   defsubr (&Scopy_sequence);
1312   defsubr (&Scopy_alist);
1313   defsubr (&Ssubstring);
1314   defsubr (&Snthcdr);
1315   defsubr (&Snth);
1316   defsubr (&Selt);
1317   defsubr (&Smember);
1318   defsubr (&Smemq);
1319   defsubr (&Sassq);
1320   defsubr (&Sassoc);
1321   defsubr (&Srassq);
1322   defsubr (&Sdelq);
1323   defsubr (&Sdelete);
1324   defsubr (&Snreverse);
1325   defsubr (&Sreverse);
1326   defsubr (&Ssort);
1327   defsubr (&Sget);
1328   defsubr (&Sput);
1329   defsubr (&Sequal);
1330   defsubr (&Sfillarray);
1331   defsubr (&Snconc);
1332   defsubr (&Smapcar);
1333   defsubr (&Smapconcat);
1334   defsubr (&Sy_or_n_p);
1335   defsubr (&Syes_or_no_p);
1336   defsubr (&Sload_average);
1337   defsubr (&Sfeaturep);
1338   defsubr (&Srequire);
1339   defsubr (&Sprovide);
1340 }