src/fns.c

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