src/fns.c

   1 /* Random utility Lisp functions.
   2    Copyright (C) 1985, 86, 87, 93, 94, 95, 97, 1998 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 2, 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, Inc., 59 Temple Place - Suite 330,
  19 Boston, MA 02111-1307, USA.  */
  20
  21
  22 #include <config.h>
  23
  24 /* Note on some machines this defines `vector' as a typedef,
  25    so make sure we don't use that name in this file.  */
  26 #undef vector
  27 #define vector *****
  28
  29 #include "lisp.h"
  30 #include "commands.h"
  31 #include "charset.h"
  32
  33 #include "buffer.h"
  34 #include "keyboard.h"
  35 #include "intervals.h"
  36 #include "frame.h"
  37 #include "window.h"
  38
  39 #ifndef NULL
  40 #define NULL (void *)0
  41 #endif
  42
  43 /* Nonzero enables use of dialog boxes for questions
  44    asked by mouse commands.  */
  45 int use_dialog_box;
  46
  47 extern Lisp_Object Flookup_key ();
  48
  49 extern int minibuffer_auto_raise;
  50 extern Lisp_Object minibuf_window;
  51
  52 Lisp_Object Qstring_lessp, Qprovide, Qrequire;
  53 Lisp_Object Qyes_or_no_p_history;
  54 Lisp_Object Qcursor_in_echo_area;
  55 Lisp_Object Qwidget_type;
  56
  57 static int internal_equal ();
  58 \f
  59 DEFUN ("identity", Fidentity, Sidentity, 1, 1, 0,
  60   "Return the argument unchanged.")
  61   (arg)
  62      Lisp_Object arg;
  63 {
  64   return arg;
  65 }
  66
  67 extern long get_random ();
  68 extern void seed_random ();
  69 extern long time ();
  70
  71 DEFUN ("random", Frandom, Srandom, 0, 1, 0,
  72   "Return a pseudo-random number.\n\
  73 All integers representable in Lisp are equally likely.\n\
  74   On most systems, this is 28 bits' worth.\n\
  75 With positive integer argument N, return random number in interval [0,N).\n\
  76 With argument t, set the random number seed from the current time and pid.")
  77   (n)
  78      Lisp_Object n;
  79 {
  80   EMACS_INT val;
  81   Lisp_Object lispy_val;
  82   unsigned long denominator;
  83
  84   if (EQ (n, Qt))
  85     seed_random (getpid () + time (NULL));
  86   if (NATNUMP (n) && XFASTINT (n) != 0)
  87     {
  88       /* Try to take our random number from the higher bits of VAL,
  89          not the lower, since (says Gentzel) the low bits of `random'
  90          are less random than the higher ones.  We do this by using the
  91          quotient rather than the remainder.  At the high end of the RNG
  92          it's possible to get a quotient larger than n; discarding
  93          these values eliminates the bias that would otherwise appear
  94          when using a large n.  */
  95       denominator = ((unsigned long)1 << VALBITS) / XFASTINT (n);
  96       do
  97         val = get_random () / denominator;
  98       while (val >= XFASTINT (n));
  99     }
 100   else
 101     val = get_random ();
 102   XSETINT (lispy_val, val);
 103   return lispy_val;
 104 }
 105 \f
 106 /* Random data-structure functions */
 107
 108 DEFUN ("length", Flength, Slength, 1, 1, 0,
 109   "Return the length of vector, list or string SEQUENCE.\n\
 110 A byte-code function object is also allowed.\n\
 111 If the string contains multibyte characters, this is not the necessarily\n\
 112 the number of characters in the string; it is the number of bytes.\n\
 113 To get the number of characters, use `chars-in-string'")
 114   (sequence)
 115      register Lisp_Object sequence;
 116 {
 117   register Lisp_Object tail, val;
 118   register int i;
 119
 120  retry:
 121   if (STRINGP (sequence))
 122     XSETFASTINT (val, XSTRING (sequence)->size);
 123   else if (VECTORP (sequence))
 124     XSETFASTINT (val, XVECTOR (sequence)->size);
 125   else if (CHAR_TABLE_P (sequence))
 126     XSETFASTINT (val, (MIN_CHAR_COMPOSITION
 127                        + (CHAR_FIELD2_MASK | CHAR_FIELD3_MASK)
 128                        - 1));
 129   else if (BOOL_VECTOR_P (sequence))
 130     XSETFASTINT (val, XBOOL_VECTOR (sequence)->size);
 131   else if (COMPILEDP (sequence))
 132     XSETFASTINT (val, XVECTOR (sequence)->size & PSEUDOVECTOR_SIZE_MASK);
 133   else if (CONSP (sequence))
 134     {
 135       for (i = 0, tail = sequence; !NILP (tail); i++)
 136         {
 137           QUIT;
 138           tail = Fcdr (tail);
 139         }
 140
 141       XSETFASTINT (val, i);
 142     }
 143   else if (NILP (sequence))
 144     XSETFASTINT (val, 0);
 145   else
 146     {
 147       sequence = wrong_type_argument (Qsequencep, sequence);
 148       goto retry;
 149     }
 150   return val;
 151 }
 152
 153 /* This does not check for quits.  That is safe
 154    since it must terminate.  */
 155
 156 DEFUN ("safe-length", Fsafe_length, Ssafe_length, 1, 1, 0,
 157   "Return the length of a list, but avoid error or infinite loop.\n\
 158 This function never gets an error.  If LIST is not really a list,\n\
 159 it returns 0.  If LIST is circular, it returns a finite value\n\
 160 which is at least the number of distinct elements.")
 161   (list)
 162      Lisp_Object list;
 163 {
 164   Lisp_Object tail, halftail, length;
 165   int len = 0;
 166
 167   /* halftail is used to detect circular lists.  */
 168   halftail = list;
 169   for (tail = list; CONSP (tail); tail = XCONS (tail)->cdr)
 170     {
 171       if (EQ (tail, halftail) && len != 0)
 172         break;
 173       len++;
 174       if ((len & 1) == 0)
 175         halftail = XCONS (halftail)->cdr;
 176     }
 177
 178   XSETINT (length, len);
 179   return length;
 180 }
 181
 182 DEFUN ("string-bytes", Fstring_bytes, Sstring_bytes, 1, 1, 0,
 183   "Return the number of bytes in STRING.\n\
 184 If STRING is a multibyte string, this is greater than the length of STRING.")
 185   (string)
 186      Lisp_Object string;
 187 {
 188   CHECK_STRING (string, 1);
 189   return make_number (STRING_BYTES (XSTRING (string)));
 190 }
 191
 192 DEFUN ("string-equal", Fstring_equal, Sstring_equal, 2, 2, 0,
 193   "Return t if two strings have identical contents.\n\
 194 Case is significant, but text properties are ignored.\n\
 195 Symbols are also allowed; their print names are used instead.")
 196   (s1, s2)
 197      register Lisp_Object s1, s2;
 198 {
 199   if (SYMBOLP (s1))
 200     XSETSTRING (s1, XSYMBOL (s1)->name);
 201   if (SYMBOLP (s2))
 202     XSETSTRING (s2, XSYMBOL (s2)->name);
 203   CHECK_STRING (s1, 0);
 204   CHECK_STRING (s2, 1);
 205
 206   if (XSTRING (s1)->size != XSTRING (s2)->size
 207       || STRING_BYTES (XSTRING (s1)) != STRING_BYTES (XSTRING (s2))
 208       || bcmp (XSTRING (s1)->data, XSTRING (s2)->data, STRING_BYTES (XSTRING (s1))))
 209     return Qnil;
 210   return Qt;
 211 }
 212
 213 DEFUN ("string-lessp", Fstring_lessp, Sstring_lessp, 2, 2, 0,
 214   "Return t if first arg string is less than second in lexicographic order.\n\
 215 Case is significant.\n\
 216 Symbols are also allowed; their print names are used instead.")
 217   (s1, s2)
 218      register Lisp_Object s1, s2;
 219 {
 220   register int end;
 221   register int i1, i1_byte, i2, i2_byte;
 222
 223   if (SYMBOLP (s1))
 224     XSETSTRING (s1, XSYMBOL (s1)->name);
 225   if (SYMBOLP (s2))
 226     XSETSTRING (s2, XSYMBOL (s2)->name);
 227   CHECK_STRING (s1, 0);
 228   CHECK_STRING (s2, 1);
 229
 230   i1 = i1_byte = i2 = i2_byte = 0;
 231
 232   end = XSTRING (s1)->size;
 233   if (end > XSTRING (s2)->size)
 234     end = XSTRING (s2)->size;
 235
 236   while (i1 < end)
 237     {
 238       /* When we find a mismatch, we must compare the
 239          characters, not just the bytes.  */
 240       int c1, c2;
 241
 242       if (STRING_MULTIBYTE (s1))
 243         FETCH_STRING_CHAR_ADVANCE (c1, s1, i1, i1_byte);
 244       else
 245         c1 = XSTRING (s1)->data[i1++];
 246
 247       if (STRING_MULTIBYTE (s2))
 248         FETCH_STRING_CHAR_ADVANCE (c2, s2, i2, i2_byte);
 249       else
 250         c2 = XSTRING (s2)->data[i2++];
 251
 252       if (c1 != c2)
 253         return c1 < c2 ? Qt : Qnil;
 254     }
 255   return i1 < XSTRING (s2)->size ? Qt : Qnil;
 256 }
 257 \f
 258 static Lisp_Object concat ();
 259
 260 /* ARGSUSED */
 261 Lisp_Object
 262 concat2 (s1, s2)
 263      Lisp_Object s1, s2;
 264 {
 265 #ifdef NO_ARG_ARRAY
 266   Lisp_Object args[2];
 267   args[0] = s1;
 268   args[1] = s2;
 269   return concat (2, args, Lisp_String, 0);
 270 #else
 271   return concat (2, &s1, Lisp_String, 0);
 272 #endif /* NO_ARG_ARRAY */
 273 }
 274
 275 /* ARGSUSED */
 276 Lisp_Object
 277 concat3 (s1, s2, s3)
 278      Lisp_Object s1, s2, s3;
 279 {
 280 #ifdef NO_ARG_ARRAY
 281   Lisp_Object args[3];
 282   args[0] = s1;
 283   args[1] = s2;
 284   args[2] = s3;
 285   return concat (3, args, Lisp_String, 0);
 286 #else
 287   return concat (3, &s1, Lisp_String, 0);
 288 #endif /* NO_ARG_ARRAY */
 289 }
 290
 291 DEFUN ("append", Fappend, Sappend, 0, MANY, 0,
 292   "Concatenate all the arguments and make the result a list.\n\
 293 The result is a list whose elements are the elements of all the arguments.\n\
 294 Each argument may be a list, vector or string.\n\
 295 The last argument is not copied, just used as the tail of the new list.")
 296   (nargs, args)
 297      int nargs;
 298      Lisp_Object *args;
 299 {
 300   return concat (nargs, args, Lisp_Cons, 1);
 301 }
 302
 303 DEFUN ("concat", Fconcat, Sconcat, 0, MANY, 0,
 304   "Concatenate all the arguments and make the result a string.\n\
 305 The result is a string whose elements are the elements of all the arguments.\n\
 306 Each argument may be a string or a list or vector of characters (integers).\n\
 307 \n\
 308 Do not use individual integers as arguments!\n\
 309 The behavior of `concat' in that case will be changed later!\n\
 310 If your program passes an integer as an argument to `concat',\n\
 311 you should change it right away not to do so.")
 312   (nargs, args)
 313      int nargs;
 314      Lisp_Object *args;
 315 {
 316   return concat (nargs, args, Lisp_String, 0);
 317 }
 318
 319 DEFUN ("vconcat", Fvconcat, Svconcat, 0, MANY, 0,
 320   "Concatenate all the arguments and make the result a vector.\n\
 321 The result is a vector whose elements are the elements of all the arguments.\n\
 322 Each argument may be a list, vector or string.")
 323   (nargs, args)
 324      int nargs;
 325      Lisp_Object *args;
 326 {
 327   return concat (nargs, args, Lisp_Vectorlike, 0);
 328 }
 329
 330 /* Retrun a copy of a sub char table ARG.  The elements except for a
 331    nested sub char table are not copied.  */
 332 static Lisp_Object
 333 copy_sub_char_table (arg)
 334      Lisp_Object arg;
 335 {
 336   Lisp_Object copy = make_sub_char_table (XCHAR_TABLE (arg)->defalt);
 337   int i;
 338
 339   /* Copy all the contents.  */
 340   bcopy (XCHAR_TABLE (arg)->contents, XCHAR_TABLE (copy)->contents,
 341          SUB_CHAR_TABLE_ORDINARY_SLOTS * sizeof (Lisp_Object));
 342   /* Recursively copy any sub char-tables in the ordinary slots.  */
 343   for (i = 32; i < SUB_CHAR_TABLE_ORDINARY_SLOTS; i++)
 344     if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg)->contents[i]))
 345       XCHAR_TABLE (copy)->contents[i]
 346         = copy_sub_char_table (XCHAR_TABLE (copy)->contents[i]);
 347
 348   return copy;
 349 }
 350
 351
 352 DEFUN ("copy-sequence", Fcopy_sequence, Scopy_sequence, 1, 1, 0,
 353   "Return a copy of a list, vector or string.\n\
 354 The elements of a list or vector are not copied; they are shared\n\
 355 with the original.")
 356   (arg)
 357      Lisp_Object arg;
 358 {
 359   if (NILP (arg)) return arg;
 360
 361   if (CHAR_TABLE_P (arg))
 362     {
 363       int i;
 364       Lisp_Object copy;
 365
 366       copy = Fmake_char_table (XCHAR_TABLE (arg)->purpose, Qnil);
 367       /* Copy all the slots, including the extra ones.  */
 368       bcopy (XVECTOR (arg)->contents, XVECTOR (copy)->contents,
 369              ((XCHAR_TABLE (arg)->size & PSEUDOVECTOR_SIZE_MASK)
 370               * sizeof (Lisp_Object)));
 371
 372       /* Recursively copy any sub char tables in the ordinary slots
 373          for multibyte characters.  */
 374       for (i = CHAR_TABLE_SINGLE_BYTE_SLOTS;
 375            i < CHAR_TABLE_ORDINARY_SLOTS; i++)
 376         if (SUB_CHAR_TABLE_P (XCHAR_TABLE (arg)->contents[i]))
 377           XCHAR_TABLE (copy)->contents[i]
 378             = copy_sub_char_table (XCHAR_TABLE (copy)->contents[i]);
 379
 380       return copy;
 381     }
 382
 383   if (BOOL_VECTOR_P (arg))
 384     {
 385       Lisp_Object val;
 386       int size_in_chars
 387         = (XBOOL_VECTOR (arg)->size + BITS_PER_CHAR - 1) / BITS_PER_CHAR;
 388
 389       val = Fmake_bool_vector (Flength (arg), Qnil);
 390       bcopy (XBOOL_VECTOR (arg)->data, XBOOL_VECTOR (val)->data,
 391              size_in_chars);
 392       return val;
 393     }
 394
 395   if (!CONSP (arg) && !VECTORP (arg) && !STRINGP (arg))
 396     arg = wrong_type_argument (Qsequencep, arg);
 397   return concat (1, &arg, CONSP (arg) ? Lisp_Cons : XTYPE (arg), 0);
 398 }
 399
 400 static Lisp_Object
 401 concat (nargs, args, target_type, last_special)
 402      int nargs;
 403      Lisp_Object *args;
 404      enum Lisp_Type target_type;
 405      int last_special;
 406 {
 407   Lisp_Object val;
 408   register Lisp_Object tail;
 409   register Lisp_Object this;
 410   int toindex;
 411   int toindex_byte;
 412   register int result_len;
 413   register int result_len_byte;
 414   register int argnum;
 415   Lisp_Object last_tail;
 416   Lisp_Object prev;
 417   int some_multibyte;
 418
 419   /* In append, the last arg isn't treated like the others */
 420   if (last_special && nargs > 0)
 421     {
 422       nargs--;
 423       last_tail = args[nargs];
 424     }
 425   else
 426     last_tail = Qnil;
 427
 428   /* Canonicalize each argument.  */
 429   for (argnum = 0; argnum < nargs; argnum++)
 430     {
 431       this = args[argnum];
 432       if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
 433             || COMPILEDP (this) || BOOL_VECTOR_P (this)))
 434         {
 435           if (INTEGERP (this))
 436             args[argnum] = Fnumber_to_string (this);
 437           else
 438             args[argnum] = wrong_type_argument (Qsequencep, this);
 439         }
 440     }
 441
 442   /* Compute total length in chars of arguments in RESULT_LEN.
 443      If desired output is a string, also compute length in bytes
 444      in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
 445      whether the result should be a multibyte string.  */
 446   result_len_byte = 0;
 447   result_len = 0;
 448   some_multibyte = 0;
 449   for (argnum = 0; argnum < nargs; argnum++)
 450     {
 451       int len;
 452       this = args[argnum];
 453       len = XFASTINT (Flength (this));
 454       if (target_type == Lisp_String)
 455         {
 456           /* We must count the number of bytes needed in the string
 457              as well as the number of characters.  */
 458           int i;
 459           Lisp_Object ch;
 460           int this_len_byte;
 461
 462           if (VECTORP (this))
 463             for (i = 0; i < len; i++)
 464               {
 465                 ch = XVECTOR (this)->contents[i];
 466                 if (! INTEGERP (ch))
 467                   wrong_type_argument (Qintegerp, ch);
 468                 this_len_byte = XFASTINT (Fchar_bytes (ch));
 469                 result_len_byte += this_len_byte;
 470                 if (this_len_byte > 1)
 471                   some_multibyte = 1;
 472               }
 473           else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size > 0)
 474             wrong_type_argument (Qintegerp, Faref (this, make_number (0)));
 475           else if (CONSP (this))
 476             for (; CONSP (this); this = XCONS (this)->cdr)
 477               {
 478                 ch = XCONS (this)->car;
 479                 if (! INTEGERP (ch))
 480                   wrong_type_argument (Qintegerp, ch);
 481                 this_len_byte = XFASTINT (Fchar_bytes (ch));
 482                 result_len_byte += this_len_byte;
 483                 if (this_len_byte > 1)
 484                   some_multibyte = 1;
 485               }
 486           else if (STRINGP (this))
 487             {
 488               if (STRING_MULTIBYTE (this))
 489                 {
 490                   some_multibyte = 1;
 491                   result_len_byte += STRING_BYTES (XSTRING (this));
 492                 }
 493               else
 494                 result_len_byte += count_size_as_multibyte (XSTRING (this)->data,
 495                                                             XSTRING (this)->size);
 496             }
 497         }
 498
 499       result_len += len;
 500     }
 501
 502   if (! some_multibyte)
 503     result_len_byte = result_len;
 504
 505   /* Create the output object.  */
 506   if (target_type == Lisp_Cons)
 507     val = Fmake_list (make_number (result_len), Qnil);
 508   else if (target_type == Lisp_Vectorlike)
 509     val = Fmake_vector (make_number (result_len), Qnil);
 510   else
 511     val = make_uninit_multibyte_string (result_len, result_len_byte);
 512
 513   /* In `append', if all but last arg are nil, return last arg.  */
 514   if (target_type == Lisp_Cons && EQ (val, Qnil))
 515     return last_tail;
 516
 517   /* Copy the contents of the args into the result.  */
 518   if (CONSP (val))
 519     tail = val, toindex = -1;           /* -1 in toindex is flag we are making a list */
 520   else
 521     toindex = 0, toindex_byte = 0;
 522
 523   prev = Qnil;
 524
 525   for (argnum = 0; argnum < nargs; argnum++)
 526     {
 527       Lisp_Object thislen;
 528       int thisleni;
 529       register unsigned int thisindex = 0;
 530       register unsigned int thisindex_byte = 0;
 531
 532       this = args[argnum];
 533       if (!CONSP (this))
 534         thislen = Flength (this), thisleni = XINT (thislen);
 535
 536       if (STRINGP (this) && STRINGP (val)
 537           && ! NULL_INTERVAL_P (XSTRING (this)->intervals))
 538         copy_text_properties (make_number (0), thislen, this,
 539                               make_number (toindex), val, Qnil);
 540
 541       /* Between strings of the same kind, copy fast.  */
 542       if (STRINGP (this) && STRINGP (val)
 543           && STRING_MULTIBYTE (this) == some_multibyte)
 544         {
 545           int thislen_byte = STRING_BYTES (XSTRING (this));
 546           bcopy (XSTRING (this)->data, XSTRING (val)->data + toindex_byte,
 547                  STRING_BYTES (XSTRING (this)));
 548           toindex_byte += thislen_byte;
 549           toindex += thisleni;
 550         }
 551       /* Copy a single-byte string to a multibyte string.  */
 552       else if (STRINGP (this) && STRINGP (val))
 553         {
 554           toindex_byte += copy_text (XSTRING (this)->data,
 555                                      XSTRING (val)->data + toindex_byte,
 556                                      XSTRING (this)->size, 0, 1);
 557           toindex += thisleni;
 558         }
 559       else
 560         /* Copy element by element.  */
 561         while (1)
 562           {
 563             register Lisp_Object elt;
 564
 565             /* Fetch next element of `this' arg into `elt', or break if
 566                `this' is exhausted. */
 567             if (NILP (this)) break;
 568             if (CONSP (this))
 569               elt = XCONS (this)->car, this = XCONS (this)->cdr;
 570             else if (thisindex >= thisleni)
 571               break;
 572             else if (STRINGP (this))
 573               {
 574                 int c;
 575                 if (STRING_MULTIBYTE (this))
 576                   {
 577                     FETCH_STRING_CHAR_ADVANCE (c, this,
 578                                                thisindex,
 579                                                thisindex_byte);
 580                     XSETFASTINT (elt, c);
 581                   }
 582                 else
 583                   {
 584                     XSETFASTINT (elt, XSTRING (this)->data[thisindex++]);
 585                     if (some_multibyte && XINT (elt) >= 0200
 586                         && XINT (elt) < 0400)
 587                       {
 588                         c = unibyte_char_to_multibyte (XINT (elt));
 589                         XSETINT (elt, c);
 590                       }
 591                   }
 592               }
 593             else if (BOOL_VECTOR_P (this))
 594               {
 595                 int byte;
 596                 byte = XBOOL_VECTOR (this)->data[thisindex / BITS_PER_CHAR];
 597                 if (byte & (1 << (thisindex % BITS_PER_CHAR)))
 598                   elt = Qt;
 599                 else
 600                   elt = Qnil;
 601                 thisindex++;
 602               }
 603             else
 604               elt = XVECTOR (this)->contents[thisindex++];
 605
 606             /* Store this element into the result.  */
 607             if (toindex < 0)
 608               {
 609                 XCONS (tail)->car = elt;
 610                 prev = tail;
 611                 tail = XCONS (tail)->cdr;
 612               }
 613             else if (VECTORP (val))
 614               XVECTOR (val)->contents[toindex++] = elt;
 615             else
 616               {
 617                 CHECK_NUMBER (elt, 0);
 618                 if (SINGLE_BYTE_CHAR_P (XINT (elt)))
 619                   {
 620                     XSTRING (val)->data[toindex++] = XINT (elt);
 621                     toindex_byte++;
 622                   }
 623                 else
 624                   /* If we have any multibyte characters,
 625                      we already decided to make a multibyte string.  */
 626                   {
 627                     int c = XINT (elt);
 628                     unsigned char work[4], *str;
 629                     int i = CHAR_STRING (c, work, str);
 630
 631                     /* P exists as a variable
 632                        to avoid a bug on the Masscomp C compiler.  */
 633                     unsigned char *p = & XSTRING (val)->data[toindex_byte];
 634                     bcopy (str, p, i);
 635                     toindex_byte += i;
 636                     toindex++;
 637                   }
 638               }
 639           }
 640     }
 641   if (!NILP (prev))
 642     XCONS (prev)->cdr = last_tail;
 643
 644   return val;
 645 }
 646 \f
 647 static Lisp_Object string_char_byte_cache_string;
 648 static int string_char_byte_cache_charpos;
 649 static int string_char_byte_cache_bytepos;
 650
 651 /* Return the character index corresponding to CHAR_INDEX in STRING.  */
 652
 653 int
 654 string_char_to_byte (string, char_index)
 655      Lisp_Object string;
 656      int char_index;
 657 {
 658   int i, i_byte;
 659   int best_below, best_below_byte;
 660   int best_above, best_above_byte;
 661
 662   if (! STRING_MULTIBYTE (string))
 663     return char_index;
 664
 665   best_below = best_below_byte = 0;
 666   best_above = XSTRING (string)->size;
 667   best_above_byte = STRING_BYTES (XSTRING (string));
 668
 669   if (EQ (string, string_char_byte_cache_string))
 670     {
 671       if (string_char_byte_cache_charpos < char_index)
 672         {
 673           best_below = string_char_byte_cache_charpos;
 674           best_below_byte = string_char_byte_cache_bytepos;
 675         }
 676       else
 677         {
 678           best_above = string_char_byte_cache_charpos;
 679           best_above_byte = string_char_byte_cache_bytepos;
 680         }
 681     }
 682
 683   if (char_index - best_below < best_above - char_index)
 684     {
 685       while (best_below < char_index)
 686         {
 687           int c;
 688           FETCH_STRING_CHAR_ADVANCE (c, string, best_below, best_below_byte);
 689         }
 690       i = best_below;
 691       i_byte = best_below_byte;
 692     }
 693   else
 694     {
 695       while (best_above > char_index)
 696         {
 697           int best_above_byte_saved = --best_above_byte;
 698
 699           while (best_above_byte > 0
 700                  && !CHAR_HEAD_P (XSTRING (string)->data[best_above_byte]))
 701             best_above_byte--;
 702           if (XSTRING (string)->data[best_above_byte] < 0x80)
 703             best_above_byte = best_above_byte_saved;
 704           best_above--;
 705         }
 706       i = best_above;
 707       i_byte = best_above_byte;
 708     }
 709
 710   string_char_byte_cache_bytepos = i_byte;
 711   string_char_byte_cache_charpos = i;
 712   string_char_byte_cache_string = string;
 713
 714   return i_byte;
 715 }
 716 \f
 717 /* Return the character index corresponding to BYTE_INDEX in STRING.  */
 718
 719 int
 720 string_byte_to_char (string, byte_index)
 721      Lisp_Object string;
 722      int byte_index;
 723 {
 724   int i, i_byte;
 725   int best_below, best_below_byte;
 726   int best_above, best_above_byte;
 727
 728   if (! STRING_MULTIBYTE (string))
 729     return byte_index;
 730
 731   best_below = best_below_byte = 0;
 732   best_above = XSTRING (string)->size;
 733   best_above_byte = STRING_BYTES (XSTRING (string));
 734
 735   if (EQ (string, string_char_byte_cache_string))
 736     {
 737       if (string_char_byte_cache_bytepos < byte_index)
 738         {
 739           best_below = string_char_byte_cache_charpos;
 740           best_below_byte = string_char_byte_cache_bytepos;
 741         }
 742       else
 743         {
 744           best_above = string_char_byte_cache_charpos;
 745           best_above_byte = string_char_byte_cache_bytepos;
 746         }
 747     }
 748
 749   if (byte_index - best_below_byte < best_above_byte - byte_index)
 750     {
 751       while (best_below_byte < byte_index)
 752         {
 753           int c;
 754           FETCH_STRING_CHAR_ADVANCE (c, string, best_below, best_below_byte);
 755         }
 756       i = best_below;
 757       i_byte = best_below_byte;
 758     }
 759   else
 760     {
 761       while (best_above_byte > byte_index)
 762         {
 763           int best_above_byte_saved = --best_above_byte;
 764
 765           while (best_above_byte > 0
 766                  && !CHAR_HEAD_P (XSTRING (string)->data[best_above_byte]))
 767             best_above_byte--;
 768           if (XSTRING (string)->data[best_above_byte] < 0x80)
 769             best_above_byte = best_above_byte_saved;
 770           best_above--;
 771         }
 772       i = best_above;
 773       i_byte = best_above_byte;
 774     }
 775
 776   string_char_byte_cache_bytepos = i_byte;
 777   string_char_byte_cache_charpos = i;
 778   string_char_byte_cache_string = string;
 779
 780   return i;
 781 }
 782 \f
 783 /* Convert STRING to a multibyte string.
 784    Single-byte characters 0240 through 0377 are converted
 785    by adding nonascii_insert_offset to each.  */
 786
 787 Lisp_Object
 788 string_make_multibyte (string)
 789      Lisp_Object string;
 790 {
 791   unsigned char *buf;
 792   int nbytes;
 793
 794   if (STRING_MULTIBYTE (string))
 795     return string;
 796
 797   nbytes = count_size_as_multibyte (XSTRING (string)->data,
 798                                     XSTRING (string)->size);
 799   /* If all the chars are ASCII, they won't need any more bytes
 800      once converted.  In that case, we can return STRING itself.  */
 801   if (nbytes == STRING_BYTES (XSTRING (string)))
 802     return string;
 803
 804   buf = (unsigned char *) alloca (nbytes);
 805   copy_text (XSTRING (string)->data, buf, STRING_BYTES (XSTRING (string)),
 806              0, 1);
 807
 808   return make_multibyte_string (buf, XSTRING (string)->size, nbytes);
 809 }
 810
 811 /* Convert STRING to a single-byte string.  */
 812
 813 Lisp_Object
 814 string_make_unibyte (string)
 815      Lisp_Object string;
 816 {
 817   unsigned char *buf;
 818
 819   if (! STRING_MULTIBYTE (string))
 820     return string;
 821
 822   buf = (unsigned char *) alloca (XSTRING (string)->size);
 823
 824   copy_text (XSTRING (string)->data, buf, STRING_BYTES (XSTRING (string)),
 825              1, 0);
 826
 827   return make_unibyte_string (buf, XSTRING (string)->size);
 828 }
 829
 830 DEFUN ("string-make-multibyte", Fstring_make_multibyte, Sstring_make_multibyte,
 831        1, 1, 0,
 832   "Return the multibyte equivalent of STRING.")
 833   (string)
 834      Lisp_Object string;
 835 {
 836   return string_make_multibyte (string);
 837 }
 838
 839 DEFUN ("string-make-unibyte", Fstring_make_unibyte, Sstring_make_unibyte,
 840        1, 1, 0,
 841   "Return the unibyte equivalent of STRING.")
 842   (string)
 843      Lisp_Object string;
 844 {
 845   return string_make_unibyte (string);
 846 }
 847
 848 DEFUN ("string-as-unibyte", Fstring_as_unibyte, Sstring_as_unibyte,
 849        1, 1, 0,
 850   "Return a unibyte string with the same individual bytes as STRING.\n\
 851 If STRING is unibyte, the result is STRING itself.")
 852   (string)
 853      Lisp_Object string;
 854 {
 855   if (STRING_MULTIBYTE (string))
 856     {
 857       string = Fcopy_sequence (string);
 858       XSTRING (string)->size = STRING_BYTES (XSTRING (string));
 859     }
 860   return string;
 861 }
 862
 863 DEFUN ("string-as-multibyte", Fstring_as_multibyte, Sstring_as_multibyte,
 864        1, 1, 0,
 865   "Return a multibyte string with the same individual bytes as STRING.\n\
 866 If STRING is multibyte, the result is STRING itself.")
 867   (string)
 868      Lisp_Object string;
 869 {
 870   if (! STRING_MULTIBYTE (string))
 871     {
 872       int newlen = multibyte_chars_in_text (XSTRING (string)->data,
 873                                             STRING_BYTES (XSTRING (string)));
 874       /* If all the chars are ASCII, STRING is already suitable.  */
 875       if (newlen != STRING_BYTES (XSTRING (string)))
 876         {
 877           string = Fcopy_sequence (string);
 878           XSTRING (string)->size = newlen;
 879         }
 880     }
 881   return string;
 882 }
 883 \f
 884 DEFUN ("copy-alist", Fcopy_alist, Scopy_alist, 1, 1, 0,
 885   "Return a copy of ALIST.\n\
 886 This is an alist which represents the same mapping from objects to objects,\n\
 887 but does not share the alist structure with ALIST.\n\
 888 The objects mapped (cars and cdrs of elements of the alist)\n\
 889 are shared, however.\n\
 890 Elements of ALIST that are not conses are also shared.")
 891   (alist)
 892      Lisp_Object alist;
 893 {
 894   register Lisp_Object tem;
 895
 896   CHECK_LIST (alist, 0);
 897   if (NILP (alist))
 898     return alist;
 899   alist = concat (1, &alist, Lisp_Cons, 0);
 900   for (tem = alist; CONSP (tem); tem = XCONS (tem)->cdr)
 901     {
 902       register Lisp_Object car;
 903       car = XCONS (tem)->car;
 904
 905       if (CONSP (car))
 906         XCONS (tem)->car = Fcons (XCONS (car)->car, XCONS (car)->cdr);
 907     }
 908   return alist;
 909 }
 910
 911 DEFUN ("substring", Fsubstring, Ssubstring, 2, 3, 0,
 912   "Return a substring of STRING, starting at index FROM and ending before TO.\n\
 913 TO may be nil or omitted; then the substring runs to the end of STRING.\n\
 914 If FROM or TO is negative, it counts from the end.\n\
 915 \n\
 916 This function allows vectors as well as strings.")
 917   (string, from, to)
 918      Lisp_Object string;
 919      register Lisp_Object from, to;
 920 {
 921   Lisp_Object res;
 922   int size;
 923   int size_byte;
 924   int from_char, to_char;
 925   int from_byte, to_byte;
 926
 927   if (! (STRINGP (string) || VECTORP (string)))
 928     wrong_type_argument (Qarrayp, string);
 929
 930   CHECK_NUMBER (from, 1);
 931
 932   if (STRINGP (string))
 933     {
 934       size = XSTRING (string)->size;
 935       size_byte = STRING_BYTES (XSTRING (string));
 936     }
 937   else
 938     size = XVECTOR (string)->size;
 939
 940   if (NILP (to))
 941     {
 942       to_char = size;
 943       to_byte = size_byte;
 944     }
 945   else
 946     {
 947       CHECK_NUMBER (to, 2);
 948
 949       to_char = XINT (to);
 950       if (to_char < 0)
 951         to_char += size;
 952
 953       if (STRINGP (string))
 954         to_byte = string_char_to_byte (string, to_char);
 955     }
 956
 957   from_char = XINT (from);
 958   if (from_char < 0)
 959     from_char += size;
 960   if (STRINGP (string))
 961     from_byte = string_char_to_byte (string, from_char);
 962
 963   if (!(0 <= from_char && from_char <= to_char && to_char <= size))
 964     args_out_of_range_3 (string, make_number (from_char),
 965                          make_number (to_char));
 966
 967   if (STRINGP (string))
 968     {
 969       res = make_multibyte_string (XSTRING (string)->data + from_byte,
 970                                    to_char - from_char, to_byte - from_byte);
 971       copy_text_properties (from_char, to_char, string,
 972                             make_number (0), res, Qnil);
 973     }
 974   else
 975     res = Fvector (to_char - from_char,
 976                    XVECTOR (string)->contents + from_char);
 977
 978   return res;
 979 }
 980
 981 /* Extract a substring of STRING, giving start and end positions
 982    both in characters and in bytes.  */
 983
 984 Lisp_Object
 985 substring_both (string, from, from_byte, to, to_byte)
 986      Lisp_Object string;
 987      int from, from_byte, to, to_byte;
 988 {
 989   Lisp_Object res;
 990   int size;
 991   int size_byte;
 992
 993   if (! (STRINGP (string) || VECTORP (string)))
 994     wrong_type_argument (Qarrayp, string);
 995
 996   if (STRINGP (string))
 997     {
 998       size = XSTRING (string)->size;
 999       size_byte = STRING_BYTES (XSTRING (string));
1000     }
1001   else
1002     size = XVECTOR (string)->size;
1003
1004   if (!(0 <= from && from <= to && to <= size))
1005     args_out_of_range_3 (string, make_number (from), make_number (to));
1006
1007   if (STRINGP (string))
1008     {
1009       res = make_multibyte_string (XSTRING (string)->data + from_byte,
1010                                    to - from, to_byte - from_byte);
1011       copy_text_properties (from, to, string, make_number (0), res, Qnil);
1012     }
1013   else
1014     res = Fvector (to - from,
1015                    XVECTOR (string)->contents + from);
1016
1017   return res;
1018 }
1019 \f
1020 DEFUN ("nthcdr", Fnthcdr, Snthcdr, 2, 2, 0,
1021   "Take cdr N times on LIST, returns the result.")
1022   (n, list)
1023      Lisp_Object n;
1024      register Lisp_Object list;
1025 {
1026   register int i, num;
1027   CHECK_NUMBER (n, 0);
1028   num = XINT (n);
1029   for (i = 0; i < num && !NILP (list); i++)
1030     {
1031       QUIT;
1032       list = Fcdr (list);
1033     }
1034   return list;
1035 }
1036
1037 DEFUN ("nth", Fnth, Snth, 2, 2, 0,
1038   "Return the Nth element of LIST.\n\
1039 N counts from zero.  If LIST is not that long, nil is returned.")
1040   (n, list)
1041      Lisp_Object n, list;
1042 {
1043   return Fcar (Fnthcdr (n, list));
1044 }
1045
1046 DEFUN ("elt", Felt, Selt, 2, 2, 0,
1047   "Return element of SEQUENCE at index N.")
1048   (sequence, n)
1049      register Lisp_Object sequence, n;
1050 {
1051   CHECK_NUMBER (n, 0);
1052   while (1)
1053     {
1054       if (CONSP (sequence) || NILP (sequence))
1055         return Fcar (Fnthcdr (n, sequence));
1056       else if (STRINGP (sequence) || VECTORP (sequence)
1057                || BOOL_VECTOR_P (sequence) || CHAR_TABLE_P (sequence))
1058         return Faref (sequence, n);
1059       else
1060         sequence = wrong_type_argument (Qsequencep, sequence);
1061     }
1062 }
1063
1064 DEFUN ("member", Fmember, Smember, 2, 2, 0,
1065   "Return non-nil if ELT is an element of LIST.  Comparison done with `equal'.\n\
1066 The value is actually the tail of LIST whose car is ELT.")
1067   (elt, list)
1068      register Lisp_Object elt;
1069      Lisp_Object list;
1070 {
1071   register Lisp_Object tail;
1072   for (tail = list; !NILP (tail); tail = XCONS (tail)->cdr)
1073     {
1074       register Lisp_Object tem;
1075       tem = Fcar (tail);
1076       if (! NILP (Fequal (elt, tem)))
1077         return tail;
1078       QUIT;
1079     }
1080   return Qnil;
1081 }
1082
1083 DEFUN ("memq", Fmemq, Smemq, 2, 2, 0,
1084   "Return non-nil if ELT is an element of LIST.  Comparison done with EQ.\n\
1085 The value is actually the tail of LIST whose car is ELT.")
1086   (elt, list)
1087      register Lisp_Object elt;
1088      Lisp_Object list;
1089 {
1090   register Lisp_Object tail;
1091   for (tail = list; !NILP (tail); tail = XCONS (tail)->cdr)
1092     {
1093       register Lisp_Object tem;
1094       tem = Fcar (tail);
1095       if (EQ (elt, tem)) return tail;
1096       QUIT;
1097     }
1098   return Qnil;
1099 }
1100
1101 DEFUN ("assq", Fassq, Sassq, 2, 2, 0,
1102   "Return non-nil if KEY is `eq' to the car of an element of LIST.\n\
1103 The value is actually the element of LIST whose car is KEY.\n\
1104 Elements of LIST that are not conses are ignored.")
1105   (key, list)
1106      register Lisp_Object key;
1107      Lisp_Object list;
1108 {
1109   register Lisp_Object tail;
1110   for (tail = list; !NILP (tail); tail = XCONS (tail)->cdr)
1111     {
1112       register Lisp_Object elt, tem;
1113       elt = Fcar (tail);
1114       if (!CONSP (elt)) continue;
1115       tem = XCONS (elt)->car;
1116       if (EQ (key, tem)) return elt;
1117       QUIT;
1118     }
1119   return Qnil;
1120 }
1121
1122 /* Like Fassq but never report an error and do not allow quits.
1123    Use only on lists known never to be circular.  */
1124
1125 Lisp_Object
1126 assq_no_quit (key, list)
1127      register Lisp_Object key;
1128      Lisp_Object list;
1129 {
1130   register Lisp_Object tail;
1131   for (tail = list; CONSP (tail); tail = XCONS (tail)->cdr)
1132     {
1133       register Lisp_Object elt, tem;
1134       elt = Fcar (tail);
1135       if (!CONSP (elt)) continue;
1136       tem = XCONS (elt)->car;
1137       if (EQ (key, tem)) return elt;
1138     }
1139   return Qnil;
1140 }
1141
1142 DEFUN ("assoc", Fassoc, Sassoc, 2, 2, 0,
1143   "Return non-nil if KEY is `equal' to the car of an element of LIST.\n\
1144 The value is actually the element of LIST whose car equals KEY.")
1145   (key, list)
1146      register Lisp_Object key;
1147      Lisp_Object list;
1148 {
1149   register Lisp_Object tail;
1150   for (tail = list; !NILP (tail); tail = XCONS (tail)->cdr)
1151     {
1152       register Lisp_Object elt, tem;
1153       elt = Fcar (tail);
1154       if (!CONSP (elt)) continue;
1155       tem = Fequal (XCONS (elt)->car, key);
1156       if (!NILP (tem)) return elt;
1157       QUIT;
1158     }
1159   return Qnil;
1160 }
1161
1162 DEFUN ("rassq", Frassq, Srassq, 2, 2, 0,
1163   "Return non-nil if ELT is `eq' to the cdr of an element of LIST.\n\
1164 The value is actually the element of LIST whose cdr is ELT.")
1165   (key, list)
1166      register Lisp_Object key;
1167      Lisp_Object list;
1168 {
1169   register Lisp_Object tail;
1170   for (tail = list; !NILP (tail); tail = XCONS (tail)->cdr)
1171     {
1172       register Lisp_Object elt, tem;
1173       elt = Fcar (tail);
1174       if (!CONSP (elt)) continue;
1175       tem = XCONS (elt)->cdr;
1176       if (EQ (key, tem)) return elt;
1177       QUIT;
1178     }
1179   return Qnil;
1180 }
1181
1182 DEFUN ("rassoc", Frassoc, Srassoc, 2, 2, 0,
1183   "Return non-nil if KEY is `equal' to the cdr of an element of LIST.\n\
1184 The value is actually the element of LIST whose cdr equals KEY.")
1185   (key, list)
1186      register Lisp_Object key;
1187      Lisp_Object list;
1188 {
1189   register Lisp_Object tail;
1190   for (tail = list; !NILP (tail); tail = XCONS (tail)->cdr)
1191     {
1192       register Lisp_Object elt, tem;
1193       elt = Fcar (tail);
1194       if (!CONSP (elt)) continue;
1195       tem = Fequal (XCONS (elt)->cdr, key);
1196       if (!NILP (tem)) return elt;
1197       QUIT;
1198     }
1199   return Qnil;
1200 }
1201 \f
1202 DEFUN ("delq", Fdelq, Sdelq, 2, 2, 0,
1203   "Delete by side effect any occurrences of ELT as a member of LIST.\n\
1204 The modified LIST is returned.  Comparison is done with `eq'.\n\
1205 If the first member of LIST is ELT, there is no way to remove it by side effect;\n\
1206 therefore, write `(setq foo (delq element foo))'\n\
1207 to be sure of changing the value of `foo'.")
1208   (elt, list)
1209      register Lisp_Object elt;
1210      Lisp_Object list;
1211 {
1212   register Lisp_Object tail, prev;
1213   register Lisp_Object tem;
1214
1215   tail = list;
1216   prev = Qnil;
1217   while (!NILP (tail))
1218     {
1219       tem = Fcar (tail);
1220       if (EQ (elt, tem))
1221         {
1222           if (NILP (prev))
1223             list = XCONS (tail)->cdr;
1224           else
1225             Fsetcdr (prev, XCONS (tail)->cdr);
1226         }
1227       else
1228         prev = tail;
1229       tail = XCONS (tail)->cdr;
1230       QUIT;
1231     }
1232   return list;
1233 }
1234
1235 DEFUN ("delete", Fdelete, Sdelete, 2, 2, 0,
1236   "Delete by side effect any occurrences of ELT as a member of LIST.\n\
1237 The modified LIST is returned.  Comparison is done with `equal'.\n\
1238 If the first member of LIST is ELT, deleting it is not a side effect;\n\
1239 it is simply using a different list.\n\
1240 Therefore, write `(setq foo (delete element foo))'\n\
1241 to be sure of changing the value of `foo'.")
1242   (elt, list)
1243      register Lisp_Object elt;
1244      Lisp_Object list;
1245 {
1246   register Lisp_Object tail, prev;
1247   register Lisp_Object tem;
1248
1249   tail = list;
1250   prev = Qnil;
1251   while (!NILP (tail))
1252     {
1253       tem = Fcar (tail);
1254       if (! NILP (Fequal (elt, tem)))
1255         {
1256           if (NILP (prev))
1257             list = XCONS (tail)->cdr;
1258           else
1259             Fsetcdr (prev, XCONS (tail)->cdr);
1260         }
1261       else
1262         prev = tail;
1263       tail = XCONS (tail)->cdr;
1264       QUIT;
1265     }
1266   return list;
1267 }
1268
1269 DEFUN ("nreverse", Fnreverse, Snreverse, 1, 1, 0,
1270   "Reverse LIST by modifying cdr pointers.\n\
1271 Returns the beginning of the reversed list.")
1272   (list)
1273      Lisp_Object list;
1274 {
1275   register Lisp_Object prev, tail, next;
1276
1277   if (NILP (list)) return list;
1278   prev = Qnil;
1279   tail = list;
1280   while (!NILP (tail))
1281     {
1282       QUIT;
1283       next = Fcdr (tail);
1284       Fsetcdr (tail, prev);
1285       prev = tail;
1286       tail = next;
1287     }
1288   return prev;
1289 }
1290
1291 DEFUN ("reverse", Freverse, Sreverse, 1, 1, 0,
1292   "Reverse LIST, copying.  Returns the beginning of the reversed list.\n\
1293 See also the function `nreverse', which is used more often.")
1294   (list)
1295      Lisp_Object list;
1296 {
1297   Lisp_Object new;
1298
1299   for (new = Qnil; CONSP (list); list = XCONS (list)->cdr)
1300     new = Fcons (XCONS (list)->car, new);
1301   if (!NILP (list))
1302     wrong_type_argument (Qconsp, list);
1303   return new;
1304 }
1305 \f
1306 Lisp_Object merge ();
1307
1308 DEFUN ("sort", Fsort, Ssort, 2, 2, 0,
1309   "Sort LIST, stably, comparing elements using PREDICATE.\n\
1310 Returns the sorted list.  LIST is modified by side effects.\n\
1311 PREDICATE is called with two elements of LIST, and should return T\n\
1312 if the first element is \"less\" than the second.")
1313   (list, predicate)
1314      Lisp_Object list, predicate;
1315 {
1316   Lisp_Object front, back;
1317   register Lisp_Object len, tem;
1318   struct gcpro gcpro1, gcpro2;
1319   register int length;
1320
1321   front = list;
1322   len = Flength (list);
1323   length = XINT (len);
1324   if (length < 2)
1325     return list;
1326
1327   XSETINT (len, (length / 2) - 1);
1328   tem = Fnthcdr (len, list);
1329   back = Fcdr (tem);
1330   Fsetcdr (tem, Qnil);
1331
1332   GCPRO2 (front, back);
1333   front = Fsort (front, predicate);
1334   back = Fsort (back, predicate);
1335   UNGCPRO;
1336   return merge (front, back, predicate);
1337 }
1338
1339 Lisp_Object
1340 merge (org_l1, org_l2, pred)
1341      Lisp_Object org_l1, org_l2;
1342      Lisp_Object pred;
1343 {
1344   Lisp_Object value;
1345   register Lisp_Object tail;
1346   Lisp_Object tem;
1347   register Lisp_Object l1, l2;
1348   struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
1349
1350   l1 = org_l1;
1351   l2 = org_l2;
1352   tail = Qnil;
1353   value = Qnil;
1354
1355   /* It is sufficient to protect org_l1 and org_l2.
1356      When l1 and l2 are updated, we copy the new values
1357      back into the org_ vars.  */
1358   GCPRO4 (org_l1, org_l2, pred, value);
1359
1360   while (1)
1361     {
1362       if (NILP (l1))
1363         {
1364           UNGCPRO;
1365           if (NILP (tail))
1366             return l2;
1367           Fsetcdr (tail, l2);
1368           return value;
1369         }
1370       if (NILP (l2))
1371         {
1372           UNGCPRO;
1373           if (NILP (tail))
1374             return l1;
1375           Fsetcdr (tail, l1);
1376           return value;
1377         }
1378       tem = call2 (pred, Fcar (l2), Fcar (l1));
1379       if (NILP (tem))
1380         {
1381           tem = l1;
1382           l1 = Fcdr (l1);
1383           org_l1 = l1;
1384         }
1385       else
1386         {
1387           tem = l2;
1388           l2 = Fcdr (l2);
1389           org_l2 = l2;
1390         }
1391       if (NILP (tail))
1392         value = tem;
1393       else
1394         Fsetcdr (tail, tem);
1395       tail = tem;
1396     }
1397 }
1398 \f
1399
1400 DEFUN ("plist-get", Fplist_get, Splist_get, 2, 2, 0,
1401   "Extract a value from a property list.\n\
1402 PLIST is a property list, which is a list of the form\n\
1403 \(PROP1 VALUE1 PROP2 VALUE2...).  This function returns the value\n\
1404 corresponding to the given PROP, or nil if PROP is not\n\
1405 one of the properties on the list.")
1406   (plist, prop)
1407      Lisp_Object plist;
1408      register Lisp_Object prop;
1409 {
1410   register Lisp_Object tail;
1411   for (tail = plist; !NILP (tail); tail = Fcdr (XCONS (tail)->cdr))
1412     {
1413       register Lisp_Object tem;
1414       tem = Fcar (tail);
1415       if (EQ (prop, tem))
1416         return Fcar (XCONS (tail)->cdr);
1417     }
1418   return Qnil;
1419 }
1420
1421 DEFUN ("get", Fget, Sget, 2, 2, 0,
1422   "Return the value of SYMBOL's PROPNAME property.\n\
1423 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'.")
1424   (symbol, propname)
1425      Lisp_Object symbol, propname;
1426 {
1427   CHECK_SYMBOL (symbol, 0);
1428   return Fplist_get (XSYMBOL (symbol)->plist, propname);
1429 }
1430
1431 DEFUN ("plist-put", Fplist_put, Splist_put, 3, 3, 0,
1432   "Change value in PLIST of PROP to VAL.\n\
1433 PLIST is a property list, which is a list of the form\n\
1434 \(PROP1 VALUE1 PROP2 VALUE2 ...).  PROP is a symbol and VAL is any object.\n\
1435 If PROP is already a property on the list, its value is set to VAL,\n\
1436 otherwise the new PROP VAL pair is added.  The new plist is returned;\n\
1437 use `(setq x (plist-put x prop val))' to be sure to use the new value.\n\
1438 The PLIST is modified by side effects.")
1439   (plist, prop, val)
1440      Lisp_Object plist;
1441      register Lisp_Object prop;
1442      Lisp_Object val;
1443 {
1444   register Lisp_Object tail, prev;
1445   Lisp_Object newcell;
1446   prev = Qnil;
1447   for (tail = plist; CONSP (tail) && CONSP (XCONS (tail)->cdr);
1448        tail = XCONS (XCONS (tail)->cdr)->cdr)
1449     {
1450       if (EQ (prop, XCONS (tail)->car))
1451         {
1452           Fsetcar (XCONS (tail)->cdr, val);
1453           return plist;
1454         }
1455       prev = tail;
1456     }
1457   newcell = Fcons (prop, Fcons (val, Qnil));
1458   if (NILP (prev))
1459     return newcell;
1460   else
1461     Fsetcdr (XCONS (prev)->cdr, newcell);
1462   return plist;
1463 }
1464
1465 DEFUN ("put", Fput, Sput, 3, 3, 0,
1466   "Store SYMBOL's PROPNAME property with value VALUE.\n\
1467 It can be retrieved with `(get SYMBOL PROPNAME)'.")
1468   (symbol, propname, value)
1469      Lisp_Object symbol, propname, value;
1470 {
1471   CHECK_SYMBOL (symbol, 0);
1472   XSYMBOL (symbol)->plist
1473     = Fplist_put (XSYMBOL (symbol)->plist, propname, value);
1474   return value;
1475 }
1476
1477 DEFUN ("equal", Fequal, Sequal, 2, 2, 0,
1478   "Return t if two Lisp objects have similar structure and contents.\n\
1479 They must have the same data type.\n\
1480 Conses are compared by comparing the cars and the cdrs.\n\
1481 Vectors and strings are compared element by element.\n\
1482 Numbers are compared by value, but integers cannot equal floats.\n\
1483  (Use `=' if you want integers and floats to be able to be equal.)\n\
1484 Symbols must match exactly.")
1485   (o1, o2)
1486      register Lisp_Object o1, o2;
1487 {
1488   return internal_equal (o1, o2, 0) ? Qt : Qnil;
1489 }
1490
1491 static int
1492 internal_equal (o1, o2, depth)
1493      register Lisp_Object o1, o2;
1494      int depth;
1495 {
1496   if (depth > 200)
1497     error ("Stack overflow in equal");
1498
1499  tail_recurse:
1500   QUIT;
1501   if (EQ (o1, o2))
1502     return 1;
1503   if (XTYPE (o1) != XTYPE (o2))
1504     return 0;
1505
1506   switch (XTYPE (o1))
1507     {
1508 #ifdef LISP_FLOAT_TYPE
1509     case Lisp_Float:
1510       return (extract_float (o1) == extract_float (o2));
1511 #endif
1512
1513     case Lisp_Cons:
1514       if (!internal_equal (XCONS (o1)->car, XCONS (o2)->car, depth + 1))
1515         return 0;
1516       o1 = XCONS (o1)->cdr;
1517       o2 = XCONS (o2)->cdr;
1518       goto tail_recurse;
1519
1520     case Lisp_Misc:
1521       if (XMISCTYPE (o1) != XMISCTYPE (o2))
1522         return 0;
1523       if (OVERLAYP (o1))
1524         {
1525           if (!internal_equal (OVERLAY_START (o1), OVERLAY_START (o1),
1526                                depth + 1)
1527               || !internal_equal (OVERLAY_END (o1), OVERLAY_END (o1),
1528                                   depth + 1))
1529             return 0;
1530           o1 = XOVERLAY (o1)->plist;
1531           o2 = XOVERLAY (o2)->plist;
1532           goto tail_recurse;
1533         }
1534       if (MARKERP (o1))
1535         {
1536           return (XMARKER (o1)->buffer == XMARKER (o2)->buffer
1537                   && (XMARKER (o1)->buffer == 0
1538                       || XMARKER (o1)->bytepos == XMARKER (o2)->bytepos));
1539         }
1540       break;
1541
1542     case Lisp_Vectorlike:
1543       {
1544         register int i, size;
1545         size = XVECTOR (o1)->size;
1546         /* Pseudovectors have the type encoded in the size field, so this test
1547            actually checks that the objects have the same type as well as the
1548            same size.  */
1549         if (XVECTOR (o2)->size != size)
1550           return 0;
1551         /* Boolvectors are compared much like strings.  */
1552         if (BOOL_VECTOR_P (o1))
1553           {
1554             int size_in_chars
1555               = (XBOOL_VECTOR (o1)->size + BITS_PER_CHAR - 1) / BITS_PER_CHAR;
1556
1557             if (XBOOL_VECTOR (o1)->size != XBOOL_VECTOR (o2)->size)
1558               return 0;
1559             if (bcmp (XBOOL_VECTOR (o1)->data, XBOOL_VECTOR (o2)->data,
1560                       size_in_chars))
1561               return 0;
1562             return 1;
1563           }
1564         if (WINDOW_CONFIGURATIONP (o1))
1565           return compare_window_configurations (o1, o2, 0);
1566
1567         /* Aside from them, only true vectors, char-tables, and compiled
1568            functions are sensible to compare, so eliminate the others now.  */
1569         if (size & PSEUDOVECTOR_FLAG)
1570           {
1571             if (!(size & (PVEC_COMPILED | PVEC_CHAR_TABLE)))
1572               return 0;
1573             size &= PSEUDOVECTOR_SIZE_MASK;
1574           }
1575         for (i = 0; i < size; i++)
1576           {
1577             Lisp_Object v1, v2;
1578             v1 = XVECTOR (o1)->contents [i];
1579             v2 = XVECTOR (o2)->contents [i];
1580             if (!internal_equal (v1, v2, depth + 1))
1581               return 0;
1582           }
1583         return 1;
1584       }
1585       break;
1586
1587     case Lisp_String:
1588       if (XSTRING (o1)->size != XSTRING (o2)->size)
1589         return 0;
1590       if (STRING_BYTES (XSTRING (o1)) != STRING_BYTES (XSTRING (o2)))
1591         return 0;
1592       if (bcmp (XSTRING (o1)->data, XSTRING (o2)->data,
1593                 STRING_BYTES (XSTRING (o1))))
1594         return 0;
1595       return 1;
1596     }
1597   return 0;
1598 }
1599 \f
1600 extern Lisp_Object Fmake_char_internal ();
1601
1602 DEFUN ("fillarray", Ffillarray, Sfillarray, 2, 2, 0,
1603   "Store each element of ARRAY with ITEM.\n\
1604 ARRAY is a vector, string, char-table, or bool-vector.")
1605   (array, item)
1606      Lisp_Object array, item;
1607 {
1608   register int size, index, charval;
1609  retry:
1610   if (VECTORP (array))
1611     {
1612       register Lisp_Object *p = XVECTOR (array)->contents;
1613       size = XVECTOR (array)->size;
1614       for (index = 0; index < size; index++)
1615         p[index] = item;
1616     }
1617   else if (CHAR_TABLE_P (array))
1618     {
1619       register Lisp_Object *p = XCHAR_TABLE (array)->contents;
1620       size = CHAR_TABLE_ORDINARY_SLOTS;
1621       for (index = 0; index < size; index++)
1622         p[index] = item;
1623       XCHAR_TABLE (array)->defalt = Qnil;
1624     }
1625   else if (STRINGP (array))
1626     {
1627       register unsigned char *p = XSTRING (array)->data;
1628       CHECK_NUMBER (item, 1);
1629       charval = XINT (item);
1630       size = XSTRING (array)->size;
1631       for (index = 0; index < size; index++)
1632         p[index] = charval;
1633     }
1634   else if (BOOL_VECTOR_P (array))
1635     {
1636       register unsigned char *p = XBOOL_VECTOR (array)->data;
1637       int size_in_chars
1638         = (XBOOL_VECTOR (array)->size + BITS_PER_CHAR - 1) / BITS_PER_CHAR;
1639
1640       charval = (! NILP (item) ? -1 : 0);
1641       for (index = 0; index < size_in_chars; index++)
1642         p[index] = charval;
1643     }
1644   else
1645     {
1646       array = wrong_type_argument (Qarrayp, array);
1647       goto retry;
1648     }
1649   return array;
1650 }
1651 \f
1652 DEFUN ("char-table-subtype", Fchar_table_subtype, Schar_table_subtype,
1653        1, 1, 0,
1654   "Return the subtype of char-table CHAR-TABLE.   The value is a symbol.")
1655   (char_table)
1656      Lisp_Object char_table;
1657 {
1658   CHECK_CHAR_TABLE (char_table, 0);
1659
1660   return XCHAR_TABLE (char_table)->purpose;
1661 }
1662
1663 DEFUN ("char-table-parent", Fchar_table_parent, Schar_table_parent,
1664        1, 1, 0,
1665   "Return the parent char-table of CHAR-TABLE.\n\
1666 The value is either nil or another char-table.\n\
1667 If CHAR-TABLE holds nil for a given character,\n\
1668 then the actual applicable value is inherited from the parent char-table\n\
1669 \(or from its parents, if necessary).")
1670   (char_table)
1671      Lisp_Object char_table;
1672 {
1673   CHECK_CHAR_TABLE (char_table, 0);
1674
1675   return XCHAR_TABLE (char_table)->parent;
1676 }
1677
1678 DEFUN ("set-char-table-parent", Fset_char_table_parent, Sset_char_table_parent,
1679        2, 2, 0,
1680   "Set the parent char-table of CHAR-TABLE to PARENT.\n\
1681 PARENT must be either nil or another char-table.")
1682   (char_table, parent)
1683      Lisp_Object char_table, parent;
1684 {
1685   Lisp_Object temp;
1686
1687   CHECK_CHAR_TABLE (char_table, 0);
1688
1689   if (!NILP (parent))
1690     {
1691       CHECK_CHAR_TABLE (parent, 0);
1692
1693       for (temp = parent; !NILP (temp); temp = XCHAR_TABLE (temp)->parent)
1694         if (EQ (temp, char_table))
1695           error ("Attempt to make a chartable be its own parent");
1696     }
1697
1698   XCHAR_TABLE (char_table)->parent = parent;
1699
1700   return parent;
1701 }
1702
1703 DEFUN ("char-table-extra-slot", Fchar_table_extra_slot, Schar_table_extra_slot,
1704        2, 2, 0,
1705   "Return the value of CHAR-TABLE's extra-slot number N.")
1706   (char_table, n)
1707      Lisp_Object char_table, n;
1708 {
1709   CHECK_CHAR_TABLE (char_table, 1);
1710   CHECK_NUMBER (n, 2);
1711   if (XINT (n) < 0
1712       || XINT (n) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table)))
1713     args_out_of_range (char_table, n);
1714
1715   return XCHAR_TABLE (char_table)->extras[XINT (n)];
1716 }
1717
1718 DEFUN ("set-char-table-extra-slot", Fset_char_table_extra_slot,
1719        Sset_char_table_extra_slot,
1720        3, 3, 0,
1721   "Set CHAR-TABLE's extra-slot number N to VALUE.")
1722   (char_table, n, value)
1723      Lisp_Object char_table, n, value;
1724 {
1725   CHECK_CHAR_TABLE (char_table, 1);
1726   CHECK_NUMBER (n, 2);
1727   if (XINT (n) < 0
1728       || XINT (n) >= CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (char_table)))
1729     args_out_of_range (char_table, n);
1730
1731   return XCHAR_TABLE (char_table)->extras[XINT (n)] = value;
1732 }
1733 \f
1734 DEFUN ("char-table-range", Fchar_table_range, Schar_table_range,
1735        2, 2, 0,
1736   "Return the value in CHAR-TABLE for a range of characters RANGE.\n\
1737 RANGE should be nil (for the default value)\n\
1738 a vector which identifies a character set or a row of a character set,\n\
1739 a character set name, or a character code.")
1740   (char_table, range)
1741      Lisp_Object char_table, range;
1742 {
1743   int i;
1744
1745   CHECK_CHAR_TABLE (char_table, 0);
1746
1747   if (EQ (range, Qnil))
1748     return XCHAR_TABLE (char_table)->defalt;
1749   else if (INTEGERP (range))
1750     return Faref (char_table, range);
1751   else if (SYMBOLP (range))
1752     {
1753       Lisp_Object charset_info;
1754
1755       charset_info = Fget (range, Qcharset);
1756       CHECK_VECTOR (charset_info, 0);
1757
1758       return Faref (char_table, XVECTOR (charset_info)->contents[0] + 128);
1759     }
1760   else if (VECTORP (range))
1761     {
1762       if (XVECTOR (range)->size == 1)
1763         return Faref (char_table, XVECTOR (range)->contents[0] + 128);
1764       else
1765         {
1766           int size = XVECTOR (range)->size;
1767           Lisp_Object *val = XVECTOR (range)->contents;
1768           Lisp_Object ch = Fmake_char_internal (size <= 0 ? Qnil : val[0],
1769                                                 size <= 1 ? Qnil : val[1],
1770                                                 size <= 2 ? Qnil : val[2]);
1771           return Faref (char_table, ch);
1772         }
1773     }
1774   else
1775     error ("Invalid RANGE argument to `char-table-range'");
1776 }
1777
1778 DEFUN ("set-char-table-range", Fset_char_table_range, Sset_char_table_range,
1779        3, 3, 0,
1780   "Set the value in CHAR-TABLE for a range of characters RANGE to VALUE.\n\
1781 RANGE should be t (for all characters), nil (for the default value)\n\
1782 a vector which identifies a character set or a row of a character set,\n\
1783 a coding system, or a character code.")
1784   (char_table, range, value)
1785      Lisp_Object char_table, range, value;
1786 {
1787   int i;
1788
1789   CHECK_CHAR_TABLE (char_table, 0);
1790
1791   if (EQ (range, Qt))
1792     for (i = 0; i < CHAR_TABLE_ORDINARY_SLOTS; i++)
1793       XCHAR_TABLE (char_table)->contents[i] = value;
1794   else if (EQ (range, Qnil))
1795     XCHAR_TABLE (char_table)->defalt = value;
1796   else if (SYMBOLP (range))
1797     {
1798       Lisp_Object charset_info;
1799
1800       charset_info = Fget (range, Qcharset);
1801       CHECK_VECTOR (charset_info, 0);
1802
1803       return Faset (char_table, XVECTOR (charset_info)->contents[0] + 128,
1804                     value);
1805     }
1806   else if (INTEGERP (range))
1807     Faset (char_table, range, value);
1808   else if (VECTORP (range))
1809     {
1810       if (XVECTOR (range)->size == 1)
1811         return Faset (char_table, XVECTOR (range)->contents[0] + 128, value);
1812       else
1813         {
1814           int size = XVECTOR (range)->size;
1815           Lisp_Object *val = XVECTOR (range)->contents;
1816           Lisp_Object ch = Fmake_char_internal (size <= 0 ? Qnil : val[0],
1817                                                 size <= 1 ? Qnil : val[1],
1818                                                 size <= 2 ? Qnil : val[2]);
1819           return Faset (char_table, ch, value);
1820         }
1821     }
1822   else
1823     error ("Invalid RANGE argument to `set-char-table-range'");
1824
1825   return value;
1826 }
1827
1828 DEFUN ("set-char-table-default", Fset_char_table_default,
1829        Sset_char_table_default, 3, 3, 0,
1830   "Set the default value in CHAR-TABLE for a generic character CHAR to VALUE.\n\
1831 The generic character specifies the group of characters.\n\
1832 See also the documentation of make-char.")
1833   (char_table, ch, value)
1834      Lisp_Object char_table, ch, value;
1835 {
1836   int c, i, charset, code1, code2;
1837   Lisp_Object temp;
1838
1839   CHECK_CHAR_TABLE (char_table, 0);
1840   CHECK_NUMBER (ch, 1);
1841
1842   c = XINT (ch);
1843   SPLIT_NON_ASCII_CHAR (c, charset, code1, code2);
1844   if (! CHARSET_DEFINED_P (charset))
1845     invalid_character (c);
1846
1847   if (charset == CHARSET_ASCII)
1848     return (XCHAR_TABLE (char_table)->defalt = value);
1849
1850   /* Even if C is not a generic char, we had better behave as if a
1851      generic char is specified.  */
1852   if (CHARSET_DIMENSION (charset) == 1)
1853     code1 = 0;
1854   temp = XCHAR_TABLE (char_table)->contents[charset + 128];
1855   if (!code1)
1856     {
1857       if (SUB_CHAR_TABLE_P (temp))
1858         XCHAR_TABLE (temp)->defalt = value;
1859       else
1860         XCHAR_TABLE (char_table)->contents[charset + 128] = value;
1861       return value;
1862     }
1863   char_table = temp;
1864   if (! SUB_CHAR_TABLE_P (char_table))
1865     char_table = (XCHAR_TABLE (char_table)->contents[charset + 128]
1866             = make_sub_char_table (temp));
1867   temp = XCHAR_TABLE (char_table)->contents[code1];
1868   if (SUB_CHAR_TABLE_P (temp))
1869     XCHAR_TABLE (temp)->defalt = value;
1870   else
1871     XCHAR_TABLE (char_table)->contents[code1] = value;
1872   return value;
1873 }
1874 \f
1875 /* Map C_FUNCTION or FUNCTION over SUBTABLE, calling it for each
1876    character or group of characters that share a value.
1877    DEPTH is the current depth in the originally specified
1878    chartable, and INDICES contains the vector indices
1879    for the levels our callers have descended.
1880
1881    ARG is passed to C_FUNCTION when that is called.  */
1882
1883 void
1884 map_char_table (c_function, function, subtable, arg, depth, indices)
1885      void (*c_function) P_ ((Lisp_Object, Lisp_Object, Lisp_Object));
1886      Lisp_Object function, subtable, arg, *indices;
1887      int depth;
1888 {
1889   int i, to;
1890
1891   if (depth == 0)
1892     {
1893       /* At first, handle ASCII and 8-bit European characters.  */
1894       for (i = 0; i < CHAR_TABLE_SINGLE_BYTE_SLOTS; i++)
1895         {
1896           Lisp_Object elt = XCHAR_TABLE (subtable)->contents[i];
1897           if (c_function)
1898             (*c_function) (arg, make_number (i), elt);
1899           else
1900             call2 (function, make_number (i), elt);
1901         }
1902 #if 0 /* If the char table has entries for higher characters,
1903          we should report them.  */
1904       if (NILP (current_buffer->enable_multibyte_characters))
1905         return;
1906 #endif
1907       to = CHAR_TABLE_ORDINARY_SLOTS;
1908     }
1909   else
1910     {
1911       i = 32;
1912       to = SUB_CHAR_TABLE_ORDINARY_SLOTS;
1913     }
1914
1915   for (; i < to; i++)
1916     {
1917       Lisp_Object elt = XCHAR_TABLE (subtable)->contents[i];
1918
1919       XSETFASTINT (indices[depth], i);
1920
1921       if (SUB_CHAR_TABLE_P (elt))
1922         {
1923           if (depth >= 3)
1924             error ("Too deep char table");
1925           map_char_table (c_function, function, elt, arg, depth + 1, indices);
1926         }
1927       else
1928         {
1929           int charset = XFASTINT (indices[0]) - 128, c1, c2, c;
1930
1931           if (CHARSET_DEFINED_P (charset))
1932             {
1933               c1 = depth >= 1 ? XFASTINT (indices[1]) : 0;
1934               c2 = depth >= 2 ? XFASTINT (indices[2]) : 0;
1935               c = MAKE_NON_ASCII_CHAR (charset, c1, c2);
1936               if (c_function)
1937                 (*c_function) (arg, make_number (c), elt);
1938               else
1939                 call2 (function, make_number (c), elt);
1940             }
1941         }
1942     }
1943 }
1944
1945 DEFUN ("map-char-table", Fmap_char_table, Smap_char_table,
1946   2, 2, 0,
1947   "Call FUNCTION for each (normal and generic) characters in CHAR-TABLE.\n\
1948 FUNCTION is called with two arguments--a key and a value.\n\
1949 The key is always a possible IDX argument to `aref'.")
1950   (function, char_table)
1951      Lisp_Object function, char_table;
1952 {
1953   /* The depth of char table is at most 3. */
1954   Lisp_Object indices[3];
1955
1956   CHECK_CHAR_TABLE (char_table, 1);
1957
1958   map_char_table (NULL, function, char_table, char_table, 0, indices);
1959   return Qnil;
1960 }
1961 \f
1962 /* ARGSUSED */
1963 Lisp_Object
1964 nconc2 (s1, s2)
1965      Lisp_Object s1, s2;
1966 {
1967 #ifdef NO_ARG_ARRAY
1968   Lisp_Object args[2];
1969   args[0] = s1;
1970   args[1] = s2;
1971   return Fnconc (2, args);
1972 #else
1973   return Fnconc (2, &s1);
1974 #endif /* NO_ARG_ARRAY */
1975 }
1976
1977 DEFUN ("nconc", Fnconc, Snconc, 0, MANY, 0,
1978   "Concatenate any number of lists by altering them.\n\
1979 Only the last argument is not altered, and need not be a list.")
1980   (nargs, args)
1981      int nargs;
1982      Lisp_Object *args;
1983 {
1984   register int argnum;
1985   register Lisp_Object tail, tem, val;
1986
1987   val = Qnil;
1988
1989   for (argnum = 0; argnum < nargs; argnum++)
1990     {
1991       tem = args[argnum];
1992       if (NILP (tem)) continue;
1993
1994       if (NILP (val))
1995         val = tem;
1996
1997       if (argnum + 1 == nargs) break;
1998
1999       if (!CONSP (tem))
2000         tem = wrong_type_argument (Qlistp, tem);
2001
2002       while (CONSP (tem))
2003         {
2004           tail = tem;
2005           tem = Fcdr (tail);
2006           QUIT;
2007         }
2008
2009       tem = args[argnum + 1];
2010       Fsetcdr (tail, tem);
2011       if (NILP (tem))
2012         args[argnum + 1] = tail;
2013     }
2014
2015   return val;
2016 }
2017 \f
2018 /* This is the guts of all mapping functions.
2019  Apply FN to each element of SEQ, one by one,
2020  storing the results into elements of VALS, a C vector of Lisp_Objects.
2021  LENI is the length of VALS, which should also be the length of SEQ.  */
2022
2023 static void
2024 mapcar1 (leni, vals, fn, seq)
2025      int leni;
2026      Lisp_Object *vals;
2027      Lisp_Object fn, seq;
2028 {
2029   register Lisp_Object tail;
2030   Lisp_Object dummy;
2031   register int i;
2032   struct gcpro gcpro1, gcpro2, gcpro3;
2033
2034   /* Don't let vals contain any garbage when GC happens.  */
2035   for (i = 0; i < leni; i++)
2036     vals[i] = Qnil;
2037
2038   GCPRO3 (dummy, fn, seq);
2039   gcpro1.var = vals;
2040   gcpro1.nvars = leni;
2041   /* We need not explicitly protect `tail' because it is used only on lists, and
2042     1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
2043
2044   if (VECTORP (seq))
2045     {
2046       for (i = 0; i < leni; i++)
2047         {
2048           dummy = XVECTOR (seq)->contents[i];
2049           vals[i] = call1 (fn, dummy);
2050         }
2051     }
2052   else if (BOOL_VECTOR_P (seq))
2053     {
2054       for (i = 0; i < leni; i++)
2055         {
2056           int byte;
2057           byte = XBOOL_VECTOR (seq)->data[i / BITS_PER_CHAR];
2058           if (byte & (1 << (i % BITS_PER_CHAR)))
2059             dummy = Qt;
2060           else
2061             dummy = Qnil;
2062
2063           vals[i] = call1 (fn, dummy);
2064         }
2065     }
2066   else if (STRINGP (seq) && ! STRING_MULTIBYTE (seq))
2067     {
2068       /* Single-byte string.  */
2069       for (i = 0; i < leni; i++)
2070         {
2071           XSETFASTINT (dummy, XSTRING (seq)->data[i]);
2072           vals[i] = call1 (fn, dummy);
2073         }
2074     }
2075   else if (STRINGP (seq))
2076     {
2077       /* Multi-byte string.  */
2078       int len_byte = STRING_BYTES (XSTRING (seq));
2079       int i_byte;
2080
2081       for (i = 0, i_byte = 0; i < leni;)
2082         {
2083           int c;
2084           int i_before = i;
2085
2086           FETCH_STRING_CHAR_ADVANCE (c, seq, i, i_byte);
2087           XSETFASTINT (dummy, c);
2088           vals[i_before] = call1 (fn, dummy);
2089         }
2090     }
2091   else   /* Must be a list, since Flength did not get an error */
2092     {
2093       tail = seq;
2094       for (i = 0; i < leni; i++)
2095         {
2096           vals[i] = call1 (fn, Fcar (tail));
2097           tail = XCONS (tail)->cdr;
2098         }
2099     }
2100
2101   UNGCPRO;
2102 }
2103
2104 DEFUN ("mapconcat", Fmapconcat, Smapconcat, 3, 3, 0,
2105   "Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.\n\
2106 In between each pair of results, stick in SEPARATOR.  Thus, \" \" as\n\
2107 SEPARATOR results in spaces between the values returned by FUNCTION.\n\
2108 SEQUENCE may be a list, a vector, a bool-vector, or a string.")
2109   (function, sequence, separator)
2110      Lisp_Object function, sequence, separator;
2111 {
2112   Lisp_Object len;
2113   register int leni;
2114   int nargs;
2115   register Lisp_Object *args;
2116   register int i;
2117   struct gcpro gcpro1;
2118
2119   len = Flength (sequence);
2120   leni = XINT (len);
2121   nargs = leni + leni - 1;
2122   if (nargs < 0) return build_string ("");
2123
2124   args = (Lisp_Object *) alloca (nargs * sizeof (Lisp_Object));
2125
2126   GCPRO1 (separator);
2127   mapcar1 (leni, args, function, sequence);
2128   UNGCPRO;
2129
2130   for (i = leni - 1; i >= 0; i--)
2131     args[i + i] = args[i];
2132
2133   for (i = 1; i < nargs; i += 2)
2134     args[i] = separator;
2135
2136   return Fconcat (nargs, args);
2137 }
2138
2139 DEFUN ("mapcar", Fmapcar, Smapcar, 2, 2, 0,
2140   "Apply FUNCTION to each element of SEQUENCE, and make a list of the results.\n\
2141 The result is a list just as long as SEQUENCE.\n\
2142 SEQUENCE may be a list, a vector, a bool-vector, or a string.")
2143   (function, sequence)
2144      Lisp_Object function, sequence;
2145 {
2146   register Lisp_Object len;
2147   register int leni;
2148   register Lisp_Object *args;
2149
2150   len = Flength (sequence);
2151   leni = XFASTINT (len);
2152   args = (Lisp_Object *) alloca (leni * sizeof (Lisp_Object));
2153
2154   mapcar1 (leni, args, function, sequence);
2155
2156   return Flist (leni, args);
2157 }
2158 \f
2159 /* Anything that calls this function must protect from GC!  */
2160
2161 DEFUN ("y-or-n-p", Fy_or_n_p, Sy_or_n_p, 1, 1, 0,
2162   "Ask user a \"y or n\" question.  Return t if answer is \"y\".\n\
2163 Takes one argument, which is the string to display to ask the question.\n\
2164 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.\n\
2165 No confirmation of the answer is requested; a single character is enough.\n\
2166 Also accepts Space to mean yes, or Delete to mean no.")
2167   (prompt)
2168      Lisp_Object prompt;
2169 {
2170   register Lisp_Object obj, key, def, answer_string, map;
2171   register int answer;
2172   Lisp_Object xprompt;
2173   Lisp_Object args[2];
2174   struct gcpro gcpro1, gcpro2;
2175   int count = specpdl_ptr - specpdl;
2176
2177   specbind (Qcursor_in_echo_area, Qt);
2178
2179   map = Fsymbol_value (intern ("query-replace-map"));
2180
2181   CHECK_STRING (prompt, 0);
2182   xprompt = prompt;
2183   GCPRO2 (prompt, xprompt);
2184
2185   while (1)
2186     {
2187
2188 #ifdef HAVE_MENUS
2189       if ((NILP (last_nonmenu_event) || CONSP (last_nonmenu_event))
2190           && use_dialog_box
2191           && have_menus_p ())
2192         {
2193           Lisp_Object pane, menu;
2194           redisplay_preserve_echo_area ();
2195           pane = Fcons (Fcons (build_string ("Yes"), Qt),
2196                         Fcons (Fcons (build_string ("No"), Qnil),
2197                                Qnil));
2198           menu = Fcons (prompt, pane);
2199           obj = Fx_popup_dialog (Qt, menu);
2200           answer = !NILP (obj);
2201           break;
2202         }
2203 #endif /* HAVE_MENUS */
2204       cursor_in_echo_area = 1;
2205       choose_minibuf_frame ();
2206       message_with_string ("%s(y or n) ", xprompt, 0);
2207
2208       if (minibuffer_auto_raise)
2209         {
2210           Lisp_Object mini_frame;
2211
2212           mini_frame = WINDOW_FRAME (XWINDOW (minibuf_window));
2213
2214           Fraise_frame (mini_frame);
2215         }
2216
2217       obj = read_filtered_event (1, 0, 0);
2218       cursor_in_echo_area = 0;
2219       /* If we need to quit, quit with cursor_in_echo_area = 0.  */
2220       QUIT;
2221
2222       key = Fmake_vector (make_number (1), obj);
2223       def = Flookup_key (map, key, Qt);
2224       answer_string = Fsingle_key_description (obj);
2225
2226       if (EQ (def, intern ("skip")))
2227         {
2228           answer = 0;
2229           break;
2230         }
2231       else if (EQ (def, intern ("act")))
2232         {
2233           answer = 1;
2234           break;
2235         }
2236       else if (EQ (def, intern ("recenter")))
2237         {
2238           Frecenter (Qnil);
2239           xprompt = prompt;
2240           continue;
2241         }
2242       else if (EQ (def, intern ("quit")))
2243         Vquit_flag = Qt;
2244       /* We want to exit this command for exit-prefix,
2245          and this is the only way to do it.  */
2246       else if (EQ (def, intern ("exit-prefix")))
2247         Vquit_flag = Qt;
2248
2249       QUIT;
2250
2251       /* If we don't clear this, then the next call to read_char will
2252          return quit_char again, and we'll enter an infinite loop.  */
2253       Vquit_flag = Qnil;
2254
2255       Fding (Qnil);
2256       Fdiscard_input ();
2257       if (EQ (xprompt, prompt))
2258         {
2259           args[0] = build_string ("Please answer y or n.  ");
2260           args[1] = prompt;
2261           xprompt = Fconcat (2, args);
2262         }
2263     }
2264   UNGCPRO;
2265
2266   if (! noninteractive)
2267     {
2268       cursor_in_echo_area = -1;
2269       message_with_string (answer ? "%s(y or n) y" : "%s(y or n) n",
2270                            xprompt, 0);
2271     }
2272
2273   unbind_to (count, Qnil);
2274   return answer ? Qt : Qnil;
2275 }
2276 \f
2277 /* This is how C code calls `yes-or-no-p' and allows the user
2278    to redefined it.
2279
2280    Anything that calls this function must protect from GC!  */
2281
2282 Lisp_Object
2283 do_yes_or_no_p (prompt)
2284      Lisp_Object prompt;
2285 {
2286   return call1 (intern ("yes-or-no-p"), prompt);
2287 }
2288
2289 /* Anything that calls this function must protect from GC!  */
2290
2291 DEFUN ("yes-or-no-p", Fyes_or_no_p, Syes_or_no_p, 1, 1, 0,
2292   "Ask user a yes-or-no question.  Return t if answer is yes.\n\
2293 Takes one argument, which is the string to display to ask the question.\n\
2294 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.\n\
2295 The user must confirm the answer with RET,\n\
2296 and can edit it until it has been confirmed.")
2297   (prompt)
2298      Lisp_Object prompt;
2299 {
2300   register Lisp_Object ans;
2301   Lisp_Object args[2];
2302   struct gcpro gcpro1;
2303   Lisp_Object menu;
2304
2305   CHECK_STRING (prompt, 0);
2306
2307 #ifdef HAVE_MENUS
2308   if ((NILP (last_nonmenu_event) || CONSP (last_nonmenu_event))
2309       && use_dialog_box
2310       && have_menus_p ())
2311     {
2312       Lisp_Object pane, menu, obj;
2313       redisplay_preserve_echo_area ();
2314       pane = Fcons (Fcons (build_string ("Yes"), Qt),
2315                     Fcons (Fcons (build_string ("No"), Qnil),
2316                            Qnil));
2317       GCPRO1 (pane);
2318       menu = Fcons (prompt, pane);
2319       obj = Fx_popup_dialog (Qt, menu);
2320       UNGCPRO;
2321       return obj;
2322     }
2323 #endif /* HAVE_MENUS */
2324
2325   args[0] = prompt;
2326   args[1] = build_string ("(yes or no) ");
2327   prompt = Fconcat (2, args);
2328
2329   GCPRO1 (prompt);
2330
2331   while (1)
2332     {
2333       ans = Fdowncase (Fread_from_minibuffer (prompt, Qnil, Qnil, Qnil,
2334                                               Qyes_or_no_p_history, Qnil,
2335                                               Qnil));
2336       if (XSTRING (ans)->size == 3 && !strcmp (XSTRING (ans)->data, "yes"))
2337         {
2338           UNGCPRO;
2339           return Qt;
2340         }
2341       if (XSTRING (ans)->size == 2 && !strcmp (XSTRING (ans)->data, "no"))
2342         {
2343           UNGCPRO;
2344           return Qnil;
2345         }
2346
2347       Fding (Qnil);
2348       Fdiscard_input ();
2349       message ("Please answer yes or no.");
2350       Fsleep_for (make_number (2), Qnil);
2351     }
2352 }
2353 \f
2354 DEFUN ("load-average", Fload_average, Sload_average, 0, 0, 0,
2355   "Return list of 1 minute, 5 minute and 15 minute load averages.\n\
2356 Each of the three load averages is multiplied by 100,\n\
2357 then converted to integer.\n\
2358 If the 5-minute or 15-minute load averages are not available, return a\n\
2359 shortened list, containing only those averages which are available.")
2360   ()
2361 {
2362   double load_ave[3];
2363   int loads = getloadavg (load_ave, 3);
2364   Lisp_Object ret;
2365
2366   if (loads < 0)
2367     error ("load-average not implemented for this operating system");
2368
2369   ret = Qnil;
2370   while (loads > 0)
2371     ret = Fcons (make_number ((int) (load_ave[--loads] * 100.0)), ret);
2372
2373   return ret;
2374 }
2375 \f
2376 Lisp_Object Vfeatures;
2377
2378 DEFUN ("featurep", Ffeaturep, Sfeaturep, 1, 1, 0,
2379   "Returns t if FEATURE is present in this Emacs.\n\
2380 Use this to conditionalize execution of lisp code based on the presence or\n\
2381 absence of emacs or environment extensions.\n\
2382 Use `provide' to declare that a feature is available.\n\
2383 This function looks at the value of the variable `features'.")
2384   (feature)
2385      Lisp_Object feature;
2386 {
2387   register Lisp_Object tem;
2388   CHECK_SYMBOL (feature, 0);
2389   tem = Fmemq (feature, Vfeatures);
2390   return (NILP (tem)) ? Qnil : Qt;
2391 }
2392
2393 DEFUN ("provide", Fprovide, Sprovide, 1, 1, 0,
2394   "Announce that FEATURE is a feature of the current Emacs.")
2395   (feature)
2396      Lisp_Object feature;
2397 {
2398   register Lisp_Object tem;
2399   CHECK_SYMBOL (feature, 0);
2400   if (!NILP (Vautoload_queue))
2401     Vautoload_queue = Fcons (Fcons (Vfeatures, Qnil), Vautoload_queue);
2402   tem = Fmemq (feature, Vfeatures);
2403   if (NILP (tem))
2404     Vfeatures = Fcons (feature, Vfeatures);
2405   LOADHIST_ATTACH (Fcons (Qprovide, feature));
2406   return feature;
2407 }
2408
2409 DEFUN ("require", Frequire, Srequire, 1, 2, 0,
2410   "If feature FEATURE is not loaded, load it from FILENAME.\n\
2411 If FEATURE is not a member of the list `features', then the feature\n\
2412 is not loaded; so load the file FILENAME.\n\
2413 If FILENAME is omitted, the printname of FEATURE is used as the file name.")
2414   (feature, file_name)
2415      Lisp_Object feature, file_name;
2416 {
2417   register Lisp_Object tem;
2418   CHECK_SYMBOL (feature, 0);
2419   tem = Fmemq (feature, Vfeatures);
2420   LOADHIST_ATTACH (Fcons (Qrequire, feature));
2421   if (NILP (tem))
2422     {
2423       int count = specpdl_ptr - specpdl;
2424
2425       /* Value saved here is to be restored into Vautoload_queue */
2426       record_unwind_protect (un_autoload, Vautoload_queue);
2427       Vautoload_queue = Qt;
2428
2429       Fload (NILP (file_name) ? Fsymbol_name (feature) : file_name,
2430              Qnil, Qt, Qnil, (NILP (file_name) ? Qt : Qnil));
2431
2432       tem = Fmemq (feature, Vfeatures);
2433       if (NILP (tem))
2434         error ("Required feature %s was not provided",
2435                XSYMBOL (feature)->name->data);
2436
2437       /* Once loading finishes, don't undo it.  */
2438       Vautoload_queue = Qt;
2439       feature = unbind_to (count, feature);
2440     }
2441   return feature;
2442 }
2443 \f
2444 /* Primitives for work of the "widget" library.
2445    In an ideal world, this section would not have been necessary.
2446    However, lisp function calls being as slow as they are, it turns
2447    out that some functions in the widget library (wid-edit.el) are the
2448    bottleneck of Widget operation.  Here is their translation to C,
2449    for the sole reason of efficiency.  */
2450
2451 DEFUN ("widget-plist-member", Fwidget_plist_member, Swidget_plist_member, 2, 2, 0,
2452   "Return non-nil if PLIST has the property PROP.\n\
2453 PLIST is a property list, which is a list of the form\n\
2454 \(PROP1 VALUE1 PROP2 VALUE2 ...\).  PROP is a symbol.\n\
2455 Unlike `plist-get', this allows you to distinguish between a missing\n\
2456 property and a property with the value nil.\n\
2457 The value is actually the tail of PLIST whose car is PROP.")
2458   (plist, prop)
2459      Lisp_Object plist, prop;
2460 {
2461   while (CONSP (plist) && !EQ (XCAR (plist), prop))
2462     {
2463       QUIT;
2464       plist = XCDR (plist);
2465       plist = CDR (plist);
2466     }
2467   return plist;
2468 }
2469
2470 DEFUN ("widget-put", Fwidget_put, Swidget_put, 3, 3, 0,
2471   "In WIDGET, set PROPERTY to VALUE.\n\
2472 The value can later be retrieved with `widget-get'.")
2473   (widget, property, value)
2474      Lisp_Object widget, property, value;
2475 {
2476   CHECK_CONS (widget, 1);
2477   XCDR (widget) = Fplist_put (XCDR (widget), property, value);
2478 }
2479
2480 DEFUN ("widget-get", Fwidget_get, Swidget_get, 2, 2, 0,
2481   "In WIDGET, get the value of PROPERTY.\n\
2482 The value could either be specified when the widget was created, or\n\
2483 later with `widget-put'.")
2484   (widget, property)
2485      Lisp_Object widget, property;
2486 {
2487   Lisp_Object tmp;
2488
2489   while (1)
2490     {
2491       if (NILP (widget))
2492         return Qnil;
2493       CHECK_CONS (widget, 1);
2494       tmp = Fwidget_plist_member (XCDR (widget), property);
2495       if (CONSP (tmp))
2496         {
2497           tmp = XCDR (tmp);
2498           return CAR (tmp);
2499         }
2500       tmp = XCAR (widget);
2501       if (NILP (tmp))
2502         return Qnil;
2503       widget = Fget (tmp, Qwidget_type);
2504     }
2505 }
2506
2507 DEFUN ("widget-apply", Fwidget_apply, Swidget_apply, 2, MANY, 0,
2508   "Apply the value of WIDGET's PROPERTY to the widget itself.\n\
2509 ARGS are passed as extra arguments to the function.")
2510   (nargs, args)
2511      int nargs;
2512      Lisp_Object *args;
2513 {
2514   /* This function can GC. */
2515   Lisp_Object newargs[3];
2516   struct gcpro gcpro1, gcpro2;
2517   Lisp_Object result;
2518
2519   newargs[0] = Fwidget_get (args[0], args[1]);
2520   newargs[1] = args[0];
2521   newargs[2] = Flist (nargs - 2, args + 2);
2522   GCPRO2 (newargs[0], newargs[2]);
2523   result = Fapply (3, newargs);
2524   UNGCPRO;
2525   return result;
2526 }
2527 \f
2528 syms_of_fns ()
2529 {
2530   Qstring_lessp = intern ("string-lessp");
2531   staticpro (&Qstring_lessp);
2532   Qprovide = intern ("provide");
2533   staticpro (&Qprovide);
2534   Qrequire = intern ("require");
2535   staticpro (&Qrequire);
2536   Qyes_or_no_p_history = intern ("yes-or-no-p-history");
2537   staticpro (&Qyes_or_no_p_history);
2538   Qcursor_in_echo_area = intern ("cursor-in-echo-area");
2539   staticpro (&Qcursor_in_echo_area);
2540   Qwidget_type = intern ("widget-type");
2541   staticpro (&Qwidget_type);
2542
2543   staticpro (&string_char_byte_cache_string);
2544   string_char_byte_cache_string = Qnil;
2545
2546   Fset (Qyes_or_no_p_history, Qnil);
2547
2548   DEFVAR_LISP ("features", &Vfeatures,
2549     "A list of symbols which are the features of the executing emacs.\n\
2550 Used by `featurep' and `require', and altered by `provide'.");
2551   Vfeatures = Qnil;
2552
2553   DEFVAR_BOOL ("use-dialog-box", &use_dialog_box,
2554     "*Non-nil means mouse commands use dialog boxes to ask questions.\n\
2555 This applies to y-or-n and yes-or-no questions asked by commands\n\
2556 invoked by mouse clicks and mouse menu items.");
2557   use_dialog_box = 1;
2558
2559   defsubr (&Sidentity);
2560   defsubr (&Srandom);
2561   defsubr (&Slength);
2562   defsubr (&Ssafe_length);
2563   defsubr (&Sstring_bytes);
2564   defsubr (&Sstring_equal);
2565   defsubr (&Sstring_lessp);
2566   defsubr (&Sappend);
2567   defsubr (&Sconcat);
2568   defsubr (&Svconcat);
2569   defsubr (&Scopy_sequence);
2570   defsubr (&Sstring_make_multibyte);
2571   defsubr (&Sstring_make_unibyte);
2572   defsubr (&Sstring_as_multibyte);
2573   defsubr (&Sstring_as_unibyte);
2574   defsubr (&Scopy_alist);
2575   defsubr (&Ssubstring);
2576   defsubr (&Snthcdr);
2577   defsubr (&Snth);
2578   defsubr (&Selt);
2579   defsubr (&Smember);
2580   defsubr (&Smemq);
2581   defsubr (&Sassq);
2582   defsubr (&Sassoc);
2583   defsubr (&Srassq);
2584   defsubr (&Srassoc);
2585   defsubr (&Sdelq);
2586   defsubr (&Sdelete);
2587   defsubr (&Snreverse);
2588   defsubr (&Sreverse);
2589   defsubr (&Ssort);
2590   defsubr (&Splist_get);
2591   defsubr (&Sget);
2592   defsubr (&Splist_put);
2593   defsubr (&Sput);
2594   defsubr (&Sequal);
2595   defsubr (&Sfillarray);
2596   defsubr (&Schar_table_subtype);
2597   defsubr (&Schar_table_parent);
2598   defsubr (&Sset_char_table_parent);
2599   defsubr (&Schar_table_extra_slot);
2600   defsubr (&Sset_char_table_extra_slot);
2601   defsubr (&Schar_table_range);
2602   defsubr (&Sset_char_table_range);
2603   defsubr (&Sset_char_table_default);
2604   defsubr (&Smap_char_table);
2605   defsubr (&Snconc);
2606   defsubr (&Smapcar);
2607   defsubr (&Smapconcat);
2608   defsubr (&Sy_or_n_p);
2609   defsubr (&Syes_or_no_p);
2610   defsubr (&Sload_average);
2611   defsubr (&Sfeaturep);
2612   defsubr (&Srequire);
2613   defsubr (&Sprovide);
2614   defsubr (&Swidget_plist_member);
2615   defsubr (&Swidget_put);
2616   defsubr (&Swidget_get);
2617   defsubr (&Swidget_apply);
2618 }