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, Qprovide, Qrequire;
  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] = Fnumber_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, key, def, answer_string, map;
1097   register int answer;
1098   Lisp_Object xprompt;
1099   Lisp_Object args[2];
1100   int ocech = cursor_in_echo_area;
1101   struct gcpro gcpro1, gcpro2;
1102
1103   map = Fsymbol_value (intern ("query-replace-map"));
1104
1105   CHECK_STRING (prompt, 0);
1106   xprompt = prompt;
1107   GCPRO2 (prompt, xprompt);
1108
1109   while (1)
1110     {
1111       cursor_in_echo_area = 1;
1112       message ("%s(y or n) ", XSTRING (xprompt)->data);
1113
1114       obj = read_char (0, 0, 0, Qnil, 0);
1115       cursor_in_echo_area = 0;
1116       /* If we need to quit, quit with cursor_in_echo_area = 0.  */
1117       QUIT;
1118
1119       key = Fmake_vector (make_number (1), obj);
1120       def = Flookup_key (map, key);
1121       answer_string = Fsingle_key_description (obj);
1122
1123       if (EQ (def, intern ("skip")))
1124         {
1125           answer = 0;
1126           break;
1127         }
1128       else if (EQ (def, intern ("act")))
1129         {
1130           answer = 1;
1131           break;
1132         }
1133       else if (EQ (def, intern ("recenter")))
1134         {
1135           Frecenter (Qnil);
1136           xprompt = prompt;
1137           continue;
1138         }
1139       else if (EQ (def, intern ("quit")))
1140         Vquit_flag = Qt;
1141
1142       QUIT;
1143
1144       /* If we don't clear this, then the next call to read_char will
1145          return quit_char again, and we'll enter an infinite loop.  */
1146       Vquit_flag = Qnil;
1147
1148       Fding (Qnil);
1149       Fdiscard_input ();
1150       if (EQ (xprompt, prompt))
1151         {
1152           args[0] = build_string ("Please answer y or n.  ");
1153           args[1] = prompt;
1154           xprompt = Fconcat (2, args);
1155         }
1156     }
1157   UNGCPRO;
1158
1159   if (! noninteractive)
1160     {
1161       cursor_in_echo_area = -1;
1162       message ("%s(y or n) %c", XSTRING (xprompt)->data, answer ? 'y' : 'n');
1163       cursor_in_echo_area = ocech;
1164     }
1165
1166   return answer ? Qt : Qnil;
1167 }
1168 \f
1169 /* This is how C code calls `yes-or-no-p' and allows the user
1170    to redefined it.
1171
1172    Anything that calls this function must protect from GC!  */
1173
1174 Lisp_Object
1175 do_yes_or_no_p (prompt)
1176      Lisp_Object prompt;
1177 {
1178   return call1 (intern ("yes-or-no-p"), prompt);
1179 }
1180
1181 /* Anything that calls this function must protect from GC!  */
1182
1183 DEFUN ("yes-or-no-p", Fyes_or_no_p, Syes_or_no_p, 1, 1, 0,
1184   "Ask user a yes-or-no question.  Return t if answer is yes.\n\
1185 Takes one argument, which is the string to display to ask the question.\n\
1186 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.\n\
1187 The user must confirm the answer with RET,\n\
1188 and can edit it until it as been confirmed.")
1189   (prompt)
1190      Lisp_Object prompt;
1191 {
1192   register Lisp_Object ans;
1193   Lisp_Object args[2];
1194   struct gcpro gcpro1;
1195
1196   CHECK_STRING (prompt, 0);
1197
1198   args[0] = prompt;
1199   args[1] = build_string ("(yes or no) ");
1200   prompt = Fconcat (2, args);
1201
1202   GCPRO1 (prompt);
1203   while (1)
1204     {
1205       ans = Fdowncase (Fread_string (prompt, Qnil));
1206       if (XSTRING (ans)->size == 3 && !strcmp (XSTRING (ans)->data, "yes"))
1207         {
1208           UNGCPRO;
1209           return Qt;
1210         }
1211       if (XSTRING (ans)->size == 2 && !strcmp (XSTRING (ans)->data, "no"))
1212         {
1213           UNGCPRO;
1214           return Qnil;
1215         }
1216
1217       Fding (Qnil);
1218       Fdiscard_input ();
1219       message ("Please answer yes or no.");
1220       Fsleep_for (make_number (2), Qnil);
1221     }
1222   UNGCPRO;
1223 }
1224 \f
1225 DEFUN ("load-average", Fload_average, Sload_average, 0, 0, 0,
1226   "Return list of 1 minute, 5 minute and 15 minute load averages.\n\
1227 Each of the three load averages is multiplied by 100,\n\
1228 then converted to integer.\n\
1229 If the 5-minute or 15-minute load averages are not available, return a\n\
1230 shortened list, containing only those averages which are available.")
1231   ()
1232 {
1233   double load_ave[3];
1234   int loads = getloadavg (load_ave, 3);
1235   Lisp_Object ret;
1236
1237   if (loads < 0)
1238     error ("load-average not implemented for this operating system");
1239
1240   ret = Qnil;
1241   while (loads > 0)
1242     ret = Fcons (make_number ((int) (load_ave[--loads] * 100.0)), ret);
1243
1244   return ret;
1245 }
1246 \f
1247 Lisp_Object Vfeatures;
1248
1249 DEFUN ("featurep", Ffeaturep, Sfeaturep, 1, 1, 0,
1250   "Returns t if FEATURE is present in this Emacs.\n\
1251 Use this to conditionalize execution of lisp code based on the presence or\n\
1252 absence of emacs or environment extensions.\n\
1253 Use `provide' to declare that a feature is available.\n\
1254 This function looks at the value of the variable `features'.")
1255      (feature)
1256      Lisp_Object feature;
1257 {
1258   register Lisp_Object tem;
1259   CHECK_SYMBOL (feature, 0);
1260   tem = Fmemq (feature, Vfeatures);
1261   return (NILP (tem)) ? Qnil : Qt;
1262 }
1263
1264 DEFUN ("provide", Fprovide, Sprovide, 1, 1, 0,
1265   "Announce that FEATURE is a feature of the current Emacs.")
1266      (feature)
1267      Lisp_Object feature;
1268 {
1269   register Lisp_Object tem;
1270   CHECK_SYMBOL (feature, 0);
1271   if (!NILP (Vautoload_queue))
1272     Vautoload_queue = Fcons (Fcons (Vfeatures, Qnil), Vautoload_queue);
1273   tem = Fmemq (feature, Vfeatures);
1274   if (NILP (tem))
1275     Vfeatures = Fcons (feature, Vfeatures);
1276   LOADHIST_ATTACH (Fcons (Qprovide, feature));
1277   return feature;
1278 }
1279
1280 DEFUN ("require", Frequire, Srequire, 1, 2, 0,
1281   "If feature FEATURE is not loaded, load it from FILENAME.\n\
1282 If FEATURE is not a member of the list `features', then the feature\n\
1283 is not loaded; so load the file FILENAME.\n\
1284 If FILENAME is omitted, the printname of FEATURE is used as the file name.")
1285      (feature, file_name)
1286      Lisp_Object feature, file_name;
1287 {
1288   register Lisp_Object tem;
1289   CHECK_SYMBOL (feature, 0);
1290   tem = Fmemq (feature, Vfeatures);
1291   LOADHIST_ATTACH (Fcons (Qrequire, feature));
1292   if (NILP (tem))
1293     {
1294       int count = specpdl_ptr - specpdl;
1295
1296       /* Value saved here is to be restored into Vautoload_queue */
1297       record_unwind_protect (un_autoload, Vautoload_queue);
1298       Vautoload_queue = Qt;
1299
1300       Fload (NILP (file_name) ? Fsymbol_name (feature) : file_name,
1301              Qnil, Qt, Qnil);
1302
1303       tem = Fmemq (feature, Vfeatures);
1304       if (NILP (tem))
1305         error ("Required feature %s was not provided",
1306                XSYMBOL (feature)->name->data );
1307
1308       /* Once loading finishes, don't undo it.  */
1309       Vautoload_queue = Qt;
1310       feature = unbind_to (count, feature);
1311     }
1312   return feature;
1313 }
1314 \f
1315 syms_of_fns ()
1316 {
1317   Qstring_lessp = intern ("string-lessp");
1318   staticpro (&Qstring_lessp);
1319   Qprovide = intern ("provide");
1320   staticpro (&Qprovide);
1321   Qrequire = intern ("require");
1322   staticpro (&Qrequire);
1323
1324   DEFVAR_LISP ("features", &Vfeatures,
1325     "A list of symbols which are the features of the executing emacs.\n\
1326 Used by `featurep' and `require', and altered by `provide'.");
1327   Vfeatures = Qnil;
1328
1329   defsubr (&Sidentity);
1330   defsubr (&Srandom);
1331   defsubr (&Slength);
1332   defsubr (&Sstring_equal);
1333   defsubr (&Sstring_lessp);
1334   defsubr (&Sappend);
1335   defsubr (&Sconcat);
1336   defsubr (&Svconcat);
1337   defsubr (&Scopy_sequence);
1338   defsubr (&Scopy_alist);
1339   defsubr (&Ssubstring);
1340   defsubr (&Snthcdr);
1341   defsubr (&Snth);
1342   defsubr (&Selt);
1343   defsubr (&Smember);
1344   defsubr (&Smemq);
1345   defsubr (&Sassq);
1346   defsubr (&Sassoc);
1347   defsubr (&Srassq);
1348   defsubr (&Sdelq);
1349   defsubr (&Sdelete);
1350   defsubr (&Snreverse);
1351   defsubr (&Sreverse);
1352   defsubr (&Ssort);
1353   defsubr (&Sget);
1354   defsubr (&Sput);
1355   defsubr (&Sequal);
1356   defsubr (&Sfillarray);
1357   defsubr (&Snconc);
1358   defsubr (&Smapcar);
1359   defsubr (&Smapconcat);
1360   defsubr (&Sy_or_n_p);
1361   defsubr (&Syes_or_no_p);
1362   defsubr (&Sload_average);
1363   defsubr (&Sfeaturep);
1364   defsubr (&Srequire);
1365   defsubr (&Sprovide);
1366 }