1 /* Random utility Lisp functions.
   2    Copyright (C) 1985, 1986, 1987, 1993, 1994, 1995, 1997,
   3                  1998, 1999, 2000, 2001, 2002, 2003, 2004,
   4                  2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
   5 
   6 This file is part of GNU Emacs.
   7 
   8 GNU Emacs is free software: you can redistribute it and/or modify
   9 it under the terms of the GNU General Public License as published by
  10 the Free Software Foundation, either version 3 of the License, or
  11 (at your option) any later version.
  12 
  13 GNU Emacs is distributed in the hope that it will be useful,
  14 but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 GNU General Public License for more details.
  17 
  18 You should have received a copy of the GNU General Public License
  19 along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.  */
  20 
  21 #include <config.h>
  22 
  23 #ifdef HAVE_UNISTD_H
  24 #include <unistd.h>
  25 #endif
  26 #include <time.h>
  27 #include <setjmp.h>
  28 
  29 /* Note on some machines this defines `vector' as a typedef,
  30    so make sure we don't use that name in this file.  */
  31 #undef vector
  32 #define vector *****
  33 
  34 #include "lisp.h"
  35 #include "commands.h"
  36 #include "character.h"
  37 #include "coding.h"
  38 #include "buffer.h"
  39 #include "keyboard.h"
  40 #include "keymap.h"
  41 #include "intervals.h"
  42 #include "frame.h"
  43 #include "window.h"
  44 #include "blockinput.h"
  45 #ifdef HAVE_MENUS
  46 #if defined (HAVE_X_WINDOWS)
  47 #include "xterm.h"
  48 #endif
  49 #endif /* HAVE_MENUS */
  50 
  51 #ifndef NULL
  52 #define NULL ((POINTER_TYPE *)0)
  53 #endif
  54 
  55 /* Nonzero enables use of dialog boxes for questions
  56    asked by mouse commands.  */
  57 int use_dialog_box;
  58 
  59 /* Nonzero enables use of a file dialog for file name
  60    questions asked by mouse commands.  */
  61 int use_file_dialog;
  62 
  63 extern int minibuffer_auto_raise;
  64 extern Lisp_Object minibuf_window;
  65 extern Lisp_Object Vlocale_coding_system;
  66 extern int load_in_progress;
  67 
  68 Lisp_Object Qstring_lessp, Qprovide, Qrequire;
  69 Lisp_Object Qyes_or_no_p_history;
  70 Lisp_Object Qcursor_in_echo_area;
  71 Lisp_Object Qwidget_type;
  72 Lisp_Object Qcodeset, Qdays, Qmonths, Qpaper;
  73 
  74 extern Lisp_Object Qinput_method_function;
  75 
  76 static int internal_equal P_ ((Lisp_Object , Lisp_Object, int, int));
  77 
  78 extern long get_random ();
  79 extern void seed_random P_ ((long));
  80 
  81 #ifndef HAVE_UNISTD_H
  82 extern long time ();
  83 #endif
  84 
  85 DEFUN ("identity", Fidentity, Sidentity, 1, 1, 0,
  86        doc: /* Return the argument unchanged.  */)
  87      (arg)
  88      Lisp_Object arg;
  89 {
  90   return arg;
  91 }
  92 
  93 DEFUN ("random", Frandom, Srandom, 0, 1, 0,
  94        doc: /* Return a pseudo-random number.
  95 All integers representable in Lisp are equally likely.
  96   On most systems, this is 29 bits' worth.
  97 With positive integer LIMIT, return random number in interval [0,LIMIT).
  98 With argument t, set the random number seed from the current time and pid.
  99 Other values of LIMIT are ignored.  */)
 100      (limit)
 101      Lisp_Object limit;
 102 {
 103   EMACS_INT val;
 104   Lisp_Object lispy_val;
 105   unsigned long denominator;
 106 
 107   if (EQ (limit, Qt))
 108     seed_random (getpid () + time (NULL));
 109   if (NATNUMP (limit) && XFASTINT (limit) != 0)
 110     {
 111       /* Try to take our random number from the higher bits of VAL,
 112          not the lower, since (says Gentzel) the low bits of `random'
 113          are less random than the higher ones.  We do this by using the
 114          quotient rather than the remainder.  At the high end of the RNG
 115          it's possible to get a quotient larger than n; discarding
 116          these values eliminates the bias that would otherwise appear
 117          when using a large n.  */
 118       denominator = ((unsigned long)1 << VALBITS) / XFASTINT (limit);
 119       do
 120         val = get_random () / denominator;
 121       while (val >= XFASTINT (limit));
 122     }
 123   else
 124     val = get_random ();
 125   XSETINT (lispy_val, val);
 126   return lispy_val;
 127 }
 128 
 129 /* Random data-structure functions */
 130 
 131 DEFUN ("length", Flength, Slength, 1, 1, 0,
 132        doc: /* Return the length of vector, list or string SEQUENCE.
 133 A byte-code function object is also allowed.
 134 If the string contains multibyte characters, this is not necessarily
 135 the number of bytes in the string; it is the number of characters.
 136 To get the number of bytes, use `string-bytes'.  */)
 137      (sequence)
 138      register Lisp_Object sequence;
 139 {
 140   register Lisp_Object val;
 141   register int i;
 142 
 143   if (STRINGP (sequence))
 144     XSETFASTINT (val, SCHARS (sequence));
 145   else if (VECTORP (sequence))
 146     XSETFASTINT (val, ASIZE (sequence));
 147   else if (CHAR_TABLE_P (sequence))
 148     XSETFASTINT (val, MAX_CHAR);
 149   else if (BOOL_VECTOR_P (sequence))
 150     XSETFASTINT (val, XBOOL_VECTOR (sequence)->size);
 151   else if (COMPILEDP (sequence))
 152     XSETFASTINT (val, ASIZE (sequence) & PSEUDOVECTOR_SIZE_MASK);
 153   else if (CONSP (sequence))
 154     {
 155       i = 0;
 156       while (CONSP (sequence))
 157         {
 158           sequence = XCDR (sequence);
 159           ++i;
 160 
 161           if (!CONSP (sequence))
 162             break;
 163 
 164           sequence = XCDR (sequence);
 165           ++i;
 166           QUIT;
 167         }
 168 
 169       CHECK_LIST_END (sequence, sequence);
 170 
 171       val = make_number (i);
 172     }
 173   else if (NILP (sequence))
 174     XSETFASTINT (val, 0);
 175   else
 176     wrong_type_argument (Qsequencep, sequence);
 177 
 178   return val;
 179 }
 180 
 181 /* This does not check for quits.  That is safe since it must terminate.  */
 182 
 183 DEFUN ("safe-length", Fsafe_length, Ssafe_length, 1, 1, 0,
 184        doc: /* Return the length of a list, but avoid error or infinite loop.
 185 This function never gets an error.  If LIST is not really a list,
 186 it returns 0.  If LIST is circular, it returns a finite value
 187 which is at least the number of distinct elements.  */)
 188      (list)
 189      Lisp_Object list;
 190 {
 191   Lisp_Object tail, halftail, length;
 192   int len = 0;
 193 
 194   /* halftail is used to detect circular lists.  */
 195   halftail = list;
 196   for (tail = list; CONSP (tail); tail = XCDR (tail))
 197     {
 198       if (EQ (tail, halftail) && len != 0)
 199         break;
 200       len++;
 201       if ((len & 1) == 0)
 202         halftail = XCDR (halftail);
 203     }
 204 
 205   XSETINT (length, len);
 206   return length;
 207 }
 208 
 209 DEFUN ("string-bytes", Fstring_bytes, Sstring_bytes, 1, 1, 0,
 210        doc: /* Return the number of bytes in STRING.
 211 If STRING is multibyte, this may be greater than the length of STRING.  */)
 212      (string)
 213      Lisp_Object string;
 214 {
 215   CHECK_STRING (string);
 216   return make_number (SBYTES (string));
 217 }
 218 
 219 DEFUN ("string-equal", Fstring_equal, Sstring_equal, 2, 2, 0,
 220        doc: /* Return t if two strings have identical contents.
 221 Case is significant, but text properties are ignored.
 222 Symbols are also allowed; their print names are used instead.  */)
 223      (s1, s2)
 224      register Lisp_Object s1, s2;
 225 {
 226   if (SYMBOLP (s1))
 227     s1 = SYMBOL_NAME (s1);
 228   if (SYMBOLP (s2))
 229     s2 = SYMBOL_NAME (s2);
 230   CHECK_STRING (s1);
 231   CHECK_STRING (s2);
 232 
 233   if (SCHARS (s1) != SCHARS (s2)
 234       || SBYTES (s1) != SBYTES (s2)
 235       || bcmp (SDATA (s1), SDATA (s2), SBYTES (s1)))
 236     return Qnil;
 237   return Qt;
 238 }
 239 
 240 DEFUN ("compare-strings", Fcompare_strings,
 241        Scompare_strings, 6, 7, 0,
 242 doc: /* Compare the contents of two strings, converting to multibyte if needed.
 243 In string STR1, skip the first START1 characters and stop at END1.
 244 In string STR2, skip the first START2 characters and stop at END2.
 245 END1 and END2 default to the full lengths of the respective strings.
 246 
 247 Case is significant in this comparison if IGNORE-CASE is nil.
 248 Unibyte strings are converted to multibyte for comparison.
 249 
 250 The value is t if the strings (or specified portions) match.
 251 If string STR1 is less, the value is a negative number N;
 252   - 1 - N is the number of characters that match at the beginning.
 253 If string STR1 is greater, the value is a positive number N;
 254   N - 1 is the number of characters that match at the beginning.  */)
 255      (str1, start1, end1, str2, start2, end2, ignore_case)
 256      Lisp_Object str1, start1, end1, start2, str2, end2, ignore_case;
 257 {
 258   register int end1_char, end2_char;
 259   register int i1, i1_byte, i2, i2_byte;
 260 
 261   CHECK_STRING (str1);
 262   CHECK_STRING (str2);
 263   if (NILP (start1))
 264     start1 = make_number (0);
 265   if (NILP (start2))
 266     start2 = make_number (0);
 267   CHECK_NATNUM (start1);
 268   CHECK_NATNUM (start2);
 269   if (! NILP (end1))
 270     CHECK_NATNUM (end1);
 271   if (! NILP (end2))
 272     CHECK_NATNUM (end2);
 273 
 274   i1 = XINT (start1);
 275   i2 = XINT (start2);
 276 
 277   i1_byte = string_char_to_byte (str1, i1);
 278   i2_byte = string_char_to_byte (str2, i2);
 279 
 280   end1_char = SCHARS (str1);
 281   if (! NILP (end1) && end1_char > XINT (end1))
 282     end1_char = XINT (end1);
 283 
 284   end2_char = SCHARS (str2);
 285   if (! NILP (end2) && end2_char > XINT (end2))
 286     end2_char = XINT (end2);
 287 
 288   while (i1 < end1_char && i2 < end2_char)
 289     {
 290       /* When we find a mismatch, we must compare the
 291          characters, not just the bytes.  */
 292       int c1, c2;
 293 
 294       if (STRING_MULTIBYTE (str1))
 295         FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c1, str1, i1, i1_byte);
 296       else
 297         {
 298           c1 = SREF (str1, i1++);
 299           MAKE_CHAR_MULTIBYTE (c1);
 300         }
 301 
 302       if (STRING_MULTIBYTE (str2))
 303         FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c2, str2, i2, i2_byte);
 304       else
 305         {
 306           c2 = SREF (str2, i2++);
 307           MAKE_CHAR_MULTIBYTE (c2);
 308         }
 309 
 310       if (c1 == c2)
 311         continue;
 312 
 313       if (! NILP (ignore_case))
 314         {
 315           Lisp_Object tem;
 316 
 317           tem = Fupcase (make_number (c1));
 318           c1 = XINT (tem);
 319           tem = Fupcase (make_number (c2));
 320           c2 = XINT (tem);
 321         }
 322 
 323       if (c1 == c2)
 324         continue;
 325 
 326       /* Note that I1 has already been incremented
 327          past the character that we are comparing;
 328          hence we don't add or subtract 1 here.  */
 329       if (c1 < c2)
 330         return make_number (- i1 + XINT (start1));
 331       else
 332         return make_number (i1 - XINT (start1));
 333     }
 334 
 335   if (i1 < end1_char)
 336     return make_number (i1 - XINT (start1) + 1);
 337   if (i2 < end2_char)
 338     return make_number (- i1 + XINT (start1) - 1);
 339 
 340   return Qt;
 341 }
 342 
 343 DEFUN ("string-lessp", Fstring_lessp, Sstring_lessp, 2, 2, 0,
 344        doc: /* Return t if first arg string is less than second in lexicographic order.
 345 Case is significant.
 346 Symbols are also allowed; their print names are used instead.  */)
 347      (s1, s2)
 348      register Lisp_Object s1, s2;
 349 {
 350   register int end;
 351   register int i1, i1_byte, i2, i2_byte;
 352 
 353   if (SYMBOLP (s1))
 354     s1 = SYMBOL_NAME (s1);
 355   if (SYMBOLP (s2))
 356     s2 = SYMBOL_NAME (s2);
 357   CHECK_STRING (s1);
 358   CHECK_STRING (s2);
 359 
 360   i1 = i1_byte = i2 = i2_byte = 0;
 361 
 362   end = SCHARS (s1);
 363   if (end > SCHARS (s2))
 364     end = SCHARS (s2);
 365 
 366   while (i1 < end)
 367     {
 368       /* When we find a mismatch, we must compare the
 369          characters, not just the bytes.  */
 370       int c1, c2;
 371 
 372       FETCH_STRING_CHAR_ADVANCE (c1, s1, i1, i1_byte);
 373       FETCH_STRING_CHAR_ADVANCE (c2, s2, i2, i2_byte);
 374 
 375       if (c1 != c2)
 376         return c1 < c2 ? Qt : Qnil;
 377     }
 378   return i1 < SCHARS (s2) ? Qt : Qnil;
 379 }
 380 
 381 #if __GNUC__
 382 /* "gcc -O3" enables automatic function inlining, which optimizes out
 383    the arguments for the invocations of this function, whereas it
 384    expects these values on the stack.  */
 385 static Lisp_Object concat P_ ((int nargs, Lisp_Object *args, enum Lisp_Type target_type, int last_special)) __attribute__((noinline));
 386 #else  /* !__GNUC__ */
 387 static Lisp_Object concat P_ ((int nargs, Lisp_Object *args, enum Lisp_Type target_type, int last_special));
 388 #endif
 389 
 390 /* ARGSUSED */
 391 Lisp_Object
 392 concat2 (s1, s2)
 393      Lisp_Object s1, s2;
 394 {
 395   Lisp_Object args[2];
 396   args[0] = s1;
 397   args[1] = s2;
 398   return concat (2, args, Lisp_String, 0);
 399 }
 400 
 401 /* ARGSUSED */
 402 Lisp_Object
 403 concat3 (s1, s2, s3)
 404      Lisp_Object s1, s2, s3;
 405 {
 406   Lisp_Object args[3];
 407   args[0] = s1;
 408   args[1] = s2;
 409   args[2] = s3;
 410   return concat (3, args, Lisp_String, 0);
 411 }
 412 
 413 DEFUN ("append", Fappend, Sappend, 0, MANY, 0,
 414        doc: /* Concatenate all the arguments and make the result a list.
 415 The result is a list whose elements are the elements of all the arguments.
 416 Each argument may be a list, vector or string.
 417 The last argument is not copied, just used as the tail of the new list.
 418 usage: (append &rest SEQUENCES)  */)
 419      (nargs, args)
 420      int nargs;
 421      Lisp_Object *args;
 422 {
 423   return concat (nargs, args, Lisp_Cons, 1);
 424 }
 425 
 426 DEFUN ("concat", Fconcat, Sconcat, 0, MANY, 0,
 427        doc: /* Concatenate all the arguments and make the result a string.
 428 The result is a string whose elements are the elements of all the arguments.
 429 Each argument may be a string or a list or vector of characters (integers).
 430 usage: (concat &rest SEQUENCES)  */)
 431      (nargs, args)
 432      int nargs;
 433      Lisp_Object *args;
 434 {
 435   return concat (nargs, args, Lisp_String, 0);
 436 }
 437 
 438 DEFUN ("vconcat", Fvconcat, Svconcat, 0, MANY, 0,
 439        doc: /* Concatenate all the arguments and make the result a vector.
 440 The result is a vector whose elements are the elements of all the arguments.
 441 Each argument may be a list, vector or string.
 442 usage: (vconcat &rest SEQUENCES)   */)
 443      (nargs, args)
 444      int nargs;
 445      Lisp_Object *args;
 446 {
 447   return concat (nargs, args, Lisp_Vectorlike, 0);
 448 }
 449 
 450 
 451 DEFUN ("copy-sequence", Fcopy_sequence, Scopy_sequence, 1, 1, 0,
 452        doc: /* Return a copy of a list, vector, string or char-table.
 453 The elements of a list or vector are not copied; they are shared
 454 with the original.  */)
 455      (arg)
 456      Lisp_Object arg;
 457 {
 458   if (NILP (arg)) return arg;
 459 
 460   if (CHAR_TABLE_P (arg))
 461     {
 462       return copy_char_table (arg);
 463     }
 464 
 465   if (BOOL_VECTOR_P (arg))
 466     {
 467       Lisp_Object val;
 468       int size_in_chars
 469         = ((XBOOL_VECTOR (arg)->size + BOOL_VECTOR_BITS_PER_CHAR - 1)
 470            / BOOL_VECTOR_BITS_PER_CHAR);
 471 
 472       val = Fmake_bool_vector (Flength (arg), Qnil);
 473       bcopy (XBOOL_VECTOR (arg)->data, XBOOL_VECTOR (val)->data,
 474              size_in_chars);
 475       return val;
 476     }
 477 
 478   if (!CONSP (arg) && !VECTORP (arg) && !STRINGP (arg))
 479     wrong_type_argument (Qsequencep, arg);
 480 
 481   return concat (1, &arg, CONSP (arg) ? Lisp_Cons : XTYPE (arg), 0);
 482 }
 483 
 484 /* This structure holds information of an argument of `concat' that is
 485    a string and has text properties to be copied.  */
 486 struct textprop_rec
 487 {
 488   int argnum;                   /* refer to ARGS (arguments of `concat') */
 489   int from;                     /* refer to ARGS[argnum] (argument string) */
 490   int to;                       /* refer to VAL (the target string) */
 491 };
 492 
 493 static Lisp_Object
 494 concat (nargs, args, target_type, last_special)
 495      int nargs;
 496      Lisp_Object *args;
 497      enum Lisp_Type target_type;
 498      int last_special;
 499 {
 500   Lisp_Object val;
 501   register Lisp_Object tail;
 502   register Lisp_Object this;
 503   int toindex;
 504   int toindex_byte = 0;
 505   register int result_len;
 506   register int result_len_byte;
 507   register int argnum;
 508   Lisp_Object last_tail;
 509   Lisp_Object prev;
 510   int some_multibyte;
 511   /* When we make a multibyte string, we can't copy text properties
 512      while concatinating each string because the length of resulting
 513      string can't be decided until we finish the whole concatination.
 514      So, we record strings that have text properties to be copied
 515      here, and copy the text properties after the concatination.  */
 516   struct textprop_rec  *textprops = NULL;
 517   /* Number of elments in textprops.  */
 518   int num_textprops = 0;
 519   USE_SAFE_ALLOCA;
 520 
 521   tail = Qnil;
 522 
 523   /* In append, the last arg isn't treated like the others */
 524   if (last_special && nargs > 0)
 525     {
 526       nargs--;
 527       last_tail = args[nargs];
 528     }
 529   else
 530     last_tail = Qnil;
 531 
 532   /* Check each argument.  */
 533   for (argnum = 0; argnum < nargs; argnum++)
 534     {
 535       this = args[argnum];
 536       if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
 537             || COMPILEDP (this) || BOOL_VECTOR_P (this)))
 538         wrong_type_argument (Qsequencep, this);
 539     }
 540 
 541   /* Compute total length in chars of arguments in RESULT_LEN.
 542      If desired output is a string, also compute length in bytes
 543      in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
 544      whether the result should be a multibyte string.  */
 545   result_len_byte = 0;
 546   result_len = 0;
 547   some_multibyte = 0;
 548   for (argnum = 0; argnum < nargs; argnum++)
 549     {
 550       int len;
 551       this = args[argnum];
 552       len = XFASTINT (Flength (this));
 553       if (target_type == Lisp_String)
 554         {
 555           /* We must count the number of bytes needed in the string
 556              as well as the number of characters.  */
 557           int i;
 558           Lisp_Object ch;
 559           int this_len_byte;
 560 
 561           if (VECTORP (this))
 562             for (i = 0; i < len; i++)
 563               {
 564                 ch = AREF (this, i);
 565                 CHECK_CHARACTER (ch);
 566                 this_len_byte = CHAR_BYTES (XINT (ch));
 567                 result_len_byte += this_len_byte;
 568                 if (! ASCII_CHAR_P (XINT (ch)) && ! CHAR_BYTE8_P (XINT (ch)))
 569                   some_multibyte = 1;
 570               }
 571           else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size > 0)
 572             wrong_type_argument (Qintegerp, Faref (this, make_number (0)));
 573           else if (CONSP (this))
 574             for (; CONSP (this); this = XCDR (this))
 575               {
 576                 ch = XCAR (this);
 577                 CHECK_CHARACTER (ch);
 578                 this_len_byte = CHAR_BYTES (XINT (ch));
 579                 result_len_byte += this_len_byte;
 580                 if (! ASCII_CHAR_P (XINT (ch)) && ! CHAR_BYTE8_P (XINT (ch)))
 581                   some_multibyte = 1;
 582               }
 583           else if (STRINGP (this))
 584             {
 585               if (STRING_MULTIBYTE (this))
 586                 {
 587                   some_multibyte = 1;
 588                   result_len_byte += SBYTES (this);
 589                 }
 590               else
 591                 result_len_byte += count_size_as_multibyte (SDATA (this),
 592                                                             SCHARS (this));
 593             }
 594         }
 595 
 596       result_len += len;
 597       if (result_len < 0)
 598         error ("String overflow");
 599     }
 600 
 601   if (! some_multibyte)
 602     result_len_byte = result_len;
 603 
 604   /* Create the output object.  */
 605   if (target_type == Lisp_Cons)
 606     val = Fmake_list (make_number (result_len), Qnil);
 607   else if (target_type == Lisp_Vectorlike)
 608     val = Fmake_vector (make_number (result_len), Qnil);
 609   else if (some_multibyte)
 610     val = make_uninit_multibyte_string (result_len, result_len_byte);
 611   else
 612     val = make_uninit_string (result_len);
 613 
 614   /* In `append', if all but last arg are nil, return last arg.  */
 615   if (target_type == Lisp_Cons && EQ (val, Qnil))
 616     return last_tail;
 617 
 618   /* Copy the contents of the args into the result.  */
 619   if (CONSP (val))
 620     tail = val, toindex = -1; /* -1 in toindex is flag we are making a list */
 621   else
 622     toindex = 0, toindex_byte = 0;
 623 
 624   prev = Qnil;
 625   if (STRINGP (val))
 626     SAFE_ALLOCA (textprops, struct textprop_rec *, sizeof (struct textprop_rec) * nargs);
 627 
 628   for (argnum = 0; argnum < nargs; argnum++)
 629     {
 630       Lisp_Object thislen;
 631       int thisleni = 0;
 632       register unsigned int thisindex = 0;
 633       register unsigned int thisindex_byte = 0;
 634 
 635       this = args[argnum];
 636       if (!CONSP (this))
 637         thislen = Flength (this), thisleni = XINT (thislen);
 638 
 639       /* Between strings of the same kind, copy fast.  */
 640       if (STRINGP (this) && STRINGP (val)
 641           && STRING_MULTIBYTE (this) == some_multibyte)
 642         {
 643           int thislen_byte = SBYTES (this);
 644 
 645           bcopy (SDATA (this), SDATA (val) + toindex_byte,
 646                  SBYTES (this));
 647           if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
 648             {
 649               textprops[num_textprops].argnum = argnum;
 650               textprops[num_textprops].from = 0;
 651               textprops[num_textprops++].to = toindex;
 652             }
 653           toindex_byte += thislen_byte;
 654           toindex += thisleni;
 655         }
 656       /* Copy a single-byte string to a multibyte string.  */
 657       else if (STRINGP (this) && STRINGP (val))
 658         {
 659           if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
 660             {
 661               textprops[num_textprops].argnum = argnum;
 662               textprops[num_textprops].from = 0;
 663               textprops[num_textprops++].to = toindex;
 664             }
 665           toindex_byte += copy_text (SDATA (this),
 666                                      SDATA (val) + toindex_byte,
 667                                      SCHARS (this), 0, 1);
 668           toindex += thisleni;
 669         }
 670       else
 671         /* Copy element by element.  */
 672         while (1)
 673           {
 674             register Lisp_Object elt;
 675 
 676             /* Fetch next element of `this' arg into `elt', or break if
 677                `this' is exhausted. */
 678             if (NILP (this)) break;
 679             if (CONSP (this))
 680               elt = XCAR (this), this = XCDR (this);
 681             else if (thisindex >= thisleni)
 682               break;
 683             else if (STRINGP (this))
 684               {
 685                 int c;
 686                 if (STRING_MULTIBYTE (this))
 687                   {
 688                     FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c, this,
 689                                                         thisindex,
 690                                                         thisindex_byte);
 691                     XSETFASTINT (elt, c);
 692                   }
 693                 else
 694                   {
 695                     XSETFASTINT (elt, SREF (this, thisindex)); thisindex++;
 696                     if (some_multibyte
 697                         && !ASCII_CHAR_P (XINT (elt))
 698                         && XINT (elt) < 0400)
 699                       {
 700                         c = BYTE8_TO_CHAR (XINT (elt));
 701                         XSETINT (elt, c);
 702                       }
 703                   }
 704               }
 705             else if (BOOL_VECTOR_P (this))
 706               {
 707                 int byte;
 708                 byte = XBOOL_VECTOR (this)->data[thisindex / BOOL_VECTOR_BITS_PER_CHAR];
 709                 if (byte & (1 << (thisindex % BOOL_VECTOR_BITS_PER_CHAR)))
 710                   elt = Qt;
 711                 else
 712                   elt = Qnil;
 713                 thisindex++;
 714               }
 715             else
 716               {
 717                 elt = AREF (this, thisindex);
 718                 thisindex++;
 719               }
 720 
 721             /* Store this element into the result.  */
 722             if (toindex < 0)
 723               {
 724                 XSETCAR (tail, elt);
 725                 prev = tail;
 726                 tail = XCDR (tail);
 727               }
 728             else if (VECTORP (val))
 729               {
 730                 ASET (val, toindex, elt);
 731                 toindex++;
 732               }
 733             else
 734               {
 735                 CHECK_NUMBER (elt);
 736                 if (some_multibyte)
 737                   toindex_byte += CHAR_STRING (XINT (elt),
 738                                                SDATA (val) + toindex_byte);
 739                 else
 740                   SSET (val, toindex_byte++, XINT (elt));
 741                 toindex++;
 742               }
 743           }
 744     }
 745   if (!NILP (prev))
 746     XSETCDR (prev, last_tail);
 747 
 748   if (num_textprops > 0)
 749     {
 750       Lisp_Object props;
 751       int last_to_end = -1;
 752 
 753       for (argnum = 0; argnum < num_textprops; argnum++)
 754         {
 755           this = args[textprops[argnum].argnum];
 756           props = text_property_list (this,
 757                                       make_number (0),
 758                                       make_number (SCHARS (this)),
 759                                       Qnil);
 760           /* If successive arguments have properites, be sure that the
 761              value of `composition' property be the copy.  */
 762           if (last_to_end == textprops[argnum].to)
 763             make_composition_value_copy (props);
 764           add_text_properties_from_list (val, props,
 765                                          make_number (textprops[argnum].to));
 766           last_to_end = textprops[argnum].to + SCHARS (this);
 767         }
 768     }
 769 
 770   SAFE_FREE ();
 771   return val;
 772 }
 773 
 774 static Lisp_Object string_char_byte_cache_string;
 775 static EMACS_INT string_char_byte_cache_charpos;
 776 static EMACS_INT string_char_byte_cache_bytepos;
 777 
 778 void
 779 clear_string_char_byte_cache ()
 780 {
 781   string_char_byte_cache_string = Qnil;
 782 }
 783 
 784 /* Return the byte index corresponding to CHAR_INDEX in STRING.  */
 785 
 786 EMACS_INT
 787 string_char_to_byte (string, char_index)
 788      Lisp_Object string;
 789      EMACS_INT char_index;
 790 {
 791   EMACS_INT i_byte;
 792   EMACS_INT best_below, best_below_byte;
 793   EMACS_INT best_above, best_above_byte;
 794 
 795   best_below = best_below_byte = 0;
 796   best_above = SCHARS (string);
 797   best_above_byte = SBYTES (string);
 798   if (best_above == best_above_byte)
 799     return char_index;
 800 
 801   if (EQ (string, string_char_byte_cache_string))
 802     {
 803       if (string_char_byte_cache_charpos < char_index)
 804         {
 805           best_below = string_char_byte_cache_charpos;
 806           best_below_byte = string_char_byte_cache_bytepos;
 807         }
 808       else
 809         {
 810           best_above = string_char_byte_cache_charpos;
 811           best_above_byte = string_char_byte_cache_bytepos;
 812         }
 813     }
 814 
 815   if (char_index - best_below < best_above - char_index)
 816     {
 817       unsigned char *p = SDATA (string) + best_below_byte;
 818 
 819       while (best_below < char_index)
 820         {
 821           p += BYTES_BY_CHAR_HEAD (*p);
 822           best_below++;
 823         }
 824       i_byte = p - SDATA (string);
 825     }
 826   else
 827     {
 828       unsigned char *p = SDATA (string) + best_above_byte;
 829 
 830       while (best_above > char_index)
 831         {
 832           p--;
 833           while (!CHAR_HEAD_P (*p)) p--;
 834           best_above--;
 835         }
 836       i_byte = p - SDATA (string);
 837     }
 838 
 839   string_char_byte_cache_bytepos = i_byte;
 840   string_char_byte_cache_charpos = char_index;
 841   string_char_byte_cache_string = string;
 842 
 843   return i_byte;
 844 }
 845 
 846 /* Return the character index corresponding to BYTE_INDEX in STRING.  */
 847 
 848 EMACS_INT
 849 string_byte_to_char (string, byte_index)
 850      Lisp_Object string;
 851      EMACS_INT byte_index;
 852 {
 853   EMACS_INT i, i_byte;
 854   EMACS_INT best_below, best_below_byte;
 855   EMACS_INT best_above, best_above_byte;
 856 
 857   best_below = best_below_byte = 0;
 858   best_above = SCHARS (string);
 859   best_above_byte = SBYTES (string);
 860   if (best_above == best_above_byte)
 861     return byte_index;
 862 
 863   if (EQ (string, string_char_byte_cache_string))
 864     {
 865       if (string_char_byte_cache_bytepos < byte_index)
 866         {
 867           best_below = string_char_byte_cache_charpos;
 868           best_below_byte = string_char_byte_cache_bytepos;
 869         }
 870       else
 871         {
 872           best_above = string_char_byte_cache_charpos;
 873           best_above_byte = string_char_byte_cache_bytepos;
 874         }
 875     }
 876 
 877   if (byte_index - best_below_byte < best_above_byte - byte_index)
 878     {
 879       unsigned char *p = SDATA (string) + best_below_byte;
 880       unsigned char *pend = SDATA (string) + byte_index;
 881 
 882       while (p < pend)
 883         {
 884           p += BYTES_BY_CHAR_HEAD (*p);
 885           best_below++;
 886         }
 887       i = best_below;
 888       i_byte = p - SDATA (string);
 889     }
 890   else
 891     {
 892       unsigned char *p = SDATA (string) + best_above_byte;
 893       unsigned char *pbeg = SDATA (string) + byte_index;
 894 
 895       while (p > pbeg)
 896         {
 897           p--;
 898           while (!CHAR_HEAD_P (*p)) p--;
 899           best_above--;
 900         }
 901       i = best_above;
 902       i_byte = p - SDATA (string);
 903     }
 904 
 905   string_char_byte_cache_bytepos = i_byte;
 906   string_char_byte_cache_charpos = i;
 907   string_char_byte_cache_string = string;
 908 
 909   return i;
 910 }
 911 
 912 /* Convert STRING to a multibyte string.  */
 913 
 914 Lisp_Object
 915 string_make_multibyte (string)
 916      Lisp_Object string;
 917 {
 918   unsigned char *buf;
 919   EMACS_INT nbytes;
 920   Lisp_Object ret;
 921   USE_SAFE_ALLOCA;
 922 
 923   if (STRING_MULTIBYTE (string))
 924     return string;
 925 
 926   nbytes = count_size_as_multibyte (SDATA (string),
 927                                     SCHARS (string));
 928   /* If all the chars are ASCII, they won't need any more bytes
 929      once converted.  In that case, we can return STRING itself.  */
 930   if (nbytes == SBYTES (string))
 931     return string;
 932 
 933   SAFE_ALLOCA (buf, unsigned char *, nbytes);
 934   copy_text (SDATA (string), buf, SBYTES (string),
 935              0, 1);
 936 
 937   ret = make_multibyte_string (buf, SCHARS (string), nbytes);
 938   SAFE_FREE ();
 939 
 940   return ret;
 941 }
 942 
 943 
 944 /* Convert STRING (if unibyte) to a multibyte string without changing
 945    the number of characters.  Characters 0200 trough 0237 are
 946    converted to eight-bit characters. */
 947 
 948 Lisp_Object
 949 string_to_multibyte (string)
 950      Lisp_Object string;
 951 {
 952   unsigned char *buf;
 953   EMACS_INT nbytes;
 954   Lisp_Object ret;
 955   USE_SAFE_ALLOCA;
 956 
 957   if (STRING_MULTIBYTE (string))
 958     return string;
 959 
 960   nbytes = parse_str_to_multibyte (SDATA (string), SBYTES (string));
 961   /* If all the chars are ASCII, they won't need any more bytes once
 962      converted.  */
 963   if (nbytes == SBYTES (string))
 964     return make_multibyte_string (SDATA (string), nbytes, nbytes);
 965 
 966   SAFE_ALLOCA (buf, unsigned char *, nbytes);
 967   bcopy (SDATA (string), buf, SBYTES (string));
 968   str_to_multibyte (buf, nbytes, SBYTES (string));
 969 
 970   ret = make_multibyte_string (buf, SCHARS (string), nbytes);
 971   SAFE_FREE ();
 972 
 973   return ret;
 974 }
 975 
 976 
 977 /* Convert STRING to a single-byte string.  */
 978 
 979 Lisp_Object
 980 string_make_unibyte (string)
 981      Lisp_Object string;
 982 {
 983   int nchars;
 984   unsigned char *buf;
 985   Lisp_Object ret;
 986   USE_SAFE_ALLOCA;
 987 
 988   if (! STRING_MULTIBYTE (string))
 989     return string;
 990 
 991   nchars = SCHARS (string);
 992 
 993   SAFE_ALLOCA (buf, unsigned char *, nchars);
 994   copy_text (SDATA (string), buf, SBYTES (string),
 995              1, 0);
 996 
 997   ret = make_unibyte_string (buf, nchars);
 998   SAFE_FREE ();
 999 
1000   return ret;
1001 }
1002 
1003 DEFUN ("string-make-multibyte", Fstring_make_multibyte, Sstring_make_multibyte,
1004        1, 1, 0,
1005        doc: /* Return the multibyte equivalent of STRING.
1006 If STRING is unibyte and contains non-ASCII characters, the function
1007 `unibyte-char-to-multibyte' is used to convert each unibyte character
1008 to a multibyte character.  In this case, the returned string is a
1009 newly created string with no text properties.  If STRING is multibyte
1010 or entirely ASCII, it is returned unchanged.  In particular, when
1011 STRING is unibyte and entirely ASCII, the returned string is unibyte.
1012 \(When the characters are all ASCII, Emacs primitives will treat the
1013 string the same way whether it is unibyte or multibyte.)  */)
1014      (string)
1015      Lisp_Object string;
1016 {
1017   CHECK_STRING (string);
1018 
1019   return string_make_multibyte (string);
1020 }
1021 
1022 DEFUN ("string-make-unibyte", Fstring_make_unibyte, Sstring_make_unibyte,
1023        1, 1, 0,
1024        doc: /* Return the unibyte equivalent of STRING.
1025 Multibyte character codes are converted to unibyte according to
1026 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
1027 If the lookup in the translation table fails, this function takes just
1028 the low 8 bits of each character.  */)
1029      (string)
1030      Lisp_Object string;
1031 {
1032   CHECK_STRING (string);
1033 
1034   return string_make_unibyte (string);
1035 }
1036 
1037 DEFUN ("string-as-unibyte", Fstring_as_unibyte, Sstring_as_unibyte,
1038        1, 1, 0,
1039        doc: /* Return a unibyte string with the same individual bytes as STRING.
1040 If STRING is unibyte, the result is STRING itself.
1041 Otherwise it is a newly created string, with no text properties.
1042 If STRING is multibyte and contains a character of charset
1043 `eight-bit', it is converted to the corresponding single byte.  */)
1044      (string)
1045      Lisp_Object string;
1046 {
1047   CHECK_STRING (string);
1048 
1049   if (STRING_MULTIBYTE (string))
1050     {
1051       int bytes = SBYTES (string);
1052       unsigned char *str = (unsigned char *) xmalloc (bytes);
1053 
1054       bcopy (SDATA (string), str, bytes);
1055       bytes = str_as_unibyte (str, bytes);
1056       string = make_unibyte_string (str, bytes);
1057       xfree (str);
1058     }
1059   return string;
1060 }
1061 
1062 DEFUN ("string-as-multibyte", Fstring_as_multibyte, Sstring_as_multibyte,
1063        1, 1, 0,
1064        doc: /* Return a multibyte string with the same individual bytes as STRING.
1065 If STRING is multibyte, the result is STRING itself.
1066 Otherwise it is a newly created string, with no text properties.
1067 
1068 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
1069 part of a correct utf-8 sequence), it is converted to the corresponding
1070 multibyte character of charset `eight-bit'.
1071 See also `string-to-multibyte'.
1072 
1073 Beware, this often doesn't really do what you think it does.
1074 It is similar to (decode-coding-string STRING 'utf-8-emacs).
1075 If you're not sure, whether to use `string-as-multibyte' or
1076 `string-to-multibyte', use `string-to-multibyte'.  */)
1077      (string)
1078      Lisp_Object string;
1079 {
1080   CHECK_STRING (string);
1081 
1082   if (! STRING_MULTIBYTE (string))
1083     {
1084       Lisp_Object new_string;
1085       int nchars, nbytes;
1086 
1087       parse_str_as_multibyte (SDATA (string),
1088                               SBYTES (string),
1089                               &nchars, &nbytes);
1090       new_string = make_uninit_multibyte_string (nchars, nbytes);
1091       bcopy (SDATA (string), SDATA (new_string),
1092              SBYTES (string));
1093       if (nbytes != SBYTES (string))
1094         str_as_multibyte (SDATA (new_string), nbytes,
1095                           SBYTES (string), NULL);
1096       string = new_string;
1097       STRING_SET_INTERVALS (string, NULL_INTERVAL);
1098     }
1099   return string;
1100 }
1101 
1102 DEFUN ("string-to-multibyte", Fstring_to_multibyte, Sstring_to_multibyte,
1103        1, 1, 0,
1104        doc: /* Return a multibyte string with the same individual chars as STRING.
1105 If STRING is multibyte, the result is STRING itself.
1106 Otherwise it is a newly created string, with no text properties.
1107 
1108 If STRING is unibyte and contains an 8-bit byte, it is converted to
1109 the corresponding multibyte character of charset `eight-bit'.
1110 
1111 This differs from `string-as-multibyte' by converting each byte of a correct
1112 utf-8 sequence to an eight-bit character, not just bytes that don't form a
1113 correct sequence.  */)
1114      (string)
1115      Lisp_Object string;
1116 {
1117   CHECK_STRING (string);
1118 
1119   return string_to_multibyte (string);
1120 }
1121 
1122 DEFUN ("string-to-unibyte", Fstring_to_unibyte, Sstring_to_unibyte,
1123        1, 1, 0,
1124        doc: /* Return a unibyte string with the same individual chars as STRING.
1125 If STRING is unibyte, the result is STRING itself.
1126 Otherwise it is a newly created string, with no text properties,
1127 where each `eight-bit' character is converted to the corresponding byte.
1128 If STRING contains a non-ASCII, non-`eight-bit' character,
1129 an error is signaled.  */)
1130      (string)
1131      Lisp_Object string;
1132 {
1133   CHECK_STRING (string);
1134 
1135   if (STRING_MULTIBYTE (string))
1136     {
1137       EMACS_INT chars = SCHARS (string);
1138       unsigned char *str = (unsigned char *) xmalloc (chars);
1139       EMACS_INT converted = str_to_unibyte (SDATA (string), str, chars, 0);
1140 
1141       if (converted < chars)
1142         error ("Can't convert the %dth character to unibyte", converted);
1143       string = make_unibyte_string (str, chars);
1144       xfree (str);
1145     }
1146   return string;
1147 }
1148 
1149 
1150 DEFUN ("copy-alist", Fcopy_alist, Scopy_alist, 1, 1, 0,
1151        doc: /* Return a copy of ALIST.
1152 This is an alist which represents the same mapping from objects to objects,
1153 but does not share the alist structure with ALIST.
1154 The objects mapped (cars and cdrs of elements of the alist)
1155 are shared, however.
1156 Elements of ALIST that are not conses are also shared.  */)
1157      (alist)
1158      Lisp_Object alist;
1159 {
1160   register Lisp_Object tem;
1161 
1162   CHECK_LIST (alist);
1163   if (NILP (alist))
1164     return alist;
1165   alist = concat (1, &alist, Lisp_Cons, 0);
1166   for (tem = alist; CONSP (tem); tem = XCDR (tem))
1167     {
1168       register Lisp_Object car;
1169       car = XCAR (tem);
1170 
1171       if (CONSP (car))
1172         XSETCAR (tem, Fcons (XCAR (car), XCDR (car)));
1173     }
1174   return alist;
1175 }
1176 
1177 DEFUN ("substring", Fsubstring, Ssubstring, 2, 3, 0,
1178        doc: /* Return a new string whose contents are a substring of STRING.
1179 The returned string consists of the characters between index FROM
1180 \(inclusive) and index TO (exclusive) of STRING.  FROM and TO are
1181 zero-indexed: 0 means the first character of STRING.  Negative values
1182 are counted from the end of STRING.  If TO is nil, the substring runs
1183 to the end of STRING.
1184 
1185 The STRING argument may also be a vector.  In that case, the return
1186 value is a new vector that contains the elements between index FROM
1187 \(inclusive) and index TO (exclusive) of that vector argument.  */)
1188      (string, from, to)
1189      Lisp_Object string;
1190      register Lisp_Object from, to;
1191 {
1192   Lisp_Object res;
1193   int size;
1194   int size_byte = 0;
1195   int from_char, to_char;
1196   int from_byte = 0, to_byte = 0;
1197 
1198   CHECK_VECTOR_OR_STRING (string);
1199   CHECK_NUMBER (from);
1200 
1201   if (STRINGP (string))
1202     {
1203       size = SCHARS (string);
1204       size_byte = SBYTES (string);
1205     }
1206   else
1207     size = ASIZE (string);
1208 
1209   if (NILP (to))
1210     {
1211       to_char = size;
1212       to_byte = size_byte;
1213     }
1214   else
1215     {
1216       CHECK_NUMBER (to);
1217 
1218       to_char = XINT (to);
1219       if (to_char < 0)
1220         to_char += size;
1221 
1222       if (STRINGP (string))
1223         to_byte = string_char_to_byte (string, to_char);
1224     }
1225 
1226   from_char = XINT (from);
1227   if (from_char < 0)
1228     from_char += size;
1229   if (STRINGP (string))
1230     from_byte = string_char_to_byte (string, from_char);
1231 
1232   if (!(0 <= from_char && from_char <= to_char && to_char <= size))
1233     args_out_of_range_3 (string, make_number (from_char),
1234                          make_number (to_char));
1235 
1236   if (STRINGP (string))
1237     {
1238       res = make_specified_string (SDATA (string) + from_byte,
1239                                    to_char - from_char, to_byte - from_byte,
1240                                    STRING_MULTIBYTE (string));
1241       copy_text_properties (make_number (from_char), make_number (to_char),
1242                             string, make_number (0), res, Qnil);
1243     }
1244   else
1245     res = Fvector (to_char - from_char, &AREF (string, from_char));
1246 
1247   return res;
1248 }
1249 
1250 
1251 DEFUN ("substring-no-properties", Fsubstring_no_properties, Ssubstring_no_properties, 1, 3, 0,
1252        doc: /* Return a substring of STRING, without text properties.
1253 It starts at index FROM and ending before TO.
1254 TO may be nil or omitted; then the substring runs to the end of STRING.
1255 If FROM is nil or omitted, the substring starts at the beginning of STRING.
1256 If FROM or TO is negative, it counts from the end.
1257 
1258 With one argument, just copy STRING without its properties.  */)
1259      (string, from, to)
1260      Lisp_Object string;
1261      register Lisp_Object from, to;
1262 {
1263   int size, size_byte;
1264   int from_char, to_char;
1265   int from_byte, to_byte;
1266 
1267   CHECK_STRING (string);
1268 
1269   size = SCHARS (string);
1270   size_byte = SBYTES (string);
1271 
1272   if (NILP (from))
1273     from_char = from_byte = 0;
1274   else
1275     {
1276       CHECK_NUMBER (from);
1277       from_char = XINT (from);
1278       if (from_char < 0)
1279         from_char += size;
1280 
1281       from_byte = string_char_to_byte (string, from_char);
1282     }
1283 
1284   if (NILP (to))
1285     {
1286       to_char = size;
1287       to_byte = size_byte;
1288     }
1289   else
1290     {
1291       CHECK_NUMBER (to);
1292 
1293       to_char = XINT (to);
1294       if (to_char < 0)
1295         to_char += size;
1296 
1297       to_byte = string_char_to_byte (string, to_char);
1298     }
1299 
1300   if (!(0 <= from_char && from_char <= to_char && to_char <= size))
1301     args_out_of_range_3 (string, make_number (from_char),
1302                          make_number (to_char));
1303 
1304   return make_specified_string (SDATA (string) + from_byte,
1305                                 to_char - from_char, to_byte - from_byte,
1306                                 STRING_MULTIBYTE (string));
1307 }
1308 
1309 /* Extract a substring of STRING, giving start and end positions
1310    both in characters and in bytes.  */
1311 
1312 Lisp_Object
1313 substring_both (string, from, from_byte, to, to_byte)
1314      Lisp_Object string;
1315      int from, from_byte, to, to_byte;
1316 {
1317   Lisp_Object res;
1318   int size;
1319   int size_byte;
1320 
1321   CHECK_VECTOR_OR_STRING (string);
1322 
1323   if (STRINGP (string))
1324     {
1325       size = SCHARS (string);
1326       size_byte = SBYTES (string);
1327     }
1328   else
1329     size = ASIZE (string);
1330 
1331   if (!(0 <= from && from <= to && to <= size))
1332     args_out_of_range_3 (string, make_number (from), make_number (to));
1333 
1334   if (STRINGP (string))
1335     {
1336       res = make_specified_string (SDATA (string) + from_byte,
1337                                    to - from, to_byte - from_byte,
1338                                    STRING_MULTIBYTE (string));
1339       copy_text_properties (make_number (from), make_number (to),
1340                             string, make_number (0), res, Qnil);
1341     }
1342   else
1343     res = Fvector (to - from, &AREF (string, from));
1344 
1345   return res;
1346 }
1347 
1348 DEFUN ("nthcdr", Fnthcdr, Snthcdr, 2, 2, 0,
1349        doc: /* Take cdr N times on LIST, returns the result.  */)
1350      (n, list)
1351      Lisp_Object n;
1352      register Lisp_Object list;
1353 {
1354   register int i, num;
1355   CHECK_NUMBER (n);
1356   num = XINT (n);
1357   for (i = 0; i < num && !NILP (list); i++)
1358     {
1359       QUIT;
1360       CHECK_LIST_CONS (list, list);
1361       list = XCDR (list);
1362     }
1363   return list;
1364 }
1365 
1366 DEFUN ("nth", Fnth, Snth, 2, 2, 0,
1367        doc: /* Return the Nth element of LIST.
1368 N counts from zero.  If LIST is not that long, nil is returned.  */)
1369      (n, list)
1370      Lisp_Object n, list;
1371 {
1372   return Fcar (Fnthcdr (n, list));
1373 }
1374 
1375 DEFUN ("elt", Felt, Selt, 2, 2, 0,
1376        doc: /* Return element of SEQUENCE at index N.  */)
1377      (sequence, n)
1378      register Lisp_Object sequence, n;
1379 {
1380   CHECK_NUMBER (n);
1381   if (CONSP (sequence) || NILP (sequence))
1382     return Fcar (Fnthcdr (n, sequence));
1383 
1384   /* Faref signals a "not array" error, so check here.  */
1385   CHECK_ARRAY (sequence, Qsequencep);
1386   return Faref (sequence, n);
1387 }
1388 
1389 DEFUN ("member", Fmember, Smember, 2, 2, 0,
1390 doc: /* Return non-nil if ELT is an element of LIST.  Comparison done with `equal'.
1391 The value is actually the tail of LIST whose car is ELT.  */)
1392      (elt, list)
1393      register Lisp_Object elt;
1394      Lisp_Object list;
1395 {
1396   register Lisp_Object tail;
1397   for (tail = list; CONSP (tail); tail = XCDR (tail))
1398     {
1399       register Lisp_Object tem;
1400       CHECK_LIST_CONS (tail, list);
1401       tem = XCAR (tail);
1402       if (! NILP (Fequal (elt, tem)))
1403         return tail;
1404       QUIT;
1405     }
1406   return Qnil;
1407 }
1408 
1409 DEFUN ("memq", Fmemq, Smemq, 2, 2, 0,
1410 doc: /* Return non-nil if ELT is an element of LIST.  Comparison done with `eq'.
1411 The value is actually the tail of LIST whose car is ELT.  */)
1412      (elt, list)
1413      register Lisp_Object elt, list;
1414 {
1415   while (1)
1416     {
1417       if (!CONSP (list) || EQ (XCAR (list), elt))
1418         break;
1419 
1420       list = XCDR (list);
1421       if (!CONSP (list) || EQ (XCAR (list), elt))
1422         break;
1423 
1424       list = XCDR (list);
1425       if (!CONSP (list) || EQ (XCAR (list), elt))
1426         break;
1427 
1428       list = XCDR (list);
1429       QUIT;
1430     }
1431 
1432   CHECK_LIST (list);
1433   return list;
1434 }
1435 
1436 DEFUN ("memql", Fmemql, Smemql, 2, 2, 0,
1437 doc: /* Return non-nil if ELT is an element of LIST.  Comparison done with `eql'.
1438 The value is actually the tail of LIST whose car is ELT.  */)
1439      (elt, list)
1440      register Lisp_Object elt;
1441      Lisp_Object list;
1442 {
1443   register Lisp_Object tail;
1444 
1445   if (!FLOATP (elt))
1446     return Fmemq (elt, list);
1447 
1448   for (tail = list; CONSP (tail); tail = XCDR (tail))
1449     {
1450       register Lisp_Object tem;
1451       CHECK_LIST_CONS (tail, list);
1452       tem = XCAR (tail);
1453       if (FLOATP (tem) && internal_equal (elt, tem, 0, 0))
1454         return tail;
1455       QUIT;
1456     }
1457   return Qnil;
1458 }
1459 
1460 DEFUN ("assq", Fassq, Sassq, 2, 2, 0,
1461        doc: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
1462 The value is actually the first element of LIST whose car is KEY.
1463 Elements of LIST that are not conses are ignored.  */)
1464      (key, list)
1465      Lisp_Object key, list;
1466 {
1467   while (1)
1468     {
1469       if (!CONSP (list)
1470           || (CONSP (XCAR (list))
1471               && EQ (XCAR (XCAR (list)), key)))
1472         break;
1473 
1474       list = XCDR (list);
1475       if (!CONSP (list)
1476           || (CONSP (XCAR (list))
1477               && EQ (XCAR (XCAR (list)), key)))
1478         break;
1479 
1480       list = XCDR (list);
1481       if (!CONSP (list)
1482           || (CONSP (XCAR (list))
1483               && EQ (XCAR (XCAR (list)), key)))
1484         break;
1485 
1486       list = XCDR (list);
1487       QUIT;
1488     }
1489 
1490   return CAR (list);
1491 }
1492 
1493 /* Like Fassq but never report an error and do not allow quits.
1494    Use only on lists known never to be circular.  */
1495 
1496 Lisp_Object
1497 assq_no_quit (key, list)
1498      Lisp_Object key, list;
1499 {
1500   while (CONSP (list)
1501          && (!CONSP (XCAR (list))
1502              || !EQ (XCAR (XCAR (list)), key)))
1503     list = XCDR (list);
1504 
1505   return CAR_SAFE (list);
1506 }
1507 
1508 DEFUN ("assoc", Fassoc, Sassoc, 2, 2, 0,
1509        doc: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
1510 The value is actually the first element of LIST whose car equals KEY.  */)
1511      (key, list)
1512      Lisp_Object key, list;
1513 {
1514   Lisp_Object car;
1515 
1516   while (1)
1517     {
1518       if (!CONSP (list)
1519           || (CONSP (XCAR (list))
1520               && (car = XCAR (XCAR (list)),
1521                   EQ (car, key) || !NILP (Fequal (car, key)))))
1522         break;
1523 
1524       list = XCDR (list);
1525       if (!CONSP (list)
1526           || (CONSP (XCAR (list))
1527               && (car = XCAR (XCAR (list)),
1528                   EQ (car, key) || !NILP (Fequal (car, key)))))
1529         break;
1530 
1531       list = XCDR (list);
1532       if (!CONSP (list)
1533           || (CONSP (XCAR (list))
1534               && (car = XCAR (XCAR (list)),
1535                   EQ (car, key) || !NILP (Fequal (car, key)))))
1536         break;
1537 
1538       list = XCDR (list);
1539       QUIT;
1540     }
1541 
1542   return CAR (list);
1543 }
1544 
1545 /* Like Fassoc but never report an error and do not allow quits.
1546    Use only on lists known never to be circular.  */
1547 
1548 Lisp_Object
1549 assoc_no_quit (key, list)
1550      Lisp_Object key, list;
1551 {
1552   while (CONSP (list)
1553          && (!CONSP (XCAR (list))
1554              || (!EQ (XCAR (XCAR (list)), key)
1555                  && NILP (Fequal (XCAR (XCAR (list)), key)))))
1556     list = XCDR (list);
1557 
1558   return CONSP (list) ? XCAR (list) : Qnil;
1559 }
1560 
1561 DEFUN ("rassq", Frassq, Srassq, 2, 2, 0,
1562        doc: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1563 The value is actually the first element of LIST whose cdr is KEY.  */)
1564      (key, list)
1565      register Lisp_Object key;
1566      Lisp_Object list;
1567 {
1568   while (1)
1569     {
1570       if (!CONSP (list)
1571           || (CONSP (XCAR (list))
1572               && EQ (XCDR (XCAR (list)), key)))
1573         break;
1574 
1575       list = XCDR (list);
1576       if (!CONSP (list)
1577           || (CONSP (XCAR (list))
1578               && EQ (XCDR (XCAR (list)), key)))
1579         break;
1580 
1581       list = XCDR (list);
1582       if (!CONSP (list)
1583           || (CONSP (XCAR (list))
1584               && EQ (XCDR (XCAR (list)), key)))
1585         break;
1586 
1587       list = XCDR (list);
1588       QUIT;
1589     }
1590 
1591   return CAR (list);
1592 }
1593 
1594 DEFUN ("rassoc", Frassoc, Srassoc, 2, 2, 0,
1595        doc: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1596 The value is actually the first element of LIST whose cdr equals KEY.  */)
1597      (key, list)
1598      Lisp_Object key, list;
1599 {
1600   Lisp_Object cdr;
1601 
1602   while (1)
1603     {
1604       if (!CONSP (list)
1605           || (CONSP (XCAR (list))
1606               && (cdr = XCDR (XCAR (list)),
1607                   EQ (cdr, key) || !NILP (Fequal (cdr, key)))))
1608         break;
1609 
1610       list = XCDR (list);
1611       if (!CONSP (list)
1612           || (CONSP (XCAR (list))
1613               && (cdr = XCDR (XCAR (list)),
1614                   EQ (cdr, key) || !NILP (Fequal (cdr, key)))))
1615         break;
1616 
1617       list = XCDR (list);
1618       if (!CONSP (list)
1619           || (CONSP (XCAR (list))
1620               && (cdr = XCDR (XCAR (list)),
1621                   EQ (cdr, key) || !NILP (Fequal (cdr, key)))))
1622         break;
1623 
1624       list = XCDR (list);
1625       QUIT;
1626     }
1627 
1628   return CAR (list);
1629 }
1630 
1631 DEFUN ("delq", Fdelq, Sdelq, 2, 2, 0,
1632        doc: /* Delete by side effect any occurrences of ELT as a member of LIST.
1633 The modified LIST is returned.  Comparison is done with `eq'.
1634 If the first member of LIST is ELT, there is no way to remove it by side effect;
1635 therefore, write `(setq foo (delq element foo))'
1636 to be sure of changing the value of `foo'.  */)
1637      (elt, list)
1638      register Lisp_Object elt;
1639      Lisp_Object list;
1640 {
1641   register Lisp_Object tail, prev;
1642   register Lisp_Object tem;
1643 
1644   tail = list;
1645   prev = Qnil;
1646   while (!NILP (tail))
1647     {
1648       CHECK_LIST_CONS (tail, list);
1649       tem = XCAR (tail);
1650       if (EQ (elt, tem))
1651         {
1652           if (NILP (prev))
1653             list = XCDR (tail);
1654           else
1655             Fsetcdr (prev, XCDR (tail));
1656         }
1657       else
1658         prev = tail;
1659       tail = XCDR (tail);
1660       QUIT;
1661     }
1662   return list;
1663 }
1664 
1665 DEFUN ("delete", Fdelete, Sdelete, 2, 2, 0,
1666        doc: /* Delete by side effect any occurrences of ELT as a member of SEQ.
1667 SEQ must be a list, a vector, or a string.
1668 The modified SEQ is returned.  Comparison is done with `equal'.
1669 If SEQ is not a list, or the first member of SEQ is ELT, deleting it
1670 is not a side effect; it is simply using a different sequence.
1671 Therefore, write `(setq foo (delete element foo))'
1672 to be sure of changing the value of `foo'.  */)
1673      (elt, seq)
1674      Lisp_Object elt, seq;
1675 {
1676   if (VECTORP (seq))
1677     {
1678       EMACS_INT i, n;
1679 
1680       for (i = n = 0; i < ASIZE (seq); ++i)
1681         if (NILP (Fequal (AREF (seq, i), elt)))
1682           ++n;
1683 
1684       if (n != ASIZE (seq))
1685         {
1686           struct Lisp_Vector *p = allocate_vector (n);
1687 
1688           for (i = n = 0; i < ASIZE (seq); ++i)
1689             if (NILP (Fequal (AREF (seq, i), elt)))
1690               p->contents[n++] = AREF (seq, i);
1691 
1692           XSETVECTOR (seq, p);
1693         }
1694     }
1695   else if (STRINGP (seq))
1696     {
1697       EMACS_INT i, ibyte, nchars, nbytes, cbytes;
1698       int c;
1699 
1700       for (i = nchars = nbytes = ibyte = 0;
1701            i < SCHARS (seq);
1702            ++i, ibyte += cbytes)
1703         {
1704           if (STRING_MULTIBYTE (seq))
1705             {
1706               c = STRING_CHAR (SDATA (seq) + ibyte);
1707               cbytes = CHAR_BYTES (c);
1708             }
1709           else
1710             {
1711               c = SREF (seq, i);
1712               cbytes = 1;
1713             }
1714 
1715           if (!INTEGERP (elt) || c != XINT (elt))
1716             {
1717               ++nchars;
1718               nbytes += cbytes;
1719             }
1720         }
1721 
1722       if (nchars != SCHARS (seq))
1723         {
1724           Lisp_Object tem;
1725 
1726           tem = make_uninit_multibyte_string (nchars, nbytes);
1727           if (!STRING_MULTIBYTE (seq))
1728             STRING_SET_UNIBYTE (tem);
1729 
1730           for (i = nchars = nbytes = ibyte = 0;
1731                i < SCHARS (seq);
1732                ++i, ibyte += cbytes)
1733             {
1734               if (STRING_MULTIBYTE (seq))
1735                 {
1736                   c = STRING_CHAR (SDATA (seq) + ibyte);
1737                   cbytes = CHAR_BYTES (c);
1738                 }
1739               else
1740                 {
1741                   c = SREF (seq, i);
1742                   cbytes = 1;
1743                 }
1744 
1745               if (!INTEGERP (elt) || c != XINT (elt))
1746                 {
1747                   unsigned char *from = SDATA (seq) + ibyte;
1748                   unsigned char *to   = SDATA (tem) + nbytes;
1749                   EMACS_INT n;
1750 
1751                   ++nchars;
1752                   nbytes += cbytes;
1753 
1754                   for (n = cbytes; n--; )
1755                     *to++ = *from++;
1756                 }
1757             }
1758 
1759           seq = tem;
1760         }
1761     }
1762   else
1763     {
1764       Lisp_Object tail, prev;
1765 
1766       for (tail = seq, prev = Qnil; CONSP (tail); tail = XCDR (tail))
1767         {
1768           CHECK_LIST_CONS (tail, seq);
1769 
1770           if (!NILP (Fequal (elt, XCAR (tail))))
1771             {
1772               if (NILP (prev))
1773                 seq = XCDR (tail);
1774               else
1775                 Fsetcdr (prev, XCDR (tail));
1776             }
1777           else
1778             prev = tail;
1779           QUIT;
1780         }
1781     }
1782 
1783   return seq;
1784 }
1785 
1786 DEFUN ("nreverse", Fnreverse, Snreverse, 1, 1, 0,
1787        doc: /* Reverse LIST by modifying cdr pointers.
1788 Return the reversed list.  */)
1789      (list)
1790      Lisp_Object list;
1791 {
1792   register Lisp_Object prev, tail, next;
1793 
1794   if (NILP (list)) return list;
1795   prev = Qnil;
1796   tail = list;
1797   while (!NILP (tail))
1798     {
1799       QUIT;
1800       CHECK_LIST_CONS (tail, list);
1801       next = XCDR (tail);
1802       Fsetcdr (tail, prev);
1803       prev = tail;
1804       tail = next;
1805     }
1806   return prev;
1807 }
1808 
1809 DEFUN ("reverse", Freverse, Sreverse, 1, 1, 0,
1810        doc: /* Reverse LIST, copying.  Return the reversed list.
1811 See also the function `nreverse', which is used more often.  */)
1812      (list)
1813      Lisp_Object list;
1814 {
1815   Lisp_Object new;
1816 
1817   for (new = Qnil; CONSP (list); list = XCDR (list))
1818     {
1819       QUIT;
1820       new = Fcons (XCAR (list), new);
1821     }
1822   CHECK_LIST_END (list, list);
1823   return new;
1824 }
1825 
1826 Lisp_Object merge ();
1827 
1828 DEFUN ("sort", Fsort, Ssort, 2, 2, 0,
1829        doc: /* Sort LIST, stably, comparing elements using PREDICATE.
1830 Returns the sorted list.  LIST is modified by side effects.
1831 PREDICATE is called with two elements of LIST, and should return non-nil
1832 if the first element should sort before the second.  */)
1833      (list, predicate)
1834      Lisp_Object list, predicate;
1835 {
1836   Lisp_Object front, back;
1837   register Lisp_Object len, tem;
1838   struct gcpro gcpro1, gcpro2;
1839   register int length;
1840 
1841   front = list;
1842   len = Flength (list);
1843   length = XINT (len);
1844   if (length < 2)
1845     return list;
1846 
1847   XSETINT (len, (length / 2) - 1);
1848   tem = Fnthcdr (len, list);
1849   back = Fcdr (tem);
1850   Fsetcdr (tem, Qnil);
1851 
1852   GCPRO2 (front, back);
1853   front = Fsort (front, predicate);
1854   back = Fsort (back, predicate);
1855   UNGCPRO;
1856   return merge (front, back, predicate);
1857 }
1858 
1859 Lisp_Object
1860 merge (org_l1, org_l2, pred)
1861      Lisp_Object org_l1, org_l2;
1862      Lisp_Object pred;
1863 {
1864   Lisp_Object value;
1865   register Lisp_Object tail;
1866   Lisp_Object tem;
1867   register Lisp_Object l1, l2;
1868   struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
1869 
1870   l1 = org_l1;
1871   l2 = org_l2;
1872   tail = Qnil;
1873   value = Qnil;
1874 
1875   /* It is sufficient to protect org_l1 and org_l2.
1876      When l1 and l2 are updated, we copy the new values
1877      back into the org_ vars.  */
1878   GCPRO4 (org_l1, org_l2, pred, value);
1879 
1880   while (1)
1881     {
1882       if (NILP (l1))
1883         {
1884           UNGCPRO;
1885           if (NILP (tail))
1886             return l2;
1887           Fsetcdr (tail, l2);
1888           return value;
1889         }
1890       if (NILP (l2))
1891         {
1892           UNGCPRO;
1893           if (NILP (tail))
1894             return l1;
1895           Fsetcdr (tail, l1);
1896           return value;
1897         }
1898       tem = call2 (pred, Fcar (l2), Fcar (l1));
1899       if (NILP (tem))
1900         {
1901           tem = l1;
1902           l1 = Fcdr (l1);
1903           org_l1 = l1;
1904         }
1905       else
1906         {
1907           tem = l2;
1908           l2 = Fcdr (l2);
1909           org_l2 = l2;
1910         }
1911       if (NILP (tail))
1912         value = tem;
1913       else
1914         Fsetcdr (tail, tem);
1915       tail = tem;
1916     }
1917 }
1918 
1919 
1920 /* This does not check for quits.  That is safe since it must terminate.  */
1921 
1922 DEFUN ("plist-get", Fplist_get, Splist_get, 2, 2, 0,
1923        doc: /* Extract a value from a property list.
1924 PLIST is a property list, which is a list of the form
1925 \(PROP1 VALUE1 PROP2 VALUE2...).  This function returns the value
1926 corresponding to the given PROP, or nil if PROP is not one of the
1927 properties on the list.  This function never signals an error.  */)
1928      (plist, prop)
1929      Lisp_Object plist;
1930      Lisp_Object prop;
1931 {
1932   Lisp_Object tail, halftail;
1933 
1934   /* halftail is used to detect circular lists.  */
1935   tail = halftail = plist;
1936   while (CONSP (tail) && CONSP (XCDR (tail)))
1937     {
1938       if (EQ (prop, XCAR (tail)))
1939         return XCAR (XCDR (tail));
1940 
1941       tail = XCDR (XCDR (tail));
1942       halftail = XCDR (halftail);
1943       if (EQ (tail, halftail))
1944         break;
1945 
1946 #if 0 /* Unsafe version.  */
1947       /* This function can be called asynchronously
1948          (setup_coding_system).  Don't QUIT in that case.  */
1949       if (!interrupt_input_blocked)
1950         QUIT;
1951 #endif
1952     }
1953 
1954   return Qnil;
1955 }
1956 
1957 DEFUN ("get", Fget, Sget, 2, 2, 0,
1958        doc: /* Return the value of SYMBOL's PROPNAME property.
1959 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'.  */)
1960      (symbol, propname)
1961      Lisp_Object symbol, propname;
1962 {
1963   CHECK_SYMBOL (symbol);
1964   return Fplist_get (XSYMBOL (symbol)->plist, propname);
1965 }
1966 
1967 DEFUN ("plist-put", Fplist_put, Splist_put, 3, 3, 0,
1968        doc: /* Change value in PLIST of PROP to VAL.
1969 PLIST is a property list, which is a list of the form
1970 \(PROP1 VALUE1 PROP2 VALUE2 ...).  PROP is a symbol and VAL is any object.
1971 If PROP is already a property on the list, its value is set to VAL,
1972 otherwise the new PROP VAL pair is added.  The new plist is returned;
1973 use `(setq x (plist-put x prop val))' to be sure to use the new value.
1974 The PLIST is modified by side effects.  */)
1975      (plist, prop, val)
1976      Lisp_Object plist;
1977      register Lisp_Object prop;
1978      Lisp_Object val;
1979 {
1980   register Lisp_Object tail, prev;
1981   Lisp_Object newcell;
1982   prev = Qnil;
1983   for (tail = plist; CONSP (tail) && CONSP (XCDR (tail));
1984        tail = XCDR (XCDR (tail)))
1985     {
1986       if (EQ (prop, XCAR (tail)))
1987         {
1988           Fsetcar (XCDR (tail), val);
1989           return plist;
1990         }
1991 
1992       prev = tail;
1993       QUIT;
1994     }
1995   newcell = Fcons (prop, Fcons (val, NILP (prev) ? plist : XCDR (XCDR (prev))));
1996   if (NILP (prev))
1997     return newcell;
1998   else
1999     Fsetcdr (XCDR (prev), newcell);
2000   return plist;
2001 }
2002 
2003 DEFUN ("put", Fput, Sput, 3, 3, 0,
2004        doc: /* Store SYMBOL's PROPNAME property with value VALUE.
2005 It can be retrieved with `(get SYMBOL PROPNAME)'.  */)
2006      (symbol, propname, value)
2007      Lisp_Object symbol, propname, value;
2008 {
2009   CHECK_SYMBOL (symbol);
2010   XSYMBOL (symbol)->plist
2011     = Fplist_put (XSYMBOL (symbol)->plist, propname, value);
2012   return value;
2013 }
2014 
2015 DEFUN ("lax-plist-get", Flax_plist_get, Slax_plist_get, 2, 2, 0,
2016        doc: /* Extract a value from a property list, comparing with `equal'.
2017 PLIST is a property list, which is a list of the form
2018 \(PROP1 VALUE1 PROP2 VALUE2...).  This function returns the value
2019 corresponding to the given PROP, or nil if PROP is not
2020 one of the properties on the list.  */)
2021      (plist, prop)
2022      Lisp_Object plist;
2023      Lisp_Object prop;
2024 {
2025   Lisp_Object tail;
2026 
2027   for (tail = plist;
2028        CONSP (tail) && CONSP (XCDR (tail));
2029        tail = XCDR (XCDR (tail)))
2030     {
2031       if (! NILP (Fequal (prop, XCAR (tail))))
2032         return XCAR (XCDR (tail));
2033 
2034       QUIT;
2035     }
2036 
2037   CHECK_LIST_END (tail, prop);
2038 
2039   return Qnil;
2040 }
2041 
2042 DEFUN ("lax-plist-put", Flax_plist_put, Slax_plist_put, 3, 3, 0,
2043        doc: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
2044 PLIST is a property list, which is a list of the form
2045 \(PROP1 VALUE1 PROP2 VALUE2 ...).  PROP and VAL are any objects.
2046 If PROP is already a property on the list, its value is set to VAL,
2047 otherwise the new PROP VAL pair is added.  The new plist is returned;
2048 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
2049 The PLIST is modified by side effects.  */)
2050      (plist, prop, val)
2051      Lisp_Object plist;
2052      register Lisp_Object prop;
2053      Lisp_Object val;
2054 {
2055   register Lisp_Object tail, prev;
2056   Lisp_Object newcell;
2057   prev = Qnil;
2058   for (tail = plist; CONSP (tail) && CONSP (XCDR (tail));
2059        tail = XCDR (XCDR (tail)))
2060     {
2061       if (! NILP (Fequal (prop, XCAR (tail))))
2062         {
2063           Fsetcar (XCDR (tail), val);
2064           return plist;
2065         }
2066 
2067       prev = tail;
2068       QUIT;
2069     }
2070   newcell = Fcons (prop, Fcons (val, Qnil));
2071   if (NILP (prev))
2072     return newcell;
2073   else
2074     Fsetcdr (XCDR (prev), newcell);
2075   return plist;
2076 }
2077 
2078 DEFUN ("eql", Feql, Seql, 2, 2, 0,
2079        doc: /* Return t if the two args are the same Lisp object.
2080 Floating-point numbers of equal value are `eql', but they may not be `eq'.  */)
2081      (obj1, obj2)
2082      Lisp_Object obj1, obj2;
2083 {
2084   if (FLOATP (obj1))
2085     return internal_equal (obj1, obj2, 0, 0) ? Qt : Qnil;
2086   else
2087     return EQ (obj1, obj2) ? Qt : Qnil;
2088 }
2089 
2090 DEFUN ("equal", Fequal, Sequal, 2, 2, 0,
2091        doc: /* Return t if two Lisp objects have similar structure and contents.
2092 They must have the same data type.
2093 Conses are compared by comparing the cars and the cdrs.
2094 Vectors and strings are compared element by element.
2095 Numbers are compared by value, but integers cannot equal floats.
2096  (Use `=' if you want integers and floats to be able to be equal.)
2097 Symbols must match exactly.  */)
2098      (o1, o2)
2099      register Lisp_Object o1, o2;
2100 {
2101   return internal_equal (o1, o2, 0, 0) ? Qt : Qnil;
2102 }
2103 
2104 DEFUN ("equal-including-properties", Fequal_including_properties, Sequal_including_properties, 2, 2, 0,
2105        doc: /* Return t if two Lisp objects have similar structure and contents.
2106 This is like `equal' except that it compares the text properties
2107 of strings.  (`equal' ignores text properties.)  */)
2108      (o1, o2)
2109      register Lisp_Object o1, o2;
2110 {
2111   return internal_equal (o1, o2, 0, 1) ? Qt : Qnil;
2112 }
2113 
2114 /* DEPTH is current depth of recursion.  Signal an error if it
2115    gets too deep.
2116    PROPS, if non-nil, means compare string text properties too.  */
2117 
2118 static int
2119 internal_equal (o1, o2, depth, props)
2120      register Lisp_Object o1, o2;
2121      int depth, props;
2122 {
2123   if (depth > 200)
2124     error ("Stack overflow in equal");
2125 
2126  tail_recurse:
2127   QUIT;
2128   if (EQ (o1, o2))
2129     return 1;
2130   if (XTYPE (o1) != XTYPE (o2))
2131     return 0;
2132 
2133   switch (XTYPE (o1))
2134     {
2135     case Lisp_Float:
2136       {
2137         double d1, d2;
2138 
2139         d1 = extract_float (o1);
2140         d2 = extract_float (o2);
2141         /* If d is a NaN, then d != d. Two NaNs should be `equal' even
2142            though they are not =. */
2143         return d1 == d2 || (d1 != d1 && d2 != d2);
2144       }
2145 
2146     case Lisp_Cons:
2147       if (!internal_equal (XCAR (o1), XCAR (o2), depth + 1, props))
2148         return 0;
2149       o1 = XCDR (o1);
2150       o2 = XCDR (o2);
2151       goto tail_recurse;
2152 
2153     case Lisp_Misc:
2154       if (XMISCTYPE (o1) != XMISCTYPE (o2))
2155         return 0;
2156       if (OVERLAYP (o1))
2157         {
2158           if (!internal_equal (OVERLAY_START (o1), OVERLAY_START (o2),
2159                                depth + 1, props)
2160               || !internal_equal (OVERLAY_END (o1), OVERLAY_END (o2),
2161                                   depth + 1, props))
2162             return 0;
2163           o1 = XOVERLAY (o1)->plist;
2164           o2 = XOVERLAY (o2)->plist;
2165           goto tail_recurse;
2166         }
2167       if (MARKERP (o1))
2168         {
2169           return (XMARKER (o1)->buffer == XMARKER (o2)->buffer
2170                   && (XMARKER (o1)->buffer == 0
2171                       || XMARKER (o1)->bytepos == XMARKER (o2)->bytepos));
2172         }
2173       break;
2174 
2175     case Lisp_Vectorlike:
2176       {
2177         register int i;
2178         EMACS_INT size = ASIZE (o1);
2179         /* Pseudovectors have the type encoded in the size field, so this test
2180            actually checks that the objects have the same type as well as the
2181            same size.  */
2182         if (ASIZE (o2) != size)
2183           return 0;
2184         /* Boolvectors are compared much like strings.  */
2185         if (BOOL_VECTOR_P (o1))
2186           {
2187             int size_in_chars
2188               = ((XBOOL_VECTOR (o1)->size + BOOL_VECTOR_BITS_PER_CHAR - 1)
2189                  / BOOL_VECTOR_BITS_PER_CHAR);
2190 
2191             if (XBOOL_VECTOR (o1)->size != XBOOL_VECTOR (o2)->size)
2192               return 0;
2193             if (bcmp (XBOOL_VECTOR (o1)->data, XBOOL_VECTOR (o2)->data,
2194                       size_in_chars))
2195               return 0;
2196             return 1;
2197           }
2198         if (WINDOW_CONFIGURATIONP (o1))
2199           return compare_window_configurations (o1, o2, 0);
2200 
2201         /* Aside from them, only true vectors, char-tables, compiled
2202            functions, and fonts (font-spec, font-entity, font-ojbect)
2203            are sensible to compare, so eliminate the others now.  */
2204         if (size & PSEUDOVECTOR_FLAG)
2205           {
2206             if (!(size & (PVEC_COMPILED
2207                           | PVEC_CHAR_TABLE | PVEC_SUB_CHAR_TABLE | PVEC_FONT)))
2208               return 0;
2209             size &= PSEUDOVECTOR_SIZE_MASK;
2210           }
2211         for (i = 0; i < size; i++)
2212           {
2213             Lisp_Object v1, v2;
2214             v1 = AREF (o1, i);
2215             v2 = AREF (o2, i);
2216             if (!internal_equal (v1, v2, depth + 1, props))
2217               return 0;
2218           }
2219         return 1;
2220       }
2221       break;
2222 
2223     case Lisp_String:
2224       if (SCHARS (o1) != SCHARS (o2))
2225         return 0;
2226       if (SBYTES (o1) != SBYTES (o2))
2227         return 0;
2228       if (bcmp (SDATA (o1), SDATA (o2),
2229                 SBYTES (o1)))
2230         return 0;
2231       if (props && !compare_string_intervals (o1, o2))
2232         return 0;
2233       return 1;
2234 
2235     default:
2236       break;
2237     }
2238 
2239   return 0;
2240 }
2241 
2242 extern Lisp_Object Fmake_char_internal ();
2243 
2244 DEFUN ("fillarray", Ffillarray, Sfillarray, 2, 2, 0,
2245        doc: /* Store each element of ARRAY with ITEM.
2246 ARRAY is a vector, string, char-table, or bool-vector.  */)
2247      (array, item)
2248      Lisp_Object array, item;
2249 {
2250   register int size, index, charval;
2251   if (VECTORP (array))
2252     {
2253       register Lisp_Object *p = XVECTOR (array)->contents;
2254       size = ASIZE (array);
2255       for (index = 0; index < size; index++)
2256         p[index] = item;
2257     }
2258   else if (CHAR_TABLE_P (array))
2259     {
2260       int i;
2261 
2262       for (i = 0; i < (1 << CHARTAB_SIZE_BITS_0); i++)
2263         XCHAR_TABLE (array)->contents[i] = item;
2264       XCHAR_TABLE (array)->defalt = item;
2265     }
2266   else if (STRINGP (array))
2267     {
2268       register unsigned char *p = SDATA (array);
2269       CHECK_NUMBER (item);
2270       charval = XINT (item);
2271       size = SCHARS (array);
2272       if (STRING_MULTIBYTE (array))
2273         {
2274           unsigned char str[MAX_MULTIBYTE_LENGTH];
2275           int len = CHAR_STRING (charval, str);
2276           int size_byte = SBYTES (array);
2277           unsigned char *p1 = p, *endp = p + size_byte;
2278           int i;
2279 
2280           if (size != size_byte)
2281             while (p1 < endp)
2282               {
2283                 int this_len = MULTIBYTE_FORM_LENGTH (p1, endp - p1);
2284                 if (len != this_len)
2285                   error ("Attempt to change byte length of a string");
2286                 p1 += this_len;
2287               }
2288           for (i = 0; i < size_byte; i++)
2289             *p++ = str[i % len];
2290         }
2291       else
2292         for (index = 0; index < size; index++)
2293           p[index] = charval;
2294     }
2295   else if (BOOL_VECTOR_P (array))
2296     {
2297       register unsigned char *p = XBOOL_VECTOR (array)->data;
2298       int size_in_chars
2299         = ((XBOOL_VECTOR (array)->size + BOOL_VECTOR_BITS_PER_CHAR - 1)
2300            / BOOL_VECTOR_BITS_PER_CHAR);
2301 
2302       charval = (! NILP (item) ? -1 : 0);
2303       for (index = 0; index < size_in_chars - 1; index++)
2304         p[index] = charval;
2305       if (index < size_in_chars)
2306         {
2307           /* Mask out bits beyond the vector size.  */
2308           if (XBOOL_VECTOR (array)->size % BOOL_VECTOR_BITS_PER_CHAR)
2309             charval &= (1 << (XBOOL_VECTOR (array)->size % BOOL_VECTOR_BITS_PER_CHAR)) - 1;
2310           p[index] = charval;
2311         }
2312     }
2313   else
2314     wrong_type_argument (Qarrayp, array);
2315   return array;
2316 }
2317 
2318 DEFUN ("clear-string", Fclear_string, Sclear_string,
2319        1, 1, 0,
2320        doc: /* Clear the contents of STRING.
2321 This makes STRING unibyte and may change its length.  */)
2322      (string)
2323      Lisp_Object string;
2324 {
2325   int len;
2326   CHECK_STRING (string);
2327   len = SBYTES (string);
2328   bzero (SDATA (string), len);
2329   STRING_SET_CHARS (string, len);
2330   STRING_SET_UNIBYTE (string);
2331   return Qnil;
2332 }
2333 
2334 /* ARGSUSED */
2335 Lisp_Object
2336 nconc2 (s1, s2)
2337      Lisp_Object s1, s2;
2338 {
2339   Lisp_Object args[2];
2340   args[0] = s1;
2341   args[1] = s2;
2342   return Fnconc (2, args);
2343 }
2344 
2345 DEFUN ("nconc", Fnconc, Snconc, 0, MANY, 0,
2346        doc: /* Concatenate any number of lists by altering them.
2347 Only the last argument is not altered, and need not be a list.
2348 usage: (nconc &rest LISTS)  */)
2349      (nargs, args)
2350      int nargs;
2351      Lisp_Object *args;
2352 {
2353   register int argnum;
2354   register Lisp_Object tail, tem, val;
2355 
2356   val = tail = Qnil;
2357 
2358   for (argnum = 0; argnum < nargs; argnum++)
2359     {
2360       tem = args[argnum];
2361       if (NILP (tem)) continue;
2362 
2363       if (NILP (val))
2364         val = tem;
2365 
2366       if (argnum + 1 == nargs) break;
2367 
2368       CHECK_LIST_CONS (tem, tem);
2369 
2370       while (CONSP (tem))
2371         {
2372           tail = tem;
2373           tem = XCDR (tail);
2374           QUIT;
2375         }
2376 
2377       tem = args[argnum + 1];
2378       Fsetcdr (tail, tem);
2379       if (NILP (tem))
2380         args[argnum + 1] = tail;
2381     }
2382 
2383   return val;
2384 }
2385 
2386 /* This is the guts of all mapping functions.
2387  Apply FN to each element of SEQ, one by one,
2388  storing the results into elements of VALS, a C vector of Lisp_Objects.
2389  LENI is the length of VALS, which should also be the length of SEQ.  */
2390 
2391 static void
2392 mapcar1 (leni, vals, fn, seq)
2393      int leni;
2394      Lisp_Object *vals;
2395      Lisp_Object fn, seq;
2396 {
2397   register Lisp_Object tail;
2398   Lisp_Object dummy;
2399   register int i;
2400   struct gcpro gcpro1, gcpro2, gcpro3;
2401 
2402   if (vals)
2403     {
2404       /* Don't let vals contain any garbage when GC happens.  */
2405       for (i = 0; i < leni; i++)
2406         vals[i] = Qnil;
2407 
2408       GCPRO3 (dummy, fn, seq);
2409       gcpro1.var = vals;
2410       gcpro1.nvars = leni;
2411     }
2412   else
2413     GCPRO2 (fn, seq);
2414   /* We need not explicitly protect `tail' because it is used only on lists, and
2415     1) lists are not relocated and 2) the list is marked via `seq' so will not
2416     be freed */
2417 
2418   if (VECTORP (seq))
2419     {
2420       for (i = 0; i < leni; i++)
2421         {
2422           dummy = call1 (fn, AREF (seq, i));
2423           if (vals)
2424             vals[i] = dummy;
2425         }
2426     }
2427   else if (BOOL_VECTOR_P (seq))
2428     {
2429       for (i = 0; i < leni; i++)
2430         {
2431           int byte;
2432           byte = XBOOL_VECTOR (seq)->data[i / BOOL_VECTOR_BITS_PER_CHAR];
2433           dummy = (byte & (1 << (i % BOOL_VECTOR_BITS_PER_CHAR))) ? Qt : Qnil;
2434           dummy = call1 (fn, dummy);
2435           if (vals)
2436             vals[i] = dummy;
2437         }
2438     }
2439   else if (STRINGP (seq))
2440     {
2441       int i_byte;
2442 
2443       for (i = 0, i_byte = 0; i < leni;)
2444         {
2445           int c;
2446           int i_before = i;
2447 
2448           FETCH_STRING_CHAR_ADVANCE (c, seq, i, i_byte);
2449           XSETFASTINT (dummy, c);
2450           dummy = call1 (fn, dummy);
2451           if (vals)
2452             vals[i_before] = dummy;
2453         }
2454     }
2455   else   /* Must be a list, since Flength did not get an error */
2456     {
2457       tail = seq;
2458       for (i = 0; i < leni && CONSP (tail); i++)
2459         {
2460           dummy = call1 (fn, XCAR (tail));
2461           if (vals)
2462             vals[i] = dummy;
2463           tail = XCDR (tail);
2464         }
2465     }
2466 
2467   UNGCPRO;
2468 }
2469 
2470 DEFUN ("mapconcat", Fmapconcat, Smapconcat, 3, 3, 0,
2471        doc: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
2472 In between each pair of results, stick in SEPARATOR.  Thus, " " as
2473 SEPARATOR results in spaces between the values returned by FUNCTION.
2474 SEQUENCE may be a list, a vector, a bool-vector, or a string.  */)
2475      (function, sequence, separator)
2476      Lisp_Object function, sequence, separator;
2477 {
2478   Lisp_Object len;
2479   register int leni;
2480   int nargs;
2481   register Lisp_Object *args;
2482   register int i;
2483   struct gcpro gcpro1;
2484   Lisp_Object ret;
2485   USE_SAFE_ALLOCA;
2486 
2487   len = Flength (sequence);
2488   if (CHAR_TABLE_P (sequence))
2489     wrong_type_argument (Qlistp, sequence);
2490   leni = XINT (len);
2491   nargs = leni + leni - 1;
2492   if (nargs < 0) return empty_unibyte_string;
2493 
2494   SAFE_ALLOCA_LISP (args, nargs);
2495 
2496   GCPRO1 (separator);
2497   mapcar1 (leni, args, function, sequence);
2498   UNGCPRO;
2499 
2500   for (i = leni - 1; i > 0; i--)
2501     args[i + i] = args[i];
2502 
2503   for (i = 1; i < nargs; i += 2)
2504     args[i] = separator;
2505 
2506   ret = Fconcat (nargs, args);
2507   SAFE_FREE ();
2508 
2509   return ret;
2510 }
2511 
2512 DEFUN ("mapcar", Fmapcar, Smapcar, 2, 2, 0,
2513        doc: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
2514 The result is a list just as long as SEQUENCE.
2515 SEQUENCE may be a list, a vector, a bool-vector, or a string.  */)
2516      (function, sequence)
2517      Lisp_Object function, sequence;
2518 {
2519   register Lisp_Object len;
2520   register int leni;
2521   register Lisp_Object *args;
2522   Lisp_Object ret;
2523   USE_SAFE_ALLOCA;
2524 
2525   len = Flength (sequence);
2526   if (CHAR_TABLE_P (sequence))
2527     wrong_type_argument (Qlistp, sequence);
2528   leni = XFASTINT (len);
2529 
2530   SAFE_ALLOCA_LISP (args, leni);
2531 
2532   mapcar1 (leni, args, function, sequence);
2533 
2534   ret = Flist (leni, args);
2535   SAFE_FREE ();
2536 
2537   return ret;
2538 }
2539 
2540 DEFUN ("mapc", Fmapc, Smapc, 2, 2, 0,
2541        doc: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
2542 Unlike `mapcar', don't accumulate the results.  Return SEQUENCE.
2543 SEQUENCE may be a list, a vector, a bool-vector, or a string.  */)
2544      (function, sequence)
2545      Lisp_Object function, sequence;
2546 {
2547   register int leni;
2548 
2549   leni = XFASTINT (Flength (sequence));
2550   if (CHAR_TABLE_P (sequence))
2551     wrong_type_argument (Qlistp, sequence);
2552   mapcar1 (leni, 0, function, sequence);
2553 
2554   return sequence;
2555 }
2556 
2557 /* Anything that calls this function must protect from GC!  */
2558 
2559 DEFUN ("y-or-n-p", Fy_or_n_p, Sy_or_n_p, 1, 1, 0,
2560        doc: /* Ask user a "y or n" question.  Return t if answer is "y".
2561 Takes one argument, which is the string to display to ask the question.
2562 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.
2563 No confirmation of the answer is requested; a single character is enough.
2564 Also accepts Space to mean yes, or Delete to mean no.  \(Actually, it uses
2565 the bindings in `query-replace-map'; see the documentation of that variable
2566 for more information.  In this case, the useful bindings are `act', `skip',
2567 `recenter', and `quit'.\)
2568 
2569 Under a windowing system a dialog box will be used if `last-nonmenu-event'
2570 is nil and `use-dialog-box' is non-nil.  */)
2571      (prompt)
2572      Lisp_Object prompt;
2573 {
2574   register Lisp_Object obj, key, def, map;
2575   register int answer;
2576   Lisp_Object xprompt;
2577   Lisp_Object args[2];
2578   struct gcpro gcpro1, gcpro2;
2579   int count = SPECPDL_INDEX ();
2580 
2581   specbind (Qcursor_in_echo_area, Qt);
2582 
2583   map = Fsymbol_value (intern ("query-replace-map"));
2584 
2585   CHECK_STRING (prompt);
2586   xprompt = prompt;
2587   GCPRO2 (prompt, xprompt);
2588 
2589 #ifdef HAVE_WINDOW_SYSTEM
2590   if (display_hourglass_p)
2591     cancel_hourglass ();
2592 #endif
2593 
2594   while (1)
2595     {
2596 
2597 #ifdef HAVE_MENUS
2598       if (FRAME_WINDOW_P (SELECTED_FRAME ())
2599           && (NILP (last_nonmenu_event) || CONSP (last_nonmenu_event))
2600           && use_dialog_box
2601           && have_menus_p ())
2602         {
2603           Lisp_Object pane, menu;
2604           redisplay_preserve_echo_area (3);
2605           pane = Fcons (Fcons (build_string ("Yes"), Qt),
2606                         Fcons (Fcons (build_string ("No"), Qnil),
2607                                Qnil));
2608           menu = Fcons (prompt, pane);
2609           obj = Fx_popup_dialog (Qt, menu, Qnil);
2610           answer = !NILP (obj);
2611           break;
2612         }
2613 #endif /* HAVE_MENUS */
2614       cursor_in_echo_area = 1;
2615       choose_minibuf_frame ();
2616 
2617       {
2618         Lisp_Object pargs[3];
2619 
2620         /* Colorize prompt according to `minibuffer-prompt' face.  */
2621         pargs[0] = build_string ("%s(y or n) ");
2622         pargs[1] = intern ("face");
2623         pargs[2] = intern ("minibuffer-prompt");
2624         args[0] = Fpropertize (3, pargs);
2625         args[1] = xprompt;
2626         Fmessage (2, args);
2627       }
2628 
2629       if (minibuffer_auto_raise)
2630         {
2631           Lisp_Object mini_frame;
2632 
2633           mini_frame = WINDOW_FRAME (XWINDOW (minibuf_window));
2634 
2635           Fraise_frame (mini_frame);
2636         }
2637 
2638       temporarily_switch_to_single_kboard (SELECTED_FRAME ());
2639       obj = read_filtered_event (1, 0, 0, 0, Qnil);
2640       cursor_in_echo_area = 0;
2641       /* If we need to quit, quit with cursor_in_echo_area = 0.  */
2642       QUIT;
2643 
2644       key = Fmake_vector (make_number (1), obj);
2645       def = Flookup_key (map, key, Qt);
2646 
2647       if (EQ (def, intern ("skip")))
2648         {
2649           answer = 0;
2650           break;
2651         }
2652       else if (EQ (def, intern ("act")))
2653         {
2654           answer = 1;
2655           break;
2656         }
2657       else if (EQ (def, intern ("recenter")))
2658         {
2659           Frecenter (Qnil);
2660           xprompt = prompt;
2661           continue;
2662         }
2663       else if (EQ (def, intern ("quit")))
2664         Vquit_flag = Qt;
2665       /* We want to exit this command for exit-prefix,
2666          and this is the only way to do it.  */
2667       else if (EQ (def, intern ("exit-prefix")))
2668         Vquit_flag = Qt;
2669 
2670       QUIT;
2671 
2672       /* If we don't clear this, then the next call to read_char will
2673          return quit_char again, and we'll enter an infinite loop.  */
2674       Vquit_flag = Qnil;
2675 
2676       Fding (Qnil);
2677       Fdiscard_input ();
2678       if (EQ (xprompt, prompt))
2679         {
2680           args[0] = build_string ("Please answer y or n.  ");
2681           args[1] = prompt;
2682           xprompt = Fconcat (2, args);
2683         }
2684     }
2685   UNGCPRO;
2686 
2687   if (! noninteractive)
2688     {
2689       cursor_in_echo_area = -1;
2690       message_with_string (answer ? "%s(y or n) y" : "%s(y or n) n",
2691                            xprompt, 0);
2692     }
2693 
2694   unbind_to (count, Qnil);
2695   return answer ? Qt : Qnil;
2696 }
2697 
2698 /* This is how C code calls `yes-or-no-p' and allows the user
2699    to redefined it.
2700 
2701    Anything that calls this function must protect from GC!  */
2702 
2703 Lisp_Object
2704 do_yes_or_no_p (prompt)
2705      Lisp_Object prompt;
2706 {
2707   return call1 (intern ("yes-or-no-p"), prompt);
2708 }
2709 
2710 /* Anything that calls this function must protect from GC!  */
2711 
2712 DEFUN ("yes-or-no-p", Fyes_or_no_p, Syes_or_no_p, 1, 1, 0,
2713        doc: /* Ask user a yes-or-no question.  Return t if answer is yes.
2714 Takes one argument, which is the string to display to ask the question.
2715 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.
2716 The user must confirm the answer with RET,
2717 and can edit it until it has been confirmed.
2718 
2719 Under a windowing system a dialog box will be used if `last-nonmenu-event'
2720 is nil, and `use-dialog-box' is non-nil.  */)
2721      (prompt)
2722      Lisp_Object prompt;
2723 {
2724   register Lisp_Object ans;
2725   Lisp_Object args[2];
2726   struct gcpro gcpro1;
2727 
2728   CHECK_STRING (prompt);
2729 
2730 #ifdef HAVE_MENUS
2731   if (FRAME_WINDOW_P (SELECTED_FRAME ())
2732       && (NILP (last_nonmenu_event) || CONSP (last_nonmenu_event))
2733       && use_dialog_box
2734       && have_menus_p ())
2735     {
2736       Lisp_Object pane, menu, obj;
2737       redisplay_preserve_echo_area (4);
2738       pane = Fcons (Fcons (build_string ("Yes"), Qt),
2739                     Fcons (Fcons (build_string ("No"), Qnil),
2740                            Qnil));
2741       GCPRO1 (pane);
2742       menu = Fcons (prompt, pane);
2743       obj = Fx_popup_dialog (Qt, menu, Qnil);
2744       UNGCPRO;
2745       return obj;
2746     }
2747 #endif /* HAVE_MENUS */
2748 
2749   args[0] = prompt;
2750   args[1] = build_string ("(yes or no) ");
2751   prompt = Fconcat (2, args);
2752 
2753   GCPRO1 (prompt);
2754 
2755   while (1)
2756     {
2757       ans = Fdowncase (Fread_from_minibuffer (prompt, Qnil, Qnil, Qnil,
2758                                               Qyes_or_no_p_history, Qnil,
2759                                               Qnil));
2760       if (SCHARS (ans) == 3 && !strcmp (SDATA (ans), "yes"))
2761         {
2762           UNGCPRO;
2763           return Qt;
2764         }
2765       if (SCHARS (ans) == 2 && !strcmp (SDATA (ans), "no"))
2766         {
2767           UNGCPRO;
2768           return Qnil;
2769         }
2770 
2771       Fding (Qnil);
2772       Fdiscard_input ();
2773       message ("Please answer yes or no.");
2774       Fsleep_for (make_number (2), Qnil);
2775     }
2776 }
2777 
2778 DEFUN ("load-average", Fload_average, Sload_average, 0, 1, 0,
2779        doc: /* Return list of 1 minute, 5 minute and 15 minute load averages.
2780 
2781 Each of the three load averages is multiplied by 100, then converted
2782 to integer.
2783 
2784 When USE-FLOATS is non-nil, floats will be used instead of integers.
2785 These floats are not multiplied by 100.
2786 
2787 If the 5-minute or 15-minute load averages are not available, return a
2788 shortened list, containing only those averages which are available.
2789 
2790 An error is thrown if the load average can't be obtained.  In some
2791 cases making it work would require Emacs being installed setuid or
2792 setgid so that it can read kernel information, and that usually isn't
2793 advisable.  */)
2794      (use_floats)
2795      Lisp_Object use_floats;
2796 {
2797   double load_ave[3];
2798   int loads = getloadavg (load_ave, 3);
2799   Lisp_Object ret = Qnil;
2800 
2801   if (loads < 0)
2802     error ("load-average not implemented for this operating system");
2803 
2804   while (loads-- > 0)
2805     {
2806       Lisp_Object load = (NILP (use_floats) ?
2807                           make_number ((int) (100.0 * load_ave[loads]))
2808                           : make_float (load_ave[loads]));
2809       ret = Fcons (load, ret);
2810     }
2811 
2812   return ret;
2813 }
2814 
2815 Lisp_Object Vfeatures, Qsubfeatures;
2816 extern Lisp_Object Vafter_load_alist;
2817 
2818 DEFUN ("featurep", Ffeaturep, Sfeaturep, 1, 2, 0,
2819        doc: /* Returns t if FEATURE is present in this Emacs.
2820 
2821 Use this to conditionalize execution of lisp code based on the
2822 presence or absence of Emacs or environment extensions.
2823 Use `provide' to declare that a feature is available.  This function
2824 looks at the value of the variable `features'.  The optional argument
2825 SUBFEATURE can be used to check a specific subfeature of FEATURE.  */)
2826      (feature, subfeature)
2827      Lisp_Object feature, subfeature;
2828 {
2829   register Lisp_Object tem;
2830   CHECK_SYMBOL (feature);
2831   tem = Fmemq (feature, Vfeatures);
2832   if (!NILP (tem) && !NILP (subfeature))
2833     tem = Fmember (subfeature, Fget (feature, Qsubfeatures));
2834   return (NILP (tem)) ? Qnil : Qt;
2835 }
2836 
2837 DEFUN ("provide", Fprovide, Sprovide, 1, 2, 0,
2838        doc: /* Announce that FEATURE is a feature of the current Emacs.
2839 The optional argument SUBFEATURES should be a list of symbols listing
2840 particular subfeatures supported in this version of FEATURE.  */)
2841      (feature, subfeatures)
2842      Lisp_Object feature, subfeatures;
2843 {
2844   register Lisp_Object tem;
2845   CHECK_SYMBOL (feature);
2846   CHECK_LIST (subfeatures);
2847   if (!NILP (Vautoload_queue))
2848     Vautoload_queue = Fcons (Fcons (make_number (0), Vfeatures),
2849                              Vautoload_queue);
2850   tem = Fmemq (feature, Vfeatures);
2851   if (NILP (tem))
2852     Vfeatures = Fcons (feature, Vfeatures);
2853   if (!NILP (subfeatures))
2854     Fput (feature, Qsubfeatures, subfeatures);
2855   LOADHIST_ATTACH (Fcons (Qprovide, feature));
2856 
2857   /* Run any load-hooks for this file.  */
2858   tem = Fassq (feature, Vafter_load_alist);
2859   if (CONSP (tem))
2860     Fprogn (XCDR (tem));
2861 
2862   return feature;
2863 }
2864 
2865 /* `require' and its subroutines.  */
2866 
2867 /* List of features currently being require'd, innermost first.  */
2868 
2869 Lisp_Object require_nesting_list;
2870 
2871 Lisp_Object
2872 require_unwind (old_value)
2873      Lisp_Object old_value;
2874 {
2875   return require_nesting_list = old_value;
2876 }
2877 
2878 DEFUN ("require", Frequire, Srequire, 1, 3, 0,
2879        doc: /* If feature FEATURE is not loaded, load it from FILENAME.
2880 If FEATURE is not a member of the list `features', then the feature
2881 is not loaded; so load the file FILENAME.
2882 If FILENAME is omitted, the printname of FEATURE is used as the file name,
2883 and `load' will try to load this name appended with the suffix `.elc' or
2884 `.el', in that order.  The name without appended suffix will not be used.
2885 If the optional third argument NOERROR is non-nil,
2886 then return nil if the file is not found instead of signaling an error.
2887 Normally the return value is FEATURE.
2888 The normal messages at start and end of loading FILENAME are suppressed.  */)
2889      (feature, filename, noerror)
2890      Lisp_Object feature, filename, noerror;
2891 {
2892   register Lisp_Object tem;
2893   struct gcpro gcpro1, gcpro2;
2894   int from_file = load_in_progress;
2895 
2896   CHECK_SYMBOL (feature);
2897 
2898   /* Record the presence of `require' in this file
2899      even if the feature specified is already loaded.
2900      But not more than once in any file,
2901      and not when we aren't loading or reading from a file.  */
2902   if (!from_file)
2903     for (tem = Vcurrent_load_list; CONSP (tem); tem = XCDR (tem))
2904       if (NILP (XCDR (tem)) && STRINGP (XCAR (tem)))
2905         from_file = 1;
2906 
2907   if (from_file)
2908     {
2909       tem = Fcons (Qrequire, feature);
2910       if (NILP (Fmember (tem, Vcurrent_load_list)))
2911         LOADHIST_ATTACH (tem);
2912     }
2913   tem = Fmemq (feature, Vfeatures);
2914 
2915   if (NILP (tem))
2916     {
2917       int count = SPECPDL_INDEX ();
2918       int nesting = 0;
2919 
2920       /* This is to make sure that loadup.el gives a clear picture
2921          of what files are preloaded and when.  */
2922       if (! NILP (Vpurify_flag))
2923         error ("(require %s) while preparing to dump",
2924                SDATA (SYMBOL_NAME (feature)));
2925 
2926       /* A certain amount of recursive `require' is legitimate,
2927          but if we require the same feature recursively 3 times,
2928          signal an error.  */
2929       tem = require_nesting_list;
2930       while (! NILP (tem))
2931         {
2932           if (! NILP (Fequal (feature, XCAR (tem))))
2933             nesting++;
2934           tem = XCDR (tem);
2935         }
2936       if (nesting > 3)
2937         error ("Recursive `require' for feature `%s'",
2938                SDATA (SYMBOL_NAME (feature)));
2939 
2940       /* Update the list for any nested `require's that occur.  */
2941       record_unwind_protect (require_unwind, require_nesting_list);
2942       require_nesting_list = Fcons (feature, require_nesting_list);
2943 
2944       /* Value saved here is to be restored into Vautoload_queue */
2945       record_unwind_protect (un_autoload, Vautoload_queue);
2946       Vautoload_queue = Qt;
2947 
2948       /* Load the file.  */
2949       GCPRO2 (feature, filename);
2950       tem = Fload (NILP (filename) ? Fsymbol_name (feature) : filename,
2951                    noerror, Qt, Qnil, (NILP (filename) ? Qt : Qnil));
2952       UNGCPRO;
2953 
2954       /* If load failed entirely, return nil.  */
2955       if (NILP (tem))
2956         return unbind_to (count, Qnil);
2957 
2958       tem = Fmemq (feature, Vfeatures);
2959       if (NILP (tem))
2960         error ("Required feature `%s' was not provided",
2961                SDATA (SYMBOL_NAME (feature)));
2962 
2963       /* Once loading finishes, don't undo it.  */
2964       Vautoload_queue = Qt;
2965       feature = unbind_to (count, feature);
2966     }
2967 
2968   return feature;
2969 }
2970 
2971 /* Primitives for work of the "widget" library.
2972    In an ideal world, this section would not have been necessary.
2973    However, lisp function calls being as slow as they are, it turns
2974    out that some functions in the widget library (wid-edit.el) are the
2975    bottleneck of Widget operation.  Here is their translation to C,
2976    for the sole reason of efficiency.  */
2977 
2978 DEFUN ("plist-member", Fplist_member, Splist_member, 2, 2, 0,
2979        doc: /* Return non-nil if PLIST has the property PROP.
2980 PLIST is a property list, which is a list of the form
2981 \(PROP1 VALUE1 PROP2 VALUE2 ...\).  PROP is a symbol.
2982 Unlike `plist-get', this allows you to distinguish between a missing
2983 property and a property with the value nil.
2984 The value is actually the tail of PLIST whose car is PROP.  */)
2985      (plist, prop)
2986      Lisp_Object plist, prop;
2987 {
2988   while (CONSP (plist) && !EQ (XCAR (plist), prop))
2989     {
2990       QUIT;
2991       plist = XCDR (plist);
2992       plist = CDR (plist);
2993     }
2994   return plist;
2995 }
2996 
2997 DEFUN ("widget-put", Fwidget_put, Swidget_put, 3, 3, 0,
2998        doc: /* In WIDGET, set PROPERTY to VALUE.
2999 The value can later be retrieved with `widget-get'.  */)
3000      (widget, property, value)
3001      Lisp_Object widget, property, value;
3002 {
3003   CHECK_CONS (widget);
3004   XSETCDR (widget, Fplist_put (XCDR (widget), property, value));
3005   return value;
3006 }
3007 
3008 DEFUN ("widget-get", Fwidget_get, Swidget_get, 2, 2, 0,
3009        doc: /* In WIDGET, get the value of PROPERTY.
3010 The value could either be specified when the widget was created, or
3011 later with `widget-put'.  */)
3012      (widget, property)
3013      Lisp_Object widget, property;
3014 {
3015   Lisp_Object tmp;
3016 
3017   while (1)
3018     {
3019       if (NILP (widget))
3020         return Qnil;
3021       CHECK_CONS (widget);
3022       tmp = Fplist_member (XCDR (widget), property);
3023       if (CONSP (tmp))
3024         {
3025           tmp = XCDR (tmp);
3026           return CAR (tmp);
3027         }
3028       tmp = XCAR (widget);
3029       if (NILP (tmp))
3030         return Qnil;
3031       widget = Fget (tmp, Qwidget_type);
3032     }
3033 }
3034 
3035 DEFUN ("widget-apply", Fwidget_apply, Swidget_apply, 2, MANY, 0,
3036        doc: /* Apply the value of WIDGET's PROPERTY to the widget itself.
3037 ARGS are passed as extra arguments to the function.
3038 usage: (widget-apply WIDGET PROPERTY &rest ARGS)  */)
3039      (nargs, args)
3040      int nargs;
3041      Lisp_Object *args;
3042 {
3043   /* This function can GC. */
3044   Lisp_Object newargs[3];
3045   struct gcpro gcpro1, gcpro2;
3046   Lisp_Object result;
3047 
3048   newargs[0] = Fwidget_get (args[0], args[1]);
3049   newargs[1] = args[0];
3050   newargs[2] = Flist (nargs - 2, args + 2);
3051   GCPRO2 (newargs[0], newargs[2]);
3052   result = Fapply (3, newargs);
3053   UNGCPRO;
3054   return result;
3055 }
3056 
3057 #ifdef HAVE_LANGINFO_CODESET
3058 #include <langinfo.h>
3059 #endif
3060 
3061 DEFUN ("locale-info", Flocale_info, Slocale_info, 1, 1, 0,
3062        doc: /* Access locale data ITEM for the current C locale, if available.
3063 ITEM should be one of the following:
3064 
3065 `codeset', returning the character set as a string (locale item CODESET);
3066 
3067 `days', returning a 7-element vector of day names (locale items DAY_n);
3068 
3069 `months', returning a 12-element vector of month names (locale items MON_n);
3070 
3071 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
3072   both measured in milimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
3073 
3074 If the system can't provide such information through a call to
3075 `nl_langinfo', or if ITEM isn't from the list above, return nil.
3076 
3077 See also Info node `(libc)Locales'.
3078 
3079 The data read from the system are decoded using `locale-coding-system'.  */)
3080      (item)
3081      Lisp_Object item;
3082 {
3083   char *str = NULL;
3084 #ifdef HAVE_LANGINFO_CODESET
3085   Lisp_Object val;
3086   if (EQ (item, Qcodeset))
3087     {
3088       str = nl_langinfo (CODESET);
3089       return build_string (str);
3090     }
3091 #ifdef DAY_1
3092   else if (EQ (item, Qdays))    /* e.g. for calendar-day-name-array */
3093     {
3094       Lisp_Object v = Fmake_vector (make_number (7), Qnil);
3095       const int days[7] = {DAY_1, DAY_2, DAY_3, DAY_4, DAY_5, DAY_6, DAY_7};
3096       int i;
3097       struct gcpro gcpro1;
3098       GCPRO1 (v);
3099       synchronize_system_time_locale ();
3100       for (i = 0; i < 7; i++)
3101         {
3102           str = nl_langinfo (days[i]);
3103           val = make_unibyte_string (str, strlen (str));
3104           /* Fixme: Is this coding system necessarily right, even if
3105              it is consistent with CODESET?  If not, what to do?  */
3106           Faset (v, make_number (i),
3107                  code_convert_string_norecord (val, Vlocale_coding_system,
3108                                                0));
3109         }
3110       UNGCPRO;
3111       return v;
3112     }
3113 #endif  /* DAY_1 */
3114 #ifdef MON_1
3115   else if (EQ (item, Qmonths))  /* e.g. for calendar-month-name-array */
3116     {
3117       Lisp_Object v = Fmake_vector (make_number (12), Qnil);
3118       const int months[12] = {MON_1, MON_2, MON_3, MON_4, MON_5, MON_6, MON_7,
3119                               MON_8, MON_9, MON_10, MON_11, MON_12};
3120       int i;
3121       struct gcpro gcpro1;
3122       GCPRO1 (v);
3123       synchronize_system_time_locale ();
3124       for (i = 0; i < 12; i++)
3125         {
3126           str = nl_langinfo (months[i]);
3127           val = make_unibyte_string (str, strlen (str));
3128           Faset (v, make_number (i),
3129                  code_convert_string_norecord (val, Vlocale_coding_system, 0));
3130         }
3131       UNGCPRO;
3132       return v;
3133     }
3134 #endif  /* MON_1 */
3135 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
3136    but is in the locale files.  This could be used by ps-print.  */
3137 #ifdef PAPER_WIDTH
3138   else if (EQ (item, Qpaper))
3139     {
3140       return list2 (make_number (nl_langinfo (PAPER_WIDTH)),
3141                     make_number (nl_langinfo (PAPER_HEIGHT)));
3142     }
3143 #endif  /* PAPER_WIDTH */
3144 #endif  /* HAVE_LANGINFO_CODESET*/
3145   return Qnil;
3146 }
3147 
3148 /* base64 encode/decode functions (RFC 2045).
3149    Based on code from GNU recode. */
3150 
3151 #define MIME_LINE_LENGTH 76
3152 
3153 #define IS_ASCII(Character) \
3154   ((Character) < 128)
3155 #define IS_BASE64(Character) \
3156   (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3157 #define IS_BASE64_IGNORABLE(Character) \
3158   ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
3159    || (Character) == '\f' || (Character) == '\r')
3160 
3161 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
3162    character or return retval if there are no characters left to
3163    process. */
3164 #define READ_QUADRUPLET_BYTE(retval)    \
3165   do                                    \
3166     {                                   \
3167       if (i == length)                  \
3168         {                               \
3169           if (nchars_return)            \
3170             *nchars_return = nchars;    \
3171           return (retval);              \
3172         }                               \
3173       c = from[i++];                    \
3174     }                                   \
3175   while (IS_BASE64_IGNORABLE (c))
3176 
3177 /* Table of characters coding the 64 values.  */
3178 static const char base64_value_to_char[64] =
3179 {
3180   'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J',     /*  0- 9 */
3181   'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T',     /* 10-19 */
3182   'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd',     /* 20-29 */
3183   'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n',     /* 30-39 */
3184   'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x',     /* 40-49 */
3185   'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7',     /* 50-59 */
3186   '8', '9', '+', '/'                                    /* 60-63 */
3187 };
3188 
3189 /* Table of base64 values for first 128 characters.  */
3190 static const short base64_char_to_value[128] =
3191 {
3192   -1,  -1,  -1,  -1,  -1,  -1,  -1,  -1,  -1,  -1,      /*   0-  9 */
3193   -1,  -1,  -1,  -1,  -1,  -1,  -1,  -1,  -1,  -1,      /*  10- 19 */
3194   -1,  -1,  -1,  -1,  -1,  -1,  -1,  -1,  -1,  -1,      /*  20- 29 */
3195   -1,  -1,  -1,  -1,  -1,  -1,  -1,  -1,  -1,  -1,      /*  30- 39 */
3196   -1,  -1,  -1,  62,  -1,  -1,  -1,  63,  52,  53,      /*  40- 49 */
3197   54,  55,  56,  57,  58,  59,  60,  61,  -1,  -1,      /*  50- 59 */
3198   -1,  -1,  -1,  -1,  -1,  0,   1,   2,   3,   4,       /*  60- 69 */
3199   5,   6,   7,   8,   9,   10,  11,  12,  13,  14,      /*  70- 79 */
3200   15,  16,  17,  18,  19,  20,  21,  22,  23,  24,      /*  80- 89 */
3201   25,  -1,  -1,  -1,  -1,  -1,  -1,  26,  27,  28,      /*  90- 99 */
3202   29,  30,  31,  32,  33,  34,  35,  36,  37,  38,      /* 100-109 */
3203   39,  40,  41,  42,  43,  44,  45,  46,  47,  48,      /* 110-119 */
3204   49,  50,  51,  -1,  -1,  -1,  -1,  -1                 /* 120-127 */
3205 };
3206 
3207 /* The following diagram shows the logical steps by which three octets
3208    get transformed into four base64 characters.
3209 
3210                  .--------.  .--------.  .--------.
3211                  |aaaaaabb|  |bbbbcccc|  |ccdddddd|
3212                  `--------'  `--------'  `--------'
3213                     6   2      4   4       2   6
3214                .--------+--------+--------+--------.
3215                |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3216                `--------+--------+--------+--------'
3217 
3218                .--------+--------+--------+--------.
3219                |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3220                `--------+--------+--------+--------'
3221 
3222    The octets are divided into 6 bit chunks, which are then encoded into
3223    base64 characters.  */
3224 
3225 
3226 static int base64_encode_1 P_ ((const char *, char *, int, int, int));
3227 static int base64_decode_1 P_ ((const char *, char *, int, int, int *));
3228 
3229 DEFUN ("base64-encode-region", Fbase64_encode_region, Sbase64_encode_region,
3230        2, 3, "r",
3231        doc: /* Base64-encode the region between BEG and END.
3232 Return the length of the encoded text.
3233 Optional third argument NO-LINE-BREAK means do not break long lines
3234 into shorter lines.  */)
3235      (beg, end, no_line_break)
3236      Lisp_Object beg, end, no_line_break;
3237 {
3238   char *encoded;
3239   int allength, length;
3240   int ibeg, iend, encoded_length;
3241   int old_pos = PT;
3242   USE_SAFE_ALLOCA;
3243 
3244   validate_region (&beg, &end);
3245 
3246   ibeg = CHAR_TO_BYTE (XFASTINT (beg));
3247   iend = CHAR_TO_BYTE (XFASTINT (end));
3248   move_gap_both (XFASTINT (beg), ibeg);
3249 
3250   /* We need to allocate enough room for encoding the text.
3251      We need 33 1/3% more space, plus a newline every 76
3252      characters, and then we round up. */
3253   length = iend - ibeg;
3254   allength = length + length/3 + 1;
3255   allength += allength / MIME_LINE_LENGTH + 1 + 6;
3256 
3257   SAFE_ALLOCA (encoded, char *, allength);
3258   encoded_length = base64_encode_1 (BYTE_POS_ADDR (ibeg), encoded, length,
3259                                     NILP (no_line_break),
3260                                     !NILP (current_buffer->enable_multibyte_characters));
3261   if (encoded_length > allength)
3262     abort ();
3263 
3264   if (encoded_length < 0)
3265     {
3266       /* The encoding wasn't possible. */
3267       SAFE_FREE ();
3268       error ("Multibyte character in data for base64 encoding");
3269     }
3270 
3271   /* Now we have encoded the region, so we insert the new contents
3272      and delete the old.  (Insert first in order to preserve markers.)  */
3273   SET_PT_BOTH (XFASTINT (beg), ibeg);
3274   insert (encoded, encoded_length);
3275   SAFE_FREE ();
3276   del_range_byte (ibeg + encoded_length, iend + encoded_length, 1);
3277 
3278   /* If point was outside of the region, restore it exactly; else just
3279      move to the beginning of the region.  */
3280   if (old_pos >= XFASTINT (end))
3281     old_pos += encoded_length - (XFASTINT (end) - XFASTINT (beg));
3282   else if (old_pos > XFASTINT (beg))
3283     old_pos = XFASTINT (beg);
3284   SET_PT (old_pos);
3285 
3286   /* We return the length of the encoded text. */
3287   return make_number (encoded_length);
3288 }
3289 
3290 DEFUN ("base64-encode-string", Fbase64_encode_string, Sbase64_encode_string,
3291        1, 2, 0,
3292        doc: /* Base64-encode STRING and return the result.
3293 Optional second argument NO-LINE-BREAK means do not break long lines
3294 into shorter lines.  */)
3295      (string, no_line_break)
3296      Lisp_Object string, no_line_break;
3297 {
3298   int allength, length, encoded_length;
3299   char *encoded;
3300   Lisp_Object encoded_string;
3301   USE_SAFE_ALLOCA;
3302 
3303   CHECK_STRING (string);
3304 
3305   /* We need to allocate enough room for encoding the text.
3306      We need 33 1/3% more space, plus a newline every 76
3307      characters, and then we round up. */
3308   length = SBYTES (string);
3309   allength = length + length/3 + 1;
3310   allength += allength / MIME_LINE_LENGTH + 1 + 6;
3311 
3312   /* We need to allocate enough room for decoding the text. */
3313   SAFE_ALLOCA (encoded, char *, allength);
3314 
3315   encoded_length = base64_encode_1 (SDATA (string),
3316                                     encoded, length, NILP (no_line_break),
3317                                     STRING_MULTIBYTE (string));
3318   if (encoded_length > allength)
3319     abort ();
3320 
3321   if (encoded_length < 0)
3322     {
3323       /* The encoding wasn't possible. */
3324       SAFE_FREE ();
3325       error ("Multibyte character in data for base64 encoding");
3326     }
3327 
3328   encoded_string = make_unibyte_string (encoded, encoded_length);
3329   SAFE_FREE ();
3330 
3331   return encoded_string;
3332 }
3333 
3334 static int
3335 base64_encode_1 (from, to, length, line_break, multibyte)
3336      const char *from;
3337      char *to;
3338      int length;
3339      int line_break;
3340      int multibyte;
3341 {
3342   int counter = 0, i = 0;
3343   char *e = to;
3344   int c;
3345   unsigned int value;
3346   int bytes;
3347 
3348   while (i < length)
3349     {
3350       if (multibyte)
3351         {
3352           c = STRING_CHAR_AND_LENGTH (from + i, bytes);
3353           if (CHAR_BYTE8_P (c))
3354             c = CHAR_TO_BYTE8 (c);
3355           else if (c >= 256)
3356             return -1;
3357           i += bytes;
3358         }
3359       else
3360         c = from[i++];
3361 
3362       /* Wrap line every 76 characters.  */
3363 
3364       if (line_break)
3365         {
3366           if (counter < MIME_LINE_LENGTH / 4)
3367             counter++;
3368           else
3369             {
3370               *e++ = '\n';
3371               counter = 1;
3372             }
3373         }
3374 
3375       /* Process first byte of a triplet.  */
3376 
3377       *e++ = base64_value_to_char[0x3f & c >> 2];
3378       value = (0x03 & c) << 4;
3379 
3380       /* Process second byte of a triplet.  */
3381 
3382       if (i == length)
3383         {
3384           *e++ = base64_value_to_char[value];
3385           *e++ = '=';
3386           *e++ = '=';
3387           break;
3388         }
3389 
3390       if (multibyte)
3391         {
3392           c = STRING_CHAR_AND_LENGTH (from + i, bytes);
3393           if (CHAR_BYTE8_P (c))
3394             c = CHAR_TO_BYTE8 (c);
3395           else if (c >= 256)
3396             return -1;
3397           i += bytes;
3398         }
3399       else
3400         c = from[i++];
3401 
3402       *e++ = base64_value_to_char[value | (0x0f & c >> 4)];
3403       value = (0x0f & c) << 2;
3404 
3405       /* Process third byte of a triplet.  */
3406 
3407       if (i == length)
3408         {
3409           *e++ = base64_value_to_char[value];
3410           *e++ = '=';
3411           break;
3412         }
3413 
3414       if (multibyte)
3415         {
3416           c = STRING_CHAR_AND_LENGTH (from + i, bytes);
3417           if (CHAR_BYTE8_P (c))
3418             c = CHAR_TO_BYTE8 (c);
3419           else if (c >= 256)
3420             return -1;
3421           i += bytes;
3422         }
3423       else
3424         c = from[i++];
3425 
3426       *e++ = base64_value_to_char[value | (0x03 & c >> 6)];
3427       *e++ = base64_value_to_char[0x3f & c];
3428     }
3429 
3430   return e - to;
3431 }
3432 
3433 
3434 DEFUN ("base64-decode-region", Fbase64_decode_region, Sbase64_decode_region,
3435        2, 2, "r",
3436        doc: /* Base64-decode the region between BEG and END.
3437 Return the length of the decoded text.
3438 If the region can't be decoded, signal an error and don't modify the buffer.  */)
3439      (beg, end)
3440      Lisp_Object beg, end;
3441 {
3442   int ibeg, iend, length, allength;
3443   char *decoded;
3444   int old_pos = PT;
3445   int decoded_length;
3446   int inserted_chars;
3447   int multibyte = !NILP (current_buffer->enable_multibyte_characters);
3448   USE_SAFE_ALLOCA;
3449 
3450   validate_region (&beg, &end);
3451 
3452   ibeg = CHAR_TO_BYTE (XFASTINT (beg));
3453   iend = CHAR_TO_BYTE (XFASTINT (end));
3454 
3455   length = iend - ibeg;
3456 
3457   /* We need to allocate enough room for decoding the text.  If we are
3458      working on a multibyte buffer, each decoded code may occupy at
3459      most two bytes.  */
3460   allength = multibyte ? length * 2 : length;
3461   SAFE_ALLOCA (decoded, char *, allength);
3462 
3463   move_gap_both (XFASTINT (beg), ibeg);
3464   decoded_length = base64_decode_1 (BYTE_POS_ADDR (ibeg), decoded, length,
3465                                     multibyte, &inserted_chars);
3466   if (decoded_length > allength)
3467     abort ();
3468 
3469   if (decoded_length < 0)
3470     {
3471       /* The decoding wasn't possible. */
3472       SAFE_FREE ();
3473       error ("Invalid base64 data");
3474     }
3475 
3476   /* Now we have decoded the region, so we insert the new contents
3477      and delete the old.  (Insert first in order to preserve markers.)  */
3478   TEMP_SET_PT_BOTH (XFASTINT (beg), ibeg);
3479   insert_1_both (decoded, inserted_chars, decoded_length, 0, 1, 0);
3480   SAFE_FREE ();
3481 
3482   /* Delete the original text.  */
3483   del_range_both (PT, PT_BYTE, XFASTINT (end) + inserted_chars,
3484                   iend + decoded_length, 1);
3485 
3486   /* If point was outside of the region, restore it exactly; else just
3487      move to the beginning of the region.  */
3488   if (old_pos >= XFASTINT (end))
3489     old_pos += inserted_chars - (XFASTINT (end) - XFASTINT (beg));
3490   else if (old_pos > XFASTINT (beg))
3491     old_pos = XFASTINT (beg);
3492   SET_PT (old_pos > ZV ? ZV : old_pos);
3493 
3494   return make_number (inserted_chars);
3495 }
3496 
3497 DEFUN ("base64-decode-string", Fbase64_decode_string, Sbase64_decode_string,
3498        1, 1, 0,
3499        doc: /* Base64-decode STRING and return the result.  */)
3500      (string)
3501      Lisp_Object string;
3502 {
3503   char *decoded;
3504   int length, decoded_length;
3505   Lisp_Object decoded_string;
3506   USE_SAFE_ALLOCA;
3507 
3508   CHECK_STRING (string);
3509 
3510   length = SBYTES (string);
3511   /* We need to allocate enough room for decoding the text. */
3512   SAFE_ALLOCA (decoded, char *, length);
3513 
3514   /* The decoded result should be unibyte. */
3515   decoded_length = base64_decode_1 (SDATA (string), decoded, length,
3516                                     0, NULL);
3517   if (decoded_length > length)
3518     abort ();
3519   else if (decoded_length >= 0)
3520     decoded_string = make_unibyte_string (decoded, decoded_length);
3521   else
3522     decoded_string = Qnil;
3523 
3524   SAFE_FREE ();
3525   if (!STRINGP (decoded_string))
3526     error ("Invalid base64 data");
3527 
3528   return decoded_string;
3529 }
3530 
3531 /* Base64-decode the data at FROM of LENGHT bytes into TO.  If
3532    MULTIBYTE is nonzero, the decoded result should be in multibyte
3533    form.  If NCHARS_RETRUN is not NULL, store the number of produced
3534    characters in *NCHARS_RETURN.  */
3535 
3536 static int
3537 base64_decode_1 (from, to, length, multibyte, nchars_return)
3538      const char *from;
3539      char *to;
3540      int length;
3541      int multibyte;
3542      int *nchars_return;
3543 {
3544   int i = 0;
3545   char *e = to;
3546   unsigned char c;
3547   unsigned long value;
3548   int nchars = 0;
3549 
3550   while (1)
3551     {
3552       /* Process first byte of a quadruplet. */
3553 
3554       READ_QUADRUPLET_BYTE (e-to);
3555 
3556       if (!IS_BASE64 (c))
3557         return -1;
3558       value = base64_char_to_value[c] << 18;
3559 
3560       /* Process second byte of a quadruplet.  */
3561 
3562       READ_QUADRUPLET_BYTE (-1);
3563 
3564       if (!IS_BASE64 (c))
3565         return -1;
3566       value |= base64_char_to_value[c] << 12;
3567 
3568       c = (unsigned char) (value >> 16);
3569       if (multibyte && c >= 128)
3570         e += BYTE8_STRING (c, e);
3571       else
3572         *e++ = c;
3573       nchars++;
3574 
3575       /* Process third byte of a quadruplet.  */
3576 
3577       READ_QUADRUPLET_BYTE (-1);
3578 
3579       if (c == '=')
3580         {
3581           READ_QUADRUPLET_BYTE (-1);
3582 
3583           if (c != '=')
3584             return -1;
3585           continue;
3586         }
3587 
3588       if (!IS_BASE64 (c))
3589         return -1;
3590       value |= base64_char_to_value[c] << 6;
3591 
3592       c = (unsigned char) (0xff & value >> 8);
3593       if (multibyte && c >= 128)
3594         e += BYTE8_STRING (c, e);
3595       else
3596         *e++ = c;
3597       nchars++;
3598 
3599       /* Process fourth byte of a quadruplet.  */
3600 
3601       READ_QUADRUPLET_BYTE (-1);
3602 
3603       if (c == '=')
3604         continue;
3605 
3606       if (!IS_BASE64 (c))
3607         return -1;
3608       value |= base64_char_to_value[c];
3609 
3610       c = (unsigned char) (0xff & value);
3611       if (multibyte && c >= 128)
3612         e += BYTE8_STRING (c, e);
3613       else
3614         *e++ = c;
3615       nchars++;
3616     }
3617 }
3618 
3619 
3620 
3621 /***********************************************************************
3622  *****                                                             *****
3623  *****                       Hash Tables                           *****
3624  *****                                                             *****
3625  ***********************************************************************/
3626 
3627 /* Implemented by gerd@gnu.org.  This hash table implementation was
3628    inspired by CMUCL hash tables.  */
3629 
3630 /* Ideas:
3631 
3632    1. For small tables, association lists are probably faster than
3633    hash tables because they have lower overhead.
3634 
3635    For uses of hash tables where the O(1) behavior of table
3636    operations is not a requirement, it might therefore be a good idea
3637    not to hash.  Instead, we could just do a linear search in the
3638    key_and_value vector of the hash table.  This could be done
3639    if a `:linear-search t' argument is given to make-hash-table.  */
3640 
3641 
3642 /* The list of all weak hash tables.  Don't staticpro this one.  */
3643 
3644 struct Lisp_Hash_Table *weak_hash_tables;
3645 
3646 /* Various symbols.  */
3647 
3648 Lisp_Object Qhash_table_p, Qeq, Qeql, Qequal, Qkey, Qvalue;
3649 Lisp_Object QCtest, QCsize, QCrehash_size, QCrehash_threshold, QCweakness;
3650 Lisp_Object Qhash_table_test, Qkey_or_value, Qkey_and_value;
3651 
3652 /* Function prototypes.  */
3653 
3654 static struct Lisp_Hash_Table *check_hash_table P_ ((Lisp_Object));
3655 static int get_key_arg P_ ((Lisp_Object, int, Lisp_Object *, char *));
3656 static void maybe_resize_hash_table P_ ((struct Lisp_Hash_Table *));
3657 static int cmpfn_eql P_ ((struct Lisp_Hash_Table *, Lisp_Object, unsigned,
3658                           Lisp_Object, unsigned));
3659 static int cmpfn_equal P_ ((struct Lisp_Hash_Table *, Lisp_Object, unsigned,
3660                             Lisp_Object, unsigned));
3661 static int cmpfn_user_defined P_ ((struct Lisp_Hash_Table *, Lisp_Object,
3662                                    unsigned, Lisp_Object, unsigned));
3663 static unsigned hashfn_eq P_ ((struct Lisp_Hash_Table *, Lisp_Object));
3664 static unsigned hashfn_eql P_ ((struct Lisp_Hash_Table *, Lisp_Object));
3665 static unsigned hashfn_equal P_ ((struct Lisp_Hash_Table *, Lisp_Object));
3666 static unsigned hashfn_user_defined P_ ((struct Lisp_Hash_Table *,
3667                                          Lisp_Object));
3668 static unsigned sxhash_string P_ ((unsigned char *, int));
3669 static unsigned sxhash_list P_ ((Lisp_Object, int));
3670 static unsigned sxhash_vector P_ ((Lisp_Object, int));
3671 static unsigned sxhash_bool_vector P_ ((Lisp_Object));
3672 static int sweep_weak_table P_ ((struct Lisp_Hash_Table *, int));
3673 
3674 
3675 
3676 /***********************************************************************
3677                                Utilities
3678  ***********************************************************************/
3679 
3680 /* If OBJ is a Lisp hash table, return a pointer to its struct
3681    Lisp_Hash_Table.  Otherwise, signal an error.  */
3682 
3683 static struct Lisp_Hash_Table *
3684 check_hash_table (obj)
3685      Lisp_Object obj;
3686 {
3687   CHECK_HASH_TABLE (obj);
3688   return XHASH_TABLE (obj);
3689 }
3690 
3691 
3692 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
3693    number.  */
3694 
3695 int
3696 next_almost_prime (n)
3697      int n;
3698 {
3699   if (n % 2 == 0)
3700     n += 1;
3701   if (n % 3 == 0)
3702     n += 2;
3703   if (n % 7 == 0)
3704     n += 4;
3705   return n;
3706 }
3707 
3708 
3709 /* Find KEY in ARGS which has size NARGS.  Don't consider indices for
3710    which USED[I] is non-zero.  If found at index I in ARGS, set
3711    USED[I] and USED[I + 1] to 1, and return I + 1.  Otherwise return
3712    -1.  This function is used to extract a keyword/argument pair from
3713    a DEFUN parameter list.  */
3714 
3715 static int
3716 get_key_arg (key, nargs, args, used)
3717      Lisp_Object key;
3718      int nargs;
3719      Lisp_Object *args;
3720      char *used;
3721 {
3722   int i;
3723 
3724   for (i = 0; i < nargs - 1; ++i)
3725     if (!used[i] && EQ (args[i], key))
3726       break;
3727 
3728   if (i >= nargs - 1)
3729     i = -1;
3730   else
3731     {
3732       used[i++] = 1;
3733       used[i] = 1;
3734     }
3735 
3736   return i;
3737 }
3738 
3739 
3740 /* Return a Lisp vector which has the same contents as VEC but has
3741    size NEW_SIZE, NEW_SIZE >= VEC->size.  Entries in the resulting
3742    vector that are not copied from VEC are set to INIT.  */
3743 
3744 Lisp_Object
3745 larger_vector (vec, new_size, init)
3746      Lisp_Object vec;
3747      int new_size;
3748      Lisp_Object init;
3749 {
3750   struct Lisp_Vector *v;
3751   int i, old_size;
3752 
3753   xassert (VECTORP (vec));
3754   old_size = ASIZE (vec);
3755   xassert (new_size >= old_size);
3756 
3757   v = allocate_vector (new_size);
3758   bcopy (XVECTOR (vec)->contents, v->contents,
3759          old_size * sizeof *v->contents);
3760   for (i = old_size; i < new_size; ++i)
3761     v->contents[i] = init;
3762   XSETVECTOR (vec, v);
3763   return vec;
3764 }
3765 
3766 
3767 /***********************************************************************
3768                          Low-level Functions
3769  ***********************************************************************/
3770 
3771 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3772    HASH2 in hash table H using `eql'.  Value is non-zero if KEY1 and
3773    KEY2 are the same.  */
3774 
3775 static int
3776 cmpfn_eql (h, key1, hash1, key2, hash2)
3777      struct Lisp_Hash_Table *h;
3778      Lisp_Object key1, key2;
3779      unsigned hash1, hash2;
3780 {
3781   return (FLOATP (key1)
3782           && FLOATP (key2)
3783           && XFLOAT_DATA (key1) == XFLOAT_DATA (key2));
3784 }
3785 
3786 
3787 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
3788    HASH2 in hash table H using `equal'.  Value is non-zero if KEY1 and
3789    KEY2 are the same.  */
3790 
3791 static int
3792 cmpfn_equal (h, key1, hash1, key2, hash2)
3793      struct Lisp_Hash_Table *h;
3794      Lisp_Object key1, key2;
3795      unsigned hash1, hash2;
3796 {
3797   return hash1 == hash2 && !NILP (Fequal (key1, key2));
3798 }
3799 
3800 
3801 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
3802    HASH2 in hash table H using H->user_cmp_function.  Value is non-zero
3803    if KEY1 and KEY2 are the same.  */
3804 
3805 static int
3806 cmpfn_user_defined (h, key1, hash1, key2, hash2)
3807      struct Lisp_Hash_Table *h;
3808      Lisp_Object key1, key2;
3809      unsigned hash1, hash2;
3810 {
3811   if (hash1 == hash2)
3812     {
3813       Lisp_Object args[3];
3814 
3815       args[0] = h->user_cmp_function;
3816       args[1] = key1;
3817       args[2] = key2;
3818       return !NILP (Ffuncall (3, args));
3819     }
3820   else
3821     return 0;
3822 }
3823 
3824 
3825 /* Value is a hash code for KEY for use in hash table H which uses
3826    `eq' to compare keys.  The hash code returned is guaranteed to fit
3827    in a Lisp integer.  */
3828 
3829 static unsigned
3830 hashfn_eq (h, key)
3831      struct Lisp_Hash_Table *h;
3832      Lisp_Object key;
3833 {
3834   unsigned hash = XUINT (key) ^ XTYPE (key);
3835   xassert ((hash & ~INTMASK) == 0);
3836   return hash;
3837 }
3838 
3839 
3840 /* Value is a hash code for KEY for use in hash table H which uses
3841    `eql' to compare keys.  The hash code returned is guaranteed to fit
3842    in a Lisp integer.  */
3843 
3844 static unsigned
3845 hashfn_eql (h, key)
3846      struct Lisp_Hash_Table *h;
3847      Lisp_Object key;
3848 {
3849   unsigned hash;
3850   if (FLOATP (key))
3851     hash = sxhash (key, 0);
3852   else
3853     hash = XUINT (key) ^ XTYPE (key);
3854   xassert ((hash & ~INTMASK) == 0);
3855   return hash;
3856 }
3857 
3858 
3859 /* Value is a hash code for KEY for use in hash table H which uses
3860    `equal' to compare keys.  The hash code returned is guaranteed to fit
3861    in a Lisp integer.  */
3862 
3863 static unsigned
3864 hashfn_equal (h, key)
3865      struct Lisp_Hash_Table *h;
3866      Lisp_Object key;
3867 {
3868   unsigned hash = sxhash (key, 0);
3869   xassert ((hash & ~INTMASK) == 0);
3870   return hash;
3871 }
3872 
3873 
3874 /* Value is a hash code for KEY for use in hash table H which uses as
3875    user-defined function to compare keys.  The hash code returned is
3876    guaranteed to fit in a Lisp integer.  */
3877 
3878 static unsigned
3879 hashfn_user_defined (h, key)
3880      struct Lisp_Hash_Table *h;
3881      Lisp_Object key;
3882 {
3883   Lisp_Object args[2], hash;
3884 
3885   args[0] = h->user_hash_function;
3886   args[1] = key;
3887   hash = Ffuncall (2, args);
3888   if (!INTEGERP (hash))
3889     signal_error ("Invalid hash code returned from user-supplied hash function", hash);
3890   return XUINT (hash);
3891 }
3892 
3893 
3894 /* Create and initialize a new hash table.
3895 
3896    TEST specifies the test the hash table will use to compare keys.
3897    It must be either one of the predefined tests `eq', `eql' or
3898    `equal' or a symbol denoting a user-defined test named TEST with
3899    test and hash functions USER_TEST and USER_HASH.
3900 
3901    Give the table initial capacity SIZE, SIZE >= 0, an integer.
3902 
3903    If REHASH_SIZE is an integer, it must be > 0, and this hash table's
3904    new size when it becomes full is computed by adding REHASH_SIZE to
3905    its old size.  If REHASH_SIZE is a float, it must be > 1.0, and the
3906    table's new size is computed by multiplying its old size with
3907    REHASH_SIZE.
3908 
3909    REHASH_THRESHOLD must be a float <= 1.0, and > 0.  The table will
3910    be resized when the ratio of (number of entries in the table) /
3911    (table size) is >= REHASH_THRESHOLD.
3912 
3913    WEAK specifies the weakness of the table.  If non-nil, it must be
3914    one of the symbols `key', `value', `key-or-value', or `key-and-value'.  */
3915 
3916 Lisp_Object
3917 make_hash_table (test, size, rehash_size, rehash_threshold, weak,
3918                  user_test, user_hash)
3919      Lisp_Object test, size, rehash_size, rehash_threshold, weak;
3920      Lisp_Object user_test, user_hash;
3921 {
3922   struct Lisp_Hash_Table *h;
3923   Lisp_Object table;
3924   int index_size, i, sz;
3925 
3926   /* Preconditions.  */
3927   xassert (SYMBOLP (test));
3928   xassert (INTEGERP (size) && XINT (size) >= 0);
3929   xassert ((INTEGERP (rehash_size) && XINT (rehash_size) > 0)
3930            || (FLOATP (rehash_size) && XFLOATINT (rehash_size) > 1.0));
3931   xassert (FLOATP (rehash_threshold)
3932            && XFLOATINT (rehash_threshold) > 0
3933            && XFLOATINT (rehash_threshold) <= 1.0);
3934 
3935   if (XFASTINT (size) == 0)
3936     size = make_number (1);
3937 
3938   /* Allocate a table and initialize it.  */
3939   h = allocate_hash_table ();
3940 
3941   /* Initialize hash table slots.  */
3942   sz = XFASTINT (size);
3943 
3944   h->test = test;
3945   if (EQ (test, Qeql))
3946     {
3947       h->cmpfn = cmpfn_eql;
3948       h->hashfn = hashfn_eql;
3949     }
3950   else if (EQ (test, Qeq))
3951     {
3952       h->cmpfn = NULL;
3953       h->hashfn = hashfn_eq;
3954     }
3955   else if (EQ (test, Qequal))
3956     {
3957       h->cmpfn = cmpfn_equal;
3958       h->hashfn = hashfn_equal;
3959     }
3960   else
3961     {
3962       h->user_cmp_function = user_test;
3963       h->user_hash_function = user_hash;
3964       h->cmpfn = cmpfn_user_defined;
3965       h->hashfn = hashfn_user_defined;
3966     }
3967 
3968   h->weak = weak;
3969   h->rehash_threshold = rehash_threshold;
3970   h->rehash_size = rehash_size;
3971   h->count = 0;
3972   h->key_and_value = Fmake_vector (make_number (2 * sz), Qnil);
3973   h->hash = Fmake_vector (size, Qnil);
3974   h->next = Fmake_vector (size, Qnil);
3975   /* Cast to int here avoids losing with gcc 2.95 on Tru64/Alpha...  */
3976   index_size = next_almost_prime ((int) (sz / XFLOATINT (rehash_threshold)));
3977   h->index = Fmake_vector (make_number (index_size), Qnil);
3978 
3979   /* Set up the free list.  */
3980   for (i = 0; i < sz - 1; ++i)
3981     HASH_NEXT (h, i) = make_number (i + 1);
3982   h->next_free = make_number (0);
3983 
3984   XSET_HASH_TABLE (table, h);
3985   xassert (HASH_TABLE_P (table));
3986   xassert (XHASH_TABLE (table) == h);
3987 
3988   /* Maybe add this hash table to the list of all weak hash tables.  */
3989   if (NILP (h->weak))
3990     h->next_weak = NULL;
3991   else
3992     {
3993       h->next_weak = weak_hash_tables;
3994       weak_hash_tables = h;
3995     }
3996 
3997   return table;
3998 }
3999 
4000 
4001 /* Return a copy of hash table H1.  Keys and values are not copied,
4002    only the table itself is.  */
4003 
4004 Lisp_Object
4005 copy_hash_table (h1)
4006      struct Lisp_Hash_Table *h1;
4007 {
4008   Lisp_Object table;
4009   struct Lisp_Hash_Table *h2;
4010   struct Lisp_Vector *next;
4011 
4012   h2 = allocate_hash_table ();
4013   next = h2->vec_next;
4014   bcopy (h1, h2, sizeof *h2);
4015   h2->vec_next = next;
4016   h2->key_and_value = Fcopy_sequence (h1->key_and_value);
4017   h2->hash = Fcopy_sequence (h1->hash);
4018   h2->next = Fcopy_sequence (h1->next);
4019   h2->index = Fcopy_sequence (h1->index);
4020   XSET_HASH_TABLE (table, h2);
4021 
4022   /* Maybe add this hash table to the list of all weak hash tables.  */
4023   if (!NILP (h2->weak))
4024     {
4025       h2->next_weak = weak_hash_tables;
4026       weak_hash_tables = h2;
4027     }
4028 
4029   return table;
4030 }
4031 
4032 
4033 /* Resize hash table H if it's too full.  If H cannot be resized
4034    because it's already too large, throw an error.  */
4035 
4036 static INLINE void
4037 maybe_resize_hash_table (h)
4038      struct Lisp_Hash_Table *h;
4039 {
4040   if (NILP (h->next_free))
4041     {
4042       int old_size = HASH_TABLE_SIZE (h);
4043       int i, new_size, index_size;
4044       EMACS_INT nsize;
4045 
4046       if (INTEGERP (h->rehash_size))
4047         new_size = old_size + XFASTINT (h->rehash_size);
4048       else
4049         new_size = old_size * XFLOATINT (h->rehash_size);
4050       new_size = max (old_size + 1, new_size);
4051       index_size = next_almost_prime ((int)
4052                                       (new_size
4053                                        / XFLOATINT (h->rehash_threshold)));
4054       /* Assignment to EMACS_INT stops GCC whining about limited range
4055          of data type.  */
4056       nsize = max (index_size, 2 * new_size);
4057       if (nsize > MOST_POSITIVE_FIXNUM)
4058         error ("Hash table too large to resize");
4059 
4060       h->key_and_value = larger_vector (h->key_and_value, 2 * new_size, Qnil);
4061       h->next = larger_vector (h->next, new_size, Qnil);
4062       h->hash = larger_vector (h->hash, new_size, Qnil);
4063       h->index = Fmake_vector (make_number (index_size), Qnil);
4064 
4065       /* Update the free list.  Do it so that new entries are added at
4066          the end of the free list.  This makes some operations like
4067          maphash faster.  */
4068       for (i = old_size; i < new_size - 1; ++i)
4069         HASH_NEXT (h, i) = make_number (i + 1);
4070 
4071       if (!NILP (h->next_free))
4072         {
4073           Lisp_Object last, next;
4074 
4075           last = h->next_free;
4076           while (next = HASH_NEXT (h, XFASTINT (last)),
4077                  !NILP (next))
4078             last = next;
4079 
4080           HASH_NEXT (h, XFASTINT (last)) = make_number (old_size);
4081         }
4082       else
4083         XSETFASTINT (h->next_free, old_size);
4084 
4085       /* Rehash.  */
4086       for (i = 0; i < old_size; ++i)
4087         if (!NILP (HASH_HASH (h, i)))
4088           {
4089             unsigned hash_code = XUINT (HASH_HASH (h, i));
4090             int start_of_bucket = hash_code % ASIZE (h->index);
4091             HASH_NEXT (h, i) = HASH_INDEX (h, start_of_bucket);
4092             HASH_INDEX (h, start_of_bucket) = make_number (i);
4093           }
4094     }
4095 }
4096 
4097 
4098 /* Lookup KEY in hash table H.  If HASH is non-null, return in *HASH
4099    the hash code of KEY.  Value is the index of the entry in H
4100    matching KEY, or -1 if not found.  */
4101 
4102 int
4103 hash_lookup (h, key, hash)
4104      struct Lisp_Hash_Table *h;
4105      Lisp_Object key;
4106      unsigned *hash;
4107 {
4108   unsigned hash_code;
4109   int start_of_bucket;
4110   Lisp_Object idx;
4111 
4112   hash_code = h->hashfn (h, key);
4113   if (hash)
4114     *hash = hash_code;
4115 
4116   start_of_bucket = hash_code % ASIZE (h->index);
4117   idx = HASH_INDEX (h, start_of_bucket);
4118 
4119   /* We need not gcpro idx since it's either an integer or nil.  */
4120   while (!NILP (idx))
4121     {
4122       int i = XFASTINT (idx);
4123       if (EQ (key, HASH_KEY (h, i))
4124           || (h->cmpfn
4125               && h->cmpfn (h, key, hash_code,
4126                            HASH_KEY (h, i), XUINT (HASH_HASH (h, i)))))
4127         break;
4128       idx = HASH_NEXT (h, i);
4129     }
4130 
4131   return NILP (idx) ? -1 : XFASTINT (idx);
4132 }
4133 
4134 
4135 /* Put an entry into hash table H that associates KEY with VALUE.
4136    HASH is a previously computed hash code of KEY.
4137    Value is the index of the entry in H matching KEY.  */
4138 
4139 int
4140 hash_put (h, key, value, hash)
4141      struct Lisp_Hash_Table *h;
4142      Lisp_Object key, value;
4143      unsigned hash;
4144 {
4145   int start_of_bucket, i;
4146 
4147   xassert ((hash & ~INTMASK) == 0);
4148 
4149   /* Increment count after resizing because resizing may fail.  */
4150   maybe_resize_hash_table (h);
4151   h->count++;
4152 
4153   /* Store key/value in the key_and_value vector.  */
4154   i = XFASTINT (h->next_free);
4155   h->next_free = HASH_NEXT (h, i);
4156   HASH_KEY (h, i) = key;
4157   HASH_VALUE (h, i) = value;
4158 
4159   /* Remember its hash code.  */
4160   HASH_HASH (h, i) = make_number (hash);
4161 
4162   /* Add new entry to its collision chain.  */
4163   start_of_bucket = hash % ASIZE (h->index);
4164   HASH_NEXT (h, i) = HASH_INDEX (h, start_of_bucket);
4165   HASH_INDEX (h, start_of_bucket) = make_number (i);
4166   return i;
4167 }
4168 
4169 
4170 /* Remove the entry matching KEY from hash table H, if there is one.  */
4171 
4172 static void
4173 hash_remove_from_table (h, key)
4174      struct Lisp_Hash_Table *h;
4175      Lisp_Object key;
4176 {
4177   unsigned hash_code;
4178   int start_of_bucket;
4179   Lisp_Object idx, prev;
4180 
4181   hash_code = h->hashfn (h, key);
4182   start_of_bucket = hash_code % ASIZE (h->index);
4183   idx = HASH_INDEX (h, start_of_bucket);
4184   prev = Qnil;
4185 
4186   /* We need not gcpro idx, prev since they're either integers or nil.  */
4187   while (!NILP (idx))
4188     {
4189       int i = XFASTINT (idx);
4190 
4191       if (EQ (key, HASH_KEY (h, i))
4192           || (h->cmpfn
4193               && h->cmpfn (h, key, hash_code,
4194                            HASH_KEY (h, i), XUINT (HASH_HASH (h, i)))))
4195         {
4196           /* Take entry out of collision chain.  */
4197           if (NILP (prev))
4198             HASH_INDEX (h, start_of_bucket) = HASH_NEXT (h, i);
4199           else
4200             HASH_NEXT (h, XFASTINT (prev)) = HASH_NEXT (h, i);
4201 
4202           /* Clear slots in key_and_value and add the slots to
4203              the free list.  */
4204           HASH_KEY (h, i) = HASH_VALUE (h, i) = HASH_HASH (h, i) = Qnil;
4205           HASH_NEXT (h, i) = h->next_free;
4206           h->next_free = make_number (i);
4207           h->count--;
4208           xassert (h->count >= 0);
4209           break;
4210         }
4211       else
4212         {
4213           prev = idx;
4214           idx = HASH_NEXT (h, i);
4215         }
4216     }
4217 }
4218 
4219 
4220 /* Clear hash table H.  */
4221 
4222 void
4223 hash_clear (h)
4224      struct Lisp_Hash_Table *h;
4225 {
4226   if (h->count > 0)
4227     {
4228       int i, size = HASH_TABLE_SIZE (h);
4229 
4230       for (i = 0; i < size; ++i)
4231         {
4232           HASH_NEXT (h, i) = i < size - 1 ? make_number (i + 1) : Qnil;
4233           HASH_KEY (h, i) = Qnil;
4234           HASH_VALUE (h, i) = Qnil;
4235           HASH_HASH (h, i) = Qnil;
4236         }
4237 
4238       for (i = 0; i < ASIZE (h->index); ++i)
4239         ASET (h->index, i, Qnil);
4240 
4241       h->next_free = make_number (0);
4242       h->count = 0;
4243     }
4244 }
4245 
4246 
4247 
4248 /************************************************************************
4249                            Weak Hash Tables
4250  ************************************************************************/
4251 
4252 void
4253 init_weak_hash_tables ()
4254 {
4255   weak_hash_tables = NULL;
4256 }
4257 
4258 /* Sweep weak hash table H.  REMOVE_ENTRIES_P non-zero means remove
4259    entries from the table that don't survive the current GC.
4260    REMOVE_ENTRIES_P zero means mark entries that are in use.  Value is
4261    non-zero if anything was marked.  */
4262 
4263 static int
4264 sweep_weak_table (h, remove_entries_p)
4265      struct Lisp_Hash_Table *h;
4266      int remove_entries_p;
4267 {
4268   int bucket, n, marked;
4269 
4270   n = ASIZE (h->index) & ~ARRAY_MARK_FLAG;
4271   marked = 0;
4272 
4273   for (bucket = 0; bucket < n; ++bucket)
4274     {
4275       Lisp_Object idx, next, prev;
4276 
4277       /* Follow collision chain, removing entries that
4278          don't survive this garbage collection.  */
4279       prev = Qnil;
4280       for (idx = HASH_INDEX (h, bucket); !NILP (idx); idx = next)
4281         {
4282           int i = XFASTINT (idx);
4283           int key_known_to_survive_p = survives_gc_p (HASH_KEY (h, i));
4284           int value_known_to_survive_p = survives_gc_p (HASH_VALUE (h, i));
4285           int remove_p;
4286 
4287           if (EQ (h->weak, Qkey))
4288             remove_p = !key_known_to_survive_p;
4289           else if (EQ (h->weak, Qvalue))
4290             remove_p = !value_known_to_survive_p;
4291           else if (EQ (h->weak, Qkey_or_value))
4292             remove_p = !(key_known_to_survive_p || value_known_to_survive_p);
4293           else if (EQ (h->weak, Qkey_and_value))
4294             remove_p = !(key_known_to_survive_p && value_known_to_survive_p);
4295           else
4296             abort ();
4297 
4298           next = HASH_NEXT (h, i);
4299 
4300           if (remove_entries_p)
4301             {
4302               if (remove_p)
4303                 {
4304                   /* Take out of collision chain.  */
4305                   if (NILP (prev))
4306                     HASH_INDEX (h, bucket) = next;
4307                   else
4308                     HASH_NEXT (h, XFASTINT (prev)) = next;
4309 
4310                   /* Add to free list.  */
4311                   HASH_NEXT (h, i) = h->next_free;
4312                   h->next_free = idx;
4313 
4314                   /* Clear key, value, and hash.  */
4315                   HASH_KEY (h, i) = HASH_VALUE (h, i) = Qnil;
4316                   HASH_HASH (h, i) = Qnil;
4317 
4318                   h->count--;
4319                 }
4320               else
4321                 {
4322                   prev = idx;
4323                 }
4324             }
4325           else
4326             {
4327               if (!remove_p)
4328                 {
4329                   /* Make sure key and value survive.  */
4330                   if (!key_known_to_survive_p)
4331                     {
4332                       mark_object (HASH_KEY (h, i));
4333                       marked = 1;
4334                     }
4335 
4336                   if (!value_known_to_survive_p)
4337                     {
4338                       mark_object (HASH_VALUE (h, i));
4339                       marked = 1;
4340                     }
4341                 }
4342             }
4343         }
4344     }
4345 
4346   return marked;
4347 }
4348 
4349 /* Remove elements from weak hash tables that don't survive the
4350    current garbage collection.  Remove weak tables that don't survive
4351    from Vweak_hash_tables.  Called from gc_sweep.  */
4352 
4353 void
4354 sweep_weak_hash_tables ()
4355 {
4356   struct Lisp_Hash_Table *h, *used, *next;
4357   int marked;
4358 
4359   /* Mark all keys and values that are in use.  Keep on marking until
4360      there is no more change.  This is necessary for cases like
4361      value-weak table A containing an entry X -> Y, where Y is used in a
4362      key-weak table B, Z -> Y.  If B comes after A in the list of weak
4363      tables, X -> Y might be removed from A, although when looking at B
4364      one finds that it shouldn't.  */
4365   do
4366     {
4367       marked = 0;
4368       for (h = weak_hash_tables; h; h = h->next_weak)
4369         {
4370           if (h->size & ARRAY_MARK_FLAG)
4371             marked |= sweep_weak_table (h, 0);
4372         }
4373     }
4374   while (marked);
4375 
4376   /* Remove tables and entries that aren't used.  */
4377   for (h = weak_hash_tables, used = NULL; h; h = next)
4378     {
4379       next = h->next_weak;
4380 
4381       if (h->size & ARRAY_MARK_FLAG)
4382         {
4383           /* TABLE is marked as used.  Sweep its contents.  */
4384           if (h->count > 0)
4385             sweep_weak_table (h, 1);
4386 
4387           /* Add table to the list of used weak hash tables.  */
4388           h->next_weak = used;
4389           used = h;
4390         }
4391     }
4392 
4393   weak_hash_tables = used;
4394 }
4395 
4396 
4397 
4398 /***********************************************************************
4399                         Hash Code Computation
4400  ***********************************************************************/
4401 
4402 /* Maximum depth up to which to dive into Lisp structures.  */
4403 
4404 #define SXHASH_MAX_DEPTH 3
4405 
4406 /* Maximum length up to which to take list and vector elements into
4407    account.  */
4408 
4409 #define SXHASH_MAX_LEN   7
4410 
4411 /* Combine two integers X and Y for hashing.  */
4412 
4413 #define SXHASH_COMBINE(X, Y)                                            \
4414      ((((unsigned)(X) << 4) + (((unsigned)(X) >> 24) & 0x0fffffff))     \
4415       + (unsigned)(Y))
4416 
4417 
4418 /* Return a hash for string PTR which has length LEN.  The hash
4419    code returned is guaranteed to fit in a Lisp integer.  */
4420 
4421 static unsigned
4422 sxhash_string (ptr, len)
4423      unsigned char *ptr;
4424      int len;
4425 {
4426   unsigned char *p = ptr;
4427   unsigned char *end = p + len;
4428   unsigned char c;
4429   unsigned hash = 0;
4430 
4431   while (p != end)
4432     {
4433       c = *p++;
4434       if (c >= 0140)
4435         c -= 40;
4436       hash = ((hash << 4) + (hash >> 28) + c);
4437     }
4438 
4439   return hash & INTMASK;
4440 }
4441 
4442 
4443 /* Return a hash for list LIST.  DEPTH is the current depth in the
4444    list.  We don't recurse deeper than SXHASH_MAX_DEPTH in it.  */
4445 
4446 static unsigned
4447 sxhash_list (list, depth)
4448      Lisp_Object list;
4449      int depth;
4450 {
4451   unsigned hash = 0;
4452   int i;
4453 
4454   if (depth < SXHASH_MAX_DEPTH)
4455     for (i = 0;
4456          CONSP (list) && i < SXHASH_MAX_LEN;
4457          list = XCDR (list), ++i)
4458       {
4459         unsigned hash2 = sxhash (XCAR (list), depth + 1);
4460         hash = SXHASH_COMBINE (hash, hash2);
4461       }
4462 
4463   if (!NILP (list))
4464     {
4465       unsigned hash2 = sxhash (list, depth + 1);
4466       hash = SXHASH_COMBINE (hash, hash2);
4467     }
4468 
4469   return hash;
4470 }
4471 
4472 
4473 /* Return a hash for vector VECTOR.  DEPTH is the current depth in
4474    the Lisp structure.  */
4475 
4476 static unsigned
4477 sxhash_vector (vec, depth)
4478      Lisp_Object vec;
4479      int depth;
4480 {
4481   unsigned hash = ASIZE (vec);
4482   int i, n;
4483 
4484   n = min (SXHASH_MAX_LEN, ASIZE (vec));
4485   for (i = 0; i < n; ++i)
4486     {
4487       unsigned hash2 = sxhash (AREF (vec, i), depth + 1);
4488       hash = SXHASH_COMBINE (hash, hash2);
4489     }
4490 
4491   return hash;
4492 }
4493 
4494 
4495 /* Return a hash for bool-vector VECTOR.  */
4496 
4497 static unsigned
4498 sxhash_bool_vector (vec)
4499      Lisp_Object vec;
4500 {
4501   unsigned hash = XBOOL_VECTOR (vec)->size;
4502   int i, n;
4503 
4504   n = min (SXHASH_MAX_LEN, XBOOL_VECTOR (vec)->vector_size);
4505   for (i = 0; i < n; ++i)
4506     hash = SXHASH_COMBINE (hash, XBOOL_VECTOR (vec)->data[i]);
4507 
4508   return hash;
4509 }
4510 
4511 
4512 /* Return a hash code for OBJ.  DEPTH is the current depth in the Lisp
4513    structure.  Value is an unsigned integer clipped to INTMASK.  */
4514 
4515 unsigned
4516 sxhash (obj, depth)
4517      Lisp_Object obj;
4518      int depth;
4519 {
4520   unsigned hash;
4521 
4522   if (depth > SXHASH_MAX_DEPTH)
4523     return 0;
4524 
4525   switch (XTYPE (obj))
4526     {
4527     case_Lisp_Int:
4528       hash = XUINT (obj);
4529       break;
4530 
4531     case Lisp_Misc:
4532       hash = XUINT (obj);
4533       break;
4534 
4535     case Lisp_Symbol:
4536       obj = SYMBOL_NAME (obj);
4537       /* Fall through.  */
4538 
4539     case Lisp_String:
4540       hash = sxhash_string (SDATA (obj), SCHARS (obj));
4541       break;
4542 
4543       /* This can be everything from a vector to an overlay.  */
4544     case Lisp_Vectorlike:
4545       if (VECTORP (obj))
4546         /* According to the CL HyperSpec, two arrays are equal only if
4547            they are `eq', except for strings and bit-vectors.  In
4548            Emacs, this works differently.  We have to compare element
4549            by element.  */
4550         hash = sxhash_vector (obj, depth);
4551       else if (BOOL_VECTOR_P (obj))
4552         hash = sxhash_bool_vector (obj);
4553       else
4554         /* Others are `equal' if they are `eq', so let's take their
4555            address as hash.  */
4556         hash = XUINT (obj);
4557       break;
4558 
4559     case Lisp_Cons:
4560       hash = sxhash_list (obj, depth);
4561       break;
4562 
4563     case Lisp_Float:
4564       {
4565         double val = XFLOAT_DATA (obj);
4566         unsigned char *p = (unsigned char *) &val;
4567         unsigned char *e = p + sizeof val;
4568         for (hash = 0; p < e; ++p)
4569           hash = SXHASH_COMBINE (hash, *p);
4570         break;
4571       }
4572 
4573     default:
4574       abort ();
4575     }
4576 
4577   return hash & INTMASK;
4578 }
4579 
4580 
4581 
4582 /***********************************************************************
4583                             Lisp Interface
4584  ***********************************************************************/
4585 
4586 
4587 DEFUN ("sxhash", Fsxhash, Ssxhash, 1, 1, 0,
4588        doc: /* Compute a hash code for OBJ and return it as integer.  */)
4589      (obj)
4590      Lisp_Object obj;
4591 {
4592   unsigned hash = sxhash (obj, 0);
4593   return make_number (hash);
4594 }
4595 
4596 
4597 DEFUN ("make-hash-table", Fmake_hash_table, Smake_hash_table, 0, MANY, 0,
4598        doc: /* Create and return a new hash table.
4599 
4600 Arguments are specified as keyword/argument pairs.  The following
4601 arguments are defined:
4602 
4603 :test TEST -- TEST must be a symbol that specifies how to compare
4604 keys.  Default is `eql'.  Predefined are the tests `eq', `eql', and
4605 `equal'.  User-supplied test and hash functions can be specified via
4606 `define-hash-table-test'.
4607 
4608 :size SIZE -- A hint as to how many elements will be put in the table.
4609 Default is 65.
4610 
4611 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
4612 fills up.  If REHASH-SIZE is an integer, add that many space.  If it
4613 is a float, it must be > 1.0, and the new size is computed by
4614 multiplying the old size with that factor.  Default is 1.5.
4615 
4616 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
4617 Resize the hash table when ratio of the number of entries in the
4618 table.  Default is 0.8.
4619 
4620 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
4621 `key-or-value', or `key-and-value'.  If WEAK is not nil, the table
4622 returned is a weak table.  Key/value pairs are removed from a weak
4623 hash table when there are no non-weak references pointing to their
4624 key, value, one of key or value, or both key and value, depending on
4625 WEAK.  WEAK t is equivalent to `key-and-value'.  Default value of WEAK
4626 is nil.
4627 
4628 usage: (make-hash-table &rest KEYWORD-ARGS)  */)
4629      (nargs, args)
4630      int nargs;
4631      Lisp_Object *args;
4632 {
4633   Lisp_Object test, size, rehash_size, rehash_threshold, weak;
4634   Lisp_Object user_test, user_hash;
4635   char *used;
4636   int i;
4637 
4638   /* The vector `used' is used to keep track of arguments that
4639      have been consumed.  */
4640   used = (char *) alloca (nargs * sizeof *used);
4641   bzero (used, nargs * sizeof *used);
4642 
4643   /* See if there's a `:test TEST' among the arguments.  */
4644   i = get_key_arg (QCtest, nargs, args, used);
4645   test = i < 0 ? Qeql : args[i];
4646   if (!EQ (test, Qeq) && !EQ (test, Qeql) && !EQ (test, Qequal))
4647     {
4648       /* See if it is a user-defined test.  */
4649       Lisp_Object prop;
4650 
4651       prop = Fget (test, Qhash_table_test);
4652       if (!CONSP (prop) || !CONSP (XCDR (prop)))
4653         signal_error ("Invalid hash table test", test);
4654       user_test = XCAR (prop);
4655       user_hash = XCAR (XCDR (prop));
4656     }
4657   else
4658     user_test = user_hash = Qnil;
4659 
4660   /* See if there's a `:size SIZE' argument.  */
4661   i = get_key_arg (QCsize, nargs, args, used);
4662   size = i < 0 ? Qnil : args[i];
4663   if (NILP (size))
4664     size = make_number (DEFAULT_HASH_SIZE);
4665   else if (!INTEGERP (size) || XINT (size) < 0)
4666     signal_error ("Invalid hash table size", size);
4667 
4668   /* Look for `:rehash-size SIZE'.  */
4669   i = get_key_arg (QCrehash_size, nargs, args, used);
4670   rehash_size = i < 0 ? make_float (DEFAULT_REHASH_SIZE) : args[i];
4671   if (!NUMBERP (rehash_size)
4672       || (INTEGERP (rehash_size) && XINT (rehash_size) <= 0)
4673       || XFLOATINT (rehash_size) <= 1.0)
4674     signal_error ("Invalid hash table rehash size", rehash_size);
4675 
4676   /* Look for `:rehash-threshold THRESHOLD'.  */
4677   i = get_key_arg (QCrehash_threshold, nargs, args, used);
4678   rehash_threshold = i < 0 ? make_float (DEFAULT_REHASH_THRESHOLD) : args[i];
4679   if (!FLOATP (rehash_threshold)
4680       || XFLOATINT (rehash_threshold) <= 0.0
4681       || XFLOATINT (rehash_threshold) > 1.0)
4682     signal_error ("Invalid hash table rehash threshold", rehash_threshold);
4683 
4684   /* Look for `:weakness WEAK'.  */
4685   i = get_key_arg (QCweakness, nargs, args, used);
4686   weak = i < 0 ? Qnil : args[i];
4687   if (EQ (weak, Qt))
4688     weak = Qkey_and_value;
4689   if (!NILP (weak)
4690       && !EQ (weak, Qkey)
4691       && !EQ (weak, Qvalue)
4692       && !EQ (weak, Qkey_or_value)
4693       && !EQ (weak, Qkey_and_value))
4694     signal_error ("Invalid hash table weakness", weak);
4695 
4696   /* Now, all args should have been used up, or there's a problem.  */
4697   for (i = 0; i < nargs; ++i)
4698     if (!used[i])
4699       signal_error ("Invalid argument list", args[i]);
4700 
4701   return make_hash_table (test, size, rehash_size, rehash_threshold, weak,
4702                           user_test, user_hash);
4703 }
4704 
4705 
4706 DEFUN ("copy-hash-table", Fcopy_hash_table, Scopy_hash_table, 1, 1, 0,
4707        doc: /* Return a copy of hash table TABLE.  */)
4708      (table)
4709      Lisp_Object table;
4710 {
4711   return copy_hash_table (check_hash_table (table));
4712 }
4713 
4714 
4715 DEFUN ("hash-table-count", Fhash_table_count, Shash_table_count, 1, 1, 0,
4716        doc: /* Return the number of elements in TABLE.  */)
4717      (table)
4718      Lisp_Object table;
4719 {
4720   return make_number (check_hash_table (table)->count);
4721 }
4722 
4723 
4724 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size,
4725        Shash_table_rehash_size, 1, 1, 0,
4726        doc: /* Return the current rehash size of TABLE.  */)
4727      (table)
4728      Lisp_Object table;
4729 {
4730   return check_hash_table (table)->rehash_size;
4731 }
4732 
4733 
4734 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold,
4735        Shash_table_rehash_threshold, 1, 1, 0,
4736        doc: /* Return the current rehash threshold of TABLE.  */)
4737      (table)
4738      Lisp_Object table;
4739 {
4740   return check_hash_table (table)->rehash_threshold;
4741 }
4742 
4743 
4744 DEFUN ("hash-table-size", Fhash_table_size, Shash_table_size, 1, 1, 0,
4745        doc: /* Return the size of TABLE.
4746 The size can be used as an argument to `make-hash-table' to create
4747 a hash table than can hold as many elements of TABLE holds
4748 without need for resizing.  */)
4749      (table)
4750        Lisp_Object table;
4751 {
4752   struct Lisp_Hash_Table *h = check_hash_table (table);
4753   return make_number (HASH_TABLE_SIZE (h));
4754 }
4755 
4756 
4757 DEFUN ("hash-table-test", Fhash_table_test, Shash_table_test, 1, 1, 0,
4758        doc: /* Return the test TABLE uses.  */)
4759      (table)
4760      Lisp_Object table;
4761 {
4762   return check_hash_table (table)->test;
4763 }
4764 
4765 
4766 DEFUN ("hash-table-weakness", Fhash_table_weakness, Shash_table_weakness,
4767        1, 1, 0,
4768        doc: /* Return the weakness of TABLE.  */)
4769      (table)
4770      Lisp_Object table;
4771 {
4772   return check_hash_table (table)->weak;
4773 }
4774 
4775 
4776 DEFUN ("hash-table-p", Fhash_table_p, Shash_table_p, 1, 1, 0,
4777        doc: /* Return t if OBJ is a Lisp hash table object.  */)
4778      (obj)
4779      Lisp_Object obj;
4780 {
4781   return HASH_TABLE_P (obj) ? Qt : Qnil;
4782 }
4783 
4784 
4785 DEFUN ("clrhash", Fclrhash, Sclrhash, 1, 1, 0,
4786        doc: /* Clear hash table TABLE and return it.  */)
4787      (table)
4788      Lisp_Object table;
4789 {
4790   hash_clear (check_hash_table (table));
4791   /* Be compatible with XEmacs.  */
4792   return table;
4793 }
4794 
4795 
4796 DEFUN ("gethash", Fgethash, Sgethash, 2, 3, 0,
4797        doc: /* Look up KEY in TABLE and return its associated value.
4798 If KEY is not found, return DFLT which defaults to nil.  */)
4799      (key, table, dflt)
4800      Lisp_Object key, table, dflt;
4801 {
4802   struct Lisp_Hash_Table *h = check_hash_table (table);
4803   int i = hash_lookup (h, key, NULL);
4804   return i >= 0 ? HASH_VALUE (h, i) : dflt;
4805 }
4806 
4807 
4808 DEFUN ("puthash", Fputhash, Sputhash, 3, 3, 0,
4809        doc: /* Associate KEY with VALUE in hash table TABLE.
4810 If KEY is already present in table, replace its current value with
4811 VALUE.  */)
4812      (key, value, table)
4813      Lisp_Object key, value, table;
4814 {
4815   struct Lisp_Hash_Table *h = check_hash_table (table);
4816   int i;
4817   unsigned hash;
4818 
4819   i = hash_lookup (h, key, &hash);
4820   if (i >= 0)
4821     HASH_VALUE (h, i) = value;
4822   else
4823     hash_put (h, key, value, hash);
4824 
4825   return value;
4826 }
4827 
4828 
4829 DEFUN ("remhash", Fremhash, Sremhash, 2, 2, 0,
4830        doc: /* Remove KEY from TABLE.  */)
4831      (key, table)
4832      Lisp_Object key, table;
4833 {
4834   struct Lisp_Hash_Table *h = check_hash_table (table);
4835   hash_remove_from_table (h, key);
4836   return Qnil;
4837 }
4838 
4839 
4840 DEFUN ("maphash", Fmaphash, Smaphash, 2, 2, 0,
4841        doc: /* Call FUNCTION for all entries in hash table TABLE.
4842 FUNCTION is called with two arguments, KEY and VALUE.  */)
4843      (function, table)
4844      Lisp_Object function, table;
4845 {
4846   struct Lisp_Hash_Table *h = check_hash_table (table);
4847   Lisp_Object args[3];
4848   int i;
4849 
4850   for (i = 0; i < HASH_TABLE_SIZE (h); ++i)
4851     if (!NILP (HASH_HASH (h, i)))
4852       {
4853         args[0] = function;
4854         args[1] = HASH_KEY (h, i);
4855         args[2] = HASH_VALUE (h, i);
4856         Ffuncall (3, args);
4857       }
4858 
4859   return Qnil;
4860 }
4861 
4862 
4863 DEFUN ("define-hash-table-test", Fdefine_hash_table_test,
4864        Sdefine_hash_table_test, 3, 3, 0,
4865        doc: /* Define a new hash table test with name NAME, a symbol.
4866 
4867 In hash tables created with NAME specified as test, use TEST to
4868 compare keys, and HASH for computing hash codes of keys.
4869 
4870 TEST must be a function taking two arguments and returning non-nil if
4871 both arguments are the same.  HASH must be a function taking one
4872 argument and return an integer that is the hash code of the argument.
4873 Hash code computation should use the whole value range of integers,
4874 including negative integers.  */)
4875      (name, test, hash)
4876      Lisp_Object name, test, hash;
4877 {
4878   return Fput (name, Qhash_table_test, list2 (test, hash));
4879 }
4880 
4881 
4882 
4883 /************************************************************************
4884                                  MD5
4885  ************************************************************************/
4886 
4887 #include "md5.h"
4888 
4889 DEFUN ("md5", Fmd5, Smd5, 1, 5, 0,
4890        doc: /* Return MD5 message digest of OBJECT, a buffer or string.
4891 
4892 A message digest is a cryptographic checksum of a document, and the
4893 algorithm to calculate it is defined in RFC 1321.
4894 
4895 The two optional arguments START and END are character positions
4896 specifying for which part of OBJECT the message digest should be
4897 computed.  If nil or omitted, the digest is computed for the whole
4898 OBJECT.
4899 
4900 The MD5 message digest is computed from the result of encoding the
4901 text in a coding system, not directly from the internal Emacs form of
4902 the text.  The optional fourth argument CODING-SYSTEM specifies which
4903 coding system to encode the text with.  It should be the same coding
4904 system that you used or will use when actually writing the text into a
4905 file.
4906 
4907 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT.  If
4908 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
4909 system would be chosen by default for writing this text into a file.
4910 
4911 If OBJECT is a string, the most preferred coding system (see the
4912 command `prefer-coding-system') is used.
4913 
4914 If NOERROR is non-nil, silently assume the `raw-text' coding if the
4915 guesswork fails.  Normally, an error is signaled in such case.  */)
4916      (object, start, end, coding_system, noerror)
4917      Lisp_Object object, start, end, coding_system, noerror;
4918 {
4919   unsigned char digest[16];
4920   unsigned char value[33];
4921   int i;
4922   int size;
4923   int size_byte = 0;
4924   int start_char = 0, end_char = 0;
4925   int start_byte = 0, end_byte = 0;
4926   register int b, e;
4927   register struct buffer *bp;
4928   int temp;
4929 
4930   if (STRINGP (object))
4931     {
4932       if (NILP (coding_system))
4933         {
4934           /* Decide the coding-system to encode the data with.  */
4935 
4936           if (STRING_MULTIBYTE (object))
4937             /* use default, we can't guess correct value */
4938             coding_system = preferred_coding_system ();
4939           else
4940             coding_system = Qraw_text;
4941         }
4942 
4943       if (NILP (Fcoding_system_p (coding_system)))
4944         {
4945           /* Invalid coding system.  */
4946 
4947           if (!NILP (noerror))
4948             coding_system = Qraw_text;
4949           else
4950             xsignal1 (Qcoding_system_error, coding_system);
4951         }
4952 
4953       if (STRING_MULTIBYTE (object))
4954         object = code_convert_string (object, coding_system, Qnil, 1, 0, 1);
4955 
4956       size = SCHARS (object);
4957       size_byte = SBYTES (object);
4958 
4959       if (!NILP (start))
4960         {
4961           CHECK_NUMBER (start);
4962 
4963           start_char = XINT (start);
4964 
4965           if (start_char < 0)
4966             start_char += size;
4967 
4968           start_byte = string_char_to_byte (object, start_char);
4969         }
4970 
4971       if (NILP (end))
4972         {
4973           end_char = size;
4974           end_byte = size_byte;
4975         }
4976       else
4977         {
4978           CHECK_NUMBER (end);
4979 
4980           end_char = XINT (end);
4981 
4982           if (end_char < 0)
4983             end_char += size;
4984 
4985           end_byte = string_char_to_byte (object, end_char);
4986         }
4987 
4988       if (!(0 <= start_char && start_char <= end_char && end_char <= size))
4989         args_out_of_range_3 (object, make_number (start_char),
4990                              make_number (end_char));
4991     }
4992   else
4993     {
4994       struct buffer *prev = current_buffer;
4995 
4996       record_unwind_protect (Fset_buffer, Fcurrent_buffer ());
4997 
4998       CHECK_BUFFER (object);
4999 
5000       bp = XBUFFER (object);
5001       if (bp != current_buffer)
5002         set_buffer_internal (bp);
5003 
5004       if (NILP (start))
5005         b = BEGV;
5006       else
5007         {
5008           CHECK_NUMBER_COERCE_MARKER (start);
5009           b = XINT (start);
5010         }
5011 
5012       if (NILP (end))
5013         e = ZV;
5014       else
5015         {
5016           CHECK_NUMBER_COERCE_MARKER (end);
5017           e = XINT (end);
5018         }
5019 
5020       if (b > e)
5021         temp = b, b = e, e = temp;
5022 
5023       if (!(BEGV <= b && e <= ZV))
5024         args_out_of_range (start, end);
5025 
5026       if (NILP (coding_system))
5027         {
5028           /* Decide the coding-system to encode the data with.
5029              See fileio.c:Fwrite-region */
5030 
5031           if (!NILP (Vcoding_system_for_write))
5032             coding_system = Vcoding_system_for_write;
5033           else
5034             {
5035               int force_raw_text = 0;
5036 
5037               coding_system = XBUFFER (object)->buffer_file_coding_system;
5038               if (NILP (coding_system)
5039                   || NILP (Flocal_variable_p (Qbuffer_file_coding_system, Qnil)))
5040                 {
5041                   coding_system = Qnil;
5042                   if (NILP (current_buffer->enable_multibyte_characters))
5043                     force_raw_text = 1;
5044                 }
5045 
5046               if (NILP (coding_system) && !NILP (Fbuffer_file_name(object)))
5047                 {
5048                   /* Check file-coding-system-alist.  */
5049                   Lisp_Object args[4], val;
5050 
5051                   args[0] = Qwrite_region; args[1] = start; args[2] = end;
5052                   args[3] = Fbuffer_file_name(object);
5053                   val = Ffind_operation_coding_system (4, args);
5054                   if (CONSP (val) && !NILP (XCDR (val)))
5055                     coding_system = XCDR (val);
5056                 }
5057 
5058               if (NILP (coding_system)
5059                   && !NILP (XBUFFER (object)->buffer_file_coding_system))
5060                 {
5061                   /* If we still have not decided a coding system, use the
5062                      default value of buffer-file-coding-system.  */
5063                   coding_system = XBUFFER (object)->buffer_file_coding_system;
5064                 }
5065 
5066               if (!force_raw_text
5067                   && !NILP (Ffboundp (Vselect_safe_coding_system_function)))
5068                 /* Confirm that VAL can surely encode the current region.  */
5069                 coding_system = call4 (Vselect_safe_coding_system_function,
5070                                        make_number (b), make_number (e),
5071                                        coding_system, Qnil);
5072 
5073               if (force_raw_text)
5074                 coding_system = Qraw_text;
5075             }
5076 
5077           if (NILP (Fcoding_system_p (coding_system)))
5078             {
5079               /* Invalid coding system.  */
5080 
5081               if (!NILP (noerror))
5082                 coding_system = Qraw_text;
5083               else
5084                 xsignal1 (Qcoding_system_error, coding_system);
5085             }
5086         }
5087 
5088       object = make_buffer_string (b, e, 0);
5089       if (prev != current_buffer)
5090         set_buffer_internal (prev);
5091       /* Discard the unwind protect for recovering the current
5092          buffer.  */
5093       specpdl_ptr--;
5094 
5095       if (STRING_MULTIBYTE (object))
5096         object = code_convert_string (object, coding_system, Qnil, 1, 0, 0);
5097     }
5098 
5099   md5_buffer (SDATA (object) + start_byte,
5100               SBYTES (object) - (size_byte - end_byte),
5101               digest);
5102 
5103   for (i = 0; i < 16; i++)
5104     sprintf (&value[2 * i], "%02x", digest[i]);
5105   value[32] = '\0';
5106 
5107   return make_string (value, 32);
5108 }
5109 
5110 
5111 void
5112 syms_of_fns ()
5113 {
5114   /* Hash table stuff.  */
5115   Qhash_table_p = intern_c_string ("hash-table-p");
5116   staticpro (&Qhash_table_p);
5117   Qeq = intern_c_string ("eq");
5118   staticpro (&Qeq);
5119   Qeql = intern_c_string ("eql");
5120   staticpro (&Qeql);
5121   Qequal = intern_c_string ("equal");
5122   staticpro (&Qequal);
5123   QCtest = intern_c_string (":test");
5124   staticpro (&QCtest);
5125   QCsize = intern_c_string (":size");
5126   staticpro (&QCsize);
5127   QCrehash_size = intern_c_string (":rehash-size");
5128   staticpro (&QCrehash_size);
5129   QCrehash_threshold = intern_c_string (":rehash-threshold");
5130   staticpro (&QCrehash_threshold);
5131   QCweakness = intern_c_string (":weakness");
5132   staticpro (&QCweakness);
5133   Qkey = intern_c_string ("key");
5134   staticpro (&Qkey);
5135   Qvalue = intern_c_string ("value");
5136   staticpro (&Qvalue);
5137   Qhash_table_test = intern_c_string ("hash-table-test");
5138   staticpro (&Qhash_table_test);
5139   Qkey_or_value = intern_c_string ("key-or-value");
5140   staticpro (&Qkey_or_value);
5141   Qkey_and_value = intern_c_string ("key-and-value");
5142   staticpro (&Qkey_and_value);
5143 
5144   defsubr (&Ssxhash);
5145   defsubr (&Smake_hash_table);
5146   defsubr (&Scopy_hash_table);
5147   defsubr (&Shash_table_count);
5148   defsubr (&Shash_table_rehash_size);
5149   defsubr (&Shash_table_rehash_threshold);
5150   defsubr (&Shash_table_size);
5151   defsubr (&Shash_table_test);
5152   defsubr (&Shash_table_weakness);
5153   defsubr (&Shash_table_p);
5154   defsubr (&Sclrhash);
5155   defsubr (&Sgethash);
5156   defsubr (&Sputhash);
5157   defsubr (&Sremhash);
5158   defsubr (&Smaphash);
5159   defsubr (&Sdefine_hash_table_test);
5160 
5161   Qstring_lessp = intern_c_string ("string-lessp");
5162   staticpro (&Qstring_lessp);
5163   Qprovide = intern_c_string ("provide");
5164   staticpro (&Qprovide);
5165   Qrequire = intern_c_string ("require");
5166   staticpro (&Qrequire);
5167   Qyes_or_no_p_history = intern_c_string ("yes-or-no-p-history");
5168   staticpro (&Qyes_or_no_p_history);
5169   Qcursor_in_echo_area = intern_c_string ("cursor-in-echo-area");
5170   staticpro (&Qcursor_in_echo_area);
5171   Qwidget_type = intern_c_string ("widget-type");
5172   staticpro (&Qwidget_type);
5173 
5174   staticpro (&string_char_byte_cache_string);
5175   string_char_byte_cache_string = Qnil;
5176 
5177   require_nesting_list = Qnil;
5178   staticpro (&require_nesting_list);
5179 
5180   Fset (Qyes_or_no_p_history, Qnil);
5181 
5182   DEFVAR_LISP ("features", &Vfeatures,
5183     doc: /* A list of symbols which are the features of the executing Emacs.
5184 Used by `featurep' and `require', and altered by `provide'.  */);
5185   Vfeatures = Fcons (intern_c_string ("emacs"), Qnil);
5186   Qsubfeatures = intern_c_string ("subfeatures");
5187   staticpro (&Qsubfeatures);
5188 
5189 #ifdef HAVE_LANGINFO_CODESET
5190   Qcodeset = intern_c_string ("codeset");
5191   staticpro (&Qcodeset);
5192   Qdays = intern_c_string ("days");
5193   staticpro (&Qdays);
5194   Qmonths = intern_c_string ("months");
5195   staticpro (&Qmonths);
5196   Qpaper = intern_c_string ("paper");
5197   staticpro (&Qpaper);
5198 #endif  /* HAVE_LANGINFO_CODESET */
5199 
5200   DEFVAR_BOOL ("use-dialog-box", &use_dialog_box,
5201     doc: /* *Non-nil means mouse commands use dialog boxes to ask questions.
5202 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
5203 invoked by mouse clicks and mouse menu items.
5204 
5205 On some platforms, file selection dialogs are also enabled if this is
5206 non-nil.  */);
5207   use_dialog_box = 1;
5208 
5209   DEFVAR_BOOL ("use-file-dialog", &use_file_dialog,
5210     doc: /* *Non-nil means mouse commands use a file dialog to ask for files.
5211 This applies to commands from menus and tool bar buttons even when
5212 they are initiated from the keyboard.  If `use-dialog-box' is nil,
5213 that disables the use of a file dialog, regardless of the value of
5214 this variable.  */);
5215   use_file_dialog = 1;
5216 
5217   defsubr (&Sidentity);
5218   defsubr (&Srandom);
5219   defsubr (&Slength);
5220   defsubr (&Ssafe_length);
5221   defsubr (&Sstring_bytes);
5222   defsubr (&Sstring_equal);
5223   defsubr (&Scompare_strings);
5224   defsubr (&Sstring_lessp);
5225   defsubr (&Sappend);
5226   defsubr (&Sconcat);
5227   defsubr (&Svconcat);
5228   defsubr (&Scopy_sequence);
5229   defsubr (&Sstring_make_multibyte);
5230   defsubr (&Sstring_make_unibyte);
5231   defsubr (&Sstring_as_multibyte);
5232   defsubr (&Sstring_as_unibyte);
5233   defsubr (&Sstring_to_multibyte);
5234   defsubr (&Sstring_to_unibyte);
5235   defsubr (&Scopy_alist);
5236   defsubr (&Ssubstring);
5237   defsubr (&Ssubstring_no_properties);
5238   defsubr (&Snthcdr);
5239   defsubr (&Snth);
5240   defsubr (&Selt);
5241   defsubr (&Smember);
5242   defsubr (&Smemq);
5243   defsubr (&Smemql);
5244   defsubr (&Sassq);
5245   defsubr (&Sassoc);
5246   defsubr (&Srassq);
5247   defsubr (&Srassoc);
5248   defsubr (&Sdelq);
5249   defsubr (&Sdelete);
5250   defsubr (&Snreverse);
5251   defsubr (&Sreverse);
5252   defsubr (&Ssort);
5253   defsubr (&Splist_get);
5254   defsubr (&Sget);
5255   defsubr (&Splist_put);
5256   defsubr (&Sput);
5257   defsubr (&Slax_plist_get);
5258   defsubr (&Slax_plist_put);
5259   defsubr (&Seql);
5260   defsubr (&Sequal);
5261   defsubr (&Sequal_including_properties);
5262   defsubr (&Sfillarray);
5263   defsubr (&Sclear_string);
5264   defsubr (&Snconc);
5265   defsubr (&Smapcar);
5266   defsubr (&Smapc);
5267   defsubr (&Smapconcat);
5268   defsubr (&Sy_or_n_p);
5269   defsubr (&Syes_or_no_p);
5270   defsubr (&Sload_average);
5271   defsubr (&Sfeaturep);
5272   defsubr (&Srequire);
5273   defsubr (&Sprovide);
5274   defsubr (&Splist_member);
5275   defsubr (&Swidget_put);
5276   defsubr (&Swidget_get);
5277   defsubr (&Swidget_apply);
5278   defsubr (&Sbase64_encode_region);
5279   defsubr (&Sbase64_decode_region);
5280   defsubr (&Sbase64_encode_string);
5281   defsubr (&Sbase64_decode_string);
5282   defsubr (&Smd5);
5283   defsubr (&Slocale_info);
5284 }
5285 
5286 
5287 void
5288 init_fns ()
5289 {
5290 }
5291 
5292 /* arch-tag: 787f8219-5b74-46bd-8469-7e1cc475fa31
5293    (do not change this comment) */