1 /* Primitive operations on Lisp data types for GNU Emacs Lisp interpreter.
   2    Copyright (C) 1985, 1986, 1988, 1993, 1994, 1995, 1997, 1998, 1999, 2000,
   3                  2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
   4                  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 
  22 #include <config.h>
  23 #include <signal.h>
  24 #include <stdio.h>
  25 #include <setjmp.h>
  26 #include "lisp.h"
  27 #include "puresize.h"
  28 #include "character.h"
  29 #include "buffer.h"
  30 #include "keyboard.h"
  31 #include "frame.h"
  32 #include "syssignal.h"
  33 #include "termhooks.h"  /* For FRAME_KBOARD reference in y-or-n-p. */
  34 #include "font.h"
  35 
  36 #ifdef STDC_HEADERS
  37 #include <float.h>
  38 #endif
  39 
  40 /* If IEEE_FLOATING_POINT isn't defined, default it from FLT_*. */
  41 #ifndef IEEE_FLOATING_POINT
  42 #if (FLT_RADIX == 2 && FLT_MANT_DIG == 24 \
  43      && FLT_MIN_EXP == -125 && FLT_MAX_EXP == 128)
  44 #define IEEE_FLOATING_POINT 1
  45 #else
  46 #define IEEE_FLOATING_POINT 0
  47 #endif
  48 #endif
  49 
  50 #include <math.h>
  51 
  52 #if !defined (atof)
  53 extern double atof ();
  54 #endif /* !atof */
  55 
  56 Lisp_Object Qnil, Qt, Qquote, Qlambda, Qsubr, Qunbound;
  57 Lisp_Object Qerror_conditions, Qerror_message, Qtop_level;
  58 Lisp_Object Qerror, Qquit, Qwrong_type_argument, Qargs_out_of_range;
  59 Lisp_Object Qvoid_variable, Qvoid_function, Qcyclic_function_indirection;
  60 Lisp_Object Qcyclic_variable_indirection, Qcircular_list;
  61 Lisp_Object Qsetting_constant, Qinvalid_read_syntax;
  62 Lisp_Object Qinvalid_function, Qwrong_number_of_arguments, Qno_catch;
  63 Lisp_Object Qend_of_file, Qarith_error, Qmark_inactive;
  64 Lisp_Object Qbeginning_of_buffer, Qend_of_buffer, Qbuffer_read_only;
  65 Lisp_Object Qtext_read_only;
  66 
  67 Lisp_Object Qintegerp, Qnatnump, Qwholenump, Qsymbolp, Qlistp, Qconsp;
  68 Lisp_Object Qstringp, Qarrayp, Qsequencep, Qbufferp;
  69 Lisp_Object Qchar_or_string_p, Qmarkerp, Qinteger_or_marker_p, Qvectorp;
  70 Lisp_Object Qbuffer_or_string_p, Qkeywordp;
  71 Lisp_Object Qboundp, Qfboundp;
  72 Lisp_Object Qchar_table_p, Qvector_or_char_table_p;
  73 
  74 Lisp_Object Qcdr;
  75 Lisp_Object Qad_advice_info, Qad_activate_internal;
  76 
  77 Lisp_Object Qrange_error, Qdomain_error, Qsingularity_error;
  78 Lisp_Object Qoverflow_error, Qunderflow_error;
  79 
  80 Lisp_Object Qfloatp;
  81 Lisp_Object Qnumberp, Qnumber_or_marker_p;
  82 
  83 Lisp_Object Qinteger;
  84 static Lisp_Object Qsymbol, Qstring, Qcons, Qmarker, Qoverlay;
  85 static Lisp_Object Qfloat, Qwindow_configuration, Qwindow;
  86 Lisp_Object Qprocess;
  87 static Lisp_Object Qcompiled_function, Qbuffer, Qframe, Qvector;
  88 static Lisp_Object Qchar_table, Qbool_vector, Qhash_table;
  89 static Lisp_Object Qsubrp, Qmany, Qunevalled;
  90 Lisp_Object Qfont_spec, Qfont_entity, Qfont_object;
  91 
  92 Lisp_Object Qinteractive_form;
  93 
  94 static void swap_in_symval_forwarding (struct Lisp_Symbol *, struct Lisp_Buffer_Local_Value *);
  95 
  96 Lisp_Object Vmost_positive_fixnum, Vmost_negative_fixnum;
  97 
  98 
  99 void
 100 circular_list_error (list)
 101      Lisp_Object list;
 102 {
 103   xsignal (Qcircular_list, list);
 104 }
 105 
 106 
 107 Lisp_Object
 108 wrong_type_argument (predicate, value)
 109      register Lisp_Object predicate, value;
 110 {
 111   /* If VALUE is not even a valid Lisp object, we'd want to abort here
 112      where we can get a backtrace showing where it came from.  We used
 113      to try and do that by checking the tagbits, but nowadays all
 114      tagbits are potentially valid.  */
 115   /* if ((unsigned int) XTYPE (value) >= Lisp_Type_Limit)
 116    *   abort (); */
 117 
 118   xsignal2 (Qwrong_type_argument, predicate, value);
 119 }
 120 
 121 void
 122 pure_write_error ()
 123 {
 124   error ("Attempt to modify read-only object");
 125 }
 126 
 127 void
 128 args_out_of_range (a1, a2)
 129      Lisp_Object a1, a2;
 130 {
 131   xsignal2 (Qargs_out_of_range, a1, a2);
 132 }
 133 
 134 void
 135 args_out_of_range_3 (a1, a2, a3)
 136      Lisp_Object a1, a2, a3;
 137 {
 138   xsignal3 (Qargs_out_of_range, a1, a2, a3);
 139 }
 140 
 141 /* On some machines, XINT needs a temporary location.
 142    Here it is, in case it is needed.  */
 143 
 144 int sign_extend_temp;
 145 
 146 /* On a few machines, XINT can only be done by calling this.  */
 147 
 148 int
 149 sign_extend_lisp_int (num)
 150      EMACS_INT num;
 151 {
 152   if (num & (((EMACS_INT) 1) << (VALBITS - 1)))
 153     return num | (((EMACS_INT) (-1)) << VALBITS);
 154   else
 155     return num & ((((EMACS_INT) 1) << VALBITS) - 1);
 156 }
 157 
 158 /* Data type predicates */
 159 
 160 DEFUN ("eq", Feq, Seq, 2, 2, 0,
 161        doc: /* Return t if the two args are the same Lisp object.  */)
 162      (obj1, obj2)
 163      Lisp_Object obj1, obj2;
 164 {
 165   if (EQ (obj1, obj2))
 166     return Qt;
 167   return Qnil;
 168 }
 169 
 170 DEFUN ("null", Fnull, Snull, 1, 1, 0,
 171        doc: /* Return t if OBJECT is nil.  */)
 172      (object)
 173      Lisp_Object object;
 174 {
 175   if (NILP (object))
 176     return Qt;
 177   return Qnil;
 178 }
 179 
 180 DEFUN ("type-of", Ftype_of, Stype_of, 1, 1, 0,
 181        doc: /* Return a symbol representing the type of OBJECT.
 182 The symbol returned names the object's basic type;
 183 for example, (type-of 1) returns `integer'.  */)
 184      (object)
 185      Lisp_Object object;
 186 {
 187   switch (XTYPE (object))
 188     {
 189     case_Lisp_Int:
 190       return Qinteger;
 191 
 192     case Lisp_Symbol:
 193       return Qsymbol;
 194 
 195     case Lisp_String:
 196       return Qstring;
 197 
 198     case Lisp_Cons:
 199       return Qcons;
 200 
 201     case Lisp_Misc:
 202       switch (XMISCTYPE (object))
 203         {
 204         case Lisp_Misc_Marker:
 205           return Qmarker;
 206         case Lisp_Misc_Overlay:
 207           return Qoverlay;
 208         case Lisp_Misc_Float:
 209           return Qfloat;
 210         }
 211       abort ();
 212 
 213     case Lisp_Vectorlike:
 214       if (WINDOW_CONFIGURATIONP (object))
 215         return Qwindow_configuration;
 216       if (PROCESSP (object))
 217         return Qprocess;
 218       if (WINDOWP (object))
 219         return Qwindow;
 220       if (SUBRP (object))
 221         return Qsubr;
 222       if (COMPILEDP (object))
 223         return Qcompiled_function;
 224       if (BUFFERP (object))
 225         return Qbuffer;
 226       if (CHAR_TABLE_P (object))
 227         return Qchar_table;
 228       if (BOOL_VECTOR_P (object))
 229         return Qbool_vector;
 230       if (FRAMEP (object))
 231         return Qframe;
 232       if (HASH_TABLE_P (object))
 233         return Qhash_table;
 234       if (FONT_SPEC_P (object))
 235         return Qfont_spec;
 236       if (FONT_ENTITY_P (object))
 237         return Qfont_entity;
 238       if (FONT_OBJECT_P (object))
 239         return Qfont_object;
 240       return Qvector;
 241 
 242     case Lisp_Float:
 243       return Qfloat;
 244 
 245     default:
 246       abort ();
 247     }
 248 }
 249 
 250 DEFUN ("consp", Fconsp, Sconsp, 1, 1, 0,
 251        doc: /* Return t if OBJECT is a cons cell.  */)
 252      (object)
 253      Lisp_Object object;
 254 {
 255   if (CONSP (object))
 256     return Qt;
 257   return Qnil;
 258 }
 259 
 260 DEFUN ("atom", Fatom, Satom, 1, 1, 0,
 261        doc: /* Return t if OBJECT is not a cons cell.  This includes nil.  */)
 262      (object)
 263      Lisp_Object object;
 264 {
 265   if (CONSP (object))
 266     return Qnil;
 267   return Qt;
 268 }
 269 
 270 DEFUN ("listp", Flistp, Slistp, 1, 1, 0,
 271        doc: /* Return t if OBJECT is a list, that is, a cons cell or nil.
 272 Otherwise, return nil.  */)
 273      (object)
 274      Lisp_Object object;
 275 {
 276   if (CONSP (object) || NILP (object))
 277     return Qt;
 278   return Qnil;
 279 }
 280 
 281 DEFUN ("nlistp", Fnlistp, Snlistp, 1, 1, 0,
 282        doc: /* Return t if OBJECT is not a list.  Lists include nil.  */)
 283      (object)
 284      Lisp_Object object;
 285 {
 286   if (CONSP (object) || NILP (object))
 287     return Qnil;
 288   return Qt;
 289 }
 290 
 291 DEFUN ("symbolp", Fsymbolp, Ssymbolp, 1, 1, 0,
 292        doc: /* Return t if OBJECT is a symbol.  */)
 293      (object)
 294      Lisp_Object object;
 295 {
 296   if (SYMBOLP (object))
 297     return Qt;
 298   return Qnil;
 299 }
 300 
 301 /* Define this in C to avoid unnecessarily consing up the symbol
 302    name.  */
 303 DEFUN ("keywordp", Fkeywordp, Skeywordp, 1, 1, 0,
 304        doc: /* Return t if OBJECT is a keyword.
 305 This means that it is a symbol with a print name beginning with `:'
 306 interned in the initial obarray.  */)
 307      (object)
 308      Lisp_Object object;
 309 {
 310   if (SYMBOLP (object)
 311       && SREF (SYMBOL_NAME (object), 0) == ':'
 312       && SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (object))
 313     return Qt;
 314   return Qnil;
 315 }
 316 
 317 DEFUN ("vectorp", Fvectorp, Svectorp, 1, 1, 0,
 318        doc: /* Return t if OBJECT is a vector.  */)
 319      (object)
 320      Lisp_Object object;
 321 {
 322   if (VECTORP (object))
 323     return Qt;
 324   return Qnil;
 325 }
 326 
 327 DEFUN ("stringp", Fstringp, Sstringp, 1, 1, 0,
 328        doc: /* Return t if OBJECT is a string.  */)
 329      (object)
 330      Lisp_Object object;
 331 {
 332   if (STRINGP (object))
 333     return Qt;
 334   return Qnil;
 335 }
 336 
 337 DEFUN ("multibyte-string-p", Fmultibyte_string_p, Smultibyte_string_p,
 338        1, 1, 0,
 339        doc: /* Return t if OBJECT is a multibyte string.  */)
 340      (object)
 341      Lisp_Object object;
 342 {
 343   if (STRINGP (object) && STRING_MULTIBYTE (object))
 344     return Qt;
 345   return Qnil;
 346 }
 347 
 348 DEFUN ("char-table-p", Fchar_table_p, Schar_table_p, 1, 1, 0,
 349        doc: /* Return t if OBJECT is a char-table.  */)
 350      (object)
 351      Lisp_Object object;
 352 {
 353   if (CHAR_TABLE_P (object))
 354     return Qt;
 355   return Qnil;
 356 }
 357 
 358 DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p,
 359        Svector_or_char_table_p, 1, 1, 0,
 360        doc: /* Return t if OBJECT is a char-table or vector.  */)
 361      (object)
 362      Lisp_Object object;
 363 {
 364   if (VECTORP (object) || CHAR_TABLE_P (object))
 365     return Qt;
 366   return Qnil;
 367 }
 368 
 369 DEFUN ("bool-vector-p", Fbool_vector_p, Sbool_vector_p, 1, 1, 0,
 370        doc: /* Return t if OBJECT is a bool-vector.  */)
 371      (object)
 372      Lisp_Object object;
 373 {
 374   if (BOOL_VECTOR_P (object))
 375     return Qt;
 376   return Qnil;
 377 }
 378 
 379 DEFUN ("arrayp", Farrayp, Sarrayp, 1, 1, 0,
 380        doc: /* Return t if OBJECT is an array (string or vector).  */)
 381      (object)
 382      Lisp_Object object;
 383 {
 384   if (ARRAYP (object))
 385     return Qt;
 386   return Qnil;
 387 }
 388 
 389 DEFUN ("sequencep", Fsequencep, Ssequencep, 1, 1, 0,
 390        doc: /* Return t if OBJECT is a sequence (list or array).  */)
 391      (object)
 392      register Lisp_Object object;
 393 {
 394   if (CONSP (object) || NILP (object) || ARRAYP (object))
 395     return Qt;
 396   return Qnil;
 397 }
 398 
 399 DEFUN ("bufferp", Fbufferp, Sbufferp, 1, 1, 0,
 400        doc: /* Return t if OBJECT is an editor buffer.  */)
 401      (object)
 402      Lisp_Object object;
 403 {
 404   if (BUFFERP (object))
 405     return Qt;
 406   return Qnil;
 407 }
 408 
 409 DEFUN ("markerp", Fmarkerp, Smarkerp, 1, 1, 0,
 410        doc: /* Return t if OBJECT is a marker (editor pointer).  */)
 411      (object)
 412      Lisp_Object object;
 413 {
 414   if (MARKERP (object))
 415     return Qt;
 416   return Qnil;
 417 }
 418 
 419 DEFUN ("subrp", Fsubrp, Ssubrp, 1, 1, 0,
 420        doc: /* Return t if OBJECT is a built-in function.  */)
 421      (object)
 422      Lisp_Object object;
 423 {
 424   if (SUBRP (object))
 425     return Qt;
 426   return Qnil;
 427 }
 428 
 429 DEFUN ("byte-code-function-p", Fbyte_code_function_p, Sbyte_code_function_p,
 430        1, 1, 0,
 431        doc: /* Return t if OBJECT is a byte-compiled function object.  */)
 432      (object)
 433      Lisp_Object object;
 434 {
 435   if (COMPILEDP (object))
 436     return Qt;
 437   return Qnil;
 438 }
 439 
 440 DEFUN ("char-or-string-p", Fchar_or_string_p, Schar_or_string_p, 1, 1, 0,
 441        doc: /* Return t if OBJECT is a character or a string.  */)
 442      (object)
 443      register Lisp_Object object;
 444 {
 445   if (CHARACTERP (object) || STRINGP (object))
 446     return Qt;
 447   return Qnil;
 448 }
 449 
 450 DEFUN ("integerp", Fintegerp, Sintegerp, 1, 1, 0,
 451        doc: /* Return t if OBJECT is an integer.  */)
 452      (object)
 453      Lisp_Object object;
 454 {
 455   if (INTEGERP (object))
 456     return Qt;
 457   return Qnil;
 458 }
 459 
 460 DEFUN ("integer-or-marker-p", Finteger_or_marker_p, Sinteger_or_marker_p, 1, 1, 0,
 461        doc: /* Return t if OBJECT is an integer or a marker (editor pointer).  */)
 462      (object)
 463      register Lisp_Object object;
 464 {
 465   if (MARKERP (object) || INTEGERP (object))
 466     return Qt;
 467   return Qnil;
 468 }
 469 
 470 DEFUN ("natnump", Fnatnump, Snatnump, 1, 1, 0,
 471        doc: /* Return t if OBJECT is a nonnegative integer.  */)
 472      (object)
 473      Lisp_Object object;
 474 {
 475   if (NATNUMP (object))
 476     return Qt;
 477   return Qnil;
 478 }
 479 
 480 DEFUN ("numberp", Fnumberp, Snumberp, 1, 1, 0,
 481        doc: /* Return t if OBJECT is a number (floating point or integer).  */)
 482      (object)
 483      Lisp_Object object;
 484 {
 485   if (NUMBERP (object))
 486     return Qt;
 487   else
 488     return Qnil;
 489 }
 490 
 491 DEFUN ("number-or-marker-p", Fnumber_or_marker_p,
 492        Snumber_or_marker_p, 1, 1, 0,
 493        doc: /* Return t if OBJECT is a number or a marker.  */)
 494      (object)
 495      Lisp_Object object;
 496 {
 497   if (NUMBERP (object) || MARKERP (object))
 498     return Qt;
 499   return Qnil;
 500 }
 501 
 502 DEFUN ("floatp", Ffloatp, Sfloatp, 1, 1, 0,
 503        doc: /* Return t if OBJECT is a floating point number.  */)
 504      (object)
 505      Lisp_Object object;
 506 {
 507   if (FLOATP (object))
 508     return Qt;
 509   return Qnil;
 510 }
 511 
 512 
 513 /* Extract and set components of lists */
 514 
 515 DEFUN ("car", Fcar, Scar, 1, 1, 0,
 516        doc: /* Return the car of LIST.  If arg is nil, return nil.
 517 Error if arg is not nil and not a cons cell.  See also `car-safe'.
 518 
 519 See Info node `(elisp)Cons Cells' for a discussion of related basic
 520 Lisp concepts such as car, cdr, cons cell and list.  */)
 521      (list)
 522      register Lisp_Object list;
 523 {
 524   return CAR (list);
 525 }
 526 
 527 DEFUN ("car-safe", Fcar_safe, Scar_safe, 1, 1, 0,
 528        doc: /* Return the car of OBJECT if it is a cons cell, or else nil.  */)
 529      (object)
 530      Lisp_Object object;
 531 {
 532   return CAR_SAFE (object);
 533 }
 534 
 535 DEFUN ("cdr", Fcdr, Scdr, 1, 1, 0,
 536        doc: /* Return the cdr of LIST.  If arg is nil, return nil.
 537 Error if arg is not nil and not a cons cell.  See also `cdr-safe'.
 538 
 539 See Info node `(elisp)Cons Cells' for a discussion of related basic
 540 Lisp concepts such as cdr, car, cons cell and list.  */)
 541      (list)
 542      register Lisp_Object list;
 543 {
 544   return CDR (list);
 545 }
 546 
 547 DEFUN ("cdr-safe", Fcdr_safe, Scdr_safe, 1, 1, 0,
 548        doc: /* Return the cdr of OBJECT if it is a cons cell, or else nil.  */)
 549      (object)
 550      Lisp_Object object;
 551 {
 552   return CDR_SAFE (object);
 553 }
 554 
 555 DEFUN ("setcar", Fsetcar, Ssetcar, 2, 2, 0,
 556        doc: /* Set the car of CELL to be NEWCAR.  Returns NEWCAR.  */)
 557      (cell, newcar)
 558      register Lisp_Object cell, newcar;
 559 {
 560   CHECK_CONS (cell);
 561   CHECK_IMPURE (cell);
 562   XSETCAR (cell, newcar);
 563   return newcar;
 564 }
 565 
 566 DEFUN ("setcdr", Fsetcdr, Ssetcdr, 2, 2, 0,
 567        doc: /* Set the cdr of CELL to be NEWCDR.  Returns NEWCDR.  */)
 568      (cell, newcdr)
 569      register Lisp_Object cell, newcdr;
 570 {
 571   CHECK_CONS (cell);
 572   CHECK_IMPURE (cell);
 573   XSETCDR (cell, newcdr);
 574   return newcdr;
 575 }
 576 
 577 /* Extract and set components of symbols */
 578 
 579 DEFUN ("boundp", Fboundp, Sboundp, 1, 1, 0,
 580        doc: /* Return t if SYMBOL's value is not void.  */)
 581      (symbol)
 582      register Lisp_Object symbol;
 583 {
 584   Lisp_Object valcontents;
 585   struct Lisp_Symbol *sym;
 586   CHECK_SYMBOL (symbol);
 587   sym = XSYMBOL (symbol);
 588 
 589  start:
 590   switch (sym->redirect)
 591     {
 592     case SYMBOL_PLAINVAL: valcontents = SYMBOL_VAL (sym); break;
 593     case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
 594     case SYMBOL_LOCALIZED:
 595       {
 596         struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (sym);
 597         if (blv->fwd)
 598           /* In set_internal, we un-forward vars when their value is
 599              set to Qunbound. */
 600           return Qt;
 601         else
 602           {
 603             swap_in_symval_forwarding (sym, blv);
 604             valcontents = BLV_VALUE (blv);
 605           }
 606         break;
 607       }
 608     case SYMBOL_FORWARDED:
 609       /* In set_internal, we un-forward vars when their value is
 610          set to Qunbound. */
 611       return Qt;
 612     default: abort ();
 613     }
 614 
 615   return (EQ (valcontents, Qunbound) ? Qnil : Qt);
 616 }
 617 
 618 DEFUN ("fboundp", Ffboundp, Sfboundp, 1, 1, 0,
 619        doc: /* Return t if SYMBOL's function definition is not void.  */)
 620      (symbol)
 621      register Lisp_Object symbol;
 622 {
 623   CHECK_SYMBOL (symbol);
 624   return (EQ (XSYMBOL (symbol)->function, Qunbound) ? Qnil : Qt);
 625 }
 626 
 627 DEFUN ("makunbound", Fmakunbound, Smakunbound, 1, 1, 0,
 628        doc: /* Make SYMBOL's value be void.
 629 Return SYMBOL.  */)
 630      (symbol)
 631      register Lisp_Object symbol;
 632 {
 633   CHECK_SYMBOL (symbol);
 634   if (SYMBOL_CONSTANT_P (symbol))
 635     xsignal1 (Qsetting_constant, symbol);
 636   Fset (symbol, Qunbound);
 637   return symbol;
 638 }
 639 
 640 DEFUN ("fmakunbound", Ffmakunbound, Sfmakunbound, 1, 1, 0,
 641        doc: /* Make SYMBOL's function definition be void.
 642 Return SYMBOL.  */)
 643      (symbol)
 644      register Lisp_Object symbol;
 645 {
 646   CHECK_SYMBOL (symbol);
 647   if (NILP (symbol) || EQ (symbol, Qt))
 648     xsignal1 (Qsetting_constant, symbol);
 649   XSYMBOL (symbol)->function = Qunbound;
 650   return symbol;
 651 }
 652 
 653 DEFUN ("symbol-function", Fsymbol_function, Ssymbol_function, 1, 1, 0,
 654        doc: /* Return SYMBOL's function definition.  Error if that is void.  */)
 655      (symbol)
 656      register Lisp_Object symbol;
 657 {
 658   CHECK_SYMBOL (symbol);
 659   if (!EQ (XSYMBOL (symbol)->function, Qunbound))
 660     return XSYMBOL (symbol)->function;
 661   xsignal1 (Qvoid_function, symbol);
 662 }
 663 
 664 DEFUN ("symbol-plist", Fsymbol_plist, Ssymbol_plist, 1, 1, 0,
 665        doc: /* Return SYMBOL's property list.  */)
 666      (symbol)
 667      register Lisp_Object symbol;
 668 {
 669   CHECK_SYMBOL (symbol);
 670   return XSYMBOL (symbol)->plist;
 671 }
 672 
 673 DEFUN ("symbol-name", Fsymbol_name, Ssymbol_name, 1, 1, 0,
 674        doc: /* Return SYMBOL's name, a string.  */)
 675      (symbol)
 676      register Lisp_Object symbol;
 677 {
 678   register Lisp_Object name;
 679 
 680   CHECK_SYMBOL (symbol);
 681   name = SYMBOL_NAME (symbol);
 682   return name;
 683 }
 684 
 685 DEFUN ("fset", Ffset, Sfset, 2, 2, 0,
 686        doc: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION.  */)
 687      (symbol, definition)
 688      register Lisp_Object symbol, definition;
 689 {
 690   register Lisp_Object function;
 691 
 692   CHECK_SYMBOL (symbol);
 693   if (NILP (symbol) || EQ (symbol, Qt))
 694     xsignal1 (Qsetting_constant, symbol);
 695 
 696   function = XSYMBOL (symbol)->function;
 697 
 698   if (!NILP (Vautoload_queue) && !EQ (function, Qunbound))
 699     Vautoload_queue = Fcons (Fcons (symbol, function), Vautoload_queue);
 700 
 701   if (CONSP (function) && EQ (XCAR (function), Qautoload))
 702     Fput (symbol, Qautoload, XCDR (function));
 703 
 704   XSYMBOL (symbol)->function = definition;
 705   /* Handle automatic advice activation */
 706   if (CONSP (XSYMBOL (symbol)->plist) && !NILP (Fget (symbol, Qad_advice_info)))
 707     {
 708       call2 (Qad_activate_internal, symbol, Qnil);
 709       definition = XSYMBOL (symbol)->function;
 710     }
 711   return definition;
 712 }
 713 
 714 extern Lisp_Object Qfunction_documentation;
 715 
 716 DEFUN ("defalias", Fdefalias, Sdefalias, 2, 3, 0,
 717        doc: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION.
 718 Associates the function with the current load file, if any.
 719 The optional third argument DOCSTRING specifies the documentation string
 720 for SYMBOL; if it is omitted or nil, SYMBOL uses the documentation string
 721 determined by DEFINITION.  */)
 722      (symbol, definition, docstring)
 723      register Lisp_Object symbol, definition, docstring;
 724 {
 725   CHECK_SYMBOL (symbol);
 726   if (CONSP (XSYMBOL (symbol)->function)
 727       && EQ (XCAR (XSYMBOL (symbol)->function), Qautoload))
 728     LOADHIST_ATTACH (Fcons (Qt, symbol));
 729   definition = Ffset (symbol, definition);
 730   LOADHIST_ATTACH (Fcons (Qdefun, symbol));
 731   if (!NILP (docstring))
 732     Fput (symbol, Qfunction_documentation, docstring);
 733   return definition;
 734 }
 735 
 736 DEFUN ("setplist", Fsetplist, Ssetplist, 2, 2, 0,
 737        doc: /* Set SYMBOL's property list to NEWPLIST, and return NEWPLIST.  */)
 738      (symbol, newplist)
 739      register Lisp_Object symbol, newplist;
 740 {
 741   CHECK_SYMBOL (symbol);
 742   XSYMBOL (symbol)->plist = newplist;
 743   return newplist;
 744 }
 745 
 746 DEFUN ("subr-arity", Fsubr_arity, Ssubr_arity, 1, 1, 0,
 747        doc: /* Return minimum and maximum number of args allowed for SUBR.
 748 SUBR must be a built-in function.
 749 The returned value is a pair (MIN . MAX).  MIN is the minimum number
 750 of args.  MAX is the maximum number or the symbol `many', for a
 751 function with `&rest' args, or `unevalled' for a special form.  */)
 752      (subr)
 753      Lisp_Object subr;
 754 {
 755   short minargs, maxargs;
 756   CHECK_SUBR (subr);
 757   minargs = XSUBR (subr)->min_args;
 758   maxargs = XSUBR (subr)->max_args;
 759   if (maxargs == MANY)
 760     return Fcons (make_number (minargs), Qmany);
 761   else if (maxargs == UNEVALLED)
 762     return Fcons (make_number (minargs), Qunevalled);
 763   else
 764     return Fcons (make_number (minargs), make_number (maxargs));
 765 }
 766 
 767 DEFUN ("subr-name", Fsubr_name, Ssubr_name, 1, 1, 0,
 768        doc: /* Return name of subroutine SUBR.
 769 SUBR must be a built-in function.  */)
 770      (subr)
 771      Lisp_Object subr;
 772 {
 773   const char *name;
 774   CHECK_SUBR (subr);
 775   name = XSUBR (subr)->symbol_name;
 776   return make_string (name, strlen (name));
 777 }
 778 
 779 DEFUN ("interactive-form", Finteractive_form, Sinteractive_form, 1, 1, 0,
 780        doc: /* Return the interactive form of CMD or nil if none.
 781 If CMD is not a command, the return value is nil.
 782 Value, if non-nil, is a list \(interactive SPEC).  */)
 783      (cmd)
 784      Lisp_Object cmd;
 785 {
 786   Lisp_Object fun = indirect_function (cmd); /* Check cycles.  */
 787 
 788   if (NILP (fun) || EQ (fun, Qunbound))
 789     return Qnil;
 790 
 791   /* Use an `interactive-form' property if present, analogous to the
 792      function-documentation property. */
 793   fun = cmd;
 794   while (SYMBOLP (fun))
 795     {
 796       Lisp_Object tmp = Fget (fun, Qinteractive_form);
 797       if (!NILP (tmp))
 798         return tmp;
 799       else
 800         fun = Fsymbol_function (fun);
 801     }
 802 
 803   if (SUBRP (fun))
 804     {
 805       char *spec = XSUBR (fun)->intspec;
 806       if (spec)
 807         return list2 (Qinteractive,
 808                       (*spec != '(') ? build_string (spec) :
 809                       Fcar (Fread_from_string (build_string (spec), Qnil, Qnil)));
 810     }
 811   else if (COMPILEDP (fun))
 812     {
 813       if ((ASIZE (fun) & PSEUDOVECTOR_SIZE_MASK) > COMPILED_INTERACTIVE)
 814         return list2 (Qinteractive, AREF (fun, COMPILED_INTERACTIVE));
 815     }
 816   else if (CONSP (fun))
 817     {
 818       Lisp_Object funcar = XCAR (fun);
 819       if (EQ (funcar, Qlambda))
 820         return Fassq (Qinteractive, Fcdr (XCDR (fun)));
 821       else if (EQ (funcar, Qautoload))
 822         {
 823           struct gcpro gcpro1;
 824           GCPRO1 (cmd);
 825           do_autoload (fun, cmd);
 826           UNGCPRO;
 827           return Finteractive_form (cmd);
 828         }
 829     }
 830   return Qnil;
 831 }
 832 
 833 
 834 /***********************************************************************
 835                 Getting and Setting Values of Symbols
 836  ***********************************************************************/
 837 
 838 /* Return the symbol holding SYMBOL's value.  Signal
 839    `cyclic-variable-indirection' if SYMBOL's chain of variable
 840    indirections contains a loop.  */
 841 
 842 struct Lisp_Symbol *
 843 indirect_variable (symbol)
 844      struct Lisp_Symbol *symbol;
 845 {
 846   struct Lisp_Symbol *tortoise, *hare;
 847 
 848   hare = tortoise = symbol;
 849 
 850   while (hare->redirect == SYMBOL_VARALIAS)
 851     {
 852       hare = SYMBOL_ALIAS (hare);
 853       if (hare->redirect != SYMBOL_VARALIAS)
 854         break;
 855 
 856       hare = SYMBOL_ALIAS (hare);
 857       tortoise = SYMBOL_ALIAS (tortoise);
 858 
 859       if (hare == tortoise)
 860         {
 861           Lisp_Object tem;
 862           XSETSYMBOL (tem, symbol);
 863           xsignal1 (Qcyclic_variable_indirection, tem);
 864         }
 865     }
 866 
 867   return hare;
 868 }
 869 
 870 
 871 DEFUN ("indirect-variable", Findirect_variable, Sindirect_variable, 1, 1, 0,
 872        doc: /* Return the variable at the end of OBJECT's variable chain.
 873 If OBJECT is a symbol, follow all variable indirections and return the final
 874 variable.  If OBJECT is not a symbol, just return it.
 875 Signal a cyclic-variable-indirection error if there is a loop in the
 876 variable chain of symbols.  */)
 877      (object)
 878      Lisp_Object object;
 879 {
 880   if (SYMBOLP (object))
 881     XSETSYMBOL (object,  indirect_variable (XSYMBOL (object)));
 882   return object;
 883 }
 884 
 885 
 886 /* Given the raw contents of a symbol value cell,
 887    return the Lisp value of the symbol.
 888    This does not handle buffer-local variables; use
 889    swap_in_symval_forwarding for that.  */
 890 
 891 #define do_blv_forwarding(blv) \
 892   ((blv)->forwarded ? do_symval_forwarding (BLV_FWD (blv)) : BLV_VALUE (blv))
 893 
 894 Lisp_Object
 895 do_symval_forwarding (valcontents)
 896      register union Lisp_Fwd *valcontents;
 897 {
 898   register Lisp_Object val;
 899   switch (XFWDTYPE (valcontents))
 900     {
 901     case Lisp_Fwd_Int:
 902       XSETINT (val, *XINTFWD (valcontents)->intvar);
 903       return val;
 904 
 905     case Lisp_Fwd_Bool:
 906       return (*XBOOLFWD (valcontents)->boolvar ? Qt : Qnil);
 907 
 908     case Lisp_Fwd_Obj:
 909       return *XOBJFWD (valcontents)->objvar;
 910 
 911     case Lisp_Fwd_Buffer_Obj:
 912       return PER_BUFFER_VALUE (current_buffer,
 913                                XBUFFER_OBJFWD (valcontents)->offset);
 914 
 915     case Lisp_Fwd_Kboard_Obj:
 916       /* We used to simply use current_kboard here, but from Lisp
 917          code, it's value is often unexpected.  It seems nicer to
 918          allow constructions like this to work as intuitively expected:
 919 
 920          (with-selected-frame frame
 921          (define-key local-function-map "\eOP" [f1]))
 922 
 923          On the other hand, this affects the semantics of
 924          last-command and real-last-command, and people may rely on
 925          that.  I took a quick look at the Lisp codebase, and I
 926          don't think anything will break.  --lorentey  */
 927       return *(Lisp_Object *)(XKBOARD_OBJFWD (valcontents)->offset
 928                               + (char *)FRAME_KBOARD (SELECTED_FRAME ()));
 929     default: abort ();
 930     }
 931 }
 932 
 933 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
 934    of SYMBOL.  If SYMBOL is buffer-local, VALCONTENTS should be the
 935    buffer-independent contents of the value cell: forwarded just one
 936    step past the buffer-localness.
 937 
 938    BUF non-zero means set the value in buffer BUF instead of the
 939    current buffer.  This only plays a role for per-buffer variables.  */
 940 
 941 #define store_blv_forwarding(blv, newval, buf)                  \
 942   do {                                                          \
 943     if ((blv)->forwarded)                                       \
 944       store_symval_forwarding (BLV_FWD (blv), (newval), (buf)); \
 945     else                                                        \
 946       SET_BLV_VALUE (blv, newval);                              \
 947   } while (0)
 948 
 949 static void
 950 store_symval_forwarding (/* symbol, */ valcontents, newval, buf)
 951      /* struct Lisp_Symbol *symbol; */
 952      union Lisp_Fwd *valcontents;
 953      register Lisp_Object newval;
 954      struct buffer *buf;
 955 {
 956   switch (XFWDTYPE (valcontents))
 957     {
 958     case Lisp_Fwd_Int:
 959       CHECK_NUMBER (newval);
 960       *XINTFWD (valcontents)->intvar = XINT (newval);
 961       break;
 962       
 963     case Lisp_Fwd_Bool:
 964       *XBOOLFWD (valcontents)->boolvar = !NILP (newval);
 965       break;
 966       
 967     case Lisp_Fwd_Obj:
 968       *XOBJFWD (valcontents)->objvar = newval;
 969       
 970       /* If this variable is a default for something stored
 971          in the buffer itself, such as default-fill-column,
 972          find the buffers that don't have local values for it
 973          and update them.  */
 974       if (XOBJFWD (valcontents)->objvar > (Lisp_Object *) &buffer_defaults
 975           && XOBJFWD (valcontents)->objvar < (Lisp_Object *) (&buffer_defaults + 1))
 976         {
 977           int offset = ((char *) XOBJFWD (valcontents)->objvar
 978                         - (char *) &buffer_defaults);
 979           int idx = PER_BUFFER_IDX (offset);
 980           
 981           Lisp_Object tail;
 982           
 983           if (idx <= 0)
 984             break;
 985           
 986           for (tail = Vbuffer_alist; CONSP (tail); tail = XCDR (tail))
 987             {
 988               Lisp_Object buf;
 989               struct buffer *b;
 990 
 991               buf = Fcdr (XCAR (tail));
 992               if (!BUFFERP (buf)) continue;
 993               b = XBUFFER (buf);
 994 
 995               if (! PER_BUFFER_VALUE_P (b, idx))
 996                 PER_BUFFER_VALUE (b, offset) = newval;
 997             }
 998         }
 999       break;
1000 
1001     case Lisp_Fwd_Buffer_Obj:
1002       {
1003         int offset = XBUFFER_OBJFWD (valcontents)->offset;
1004         Lisp_Object type = XBUFFER_OBJFWD (valcontents)->slottype;
1005 
1006         if (!(NILP (type) || NILP (newval)
1007               || (XINT (type) == LISP_INT_TAG
1008                   ? INTEGERP (newval)
1009                   : XTYPE (newval) == XINT (type))))
1010           buffer_slot_type_mismatch (newval, XINT (type));
1011 
1012         if (buf == NULL)
1013           buf = current_buffer;
1014         PER_BUFFER_VALUE (buf, offset) = newval;
1015       }
1016       break;
1017 
1018     case Lisp_Fwd_Kboard_Obj:
1019       {
1020         char *base = (char *) FRAME_KBOARD (SELECTED_FRAME ());
1021         char *p = base + XKBOARD_OBJFWD (valcontents)->offset;
1022         *(Lisp_Object *) p = newval;
1023       }
1024       break;
1025 
1026     default:
1027       abort (); /* goto def; */
1028     }
1029 }
1030 
1031 /* Set up SYMBOL to refer to its global binding.
1032    This makes it safe to alter the status of other bindings.  */
1033 
1034 void
1035 swap_in_global_binding (symbol)
1036      struct Lisp_Symbol *symbol;
1037 {
1038   struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (symbol);
1039 
1040   /* Unload the previously loaded binding.  */
1041   if (blv->fwd)
1042     SET_BLV_VALUE (blv, do_symval_forwarding (blv->fwd));
1043 
1044   /* Select the global binding in the symbol.  */
1045   blv->valcell = blv->defcell;
1046   if (blv->fwd)
1047     store_symval_forwarding (blv->fwd, XCDR (blv->defcell), NULL);
1048 
1049   /* Indicate that the global binding is set up now.  */
1050   blv->where = Qnil;
1051   SET_BLV_FOUND (blv, 0);
1052 }
1053 
1054 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
1055    VALCONTENTS is the contents of its value cell,
1056    which points to a struct Lisp_Buffer_Local_Value.
1057 
1058    Return the value forwarded one step past the buffer-local stage.
1059    This could be another forwarding pointer.  */
1060 
1061 static void
1062 swap_in_symval_forwarding (symbol, blv)
1063      struct Lisp_Symbol *symbol;
1064      struct Lisp_Buffer_Local_Value *blv;
1065 {
1066   register Lisp_Object tem1;
1067 
1068   eassert (blv == SYMBOL_BLV (symbol));
1069 
1070   tem1 = blv->where;
1071 
1072   if (NILP (tem1)
1073       || (blv->frame_local
1074           ? !EQ (selected_frame, tem1)
1075           : current_buffer != XBUFFER (tem1)))
1076     {
1077 
1078       /* Unload the previously loaded binding.  */
1079       tem1 = blv->valcell;
1080       if (blv->fwd)
1081         SET_BLV_VALUE (blv, do_symval_forwarding (blv->fwd));
1082       /* Choose the new binding.  */
1083       {
1084         Lisp_Object var;
1085         XSETSYMBOL (var, symbol);
1086         if (blv->frame_local)
1087           {
1088             tem1 = assq_no_quit (var, XFRAME (selected_frame)->param_alist);
1089             blv->where = selected_frame;
1090           }
1091         else
1092           {
1093             tem1 = assq_no_quit (var, current_buffer->local_var_alist);
1094             XSETBUFFER (blv->where, current_buffer);
1095           }
1096       }
1097       if (!(blv->found = !NILP (tem1)))
1098         tem1 = blv->defcell;
1099 
1100       /* Load the new binding.  */
1101       blv->valcell = tem1;
1102       if (blv->fwd)
1103         store_symval_forwarding (blv->fwd, BLV_VALUE (blv), NULL);
1104     }
1105 }
1106 
1107 /* Find the value of a symbol, returning Qunbound if it's not bound.
1108    This is helpful for code which just wants to get a variable's value
1109    if it has one, without signaling an error.
1110    Note that it must not be possible to quit
1111    within this function.  Great care is required for this.  */
1112 
1113 Lisp_Object
1114 find_symbol_value (symbol)
1115      Lisp_Object symbol;
1116 {
1117   struct Lisp_Symbol *sym;
1118 
1119   CHECK_SYMBOL (symbol);
1120   sym = XSYMBOL (symbol);
1121 
1122  start:
1123   switch (sym->redirect)
1124     {
1125     case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
1126     case SYMBOL_PLAINVAL: return SYMBOL_VAL (sym);
1127     case SYMBOL_LOCALIZED:
1128       {
1129         struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (sym);
1130         swap_in_symval_forwarding (sym, blv);
1131         return blv->fwd ? do_symval_forwarding (blv->fwd) : BLV_VALUE (blv);
1132       }
1133       /* FALLTHROUGH */
1134     case SYMBOL_FORWARDED:
1135       return do_symval_forwarding (SYMBOL_FWD (sym));
1136     default: abort ();
1137     }
1138 }
1139 
1140 DEFUN ("symbol-value", Fsymbol_value, Ssymbol_value, 1, 1, 0,
1141        doc: /* Return SYMBOL's value.  Error if that is void.  */)
1142      (symbol)
1143      Lisp_Object symbol;
1144 {
1145   Lisp_Object val;
1146 
1147   val = find_symbol_value (symbol);
1148   if (!EQ (val, Qunbound))
1149     return val;
1150 
1151   xsignal1 (Qvoid_variable, symbol);
1152 }
1153 
1154 DEFUN ("set", Fset, Sset, 2, 2, 0,
1155        doc: /* Set SYMBOL's value to NEWVAL, and return NEWVAL.  */)
1156      (symbol, newval)
1157      register Lisp_Object symbol, newval;
1158 {
1159   set_internal (symbol, newval, Qnil, 0);
1160   return newval;
1161 }
1162 
1163 /* Return 1 if SYMBOL currently has a let-binding
1164    which was made in the buffer that is now current.  */
1165 
1166 static int
1167 let_shadows_buffer_binding_p (struct Lisp_Symbol *symbol)
1168 {
1169   struct specbinding *p;
1170 
1171   for (p = specpdl_ptr - 1; p >= specpdl; p--)
1172     if (p->func == NULL
1173         && CONSP (p->symbol))
1174       {
1175         struct Lisp_Symbol *let_bound_symbol = XSYMBOL (XCAR (p->symbol));
1176         eassert (let_bound_symbol->redirect != SYMBOL_VARALIAS);
1177         if (symbol == let_bound_symbol
1178             && XBUFFER (XCDR (XCDR (p->symbol))) == current_buffer)
1179           break;
1180       }
1181 
1182   return p >= specpdl;
1183 }
1184 
1185 static int
1186 let_shadows_global_binding_p (symbol)
1187      Lisp_Object symbol;
1188 {
1189   struct specbinding *p;
1190 
1191   for (p = specpdl_ptr - 1; p >= specpdl; p--)
1192     if (p->func == NULL && EQ (p->symbol, symbol))
1193       break;
1194 
1195   return p >= specpdl;
1196 }
1197 
1198 /* Store the value NEWVAL into SYMBOL.
1199    If buffer/frame-locality is an issue, WHERE specifies which context to use.
1200    (nil stands for the current buffer/frame).
1201 
1202    If BINDFLAG is zero, then if this symbol is supposed to become
1203    local in every buffer where it is set, then we make it local.
1204    If BINDFLAG is nonzero, we don't do that.  */
1205 
1206 void
1207 set_internal (symbol, newval, where, bindflag)
1208      register Lisp_Object symbol, newval, where;
1209      int bindflag;
1210 {
1211   int voide = EQ (newval, Qunbound);
1212   struct Lisp_Symbol *sym;
1213   Lisp_Object tem1;
1214 
1215   /* If restoring in a dead buffer, do nothing.  */
1216   /* if (BUFFERP (where) && NILP (XBUFFER (where)->name))
1217       return; */
1218 
1219   CHECK_SYMBOL (symbol);
1220   if (SYMBOL_CONSTANT_P (symbol))
1221     {
1222       if (NILP (Fkeywordp (symbol))
1223           || !EQ (newval, Fsymbol_value (symbol)))
1224         xsignal1 (Qsetting_constant, symbol);
1225       else
1226         /* Allow setting keywords to their own value.  */
1227         return;
1228     }
1229 
1230   sym = XSYMBOL (symbol);
1231 
1232  start:
1233   switch (sym->redirect)
1234     {
1235     case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
1236     case SYMBOL_PLAINVAL: SET_SYMBOL_VAL (sym , newval); return;
1237     case SYMBOL_LOCALIZED:
1238       {
1239         struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (sym);
1240         if (NILP (where))
1241           {
1242             if (blv->frame_local)
1243               where = selected_frame;
1244             else
1245               XSETBUFFER (where, current_buffer);
1246           }
1247         /* If the current buffer is not the buffer whose binding is
1248            loaded, or if there may be frame-local bindings and the frame
1249            isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1250            the default binding is loaded, the loaded binding may be the
1251            wrong one.  */
1252         if (!EQ (blv->where, where)
1253             /* Also unload a global binding (if the var is local_if_set). */
1254             || (EQ (blv->valcell, blv->defcell)))
1255           {
1256             /* The currently loaded binding is not necessarily valid.
1257                We need to unload it, and choose a new binding.  */
1258 
1259             /* Write out `realvalue' to the old loaded binding.  */
1260             if (blv->fwd)
1261               SET_BLV_VALUE (blv, do_symval_forwarding (blv->fwd));
1262 
1263             /* Find the new binding.  */
1264             XSETSYMBOL (symbol, sym); /* May have changed via aliasing.  */
1265             tem1 = Fassq (symbol,
1266                           (blv->frame_local
1267                            ? XFRAME (where)->param_alist
1268                            : XBUFFER (where)->local_var_alist));
1269             blv->where = where;
1270             blv->found = 1;
1271 
1272             if (NILP (tem1))
1273               {
1274                 /* This buffer still sees the default value.  */
1275 
1276                 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1277                    or if this is `let' rather than `set',
1278                    make CURRENT-ALIST-ELEMENT point to itself,
1279                    indicating that we're seeing the default value.
1280                    Likewise if the variable has been let-bound
1281                    in the current buffer.  */
1282                 if (bindflag || !blv->local_if_set
1283                     || let_shadows_buffer_binding_p (sym))
1284                   {
1285                     blv->found = 0;
1286                     tem1 = blv->defcell;
1287                   }
1288                 /* If it's a local_if_set, being set not bound,
1289                    and we're not within a let that was made for this buffer,
1290                    create a new buffer-local binding for the variable.
1291                    That means, give this buffer a new assoc for a local value
1292                    and load that binding.  */
1293                 else
1294                   {
1295                     /* local_if_set is only supported for buffer-local
1296                        bindings, not for frame-local bindings.  */
1297                     eassert (!blv->frame_local);
1298                     tem1 = Fcons (symbol, XCDR (blv->defcell));
1299                     XBUFFER (where)->local_var_alist
1300                       = Fcons (tem1, XBUFFER (where)->local_var_alist);
1301                   }
1302               }
1303 
1304             /* Record which binding is now loaded.  */
1305             blv->valcell = tem1;
1306           }
1307 
1308         /* Store the new value in the cons cell.  */
1309         SET_BLV_VALUE (blv, newval);
1310 
1311         if (blv->fwd)
1312           {
1313             if (voide)
1314               /* If storing void (making the symbol void), forward only through
1315                  buffer-local indicator, not through Lisp_Objfwd, etc.  */
1316               blv->fwd = NULL;
1317             else
1318               store_symval_forwarding (blv->fwd, newval,
1319                                        BUFFERP (where)
1320                                        ? XBUFFER (where) : current_buffer);
1321           }
1322         break;
1323       }
1324     case SYMBOL_FORWARDED:
1325       {
1326         struct buffer *buf
1327           = BUFFERP (where) ? XBUFFER (where) : current_buffer;
1328         union Lisp_Fwd *innercontents = SYMBOL_FWD (sym);
1329         if (BUFFER_OBJFWDP (innercontents))
1330           {
1331             int offset = XBUFFER_OBJFWD (innercontents)->offset;
1332             int idx = PER_BUFFER_IDX (offset);
1333             if (idx > 0
1334                 && !bindflag
1335                 && !let_shadows_buffer_binding_p (sym))
1336               SET_PER_BUFFER_VALUE_P (buf, idx, 1);
1337           }
1338 
1339         if (voide)
1340           { /* If storing void (making the symbol void), forward only through
1341                buffer-local indicator, not through Lisp_Objfwd, etc.  */
1342             sym->redirect = SYMBOL_PLAINVAL;
1343             SET_SYMBOL_VAL (sym, newval);
1344           }
1345         else
1346           store_symval_forwarding (/* sym, */ innercontents, newval, buf);
1347         break;
1348       }
1349     default: abort ();
1350     }
1351   return;
1352 }
1353 
1354 /* Access or set a buffer-local symbol's default value.  */
1355 
1356 /* Return the default value of SYMBOL, but don't check for voidness.
1357    Return Qunbound if it is void.  */
1358 
1359 Lisp_Object
1360 default_value (symbol)
1361      Lisp_Object symbol;
1362 {
1363   struct Lisp_Symbol *sym;
1364 
1365   CHECK_SYMBOL (symbol);
1366   sym = XSYMBOL (symbol);
1367 
1368  start:
1369   switch (sym->redirect)
1370     {
1371     case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
1372     case SYMBOL_PLAINVAL: return SYMBOL_VAL (sym);
1373     case SYMBOL_LOCALIZED:
1374       {
1375         /* If var is set up for a buffer that lacks a local value for it,
1376            the current value is nominally the default value.
1377            But the `realvalue' slot may be more up to date, since
1378            ordinary setq stores just that slot.  So use that.  */
1379         struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (sym);
1380         if (blv->fwd && EQ (blv->valcell, blv->defcell))
1381           return do_symval_forwarding (blv->fwd);
1382         else
1383           return XCDR (blv->defcell);
1384       }
1385     case SYMBOL_FORWARDED:
1386       {
1387         union Lisp_Fwd *valcontents = SYMBOL_FWD (sym);
1388 
1389         /* For a built-in buffer-local variable, get the default value
1390            rather than letting do_symval_forwarding get the current value.  */
1391         if (BUFFER_OBJFWDP (valcontents))
1392           {
1393             int offset = XBUFFER_OBJFWD (valcontents)->offset;
1394             if (PER_BUFFER_IDX (offset) != 0)
1395               return PER_BUFFER_DEFAULT (offset);
1396           }
1397 
1398         /* For other variables, get the current value.  */
1399         return do_symval_forwarding (valcontents);
1400       }
1401     default: abort ();
1402     }
1403 }
1404 
1405 DEFUN ("default-boundp", Fdefault_boundp, Sdefault_boundp, 1, 1, 0,
1406        doc: /* Return t if SYMBOL has a non-void default value.
1407 This is the value that is seen in buffers that do not have their own values
1408 for this variable.  */)
1409      (symbol)
1410      Lisp_Object symbol;
1411 {
1412   register Lisp_Object value;
1413 
1414   value = default_value (symbol);
1415   return (EQ (value, Qunbound) ? Qnil : Qt);
1416 }
1417 
1418 DEFUN ("default-value", Fdefault_value, Sdefault_value, 1, 1, 0,
1419        doc: /* Return SYMBOL's default value.
1420 This is the value that is seen in buffers that do not have their own values
1421 for this variable.  The default value is meaningful for variables with
1422 local bindings in certain buffers.  */)
1423      (symbol)
1424      Lisp_Object symbol;
1425 {
1426   register Lisp_Object value;
1427 
1428   value = default_value (symbol);
1429   if (!EQ (value, Qunbound))
1430     return value;
1431 
1432   xsignal1 (Qvoid_variable, symbol);
1433 }
1434 
1435 DEFUN ("set-default", Fset_default, Sset_default, 2, 2, 0,
1436        doc: /* Set SYMBOL's default value to VALUE.  SYMBOL and VALUE are evaluated.
1437 The default value is seen in buffers that do not have their own values
1438 for this variable.  */)
1439      (symbol, value)
1440      Lisp_Object symbol, value;
1441 {
1442   struct Lisp_Symbol *sym;
1443 
1444   CHECK_SYMBOL (symbol);
1445   if (SYMBOL_CONSTANT_P (symbol))
1446     {
1447       if (NILP (Fkeywordp (symbol))
1448           || !EQ (value, Fdefault_value (symbol)))
1449         xsignal1 (Qsetting_constant, symbol);
1450       else
1451         /* Allow setting keywords to their own value.  */
1452         return value;
1453     }
1454   sym = XSYMBOL (symbol);
1455 
1456  start:
1457   switch (sym->redirect)
1458     {
1459     case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
1460     case SYMBOL_PLAINVAL: return Fset (symbol, value);
1461     case SYMBOL_LOCALIZED:
1462       {
1463         struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (sym);
1464 
1465         /* Store new value into the DEFAULT-VALUE slot.  */
1466         XSETCDR (blv->defcell, value);
1467 
1468         /* If the default binding is now loaded, set the REALVALUE slot too.  */
1469         if (blv->fwd && EQ (blv->defcell, blv->valcell))
1470           store_symval_forwarding (blv->fwd, value, NULL);
1471         return value;
1472       }
1473     case SYMBOL_FORWARDED:
1474       {
1475         union Lisp_Fwd *valcontents = SYMBOL_FWD (sym);
1476 
1477         /* Handle variables like case-fold-search that have special slots
1478            in the buffer.
1479            Make them work apparently like Lisp_Buffer_Local_Value variables.  */
1480         if (BUFFER_OBJFWDP (valcontents))
1481           {
1482             int offset = XBUFFER_OBJFWD (valcontents)->offset;
1483             int idx = PER_BUFFER_IDX (offset);
1484 
1485             PER_BUFFER_DEFAULT (offset) = value;
1486 
1487             /* If this variable is not always local in all buffers,
1488                set it in the buffers that don't nominally have a local value.  */
1489             if (idx > 0)
1490               {
1491                 struct buffer *b;
1492 
1493                 for (b = all_buffers; b; b = b->next)
1494                   if (!PER_BUFFER_VALUE_P (b, idx))
1495                     PER_BUFFER_VALUE (b, offset) = value;
1496               }
1497             return value;
1498           }
1499         else
1500           return Fset (symbol, value);
1501       }
1502     default: abort ();
1503     }
1504 }
1505 
1506 DEFUN ("setq-default", Fsetq_default, Ssetq_default, 0, UNEVALLED, 0,
1507        doc: /* Set the default value of variable VAR to VALUE.
1508 VAR, the variable name, is literal (not evaluated);
1509 VALUE is an expression: it is evaluated and its value returned.
1510 The default value of a variable is seen in buffers
1511 that do not have their own values for the variable.
1512 
1513 More generally, you can use multiple variables and values, as in
1514   (setq-default VAR VALUE VAR VALUE...)
1515 This sets each VAR's default value to the corresponding VALUE.
1516 The VALUE for the Nth VAR can refer to the new default values
1517 of previous VARs.
1518 usage: (setq-default [VAR VALUE]...)  */)
1519      (args)
1520      Lisp_Object args;
1521 {
1522   register Lisp_Object args_left;
1523   register Lisp_Object val, symbol;
1524   struct gcpro gcpro1;
1525 
1526   if (NILP (args))
1527     return Qnil;
1528 
1529   args_left = args;
1530   GCPRO1 (args);
1531 
1532   do
1533     {
1534       val = Feval (Fcar (Fcdr (args_left)));
1535       symbol = XCAR (args_left);
1536       Fset_default (symbol, val);
1537       args_left = Fcdr (XCDR (args_left));
1538     }
1539   while (!NILP (args_left));
1540 
1541   UNGCPRO;
1542   return val;
1543 }
1544 
1545 /* Lisp functions for creating and removing buffer-local variables.  */
1546 
1547 union Lisp_Val_Fwd
1548   {
1549     Lisp_Object value;
1550     union Lisp_Fwd *fwd;
1551   };
1552 
1553 static struct Lisp_Buffer_Local_Value *
1554 make_blv (struct Lisp_Symbol *sym, int forwarded, union Lisp_Val_Fwd valcontents)
1555 {
1556   struct Lisp_Buffer_Local_Value *blv
1557     = xmalloc (sizeof (struct Lisp_Buffer_Local_Value));
1558   Lisp_Object symbol;
1559   Lisp_Object tem;
1560 
1561  XSETSYMBOL (symbol, sym);
1562  tem = Fcons (symbol, (forwarded
1563                        ? do_symval_forwarding (valcontents.fwd)
1564                        : valcontents.value));
1565 
1566   /* Buffer_Local_Values cannot have as realval a buffer-local
1567      or keyboard-local forwarding.  */
1568   eassert (!(forwarded && BUFFER_OBJFWDP (valcontents.fwd)));
1569   eassert (!(forwarded && KBOARD_OBJFWDP (valcontents.fwd)));
1570   blv->fwd = forwarded ? valcontents.fwd : NULL;
1571   blv->where = Qnil;
1572   blv->frame_local = 0;
1573   blv->local_if_set = 0;
1574   blv->defcell = tem;
1575   blv->valcell = tem;
1576   SET_BLV_FOUND (blv, 0);
1577   return blv;
1578 }
1579 
1580 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local, Smake_variable_buffer_local,
1581        1, 1, "vMake Variable Buffer Local: ",
1582        doc: /* Make VARIABLE become buffer-local whenever it is set.
1583 At any time, the value for the current buffer is in effect,
1584 unless the variable has never been set in this buffer,
1585 in which case the default value is in effect.
1586 Note that binding the variable with `let', or setting it while
1587 a `let'-style binding made in this buffer is in effect,
1588 does not make the variable buffer-local.  Return VARIABLE.
1589 
1590 In most cases it is better to use `make-local-variable',
1591 which makes a variable local in just one buffer.
1592 
1593 The function `default-value' gets the default value and `set-default' sets it.  */)
1594      (variable)
1595      register Lisp_Object variable;
1596 {
1597   struct Lisp_Symbol *sym;
1598   struct Lisp_Buffer_Local_Value *blv = NULL;
1599   union Lisp_Val_Fwd valcontents;
1600   int forwarded;
1601 
1602   CHECK_SYMBOL (variable);
1603   sym = XSYMBOL (variable);
1604 
1605  start:
1606   switch (sym->redirect)
1607     {
1608     case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
1609     case SYMBOL_PLAINVAL:
1610       forwarded = 0; valcontents.value = SYMBOL_VAL (sym);
1611       if (EQ (valcontents.value, Qunbound))
1612         valcontents.value = Qnil;
1613       break;
1614     case SYMBOL_LOCALIZED:
1615       blv = SYMBOL_BLV (sym);
1616       if (blv->frame_local)
1617         error ("Symbol %s may not be buffer-local",
1618                SDATA (SYMBOL_NAME (variable)));
1619       break;
1620     case SYMBOL_FORWARDED:
1621       forwarded = 1; valcontents.fwd = SYMBOL_FWD (sym);
1622       if (KBOARD_OBJFWDP (valcontents.fwd))
1623         error ("Symbol %s may not be buffer-local",
1624                SDATA (SYMBOL_NAME (variable)));
1625       else if (BUFFER_OBJFWDP (valcontents.fwd))
1626         return variable;
1627       break;
1628     default: abort ();
1629     }
1630 
1631   if (sym->constant)
1632     error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable)));
1633 
1634   if (!blv)
1635     {
1636       blv = make_blv (sym, forwarded, valcontents);
1637       sym->redirect = SYMBOL_LOCALIZED;
1638       SET_SYMBOL_BLV (sym, blv);
1639       {
1640         Lisp_Object symbol;
1641         XSETSYMBOL (symbol, sym); /* In case `variable' is aliased.  */
1642         if (let_shadows_global_binding_p (symbol))
1643           message ("Making %s buffer-local while let-bound!",
1644                    SDATA (SYMBOL_NAME (variable)));
1645       }
1646     }
1647 
1648   blv->local_if_set = 1;
1649   return variable;
1650 }
1651 
1652 DEFUN ("make-local-variable", Fmake_local_variable, Smake_local_variable,
1653        1, 1, "vMake Local Variable: ",
1654        doc: /* Make VARIABLE have a separate value in the current buffer.
1655 Other buffers will continue to share a common default value.
1656 \(The buffer-local value of VARIABLE starts out as the same value
1657 VARIABLE previously had.  If VARIABLE was void, it remains void.\)
1658 Return VARIABLE.
1659 
1660 If the variable is already arranged to become local when set,
1661 this function causes a local value to exist for this buffer,
1662 just as setting the variable would do.
1663 
1664 This function returns VARIABLE, and therefore
1665   (set (make-local-variable 'VARIABLE) VALUE-EXP)
1666 works.
1667 
1668 See also `make-variable-buffer-local'.
1669 
1670 Do not use `make-local-variable' to make a hook variable buffer-local.
1671 Instead, use `add-hook' and specify t for the LOCAL argument.  */)
1672      (variable)
1673      register Lisp_Object variable;
1674 {
1675   register Lisp_Object tem;
1676   int forwarded;
1677   union Lisp_Val_Fwd valcontents;
1678   struct Lisp_Symbol *sym;
1679   struct Lisp_Buffer_Local_Value *blv = NULL;
1680 
1681   CHECK_SYMBOL (variable);
1682   sym = XSYMBOL (variable);
1683 
1684  start:
1685   switch (sym->redirect)
1686     {
1687     case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
1688     case SYMBOL_PLAINVAL:
1689       forwarded = 0; valcontents.value = SYMBOL_VAL (sym); break;
1690     case SYMBOL_LOCALIZED:
1691       blv = SYMBOL_BLV (sym);
1692       if (blv->frame_local)
1693         error ("Symbol %s may not be buffer-local",
1694                SDATA (SYMBOL_NAME (variable)));
1695       break;
1696     case SYMBOL_FORWARDED:
1697       forwarded = 1; valcontents.fwd = SYMBOL_FWD (sym);
1698       if (KBOARD_OBJFWDP (valcontents.fwd))
1699         error ("Symbol %s may not be buffer-local",
1700                SDATA (SYMBOL_NAME (variable)));
1701       break;
1702     default: abort ();
1703     }
1704 
1705   if (sym->constant)
1706     error ("Symbol %s may not be buffer-local",
1707            SDATA (SYMBOL_NAME (variable)));
1708 
1709   if (blv ? blv->local_if_set
1710       : (forwarded && BUFFER_OBJFWDP (valcontents.fwd)))
1711     {
1712       tem = Fboundp (variable);
1713       /* Make sure the symbol has a local value in this particular buffer,
1714          by setting it to the same value it already has.  */
1715       Fset (variable, (EQ (tem, Qt) ? Fsymbol_value (variable) : Qunbound));
1716       return variable;
1717     }
1718   if (!blv)
1719     {
1720       blv = make_blv (sym, forwarded, valcontents);
1721       sym->redirect = SYMBOL_LOCALIZED;
1722       SET_SYMBOL_BLV (sym, blv);
1723       {
1724         Lisp_Object symbol;
1725         XSETSYMBOL (symbol, sym); /* In case `variable' is aliased.  */
1726         if (let_shadows_global_binding_p (symbol))
1727           message ("Making %s local to %s while let-bound!",
1728                    SDATA (SYMBOL_NAME (variable)),
1729                    SDATA (current_buffer->name));
1730       }
1731     }
1732 
1733   /* Make sure this buffer has its own value of symbol.  */
1734   XSETSYMBOL (variable, sym);   /* Update in case of aliasing.  */
1735   tem = Fassq (variable, current_buffer->local_var_alist);
1736   if (NILP (tem))
1737     {
1738       if (let_shadows_buffer_binding_p (sym))
1739         message ("Making %s buffer-local while locally let-bound!",
1740                  SDATA (SYMBOL_NAME (variable)));
1741 
1742       /* Swap out any local binding for some other buffer, and make
1743          sure the current value is permanently recorded, if it's the
1744          default value.  */
1745       find_symbol_value (variable);
1746 
1747       current_buffer->local_var_alist
1748         = Fcons (Fcons (variable, XCDR (blv->defcell)),
1749                  current_buffer->local_var_alist);
1750 
1751       /* Make sure symbol does not think it is set up for this buffer;
1752          force it to look once again for this buffer's value.  */
1753       if (current_buffer == XBUFFER (blv->where))
1754         blv->where = Qnil;
1755       /* blv->valcell = blv->defcell;
1756        * SET_BLV_FOUND (blv, 0); */
1757       blv->found = 0;
1758     }
1759 
1760   /* If the symbol forwards into a C variable, then load the binding
1761      for this buffer now.  If C code modifies the variable before we
1762      load the binding in, then that new value will clobber the default
1763      binding the next time we unload it.  */
1764   if (blv->fwd)
1765     swap_in_symval_forwarding (sym, blv);
1766 
1767   return variable;
1768 }
1769 
1770 DEFUN ("kill-local-variable", Fkill_local_variable, Skill_local_variable,
1771        1, 1, "vKill Local Variable: ",
1772        doc: /* Make VARIABLE no longer have a separate value in the current buffer.
1773 From now on the default value will apply in this buffer.  Return VARIABLE.  */)
1774      (variable)
1775      register Lisp_Object variable;
1776 {
1777   register Lisp_Object tem;
1778   struct Lisp_Buffer_Local_Value *blv;
1779   struct Lisp_Symbol *sym;
1780 
1781   CHECK_SYMBOL (variable);
1782   sym = XSYMBOL (variable);
1783 
1784  start:
1785   switch (sym->redirect)
1786     {
1787     case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
1788     case SYMBOL_PLAINVAL: return variable;
1789     case SYMBOL_FORWARDED:
1790       {
1791         union Lisp_Fwd *valcontents = SYMBOL_FWD (sym);
1792         if (BUFFER_OBJFWDP (valcontents))
1793           {
1794             int offset = XBUFFER_OBJFWD (valcontents)->offset;
1795             int idx = PER_BUFFER_IDX (offset);
1796 
1797             if (idx > 0)
1798               {
1799                 SET_PER_BUFFER_VALUE_P (current_buffer, idx, 0);
1800                 PER_BUFFER_VALUE (current_buffer, offset)
1801                   = PER_BUFFER_DEFAULT (offset);
1802               }
1803           }
1804         return variable;
1805       }
1806     case SYMBOL_LOCALIZED:
1807       blv = SYMBOL_BLV (sym);
1808       if (blv->frame_local)
1809         return variable;
1810       break;
1811     default: abort ();
1812     }
1813 
1814   /* Get rid of this buffer's alist element, if any.  */
1815   XSETSYMBOL (variable, sym);   /* Propagate variable indirection.  */
1816   tem = Fassq (variable, current_buffer->local_var_alist);
1817   if (!NILP (tem))
1818     current_buffer->local_var_alist
1819       = Fdelq (tem, current_buffer->local_var_alist);
1820 
1821   /* If the symbol is set up with the current buffer's binding
1822      loaded, recompute its value.  We have to do it now, or else
1823      forwarded objects won't work right.  */
1824   {
1825     Lisp_Object buf; XSETBUFFER (buf, current_buffer);
1826     if (EQ (buf, blv->where))
1827       {
1828         blv->where = Qnil;
1829         /* blv->valcell = blv->defcell;
1830          * SET_BLV_FOUND (blv, 0); */
1831         blv->found = 0;
1832         find_symbol_value (variable);
1833       }
1834   }
1835 
1836   return variable;
1837 }
1838 
1839 /* Lisp functions for creating and removing buffer-local variables.  */
1840 
1841 /* Obsolete since 22.2.  NB adjust doc of modify-frame-parameters
1842    when/if this is removed.  */
1843 
1844 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local, Smake_variable_frame_local,
1845        1, 1, "vMake Variable Frame Local: ",
1846        doc: /* Enable VARIABLE to have frame-local bindings.
1847 This does not create any frame-local bindings for VARIABLE,
1848 it just makes them possible.
1849 
1850 A frame-local binding is actually a frame parameter value.
1851 If a frame F has a value for the frame parameter named VARIABLE,
1852 that also acts as a frame-local binding for VARIABLE in F--
1853 provided this function has been called to enable VARIABLE
1854 to have frame-local bindings at all.
1855 
1856 The only way to create a frame-local binding for VARIABLE in a frame
1857 is to set the VARIABLE frame parameter of that frame.  See
1858 `modify-frame-parameters' for how to set frame parameters.
1859 
1860 Note that since Emacs 23.1, variables cannot be both buffer-local and
1861 frame-local any more (buffer-local bindings used to take precedence over
1862 frame-local bindings).  */)
1863      (variable)
1864      register Lisp_Object variable;
1865 {
1866   int forwarded;
1867   union Lisp_Val_Fwd valcontents;
1868   struct Lisp_Symbol *sym;
1869   struct Lisp_Buffer_Local_Value *blv = NULL;
1870 
1871   CHECK_SYMBOL (variable);
1872   sym = XSYMBOL (variable);
1873 
1874  start:
1875   switch (sym->redirect)
1876     {
1877     case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
1878     case SYMBOL_PLAINVAL:
1879       forwarded = 0; valcontents.value = SYMBOL_VAL (sym);
1880       if (EQ (valcontents.value, Qunbound))
1881         valcontents.value = Qnil;
1882       break;
1883     case SYMBOL_LOCALIZED:
1884       if (SYMBOL_BLV (sym)->frame_local)
1885         return variable;
1886       else
1887         error ("Symbol %s may not be frame-local",
1888                SDATA (SYMBOL_NAME (variable)));
1889     case SYMBOL_FORWARDED:
1890       forwarded = 1; valcontents.fwd = SYMBOL_FWD (sym);
1891       if (KBOARD_OBJFWDP (valcontents.fwd) || BUFFER_OBJFWDP (valcontents.fwd))
1892         error ("Symbol %s may not be frame-local",
1893                SDATA (SYMBOL_NAME (variable)));
1894       break;
1895     default: abort ();
1896     }
1897 
1898   if (sym->constant)
1899     error ("Symbol %s may not be frame-local", SDATA (SYMBOL_NAME (variable)));
1900 
1901   blv = make_blv (sym, forwarded, valcontents);
1902   blv->frame_local = 1;
1903   sym->redirect = SYMBOL_LOCALIZED;
1904   SET_SYMBOL_BLV (sym, blv);
1905   {
1906     Lisp_Object symbol;
1907     XSETSYMBOL (symbol, sym); /* In case `variable' is aliased.  */
1908     if (let_shadows_global_binding_p (symbol))
1909       message ("Making %s frame-local while let-bound!",
1910                SDATA (SYMBOL_NAME (variable)));
1911   }
1912   return variable;
1913 }
1914 
1915 DEFUN ("local-variable-p", Flocal_variable_p, Slocal_variable_p,
1916        1, 2, 0,
1917        doc: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
1918 BUFFER defaults to the current buffer.  */)
1919      (variable, buffer)
1920      register Lisp_Object variable, buffer;
1921 {
1922   register struct buffer *buf;
1923   struct Lisp_Symbol *sym;
1924 
1925   if (NILP (buffer))
1926     buf = current_buffer;
1927   else
1928     {
1929       CHECK_BUFFER (buffer);
1930       buf = XBUFFER (buffer);
1931     }
1932 
1933   CHECK_SYMBOL (variable);
1934   sym = XSYMBOL (variable);
1935 
1936  start:
1937   switch (sym->redirect)
1938     {
1939     case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
1940     case SYMBOL_PLAINVAL: return Qnil;
1941     case SYMBOL_LOCALIZED:
1942       {
1943         Lisp_Object tail, elt, tmp;
1944         struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (sym);
1945         XSETBUFFER (tmp, buf);
1946         
1947         for (tail = buf->local_var_alist; CONSP (tail); tail = XCDR (tail))
1948           {
1949             elt = XCAR (tail);
1950             if (EQ (variable, XCAR (elt)))
1951               {
1952                 eassert (!blv->frame_local);
1953                 eassert (BLV_FOUND (blv) || !EQ (blv->where, tmp));
1954                 return Qt;
1955               }
1956           }
1957         eassert (!BLV_FOUND (blv) || !EQ (blv->where, tmp));
1958         return Qnil;
1959       }
1960     case SYMBOL_FORWARDED:
1961       {
1962         union Lisp_Fwd *valcontents = SYMBOL_FWD (sym);
1963         if (BUFFER_OBJFWDP (valcontents))
1964           {
1965             int offset = XBUFFER_OBJFWD (valcontents)->offset;
1966             int idx = PER_BUFFER_IDX (offset);
1967             if (idx == -1 || PER_BUFFER_VALUE_P (buf, idx))
1968               return Qt;
1969           }
1970         return Qnil;
1971       }
1972     default: abort ();
1973     }
1974 }
1975 
1976 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p, Slocal_variable_if_set_p,
1977        1, 2, 0,
1978        doc: /* Non-nil if VARIABLE will be local in buffer BUFFER when set there.
1979 More precisely, this means that setting the variable \(with `set' or`setq'),
1980 while it does not have a `let'-style binding that was made in BUFFER,
1981 will produce a buffer local binding.  See Info node
1982 `(elisp)Creating Buffer-Local'.
1983 BUFFER defaults to the current buffer.  */)
1984      (variable, buffer)
1985      register Lisp_Object variable, buffer;
1986 {
1987   struct Lisp_Symbol *sym;
1988 
1989   CHECK_SYMBOL (variable);
1990   sym = XSYMBOL (variable);
1991 
1992  start:
1993   switch (sym->redirect)
1994     {
1995     case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
1996     case SYMBOL_PLAINVAL: return Qnil;
1997     case SYMBOL_LOCALIZED:
1998       {
1999         struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (sym);
2000         if (blv->local_if_set)
2001           return Qt;
2002         XSETSYMBOL (variable, sym); /* Update in case of aliasing.  */
2003         return Flocal_variable_p (variable, buffer);
2004       }
2005     case SYMBOL_FORWARDED:
2006       /* All BUFFER_OBJFWD slots become local if they are set.  */
2007       return (BUFFER_OBJFWDP (SYMBOL_FWD (sym)) ? Qt : Qnil);
2008     default: abort ();
2009     }
2010 }
2011 
2012 DEFUN ("variable-binding-locus", Fvariable_binding_locus, Svariable_binding_locus,
2013        1, 1, 0,
2014        doc: /* Return a value indicating where VARIABLE's current binding comes from.
2015 If the current binding is buffer-local, the value is the current buffer.
2016 If the current binding is frame-local, the value is the selected frame.
2017 If the current binding is global (the default), the value is nil.  */)
2018      (variable)
2019      register Lisp_Object variable;
2020 {
2021   struct Lisp_Symbol *sym;
2022 
2023   CHECK_SYMBOL (variable);
2024   sym = XSYMBOL (variable);
2025 
2026   /* Make sure the current binding is actually swapped in.  */
2027   find_symbol_value (variable);
2028 
2029  start:
2030   switch (sym->redirect)
2031     {
2032     case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
2033     case SYMBOL_PLAINVAL: return Qnil;
2034     case SYMBOL_FORWARDED:
2035       {
2036         union Lisp_Fwd *valcontents = SYMBOL_FWD (sym);
2037         if (KBOARD_OBJFWDP (valcontents))
2038           return Fframe_terminal (Fselected_frame ());
2039         else if (!BUFFER_OBJFWDP (valcontents))
2040           return Qnil;
2041       }
2042       /* FALLTHROUGH */
2043     case SYMBOL_LOCALIZED:
2044       /* For a local variable, record both the symbol and which
2045          buffer's or frame's value we are saving.  */
2046       if (!NILP (Flocal_variable_p (variable, Qnil)))
2047         return Fcurrent_buffer ();
2048       else if (sym->redirect == SYMBOL_LOCALIZED
2049                && BLV_FOUND (SYMBOL_BLV (sym)))
2050         return SYMBOL_BLV (sym)->where;
2051       else
2052         return Qnil;
2053     default: abort ();
2054     }
2055 }
2056 
2057 /* This code is disabled now that we use the selected frame to return
2058    keyboard-local-values. */
2059 #if 0
2060 extern struct terminal *get_terminal P_ ((Lisp_Object display, int));
2061 
2062 DEFUN ("terminal-local-value", Fterminal_local_value, Sterminal_local_value, 2, 2, 0,
2063        doc: /* Return the terminal-local value of SYMBOL on TERMINAL.
2064 If SYMBOL is not a terminal-local variable, then return its normal
2065 value, like `symbol-value'.
2066 
2067 TERMINAL may be a terminal object, a frame, or nil (meaning the
2068 selected frame's terminal device).  */)
2069   (symbol, terminal)
2070      Lisp_Object symbol;
2071      Lisp_Object terminal;
2072 {
2073   Lisp_Object result;
2074   struct terminal *t = get_terminal (terminal, 1);
2075   push_kboard (t->kboard);
2076   result = Fsymbol_value (symbol);
2077   pop_kboard ();
2078   return result;
2079 }
2080 
2081 DEFUN ("set-terminal-local-value", Fset_terminal_local_value, Sset_terminal_local_value, 3, 3, 0,
2082        doc: /* Set the terminal-local binding of SYMBOL on TERMINAL to VALUE.
2083 If VARIABLE is not a terminal-local variable, then set its normal
2084 binding, like `set'.
2085 
2086 TERMINAL may be a terminal object, a frame, or nil (meaning the
2087 selected frame's terminal device).  */)
2088   (symbol, terminal, value)
2089      Lisp_Object symbol;
2090      Lisp_Object terminal;
2091      Lisp_Object value;
2092 {
2093   Lisp_Object result;
2094   struct terminal *t = get_terminal (terminal, 1);
2095   push_kboard (d->kboard);
2096   result = Fset (symbol, value);
2097   pop_kboard ();
2098   return result;
2099 }
2100 #endif
2101 
2102 /* Find the function at the end of a chain of symbol function indirections.  */
2103 
2104 /* If OBJECT is a symbol, find the end of its function chain and
2105    return the value found there.  If OBJECT is not a symbol, just
2106    return it.  If there is a cycle in the function chain, signal a
2107    cyclic-function-indirection error.
2108 
2109    This is like Findirect_function, except that it doesn't signal an
2110    error if the chain ends up unbound.  */
2111 Lisp_Object
2112 indirect_function (object)
2113      register Lisp_Object object;
2114 {
2115   Lisp_Object tortoise, hare;
2116 
2117   hare = tortoise = object;
2118 
2119   for (;;)
2120     {
2121       if (!SYMBOLP (hare) || EQ (hare, Qunbound))
2122         break;
2123       hare = XSYMBOL (hare)->function;
2124       if (!SYMBOLP (hare) || EQ (hare, Qunbound))
2125         break;
2126       hare = XSYMBOL (hare)->function;
2127 
2128       tortoise = XSYMBOL (tortoise)->function;
2129 
2130       if (EQ (hare, tortoise))
2131         xsignal1 (Qcyclic_function_indirection, object);
2132     }
2133 
2134   return hare;
2135 }
2136 
2137 DEFUN ("indirect-function", Findirect_function, Sindirect_function, 1, 2, 0,
2138        doc: /* Return the function at the end of OBJECT's function chain.
2139 If OBJECT is not a symbol, just return it.  Otherwise, follow all
2140 function indirections to find the final function binding and return it.
2141 If the final symbol in the chain is unbound, signal a void-function error.
2142 Optional arg NOERROR non-nil means to return nil instead of signalling.
2143 Signal a cyclic-function-indirection error if there is a loop in the
2144 function chain of symbols.  */)
2145      (object, noerror)
2146      register Lisp_Object object;
2147      Lisp_Object noerror;
2148 {
2149   Lisp_Object result;
2150 
2151   /* Optimize for no indirection.  */
2152   result = object;
2153   if (SYMBOLP (result) && !EQ (result, Qunbound)
2154       && (result = XSYMBOL (result)->function, SYMBOLP (result)))
2155     result = indirect_function (result);
2156   if (!EQ (result, Qunbound))
2157     return result;
2158 
2159   if (NILP (noerror))
2160     xsignal1 (Qvoid_function, object);
2161 
2162   return Qnil;
2163 }
2164 
2165 /* Extract and set vector and string elements */
2166 
2167 DEFUN ("aref", Faref, Saref, 2, 2, 0,
2168        doc: /* Return the element of ARRAY at index IDX.
2169 ARRAY may be a vector, a string, a char-table, a bool-vector,
2170 or a byte-code object.  IDX starts at 0.  */)
2171      (array, idx)
2172      register Lisp_Object array;
2173      Lisp_Object idx;
2174 {
2175   register int idxval;
2176 
2177   CHECK_NUMBER (idx);
2178   idxval = XINT (idx);
2179   if (STRINGP (array))
2180     {
2181       int c, idxval_byte;
2182 
2183       if (idxval < 0 || idxval >= SCHARS (array))
2184         args_out_of_range (array, idx);
2185       if (! STRING_MULTIBYTE (array))
2186         return make_number ((unsigned char) SREF (array, idxval));
2187       idxval_byte = string_char_to_byte (array, idxval);
2188 
2189       c = STRING_CHAR (SDATA (array) + idxval_byte);
2190       return make_number (c);
2191     }
2192   else if (BOOL_VECTOR_P (array))
2193     {
2194       int val;
2195 
2196       if (idxval < 0 || idxval >= XBOOL_VECTOR (array)->size)
2197         args_out_of_range (array, idx);
2198 
2199       val = (unsigned char) XBOOL_VECTOR (array)->data[idxval / BOOL_VECTOR_BITS_PER_CHAR];
2200       return (val & (1 << (idxval % BOOL_VECTOR_BITS_PER_CHAR)) ? Qt : Qnil);
2201     }
2202   else if (CHAR_TABLE_P (array))
2203     {
2204       CHECK_CHARACTER (idx);
2205       return CHAR_TABLE_REF (array, idxval);
2206     }
2207   else
2208     {
2209       int size = 0;
2210       if (VECTORP (array))
2211         size = XVECTOR (array)->size;
2212       else if (COMPILEDP (array))
2213         size = XVECTOR (array)->size & PSEUDOVECTOR_SIZE_MASK;
2214       else
2215         wrong_type_argument (Qarrayp, array);
2216 
2217       if (idxval < 0 || idxval >= size)
2218         args_out_of_range (array, idx);
2219       return XVECTOR (array)->contents[idxval];
2220     }
2221 }
2222 
2223 DEFUN ("aset", Faset, Saset, 3, 3, 0,
2224        doc: /* Store into the element of ARRAY at index IDX the value NEWELT.
2225 Return NEWELT.  ARRAY may be a vector, a string, a char-table or a
2226 bool-vector.  IDX starts at 0.  */)
2227      (array, idx, newelt)
2228      register Lisp_Object array;
2229      Lisp_Object idx, newelt;
2230 {
2231   register int idxval;
2232 
2233   CHECK_NUMBER (idx);
2234   idxval = XINT (idx);
2235   CHECK_ARRAY (array, Qarrayp);
2236   CHECK_IMPURE (array);
2237 
2238   if (VECTORP (array))
2239     {
2240       if (idxval < 0 || idxval >= XVECTOR (array)->size)
2241         args_out_of_range (array, idx);
2242       XVECTOR (array)->contents[idxval] = newelt;
2243     }
2244   else if (BOOL_VECTOR_P (array))
2245     {
2246       int val;
2247 
2248       if (idxval < 0 || idxval >= XBOOL_VECTOR (array)->size)
2249         args_out_of_range (array, idx);
2250 
2251       val = (unsigned char) XBOOL_VECTOR (array)->data[idxval / BOOL_VECTOR_BITS_PER_CHAR];
2252 
2253       if (! NILP (newelt))
2254         val |= 1 << (idxval % BOOL_VECTOR_BITS_PER_CHAR);
2255       else
2256         val &= ~(1 << (idxval % BOOL_VECTOR_BITS_PER_CHAR));
2257       XBOOL_VECTOR (array)->data[idxval / BOOL_VECTOR_BITS_PER_CHAR] = val;
2258     }
2259   else if (CHAR_TABLE_P (array))
2260     {
2261       CHECK_CHARACTER (idx);
2262       CHAR_TABLE_SET (array, idxval, newelt);
2263     }
2264   else if (STRING_MULTIBYTE (array))
2265     {
2266       int idxval_byte, prev_bytes, new_bytes, nbytes;
2267       unsigned char workbuf[MAX_MULTIBYTE_LENGTH], *p0 = workbuf, *p1;
2268 
2269       if (idxval < 0 || idxval >= SCHARS (array))
2270         args_out_of_range (array, idx);
2271       CHECK_CHARACTER (newelt);
2272 
2273       nbytes = SBYTES (array);
2274 
2275       idxval_byte = string_char_to_byte (array, idxval);
2276       p1 = SDATA (array) + idxval_byte;
2277       PARSE_MULTIBYTE_SEQ (p1, nbytes - idxval_byte, prev_bytes);
2278       new_bytes = CHAR_STRING (XINT (newelt), p0);
2279       if (prev_bytes != new_bytes)
2280         {
2281           /* We must relocate the string data.  */
2282           int nchars = SCHARS (array);
2283           unsigned char *str;
2284           USE_SAFE_ALLOCA;
2285 
2286           SAFE_ALLOCA (str, unsigned char *, nbytes);
2287           bcopy (SDATA (array), str, nbytes);
2288           allocate_string_data (XSTRING (array), nchars,
2289                                 nbytes + new_bytes - prev_bytes);
2290           bcopy (str, SDATA (array), idxval_byte);
2291           p1 = SDATA (array) + idxval_byte;
2292           bcopy (str + idxval_byte + prev_bytes, p1 + new_bytes,
2293                  nbytes - (idxval_byte + prev_bytes));
2294           SAFE_FREE ();
2295           clear_string_char_byte_cache ();
2296         }
2297       while (new_bytes--)
2298         *p1++ = *p0++;
2299     }
2300   else
2301     {
2302       if (idxval < 0 || idxval >= SCHARS (array))
2303         args_out_of_range (array, idx);
2304       CHECK_NUMBER (newelt);
2305 
2306       if (XINT (newelt) >= 0 && ! SINGLE_BYTE_CHAR_P (XINT (newelt)))
2307         {
2308           int i;
2309 
2310           for (i = SBYTES (array) - 1; i >= 0; i--)
2311             if (SREF (array, i) >= 0x80)
2312               args_out_of_range (array, newelt);
2313           /* ARRAY is an ASCII string.  Convert it to a multibyte
2314              string, and try `aset' again.  */
2315           STRING_SET_MULTIBYTE (array);
2316           return Faset (array, idx, newelt);
2317         }
2318       SSET (array, idxval, XINT (newelt));
2319     }
2320 
2321   return newelt;
2322 }
2323 
2324 /* Arithmetic functions */
2325 
2326 enum comparison { equal, notequal, less, grtr, less_or_equal, grtr_or_equal };
2327 
2328 Lisp_Object
2329 arithcompare (num1, num2, comparison)
2330      Lisp_Object num1, num2;
2331      enum comparison comparison;
2332 {
2333   double f1 = 0, f2 = 0;
2334   int floatp = 0;
2335 
2336   CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1);
2337   CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2);
2338 
2339   if (FLOATP (num1) || FLOATP (num2))
2340     {
2341       floatp = 1;
2342       f1 = (FLOATP (num1)) ? XFLOAT_DATA (num1) : XINT (num1);
2343       f2 = (FLOATP (num2)) ? XFLOAT_DATA (num2) : XINT (num2);
2344     }
2345 
2346   switch (comparison)
2347     {
2348     case equal:
2349       if (floatp ? f1 == f2 : XINT (num1) == XINT (num2))
2350         return Qt;
2351       return Qnil;
2352 
2353     case notequal:
2354       if (floatp ? f1 != f2 : XINT (num1) != XINT (num2))
2355         return Qt;
2356       return Qnil;
2357 
2358     case less:
2359       if (floatp ? f1 < f2 : XINT (num1) < XINT (num2))
2360         return Qt;
2361       return Qnil;
2362 
2363     case less_or_equal:
2364       if (floatp ? f1 <= f2 : XINT (num1) <= XINT (num2))
2365         return Qt;
2366       return Qnil;
2367 
2368     case grtr:
2369       if (floatp ? f1 > f2 : XINT (num1) > XINT (num2))
2370         return Qt;
2371       return Qnil;
2372 
2373     case grtr_or_equal:
2374       if (floatp ? f1 >= f2 : XINT (num1) >= XINT (num2))
2375         return Qt;
2376       return Qnil;
2377 
2378     default:
2379       abort ();
2380     }
2381 }
2382 
2383 DEFUN ("=", Feqlsign, Seqlsign, 2, 2, 0,
2384        doc: /* Return t if two args, both numbers or markers, are equal.  */)
2385      (num1, num2)
2386      register Lisp_Object num1, num2;
2387 {
2388   return arithcompare (num1, num2, equal);
2389 }
2390 
2391 DEFUN ("<", Flss, Slss, 2, 2, 0,
2392        doc: /* Return t if first arg is less than second arg.  Both must be numbers or markers.  */)
2393      (num1, num2)
2394      register Lisp_Object num1, num2;
2395 {
2396   return arithcompare (num1, num2, less);
2397 }
2398 
2399 DEFUN (">", Fgtr, Sgtr, 2, 2, 0,
2400        doc: /* Return t if first arg is greater than second arg.  Both must be numbers or markers.  */)
2401      (num1, num2)
2402      register Lisp_Object num1, num2;
2403 {
2404   return arithcompare (num1, num2, grtr);
2405 }
2406 
2407 DEFUN ("<=", Fleq, Sleq, 2, 2, 0,
2408        doc: /* Return t if first arg is less than or equal to second arg.
2409 Both must be numbers or markers.  */)
2410      (num1, num2)
2411      register Lisp_Object num1, num2;
2412 {
2413   return arithcompare (num1, num2, less_or_equal);
2414 }
2415 
2416 DEFUN (">=", Fgeq, Sgeq, 2, 2, 0,
2417        doc: /* Return t if first arg is greater than or equal to second arg.
2418 Both must be numbers or markers.  */)
2419      (num1, num2)
2420      register Lisp_Object num1, num2;
2421 {
2422   return arithcompare (num1, num2, grtr_or_equal);
2423 }
2424 
2425 DEFUN ("/=", Fneq, Sneq, 2, 2, 0,
2426        doc: /* Return t if first arg is not equal to second arg.  Both must be numbers or markers.  */)
2427      (num1, num2)
2428      register Lisp_Object num1, num2;
2429 {
2430   return arithcompare (num1, num2, notequal);
2431 }
2432 
2433 DEFUN ("zerop", Fzerop, Szerop, 1, 1, 0,
2434        doc: /* Return t if NUMBER is zero.  */)
2435      (number)
2436      register Lisp_Object number;
2437 {
2438   CHECK_NUMBER_OR_FLOAT (number);
2439 
2440   if (FLOATP (number))
2441     {
2442       if (XFLOAT_DATA (number) == 0.0)
2443         return Qt;
2444       return Qnil;
2445     }
2446 
2447   if (!XINT (number))
2448     return Qt;
2449   return Qnil;
2450 }
2451 
2452 /* Convert between long values and pairs of Lisp integers.
2453    Note that long_to_cons returns a single Lisp integer
2454    when the value fits in one.  */
2455 
2456 Lisp_Object
2457 long_to_cons (i)
2458      unsigned long i;
2459 {
2460   unsigned long top = i >> 16;
2461   unsigned int bot = i & 0xFFFF;
2462   if (top == 0)
2463     return make_number (bot);
2464   if (top == (unsigned long)-1 >> 16)
2465     return Fcons (make_number (-1), make_number (bot));
2466   return Fcons (make_number (top), make_number (bot));
2467 }
2468 
2469 unsigned long
2470 cons_to_long (c)
2471      Lisp_Object c;
2472 {
2473   Lisp_Object top, bot;
2474   if (INTEGERP (c))
2475     return XINT (c);
2476   top = XCAR (c);
2477   bot = XCDR (c);
2478   if (CONSP (bot))
2479     bot = XCAR (bot);
2480   return ((XINT (top) << 16) | XINT (bot));
2481 }
2482 
2483 DEFUN ("number-to-string", Fnumber_to_string, Snumber_to_string, 1, 1, 0,
2484        doc: /* Return the decimal representation of NUMBER as a string.
2485 Uses a minus sign if negative.
2486 NUMBER may be an integer or a floating point number.  */)
2487      (number)
2488      Lisp_Object number;
2489 {
2490   char buffer[VALBITS];
2491 
2492   CHECK_NUMBER_OR_FLOAT (number);
2493 
2494   if (FLOATP (number))
2495     {
2496       char pigbuf[350]; /* see comments in float_to_string */
2497 
2498       float_to_string (pigbuf, XFLOAT_DATA (number));
2499       return build_string (pigbuf);
2500     }
2501 
2502   if (sizeof (int) == sizeof (EMACS_INT))
2503     sprintf (buffer, "%d", (int) XINT (number));
2504   else if (sizeof (long) == sizeof (EMACS_INT))
2505     sprintf (buffer, "%ld", (long) XINT (number));
2506   else
2507     abort ();
2508   return build_string (buffer);
2509 }
2510 
2511 INLINE static int
2512 digit_to_number (character, base)
2513      int character, base;
2514 {
2515   int digit;
2516 
2517   if (character >= '0' && character <= '9')
2518     digit = character - '0';
2519   else if (character >= 'a' && character <= 'z')
2520     digit = character - 'a' + 10;
2521   else if (character >= 'A' && character <= 'Z')
2522     digit = character - 'A' + 10;
2523   else
2524     return -1;
2525 
2526   if (digit >= base)
2527     return -1;
2528   else
2529     return digit;
2530 }
2531 
2532 DEFUN ("string-to-number", Fstring_to_number, Sstring_to_number, 1, 2, 0,
2533        doc: /* Parse STRING as a decimal number and return the number.
2534 This parses both integers and floating point numbers.
2535 It ignores leading spaces and tabs, and all trailing chars.
2536 
2537 If BASE, interpret STRING as a number in that base.  If BASE isn't
2538 present, base 10 is used.  BASE must be between 2 and 16 (inclusive).
2539 If the base used is not 10, STRING is always parsed as integer.  */)
2540      (string, base)
2541      register Lisp_Object string, base;
2542 {
2543   register unsigned char *p;
2544   register int b;
2545   int sign = 1;
2546   Lisp_Object val;
2547 
2548   CHECK_STRING (string);
2549 
2550   if (NILP (base))
2551     b = 10;
2552   else
2553     {
2554       CHECK_NUMBER (base);
2555       b = XINT (base);
2556       if (b < 2 || b > 16)
2557         xsignal1 (Qargs_out_of_range, base);
2558     }
2559 
2560   /* Skip any whitespace at the front of the number.  Some versions of
2561      atoi do this anyway, so we might as well make Emacs lisp consistent.  */
2562   p = SDATA (string);
2563   while (*p == ' ' || *p == '\t')
2564     p++;
2565 
2566   if (*p == '-')
2567     {
2568       sign = -1;
2569       p++;
2570     }
2571   else if (*p == '+')
2572     p++;
2573 
2574   if (isfloat_string (p, 1) && b == 10)
2575     val = make_float (sign * atof (p));
2576   else
2577     {
2578       double v = 0;
2579 
2580       while (1)
2581         {
2582           int digit = digit_to_number (*p++, b);
2583           if (digit < 0)
2584             break;
2585           v = v * b + digit;
2586         }
2587 
2588       val = make_fixnum_or_float (sign * v);
2589     }
2590 
2591   return val;
2592 }
2593 
2594 
2595 enum arithop
2596   {
2597     Aadd,
2598     Asub,
2599     Amult,
2600     Adiv,
2601     Alogand,
2602     Alogior,
2603     Alogxor,
2604     Amax,
2605     Amin
2606   };
2607 
2608 static Lisp_Object float_arith_driver P_ ((double, int, enum arithop,
2609                                            int, Lisp_Object *));
2610 extern Lisp_Object fmod_float ();
2611 
2612 Lisp_Object
2613 arith_driver (code, nargs, args)
2614      enum arithop code;
2615      int nargs;
2616      register Lisp_Object *args;
2617 {
2618   register Lisp_Object val;
2619   register int argnum;
2620   register EMACS_INT accum = 0;
2621   register EMACS_INT next;
2622 
2623   switch (SWITCH_ENUM_CAST (code))
2624     {
2625     case Alogior:
2626     case Alogxor:
2627     case Aadd:
2628     case Asub:
2629       accum = 0;
2630       break;
2631     case Amult:
2632       accum = 1;
2633       break;
2634     case Alogand:
2635       accum = -1;
2636       break;
2637     default:
2638       break;
2639     }
2640 
2641   for (argnum = 0; argnum < nargs; argnum++)
2642     {
2643       /* Using args[argnum] as argument to CHECK_NUMBER_... */
2644       val = args[argnum];
2645       CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val);
2646 
2647       if (FLOATP (val))
2648         return float_arith_driver ((double) accum, argnum, code,
2649                                    nargs, args);
2650       args[argnum] = val;
2651       next = XINT (args[argnum]);
2652       switch (SWITCH_ENUM_CAST (code))
2653         {
2654         case Aadd:
2655           accum += next;
2656           break;
2657         case Asub:
2658           accum = argnum ? accum - next : nargs == 1 ? - next : next;
2659           break;
2660         case Amult:
2661           accum *= next;
2662           break;
2663         case Adiv:
2664           if (!argnum)
2665             accum = next;
2666           else
2667             {
2668               if (next == 0)
2669                 xsignal0 (Qarith_error);
2670               accum /= next;
2671             }
2672           break;
2673         case Alogand:
2674           accum &= next;
2675           break;
2676         case Alogior:
2677           accum |= next;
2678           break;
2679         case Alogxor:
2680           accum ^= next;
2681           break;
2682         case Amax:
2683           if (!argnum || next > accum)
2684             accum = next;
2685           break;
2686         case Amin:
2687           if (!argnum || next < accum)
2688             accum = next;
2689           break;
2690         }
2691     }
2692 
2693   XSETINT (val, accum);
2694   return val;
2695 }
2696 
2697 #undef isnan
2698 #define isnan(x) ((x) != (x))
2699 
2700 static Lisp_Object
2701 float_arith_driver (accum, argnum, code, nargs, args)
2702      double accum;
2703      register int argnum;
2704      enum arithop code;
2705      int nargs;
2706      register Lisp_Object *args;
2707 {
2708   register Lisp_Object val;
2709   double next;
2710 
2711   for (; argnum < nargs; argnum++)
2712     {
2713       val = args[argnum];    /* using args[argnum] as argument to CHECK_NUMBER_... */
2714       CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val);
2715 
2716       if (FLOATP (val))
2717         {
2718           next = XFLOAT_DATA (val);
2719         }
2720       else
2721         {
2722           args[argnum] = val;    /* runs into a compiler bug. */
2723           next = XINT (args[argnum]);
2724         }
2725       switch (SWITCH_ENUM_CAST (code))
2726         {
2727         case Aadd:
2728           accum += next;
2729           break;
2730         case Asub:
2731           accum = argnum ? accum - next : nargs == 1 ? - next : next;
2732           break;
2733         case Amult:
2734           accum *= next;
2735           break;
2736         case Adiv:
2737           if (!argnum)
2738             accum = next;
2739           else
2740             {
2741               if (! IEEE_FLOATING_POINT && next == 0)
2742                 xsignal0 (Qarith_error);
2743               accum /= next;
2744             }
2745           break;
2746         case Alogand:
2747         case Alogior:
2748         case Alogxor:
2749           return wrong_type_argument (Qinteger_or_marker_p, val);
2750         case Amax:
2751           if (!argnum || isnan (next) || next > accum)
2752             accum = next;
2753           break;
2754         case Amin:
2755           if (!argnum || isnan (next) || next < accum)
2756             accum = next;
2757           break;
2758         }
2759     }
2760 
2761   return make_float (accum);
2762 }
2763 
2764 
2765 DEFUN ("+", Fplus, Splus, 0, MANY, 0,
2766        doc: /* Return sum of any number of arguments, which are numbers or markers.
2767 usage: (+ &rest NUMBERS-OR-MARKERS)  */)
2768      (nargs, args)
2769      int nargs;
2770      Lisp_Object *args;
2771 {
2772   return arith_driver (Aadd, nargs, args);
2773 }
2774 
2775 DEFUN ("-", Fminus, Sminus, 0, MANY, 0,
2776        doc: /* Negate number or subtract numbers or markers and return the result.
2777 With one arg, negates it.  With more than one arg,
2778 subtracts all but the first from the first.
2779 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS)  */)
2780      (nargs, args)
2781      int nargs;
2782      Lisp_Object *args;
2783 {
2784   return arith_driver (Asub, nargs, args);
2785 }
2786 
2787 DEFUN ("*", Ftimes, Stimes, 0, MANY, 0,
2788        doc: /* Return product of any number of arguments, which are numbers or markers.
2789 usage: (* &rest NUMBERS-OR-MARKERS)  */)
2790      (nargs, args)
2791      int nargs;
2792      Lisp_Object *args;
2793 {
2794   return arith_driver (Amult, nargs, args);
2795 }
2796 
2797 DEFUN ("/", Fquo, Squo, 2, MANY, 0,
2798        doc: /* Return first argument divided by all the remaining arguments.
2799 The arguments must be numbers or markers.
2800 usage: (/ DIVIDEND DIVISOR &rest DIVISORS)  */)
2801      (nargs, args)
2802      int nargs;
2803      Lisp_Object *args;
2804 {
2805   int argnum;
2806   for (argnum = 2; argnum < nargs; argnum++)
2807     if (FLOATP (args[argnum]))
2808       return float_arith_driver (0, 0, Adiv, nargs, args);
2809   return arith_driver (Adiv, nargs, args);
2810 }
2811 
2812 DEFUN ("%", Frem, Srem, 2, 2, 0,
2813        doc: /* Return remainder of X divided by Y.
2814 Both must be integers or markers.  */)
2815      (x, y)
2816      register Lisp_Object x, y;
2817 {
2818   Lisp_Object val;
2819 
2820   CHECK_NUMBER_COERCE_MARKER (x);
2821   CHECK_NUMBER_COERCE_MARKER (y);
2822 
2823   if (XFASTINT (y) == 0)
2824     xsignal0 (Qarith_error);
2825 
2826   XSETINT (val, XINT (x) % XINT (y));
2827   return val;
2828 }
2829 
2830 #ifndef HAVE_FMOD
2831 double
2832 fmod (f1, f2)
2833      double f1, f2;
2834 {
2835   double r = f1;
2836 
2837   if (f2 < 0.0)
2838     f2 = -f2;
2839 
2840   /* If the magnitude of the result exceeds that of the divisor, or
2841      the sign of the result does not agree with that of the dividend,
2842      iterate with the reduced value.  This does not yield a
2843      particularly accurate result, but at least it will be in the
2844      range promised by fmod.  */
2845   do
2846     r -= f2 * floor (r / f2);
2847   while (f2 <= (r < 0 ? -r : r) || ((r < 0) != (f1 < 0) && ! isnan (r)));
2848 
2849   return r;
2850 }
2851 #endif /* ! HAVE_FMOD */
2852 
2853 DEFUN ("mod", Fmod, Smod, 2, 2, 0,
2854        doc: /* Return X modulo Y.
2855 The result falls between zero (inclusive) and Y (exclusive).
2856 Both X and Y must be numbers or markers.  */)
2857      (x, y)
2858      register Lisp_Object x, y;
2859 {
2860   Lisp_Object val;
2861   EMACS_INT i1, i2;
2862 
2863   CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x);
2864   CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y);
2865 
2866   if (FLOATP (x) || FLOATP (y))
2867     return fmod_float (x, y);
2868 
2869   i1 = XINT (x);
2870   i2 = XINT (y);
2871 
2872   if (i2 == 0)
2873     xsignal0 (Qarith_error);
2874 
2875   i1 %= i2;
2876 
2877   /* If the "remainder" comes out with the wrong sign, fix it.  */
2878   if (i2 < 0 ? i1 > 0 : i1 < 0)
2879     i1 += i2;
2880 
2881   XSETINT (val, i1);
2882   return val;
2883 }
2884 
2885 DEFUN ("max", Fmax, Smax, 1, MANY, 0,
2886        doc: /* Return largest of all the arguments (which must be numbers or markers).
2887 The value is always a number; markers are converted to numbers.
2888 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS)  */)
2889      (nargs, args)
2890      int nargs;
2891      Lisp_Object *args;
2892 {
2893   return arith_driver (Amax, nargs, args);
2894 }
2895 
2896 DEFUN ("min", Fmin, Smin, 1, MANY, 0,
2897        doc: /* Return smallest of all the arguments (which must be numbers or markers).
2898 The value is always a number; markers are converted to numbers.
2899 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS)  */)
2900      (nargs, args)
2901      int nargs;
2902      Lisp_Object *args;
2903 {
2904   return arith_driver (Amin, nargs, args);
2905 }
2906 
2907 DEFUN ("logand", Flogand, Slogand, 0, MANY, 0,
2908        doc: /* Return bitwise-and of all the arguments.
2909 Arguments may be integers, or markers converted to integers.
2910 usage: (logand &rest INTS-OR-MARKERS)  */)
2911      (nargs, args)
2912      int nargs;
2913      Lisp_Object *args;
2914 {
2915   return arith_driver (Alogand, nargs, args);
2916 }
2917 
2918 DEFUN ("logior", Flogior, Slogior, 0, MANY, 0,
2919        doc: /* Return bitwise-or of all the arguments.
2920 Arguments may be integers, or markers converted to integers.
2921 usage: (logior &rest INTS-OR-MARKERS)  */)
2922      (nargs, args)
2923      int nargs;
2924      Lisp_Object *args;
2925 {
2926   return arith_driver (Alogior, nargs, args);
2927 }
2928 
2929 DEFUN ("logxor", Flogxor, Slogxor, 0, MANY, 0,
2930        doc: /* Return bitwise-exclusive-or of all the arguments.
2931 Arguments may be integers, or markers converted to integers.
2932 usage: (logxor &rest INTS-OR-MARKERS)  */)
2933      (nargs, args)
2934      int nargs;
2935      Lisp_Object *args;
2936 {
2937   return arith_driver (Alogxor, nargs, args);
2938 }
2939 
2940 DEFUN ("ash", Fash, Sash, 2, 2, 0,
2941        doc: /* Return VALUE with its bits shifted left by COUNT.
2942 If COUNT is negative, shifting is actually to the right.
2943 In this case, the sign bit is duplicated.  */)
2944      (value, count)
2945      register Lisp_Object value, count;
2946 {
2947   register Lisp_Object val;
2948 
2949   CHECK_NUMBER (value);
2950   CHECK_NUMBER (count);
2951 
2952   if (XINT (count) >= BITS_PER_EMACS_INT)
2953     XSETINT (val, 0);
2954   else if (XINT (count) > 0)
2955     XSETINT (val, XINT (value) << XFASTINT (count));
2956   else if (XINT (count) <= -BITS_PER_EMACS_INT)
2957     XSETINT (val, XINT (value) < 0 ? -1 : 0);
2958   else
2959     XSETINT (val, XINT (value) >> -XINT (count));
2960   return val;
2961 }
2962 
2963 DEFUN ("lsh", Flsh, Slsh, 2, 2, 0,
2964        doc: /* Return VALUE with its bits shifted left by COUNT.
2965 If COUNT is negative, shifting is actually to the right.
2966 In this case, zeros are shifted in on the left.  */)
2967      (value, count)
2968      register Lisp_Object value, count;
2969 {
2970   register Lisp_Object val;
2971 
2972   CHECK_NUMBER (value);
2973   CHECK_NUMBER (count);
2974 
2975   if (XINT (count) >= BITS_PER_EMACS_INT)
2976     XSETINT (val, 0);
2977   else if (XINT (count) > 0)
2978     XSETINT (val, (EMACS_UINT) XUINT (value) << XFASTINT (count));
2979   else if (XINT (count) <= -BITS_PER_EMACS_INT)
2980     XSETINT (val, 0);
2981   else
2982     XSETINT (val, (EMACS_UINT) XUINT (value) >> -XINT (count));
2983   return val;
2984 }
2985 
2986 DEFUN ("1+", Fadd1, Sadd1, 1, 1, 0,
2987        doc: /* Return NUMBER plus one.  NUMBER may be a number or a marker.
2988 Markers are converted to integers.  */)
2989      (number)
2990      register Lisp_Object number;
2991 {
2992   CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number);
2993 
2994   if (FLOATP (number))
2995     return (make_float (1.0 + XFLOAT_DATA (number)));
2996 
2997   XSETINT (number, XINT (number) + 1);
2998   return number;
2999 }
3000 
3001 DEFUN ("1-", Fsub1, Ssub1, 1, 1, 0,
3002        doc: /* Return NUMBER minus one.  NUMBER may be a number or a marker.
3003 Markers are converted to integers.  */)
3004      (number)
3005      register Lisp_Object number;
3006 {
3007   CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number);
3008 
3009   if (FLOATP (number))
3010     return (make_float (-1.0 + XFLOAT_DATA (number)));
3011 
3012   XSETINT (number, XINT (number) - 1);
3013   return number;
3014 }
3015 
3016 DEFUN ("lognot", Flognot, Slognot, 1, 1, 0,
3017        doc: /* Return the bitwise complement of NUMBER.  NUMBER must be an integer.  */)
3018      (number)
3019      register Lisp_Object number;
3020 {
3021   CHECK_NUMBER (number);
3022   XSETINT (number, ~XINT (number));
3023   return number;
3024 }
3025 
3026 DEFUN ("byteorder", Fbyteorder, Sbyteorder, 0, 0, 0,
3027        doc: /* Return the byteorder for the machine.
3028 Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
3029 lowercase l) for small endian machines.  */)
3030      ()
3031 {
3032   unsigned i = 0x04030201;
3033   int order = *(char *)&i == 1 ? 108 : 66;
3034 
3035   return make_number (order);
3036 }
3037 
3038 
3039 
3040 void
3041 syms_of_data ()
3042 {
3043   Lisp_Object error_tail, arith_tail;
3044 
3045   Qquote = intern_c_string ("quote");
3046   Qlambda = intern_c_string ("lambda");
3047   Qsubr = intern_c_string ("subr");
3048   Qerror_conditions = intern_c_string ("error-conditions");
3049   Qerror_message = intern_c_string ("error-message");
3050   Qtop_level = intern_c_string ("top-level");
3051 
3052   Qerror = intern_c_string ("error");
3053   Qquit = intern_c_string ("quit");
3054   Qwrong_type_argument = intern_c_string ("wrong-type-argument");
3055   Qargs_out_of_range = intern_c_string ("args-out-of-range");
3056   Qvoid_function = intern_c_string ("void-function");
3057   Qcyclic_function_indirection = intern_c_string ("cyclic-function-indirection");
3058   Qcyclic_variable_indirection = intern_c_string ("cyclic-variable-indirection");
3059   Qvoid_variable = intern_c_string ("void-variable");
3060   Qsetting_constant = intern_c_string ("setting-constant");
3061   Qinvalid_read_syntax = intern_c_string ("invalid-read-syntax");
3062 
3063   Qinvalid_function = intern_c_string ("invalid-function");
3064   Qwrong_number_of_arguments = intern_c_string ("wrong-number-of-arguments");
3065   Qno_catch = intern_c_string ("no-catch");
3066   Qend_of_file = intern_c_string ("end-of-file");
3067   Qarith_error = intern_c_string ("arith-error");
3068   Qbeginning_of_buffer = intern_c_string ("beginning-of-buffer");
3069   Qend_of_buffer = intern_c_string ("end-of-buffer");
3070   Qbuffer_read_only = intern_c_string ("buffer-read-only");
3071   Qtext_read_only = intern_c_string ("text-read-only");
3072   Qmark_inactive = intern_c_string ("mark-inactive");
3073 
3074   Qlistp = intern_c_string ("listp");
3075   Qconsp = intern_c_string ("consp");
3076   Qsymbolp = intern_c_string ("symbolp");
3077   Qkeywordp = intern_c_string ("keywordp");
3078   Qintegerp = intern_c_string ("integerp");
3079   Qnatnump = intern_c_string ("natnump");
3080   Qwholenump = intern_c_string ("wholenump");
3081   Qstringp = intern_c_string ("stringp");
3082   Qarrayp = intern_c_string ("arrayp");
3083   Qsequencep = intern_c_string ("sequencep");
3084   Qbufferp = intern_c_string ("bufferp");
3085   Qvectorp = intern_c_string ("vectorp");
3086   Qchar_or_string_p = intern_c_string ("char-or-string-p");
3087   Qmarkerp = intern_c_string ("markerp");
3088   Qbuffer_or_string_p = intern_c_string ("buffer-or-string-p");
3089   Qinteger_or_marker_p = intern_c_string ("integer-or-marker-p");
3090   Qboundp = intern_c_string ("boundp");
3091   Qfboundp = intern_c_string ("fboundp");
3092 
3093   Qfloatp = intern_c_string ("floatp");
3094   Qnumberp = intern_c_string ("numberp");
3095   Qnumber_or_marker_p = intern_c_string ("number-or-marker-p");
3096 
3097   Qchar_table_p = intern_c_string ("char-table-p");
3098   Qvector_or_char_table_p = intern_c_string ("vector-or-char-table-p");
3099 
3100   Qsubrp = intern_c_string ("subrp");
3101   Qunevalled = intern_c_string ("unevalled");
3102   Qmany = intern_c_string ("many");
3103 
3104   Qcdr = intern_c_string ("cdr");
3105 
3106   /* Handle automatic advice activation */
3107   Qad_advice_info = intern_c_string ("ad-advice-info");
3108   Qad_activate_internal = intern_c_string ("ad-activate-internal");
3109 
3110   error_tail = pure_cons (Qerror, Qnil);
3111 
3112   /* ERROR is used as a signaler for random errors for which nothing else is right */
3113 
3114   Fput (Qerror, Qerror_conditions,
3115         error_tail);
3116   Fput (Qerror, Qerror_message,
3117         make_pure_c_string ("error"));
3118 
3119   Fput (Qquit, Qerror_conditions,
3120         pure_cons (Qquit, Qnil));
3121   Fput (Qquit, Qerror_message,
3122         make_pure_c_string ("Quit"));
3123 
3124   Fput (Qwrong_type_argument, Qerror_conditions,
3125         pure_cons (Qwrong_type_argument, error_tail));
3126   Fput (Qwrong_type_argument, Qerror_message,
3127         make_pure_c_string ("Wrong type argument"));
3128 
3129   Fput (Qargs_out_of_range, Qerror_conditions,
3130         pure_cons (Qargs_out_of_range, error_tail));
3131   Fput (Qargs_out_of_range, Qerror_message,
3132         make_pure_c_string ("Args out of range"));
3133 
3134   Fput (Qvoid_function, Qerror_conditions,
3135         pure_cons (Qvoid_function, error_tail));
3136   Fput (Qvoid_function, Qerror_message,
3137         make_pure_c_string ("Symbol's function definition is void"));
3138 
3139   Fput (Qcyclic_function_indirection, Qerror_conditions,
3140         pure_cons (Qcyclic_function_indirection, error_tail));
3141   Fput (Qcyclic_function_indirection, Qerror_message,
3142         make_pure_c_string ("Symbol's chain of function indirections contains a loop"));
3143 
3144   Fput (Qcyclic_variable_indirection, Qerror_conditions,
3145         pure_cons (Qcyclic_variable_indirection, error_tail));
3146   Fput (Qcyclic_variable_indirection, Qerror_message,
3147         make_pure_c_string ("Symbol's chain of variable indirections contains a loop"));
3148 
3149   Qcircular_list = intern_c_string ("circular-list");
3150   staticpro (&Qcircular_list);
3151   Fput (Qcircular_list, Qerror_conditions,
3152         pure_cons (Qcircular_list, error_tail));
3153   Fput (Qcircular_list, Qerror_message,
3154         make_pure_c_string ("List contains a loop"));
3155 
3156   Fput (Qvoid_variable, Qerror_conditions,
3157         pure_cons (Qvoid_variable, error_tail));
3158   Fput (Qvoid_variable, Qerror_message,
3159         make_pure_c_string ("Symbol's value as variable is void"));
3160 
3161   Fput (Qsetting_constant, Qerror_conditions,
3162         pure_cons (Qsetting_constant, error_tail));
3163   Fput (Qsetting_constant, Qerror_message,
3164         make_pure_c_string ("Attempt to set a constant symbol"));
3165 
3166   Fput (Qinvalid_read_syntax, Qerror_conditions,
3167         pure_cons (Qinvalid_read_syntax, error_tail));
3168   Fput (Qinvalid_read_syntax, Qerror_message,
3169         make_pure_c_string ("Invalid read syntax"));
3170 
3171   Fput (Qinvalid_function, Qerror_conditions,
3172         pure_cons (Qinvalid_function, error_tail));
3173   Fput (Qinvalid_function, Qerror_message,
3174         make_pure_c_string ("Invalid function"));
3175 
3176   Fput (Qwrong_number_of_arguments, Qerror_conditions,
3177         pure_cons (Qwrong_number_of_arguments, error_tail));
3178   Fput (Qwrong_number_of_arguments, Qerror_message,
3179         make_pure_c_string ("Wrong number of arguments"));
3180 
3181   Fput (Qno_catch, Qerror_conditions,
3182         pure_cons (Qno_catch, error_tail));
3183   Fput (Qno_catch, Qerror_message,
3184         make_pure_c_string ("No catch for tag"));
3185 
3186   Fput (Qend_of_file, Qerror_conditions,
3187         pure_cons (Qend_of_file, error_tail));
3188   Fput (Qend_of_file, Qerror_message,
3189         make_pure_c_string ("End of file during parsing"));
3190 
3191   arith_tail = pure_cons (Qarith_error, error_tail);
3192   Fput (Qarith_error, Qerror_conditions,
3193         arith_tail);
3194   Fput (Qarith_error, Qerror_message,
3195         make_pure_c_string ("Arithmetic error"));
3196 
3197   Fput (Qbeginning_of_buffer, Qerror_conditions,
3198         pure_cons (Qbeginning_of_buffer, error_tail));
3199   Fput (Qbeginning_of_buffer, Qerror_message,
3200         make_pure_c_string ("Beginning of buffer"));
3201 
3202   Fput (Qend_of_buffer, Qerror_conditions,
3203         pure_cons (Qend_of_buffer, error_tail));
3204   Fput (Qend_of_buffer, Qerror_message,
3205         make_pure_c_string ("End of buffer"));
3206 
3207   Fput (Qbuffer_read_only, Qerror_conditions,
3208         pure_cons (Qbuffer_read_only, error_tail));
3209   Fput (Qbuffer_read_only, Qerror_message,
3210         make_pure_c_string ("Buffer is read-only"));
3211 
3212   Fput (Qtext_read_only, Qerror_conditions,
3213         pure_cons (Qtext_read_only, error_tail));
3214   Fput (Qtext_read_only, Qerror_message,
3215         make_pure_c_string ("Text is read-only"));
3216 
3217   Qrange_error = intern_c_string ("range-error");
3218   Qdomain_error = intern_c_string ("domain-error");
3219   Qsingularity_error = intern_c_string ("singularity-error");
3220   Qoverflow_error = intern_c_string ("overflow-error");
3221   Qunderflow_error = intern_c_string ("underflow-error");
3222 
3223   Fput (Qdomain_error, Qerror_conditions,
3224         pure_cons (Qdomain_error, arith_tail));
3225   Fput (Qdomain_error, Qerror_message,
3226         make_pure_c_string ("Arithmetic domain error"));
3227 
3228   Fput (Qrange_error, Qerror_conditions,
3229         pure_cons (Qrange_error, arith_tail));
3230   Fput (Qrange_error, Qerror_message,
3231         make_pure_c_string ("Arithmetic range error"));
3232 
3233   Fput (Qsingularity_error, Qerror_conditions,
3234         pure_cons (Qsingularity_error, Fcons (Qdomain_error, arith_tail)));
3235   Fput (Qsingularity_error, Qerror_message,
3236         make_pure_c_string ("Arithmetic singularity error"));
3237 
3238   Fput (Qoverflow_error, Qerror_conditions,
3239         pure_cons (Qoverflow_error, Fcons (Qdomain_error, arith_tail)));
3240   Fput (Qoverflow_error, Qerror_message,
3241         make_pure_c_string ("Arithmetic overflow error"));
3242 
3243   Fput (Qunderflow_error, Qerror_conditions,
3244         pure_cons (Qunderflow_error, Fcons (Qdomain_error, arith_tail)));
3245   Fput (Qunderflow_error, Qerror_message,
3246         make_pure_c_string ("Arithmetic underflow error"));
3247 
3248   staticpro (&Qrange_error);
3249   staticpro (&Qdomain_error);
3250   staticpro (&Qsingularity_error);
3251   staticpro (&Qoverflow_error);
3252   staticpro (&Qunderflow_error);
3253 
3254   staticpro (&Qnil);
3255   staticpro (&Qt);
3256   staticpro (&Qquote);
3257   staticpro (&Qlambda);
3258   staticpro (&Qsubr);
3259   staticpro (&Qunbound);
3260   staticpro (&Qerror_conditions);
3261   staticpro (&Qerror_message);
3262   staticpro (&Qtop_level);
3263 
3264   staticpro (&Qerror);
3265   staticpro (&Qquit);
3266   staticpro (&Qwrong_type_argument);
3267   staticpro (&Qargs_out_of_range);
3268   staticpro (&Qvoid_function);
3269   staticpro (&Qcyclic_function_indirection);
3270   staticpro (&Qcyclic_variable_indirection);
3271   staticpro (&Qvoid_variable);
3272   staticpro (&Qsetting_constant);
3273   staticpro (&Qinvalid_read_syntax);
3274   staticpro (&Qwrong_number_of_arguments);
3275   staticpro (&Qinvalid_function);
3276   staticpro (&Qno_catch);
3277   staticpro (&Qend_of_file);
3278   staticpro (&Qarith_error);
3279   staticpro (&Qbeginning_of_buffer);
3280   staticpro (&Qend_of_buffer);
3281   staticpro (&Qbuffer_read_only);
3282   staticpro (&Qtext_read_only);
3283   staticpro (&Qmark_inactive);
3284 
3285   staticpro (&Qlistp);
3286   staticpro (&Qconsp);
3287   staticpro (&Qsymbolp);
3288   staticpro (&Qkeywordp);
3289   staticpro (&Qintegerp);
3290   staticpro (&Qnatnump);
3291   staticpro (&Qwholenump);
3292   staticpro (&Qstringp);
3293   staticpro (&Qarrayp);
3294   staticpro (&Qsequencep);
3295   staticpro (&Qbufferp);
3296   staticpro (&Qvectorp);
3297   staticpro (&Qchar_or_string_p);
3298   staticpro (&Qmarkerp);
3299   staticpro (&Qbuffer_or_string_p);
3300   staticpro (&Qinteger_or_marker_p);
3301   staticpro (&Qfloatp);
3302   staticpro (&Qnumberp);
3303   staticpro (&Qnumber_or_marker_p);
3304   staticpro (&Qchar_table_p);
3305   staticpro (&Qvector_or_char_table_p);
3306   staticpro (&Qsubrp);
3307   staticpro (&Qmany);
3308   staticpro (&Qunevalled);
3309 
3310   staticpro (&Qboundp);
3311   staticpro (&Qfboundp);
3312   staticpro (&Qcdr);
3313   staticpro (&Qad_advice_info);
3314   staticpro (&Qad_activate_internal);
3315 
3316   /* Types that type-of returns.  */
3317   Qinteger = intern_c_string ("integer");
3318   Qsymbol = intern_c_string ("symbol");
3319   Qstring = intern_c_string ("string");
3320   Qcons = intern_c_string ("cons");
3321   Qmarker = intern_c_string ("marker");
3322   Qoverlay = intern_c_string ("overlay");
3323   Qfloat = intern_c_string ("float");
3324   Qwindow_configuration = intern_c_string ("window-configuration");
3325   Qprocess = intern_c_string ("process");
3326   Qwindow = intern_c_string ("window");
3327   /* Qsubr = intern_c_string ("subr"); */
3328   Qcompiled_function = intern_c_string ("compiled-function");
3329   Qbuffer = intern_c_string ("buffer");
3330   Qframe = intern_c_string ("frame");
3331   Qvector = intern_c_string ("vector");
3332   Qchar_table = intern_c_string ("char-table");
3333   Qbool_vector = intern_c_string ("bool-vector");
3334   Qhash_table = intern_c_string ("hash-table");
3335 
3336   DEFSYM (Qfont_spec, "font-spec");
3337   DEFSYM (Qfont_entity, "font-entity");
3338   DEFSYM (Qfont_object, "font-object");
3339 
3340   DEFSYM (Qinteractive_form, "interactive-form");
3341 
3342   staticpro (&Qinteger);
3343   staticpro (&Qsymbol);
3344   staticpro (&Qstring);
3345   staticpro (&Qcons);
3346   staticpro (&Qmarker);
3347   staticpro (&Qoverlay);
3348   staticpro (&Qfloat);
3349   staticpro (&Qwindow_configuration);
3350   staticpro (&Qprocess);
3351   staticpro (&Qwindow);
3352   /* staticpro (&Qsubr); */
3353   staticpro (&Qcompiled_function);
3354   staticpro (&Qbuffer);
3355   staticpro (&Qframe);
3356   staticpro (&Qvector);
3357   staticpro (&Qchar_table);
3358   staticpro (&Qbool_vector);
3359   staticpro (&Qhash_table);
3360 
3361   defsubr (&Sindirect_variable);
3362   defsubr (&Sinteractive_form);
3363   defsubr (&Seq);
3364   defsubr (&Snull);
3365   defsubr (&Stype_of);
3366   defsubr (&Slistp);
3367   defsubr (&Snlistp);
3368   defsubr (&Sconsp);
3369   defsubr (&Satom);
3370   defsubr (&Sintegerp);
3371   defsubr (&Sinteger_or_marker_p);
3372   defsubr (&Snumberp);
3373   defsubr (&Snumber_or_marker_p);
3374   defsubr (&Sfloatp);
3375   defsubr (&Snatnump);
3376   defsubr (&Ssymbolp);
3377   defsubr (&Skeywordp);
3378   defsubr (&Sstringp);
3379   defsubr (&Smultibyte_string_p);
3380   defsubr (&Svectorp);
3381   defsubr (&Schar_table_p);
3382   defsubr (&Svector_or_char_table_p);
3383   defsubr (&Sbool_vector_p);
3384   defsubr (&Sarrayp);
3385   defsubr (&Ssequencep);
3386   defsubr (&Sbufferp);
3387   defsubr (&Smarkerp);
3388   defsubr (&Ssubrp);
3389   defsubr (&Sbyte_code_function_p);
3390   defsubr (&Schar_or_string_p);
3391   defsubr (&Scar);
3392   defsubr (&Scdr);
3393   defsubr (&Scar_safe);
3394   defsubr (&Scdr_safe);
3395   defsubr (&Ssetcar);
3396   defsubr (&Ssetcdr);
3397   defsubr (&Ssymbol_function);
3398   defsubr (&Sindirect_function);
3399   defsubr (&Ssymbol_plist);
3400   defsubr (&Ssymbol_name);
3401   defsubr (&Smakunbound);
3402   defsubr (&Sfmakunbound);
3403   defsubr (&Sboundp);
3404   defsubr (&Sfboundp);
3405   defsubr (&Sfset);
3406   defsubr (&Sdefalias);
3407   defsubr (&Ssetplist);
3408   defsubr (&Ssymbol_value);
3409   defsubr (&Sset);
3410   defsubr (&Sdefault_boundp);
3411   defsubr (&Sdefault_value);
3412   defsubr (&Sset_default);
3413   defsubr (&Ssetq_default);
3414   defsubr (&Smake_variable_buffer_local);
3415   defsubr (&Smake_local_variable);
3416   defsubr (&Skill_local_variable);
3417   defsubr (&Smake_variable_frame_local);
3418   defsubr (&Slocal_variable_p);
3419   defsubr (&Slocal_variable_if_set_p);
3420   defsubr (&Svariable_binding_locus);
3421 #if 0                           /* XXX Remove this. --lorentey */
3422   defsubr (&Sterminal_local_value);
3423   defsubr (&Sset_terminal_local_value);
3424 #endif
3425   defsubr (&Saref);
3426   defsubr (&Saset);
3427   defsubr (&Snumber_to_string);
3428   defsubr (&Sstring_to_number);
3429   defsubr (&Seqlsign);
3430   defsubr (&Slss);
3431   defsubr (&Sgtr);
3432   defsubr (&Sleq);
3433   defsubr (&Sgeq);
3434   defsubr (&Sneq);
3435   defsubr (&Szerop);
3436   defsubr (&Splus);
3437   defsubr (&Sminus);
3438   defsubr (&Stimes);
3439   defsubr (&Squo);
3440   defsubr (&Srem);
3441   defsubr (&Smod);
3442   defsubr (&Smax);
3443   defsubr (&Smin);
3444   defsubr (&Slogand);
3445   defsubr (&Slogior);
3446   defsubr (&Slogxor);
3447   defsubr (&Slsh);
3448   defsubr (&Sash);
3449   defsubr (&Sadd1);
3450   defsubr (&Ssub1);
3451   defsubr (&Slognot);
3452   defsubr (&Sbyteorder);
3453   defsubr (&Ssubr_arity);
3454   defsubr (&Ssubr_name);
3455 
3456   XSYMBOL (Qwholenump)->function = XSYMBOL (Qnatnump)->function;
3457 
3458   DEFVAR_LISP ("most-positive-fixnum", &Vmost_positive_fixnum,
3459                doc: /* The largest value that is representable in a Lisp integer.  */);
3460   Vmost_positive_fixnum = make_number (MOST_POSITIVE_FIXNUM);
3461   XSYMBOL (intern_c_string ("most-positive-fixnum"))->constant = 1;
3462 
3463   DEFVAR_LISP ("most-negative-fixnum", &Vmost_negative_fixnum,
3464                doc: /* The smallest value that is representable in a Lisp integer.  */);
3465   Vmost_negative_fixnum = make_number (MOST_NEGATIVE_FIXNUM);
3466   XSYMBOL (intern_c_string ("most-negative-fixnum"))->constant = 1;
3467 }
3468 
3469 SIGTYPE
3470 arith_error (signo)
3471      int signo;
3472 {
3473   sigsetmask (SIGEMPTYMASK);
3474 
3475   SIGNAL_THREAD_CHECK (signo);
3476   xsignal0 (Qarith_error);
3477 }
3478 
3479 void
3480 init_data ()
3481 {
3482   /* Don't do this if just dumping out.
3483      We don't want to call `signal' in this case
3484      so that we don't have trouble with dumping
3485      signal-delivering routines in an inconsistent state.  */
3486 #ifndef CANNOT_DUMP
3487   if (!initialized)
3488     return;
3489 #endif /* CANNOT_DUMP */
3490   signal (SIGFPE, arith_error);
3491 
3492 #ifdef uts
3493   signal (SIGEMT, arith_error);
3494 #endif /* uts */
3495 }
3496 
3497 /* arch-tag: 25879798-b84d-479a-9c89-7d148e2109f7
3498    (do not change this comment) */