src/data.c

   1 /* Primitive operations on Lisp data types for GNU Emacs Lisp interpreter.
   2    Copyright (C) 1985, 86, 88, 93, 94, 95 Free Software Foundation, Inc.
   3
   4 This file is part of GNU Emacs.
   5
   6 GNU Emacs is free software; you can redistribute it and/or modify
   7 it under the terms of the GNU General Public License as published by
   8 the Free Software Foundation; either version 2, or (at your option)
   9 any later version.
  10
  11 GNU Emacs is distributed in the hope that it will be useful,
  12 but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 GNU General Public License for more details.
  15
  16 You should have received a copy of the GNU General Public License
  17 along with GNU Emacs; see the file COPYING.  If not, write to
  18 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  19 Boston, MA 02111-1307, USA.  */
  20
  21
  22 #include <signal.h>
  23
  24 #include <config.h>
  25 #include "lisp.h"
  26 #include "puresize.h"
  27
  28 #ifndef standalone
  29 #include "buffer.h"
  30 #include "keyboard.h"
  31 #endif
  32
  33 #include "syssignal.h"
  34
  35 #ifdef LISP_FLOAT_TYPE
  36
  37 #ifdef STDC_HEADERS
  38 #include <stdlib.h>
  39 #endif
  40
  41 /* Work around a problem that happens because math.h on hpux 7
  42    defines two static variables--which, in Emacs, are not really static,
  43    because `static' is defined as nothing.  The problem is that they are
  44    here, in floatfns.c, and in lread.c.
  45    These macros prevent the name conflict.  */
  46 #if defined (HPUX) && !defined (HPUX8)
  47 #define _MAXLDBL data_c_maxldbl
  48 #define _NMAXLDBL data_c_nmaxldbl
  49 #endif
  50
  51 #include <math.h>
  52 #endif /* LISP_FLOAT_TYPE */
  53
  54 #if !defined (atof)
  55 extern double atof ();
  56 #endif /* !atof */
  57
  58 Lisp_Object Qnil, Qt, Qquote, Qlambda, Qsubr, Qunbound;
  59 Lisp_Object Qerror_conditions, Qerror_message, Qtop_level;
  60 Lisp_Object Qerror, Qquit, Qwrong_type_argument, Qargs_out_of_range;
  61 Lisp_Object Qvoid_variable, Qvoid_function, Qcyclic_function_indirection;
  62 Lisp_Object Qsetting_constant, Qinvalid_read_syntax;
  63 Lisp_Object Qinvalid_function, Qwrong_number_of_arguments, Qno_catch;
  64 Lisp_Object Qend_of_file, Qarith_error, Qmark_inactive;
  65 Lisp_Object Qbeginning_of_buffer, Qend_of_buffer, Qbuffer_read_only;
  66 Lisp_Object Qintegerp, Qnatnump, Qwholenump, Qsymbolp, Qlistp, Qconsp;
  67 Lisp_Object Qstringp, Qarrayp, Qsequencep, Qbufferp;
  68 Lisp_Object Qchar_or_string_p, Qmarkerp, Qinteger_or_marker_p, Qvectorp;
  69 Lisp_Object Qbuffer_or_string_p;
  70 Lisp_Object Qboundp, Qfboundp;
  71 Lisp_Object Qchar_table_p, Qvector_or_char_table_p;
  72
  73 Lisp_Object Qcdr;
  74 Lisp_Object Qad_advice_info, Qad_activate;
  75
  76 Lisp_Object Qrange_error, Qdomain_error, Qsingularity_error;
  77 Lisp_Object Qoverflow_error, Qunderflow_error;
  78
  79 #ifdef LISP_FLOAT_TYPE
  80 Lisp_Object Qfloatp;
  81 Lisp_Object Qnumberp, Qnumber_or_marker_p;
  82 #endif
  83
  84 static Lisp_Object Qinteger, Qsymbol, Qstring, Qcons, Qmarker, Qoverlay;
  85 static Lisp_Object Qfloat, Qwindow_configuration, Qprocess, Qwindow;
  86 static Lisp_Object Qcompiled_function, Qbuffer, Qframe, Qvector;
  87 static Lisp_Object Qchar_table, Qbool_vector;
  88
  89 static Lisp_Object swap_in_symval_forwarding ();
  90
  91 Lisp_Object
  92 wrong_type_argument (predicate, value)
  93      register Lisp_Object predicate, value;
  94 {
  95   register Lisp_Object tem;
  96   do
  97     {
  98       if (!EQ (Vmocklisp_arguments, Qt))
  99         {
 100          if (STRINGP (value) &&
 101              (EQ (predicate, Qintegerp) || EQ (predicate, Qinteger_or_marker_p)))
 102            return Fstring_to_number (value);
 103          if (INTEGERP (value) && EQ (predicate, Qstringp))
 104            return Fnumber_to_string (value);
 105         }
 106
 107       /* If VALUE is not even a valid Lisp object, abort here
 108          where we can get a backtrace showing where it came from.  */
 109       if ((unsigned int) XGCTYPE (value) >= Lisp_Type_Limit)
 110         abort ();
 111
 112       value = Fsignal (Qwrong_type_argument, Fcons (predicate, Fcons (value, Qnil)));
 113       tem = call1 (predicate, value);
 114     }
 115   while (NILP (tem));
 116   return value;
 117 }
 118
 119 pure_write_error ()
 120 {
 121   error ("Attempt to modify read-only object");
 122 }
 123
 124 void
 125 args_out_of_range (a1, a2)
 126      Lisp_Object a1, a2;
 127 {
 128   while (1)
 129     Fsignal (Qargs_out_of_range, Fcons (a1, Fcons (a2, Qnil)));
 130 }
 131
 132 void
 133 args_out_of_range_3 (a1, a2, a3)
 134      Lisp_Object a1, a2, a3;
 135 {
 136   while (1)
 137     Fsignal (Qargs_out_of_range, Fcons (a1, Fcons (a2, Fcons (a3, Qnil))));
 138 }
 139
 140 /* On some machines, XINT needs a temporary location.
 141    Here it is, in case it is needed.  */
 142
 143 int sign_extend_temp;
 144
 145 /* On a few machines, XINT can only be done by calling this.  */
 146
 147 int
 148 sign_extend_lisp_int (num)
 149      EMACS_INT num;
 150 {
 151   if (num & (((EMACS_INT) 1) << (VALBITS - 1)))
 152     return num | (((EMACS_INT) (-1)) << VALBITS);
 153   else
 154     return num & ((((EMACS_INT) 1) << VALBITS) - 1);
 155 }
 156 \f
 157 /* Data type predicates */
 158
 159 DEFUN ("eq", Feq, Seq, 2, 2, 0,
 160   "T if the two args are the same Lisp object.")
 161   (obj1, obj2)
 162      Lisp_Object obj1, obj2;
 163 {
 164   if (EQ (obj1, obj2))
 165     return Qt;
 166   return Qnil;
 167 }
 168
 169 DEFUN ("null", Fnull, Snull, 1, 1, 0, "T if OBJECT is nil.")
 170   (object)
 171      Lisp_Object object;
 172 {
 173   if (NILP (object))
 174     return Qt;
 175   return Qnil;
 176 }
 177
 178 DEFUN ("type-of", Ftype_of, Stype_of, 1, 1, 0,
 179   "Return a symbol representing the type of OBJECT.\n\
 180 The symbol returned names the object's basic type;\n\
 181 for example, (type-of 1) returns `integer'.")
 182   (object)
 183      Lisp_Object object;
 184 {
 185   switch (XGCTYPE (object))
 186     {
 187     case Lisp_Int:
 188       return Qinteger;
 189
 190     case Lisp_Symbol:
 191       return Qsymbol;
 192
 193     case Lisp_String:
 194       return Qstring;
 195
 196     case Lisp_Cons:
 197       return Qcons;
 198
 199     case Lisp_Misc:
 200       switch (XMISCTYPE (object))
 201         {
 202         case Lisp_Misc_Marker:
 203           return Qmarker;
 204         case Lisp_Misc_Overlay:
 205           return Qoverlay;
 206         case Lisp_Misc_Float:
 207           return Qfloat;
 208         }
 209       abort ();
 210
 211     case Lisp_Vectorlike:
 212       if (GC_WINDOW_CONFIGURATIONP (object))
 213         return Qwindow_configuration;
 214       if (GC_PROCESSP (object))
 215         return Qprocess;
 216       if (GC_WINDOWP (object))
 217         return Qwindow;
 218       if (GC_SUBRP (object))
 219         return Qsubr;
 220       if (GC_COMPILEDP (object))
 221         return Qcompiled_function;
 222       if (GC_BUFFERP (object))
 223         return Qbuffer;
 224       if (GC_CHAR_TABLE_P (object))
 225         return Qchar_table;
 226       if (GC_BOOL_VECTOR_P (object))
 227         return Qbool_vector;
 228       if (GC_FRAMEP (object))
 229         return Qframe;
 230       return Qvector;
 231
 232 #ifdef LISP_FLOAT_TYPE
 233     case Lisp_Float:
 234       return Qfloat;
 235 #endif
 236
 237     default:
 238       abort ();
 239     }
 240 }
 241
 242 DEFUN ("consp", Fconsp, Sconsp, 1, 1, 0, "T if OBJECT is a cons cell.")
 243   (object)
 244      Lisp_Object object;
 245 {
 246   if (CONSP (object))
 247     return Qt;
 248   return Qnil;
 249 }
 250
 251 DEFUN ("atom", Fatom, Satom, 1, 1, 0, "T if OBJECT is not a cons cell.  This includes nil.")
 252   (object)
 253      Lisp_Object object;
 254 {
 255   if (CONSP (object))
 256     return Qnil;
 257   return Qt;
 258 }
 259
 260 DEFUN ("listp", Flistp, Slistp, 1, 1, 0, "T if OBJECT is a list.  This includes nil.")
 261   (object)
 262      Lisp_Object object;
 263 {
 264   if (CONSP (object) || NILP (object))
 265     return Qt;
 266   return Qnil;
 267 }
 268
 269 DEFUN ("nlistp", Fnlistp, Snlistp, 1, 1, 0, "T if OBJECT is not a list.  Lists include nil.")
 270   (object)
 271      Lisp_Object object;
 272 {
 273   if (CONSP (object) || NILP (object))
 274     return Qnil;
 275   return Qt;
 276 }
 277 \f
 278 DEFUN ("symbolp", Fsymbolp, Ssymbolp, 1, 1, 0, "T if OBJECT is a symbol.")
 279   (object)
 280      Lisp_Object object;
 281 {
 282   if (SYMBOLP (object))
 283     return Qt;
 284   return Qnil;
 285 }
 286
 287 DEFUN ("vectorp", Fvectorp, Svectorp, 1, 1, 0, "T if OBJECT is a vector.")
 288   (object)
 289      Lisp_Object object;
 290 {
 291   if (VECTORP (object))
 292     return Qt;
 293   return Qnil;
 294 }
 295
 296 DEFUN ("stringp", Fstringp, Sstringp, 1, 1, 0, "T if OBJECT is a string.")
 297   (object)
 298      Lisp_Object object;
 299 {
 300   if (STRINGP (object))
 301     return Qt;
 302   return Qnil;
 303 }
 304
 305 DEFUN ("char-table-p", Fchar_table_p, Schar_table_p, 1, 1, 0, "T if OBJECT is a char-table.")
 306   (object)
 307      Lisp_Object object;
 308 {
 309   if (CHAR_TABLE_P (object))
 310     return Qt;
 311   return Qnil;
 312 }
 313
 314 DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p,
 315        Svector_or_char_table_p, 1, 1, 0,
 316        "T if OBJECT is a char-table or vector.")
 317   (object)
 318      Lisp_Object object;
 319 {
 320   if (VECTORP (object) || CHAR_TABLE_P (object))
 321     return Qt;
 322   return Qnil;
 323 }
 324
 325 DEFUN ("bool-vector-p", Fbool_vector_p, Sbool_vector_p, 1, 1, 0, "T if OBJECT is a bool-vector.")
 326   (object)
 327      Lisp_Object object;
 328 {
 329   if (BOOL_VECTOR_P (object))
 330     return Qt;
 331   return Qnil;
 332 }
 333
 334 DEFUN ("arrayp", Farrayp, Sarrayp, 1, 1, 0, "T if OBJECT is an array (string or vector).")
 335   (object)
 336      Lisp_Object object;
 337 {
 338   if (VECTORP (object) || STRINGP (object))
 339     return Qt;
 340   return Qnil;
 341 }
 342
 343 DEFUN ("sequencep", Fsequencep, Ssequencep, 1, 1, 0,
 344   "T if OBJECT is a sequence (list or array).")
 345   (object)
 346      register Lisp_Object object;
 347 {
 348   if (CONSP (object) || NILP (object) || VECTORP (object) || STRINGP (object)
 349       || CHAR_TABLE_P (object) || BOOL_VECTOR_P (object))
 350     return Qt;
 351   return Qnil;
 352 }
 353
 354 DEFUN ("bufferp", Fbufferp, Sbufferp, 1, 1, 0, "T if OBJECT is an editor buffer.")
 355   (object)
 356      Lisp_Object object;
 357 {
 358   if (BUFFERP (object))
 359     return Qt;
 360   return Qnil;
 361 }
 362
 363 DEFUN ("markerp", Fmarkerp, Smarkerp, 1, 1, 0, "T if OBJECT is a marker (editor pointer).")
 364   (object)
 365      Lisp_Object object;
 366 {
 367   if (MARKERP (object))
 368     return Qt;
 369   return Qnil;
 370 }
 371
 372 DEFUN ("subrp", Fsubrp, Ssubrp, 1, 1, 0, "T if OBJECT is a built-in function.")
 373   (object)
 374      Lisp_Object object;
 375 {
 376   if (SUBRP (object))
 377     return Qt;
 378   return Qnil;
 379 }
 380
 381 DEFUN ("byte-code-function-p", Fbyte_code_function_p, Sbyte_code_function_p,
 382        1, 1, 0, "T if OBJECT is a byte-compiled function object.")
 383   (object)
 384      Lisp_Object object;
 385 {
 386   if (COMPILEDP (object))
 387     return Qt;
 388   return Qnil;
 389 }
 390
 391 DEFUN ("char-or-string-p", Fchar_or_string_p, Schar_or_string_p, 1, 1, 0,
 392   "T if OBJECT is a character (an integer) or a string.")
 393   (object)
 394      register Lisp_Object object;
 395 {
 396   if (INTEGERP (object) || STRINGP (object))
 397     return Qt;
 398   return Qnil;
 399 }
 400 \f
 401 DEFUN ("integerp", Fintegerp, Sintegerp, 1, 1, 0, "T if OBJECT is an integer.")
 402   (object)
 403      Lisp_Object object;
 404 {
 405   if (INTEGERP (object))
 406     return Qt;
 407   return Qnil;
 408 }
 409
 410 DEFUN ("integer-or-marker-p", Finteger_or_marker_p, Sinteger_or_marker_p, 1, 1, 0,
 411   "T if OBJECT is an integer or a marker (editor pointer).")
 412   (object)
 413      register Lisp_Object object;
 414 {
 415   if (MARKERP (object) || INTEGERP (object))
 416     return Qt;
 417   return Qnil;
 418 }
 419
 420 DEFUN ("natnump", Fnatnump, Snatnump, 1, 1, 0,
 421   "T if OBJECT is a nonnegative integer.")
 422   (object)
 423      Lisp_Object object;
 424 {
 425   if (NATNUMP (object))
 426     return Qt;
 427   return Qnil;
 428 }
 429
 430 DEFUN ("numberp", Fnumberp, Snumberp, 1, 1, 0,
 431        "T if OBJECT is a number (floating point or integer).")
 432   (object)
 433      Lisp_Object object;
 434 {
 435   if (NUMBERP (object))
 436     return Qt;
 437   else
 438     return Qnil;
 439 }
 440
 441 DEFUN ("number-or-marker-p", Fnumber_or_marker_p,
 442        Snumber_or_marker_p, 1, 1, 0,
 443        "T if OBJECT is a number or a marker.")
 444   (object)
 445      Lisp_Object object;
 446 {
 447   if (NUMBERP (object) || MARKERP (object))
 448     return Qt;
 449   return Qnil;
 450 }
 451
 452 #ifdef LISP_FLOAT_TYPE
 453 DEFUN ("floatp", Ffloatp, Sfloatp, 1, 1, 0,
 454        "T if OBJECT is a floating point number.")
 455   (object)
 456      Lisp_Object object;
 457 {
 458   if (FLOATP (object))
 459     return Qt;
 460   return Qnil;
 461 }
 462 #endif /* LISP_FLOAT_TYPE */
 463 \f
 464 /* Extract and set components of lists */
 465
 466 DEFUN ("car", Fcar, Scar, 1, 1, 0,
 467   "Return the car of LIST.  If arg is nil, return nil.\n\
 468 Error if arg is not nil and not a cons cell.  See also `car-safe'.")
 469   (list)
 470      register Lisp_Object list;
 471 {
 472   while (1)
 473     {
 474       if (CONSP (list))
 475         return XCONS (list)->car;
 476       else if (EQ (list, Qnil))
 477         return Qnil;
 478       else
 479         list = wrong_type_argument (Qlistp, list);
 480     }
 481 }
 482
 483 DEFUN ("car-safe", Fcar_safe, Scar_safe, 1, 1, 0,
 484   "Return the car of OBJECT if it is a cons cell, or else nil.")
 485   (object)
 486      Lisp_Object object;
 487 {
 488   if (CONSP (object))
 489     return XCONS (object)->car;
 490   else
 491     return Qnil;
 492 }
 493
 494 DEFUN ("cdr", Fcdr, Scdr, 1, 1, 0,
 495   "Return the cdr of LIST.  If arg is nil, return nil.\n\
 496 Error if arg is not nil and not a cons cell.  See also `cdr-safe'.")
 497
 498   (list)
 499      register Lisp_Object list;
 500 {
 501   while (1)
 502     {
 503       if (CONSP (list))
 504         return XCONS (list)->cdr;
 505       else if (EQ (list, Qnil))
 506         return Qnil;
 507       else
 508         list = wrong_type_argument (Qlistp, list);
 509     }
 510 }
 511
 512 DEFUN ("cdr-safe", Fcdr_safe, Scdr_safe, 1, 1, 0,
 513   "Return the cdr of OBJECT if it is a cons cell, or else nil.")
 514   (object)
 515      Lisp_Object object;
 516 {
 517   if (CONSP (object))
 518     return XCONS (object)->cdr;
 519   else
 520     return Qnil;
 521 }
 522
 523 DEFUN ("setcar", Fsetcar, Ssetcar, 2, 2, 0,
 524   "Set the car of CELL to be NEWCAR.  Returns NEWCAR.")
 525   (cell, newcar)
 526      register Lisp_Object cell, newcar;
 527 {
 528   if (!CONSP (cell))
 529     cell = wrong_type_argument (Qconsp, cell);
 530
 531   CHECK_IMPURE (cell);
 532   XCONS (cell)->car = newcar;
 533   return newcar;
 534 }
 535
 536 DEFUN ("setcdr", Fsetcdr, Ssetcdr, 2, 2, 0,
 537   "Set the cdr of CELL to be NEWCDR.  Returns NEWCDR.")
 538   (cell, newcdr)
 539      register Lisp_Object cell, newcdr;
 540 {
 541   if (!CONSP (cell))
 542     cell = wrong_type_argument (Qconsp, cell);
 543
 544   CHECK_IMPURE (cell);
 545   XCONS (cell)->cdr = newcdr;
 546   return newcdr;
 547 }
 548 \f
 549 /* Extract and set components of symbols */
 550
 551 DEFUN ("boundp", Fboundp, Sboundp, 1, 1, 0, "T if SYMBOL's value is not void.")
 552   (symbol)
 553      register Lisp_Object symbol;
 554 {
 555   Lisp_Object valcontents;
 556   CHECK_SYMBOL (symbol, 0);
 557
 558   valcontents = XSYMBOL (symbol)->value;
 559
 560   if (BUFFER_LOCAL_VALUEP (valcontents)
 561       || SOME_BUFFER_LOCAL_VALUEP (valcontents))
 562     valcontents = swap_in_symval_forwarding (symbol, valcontents);
 563
 564   return (EQ (valcontents, Qunbound) ? Qnil : Qt);
 565 }
 566
 567 DEFUN ("fboundp", Ffboundp, Sfboundp, 1, 1, 0, "T if SYMBOL's function definition is not void.")
 568   (symbol)
 569      register Lisp_Object symbol;
 570 {
 571   CHECK_SYMBOL (symbol, 0);
 572   return (EQ (XSYMBOL (symbol)->function, Qunbound) ? Qnil : Qt);
 573 }
 574
 575 DEFUN ("makunbound", Fmakunbound, Smakunbound, 1, 1, 0, "Make SYMBOL's value be void.")
 576   (symbol)
 577      register Lisp_Object symbol;
 578 {
 579   CHECK_SYMBOL (symbol, 0);
 580   if (NILP (symbol) || EQ (symbol, Qt))
 581     return Fsignal (Qsetting_constant, Fcons (symbol, Qnil));
 582   Fset (symbol, Qunbound);
 583   return symbol;
 584 }
 585
 586 DEFUN ("fmakunbound", Ffmakunbound, Sfmakunbound, 1, 1, 0, "Make SYMBOL's function definition be void.")
 587   (symbol)
 588      register Lisp_Object symbol;
 589 {
 590   CHECK_SYMBOL (symbol, 0);
 591   if (NILP (symbol) || EQ (symbol, Qt))
 592     return Fsignal (Qsetting_constant, Fcons (symbol, Qnil));
 593   XSYMBOL (symbol)->function = Qunbound;
 594   return symbol;
 595 }
 596
 597 DEFUN ("symbol-function", Fsymbol_function, Ssymbol_function, 1, 1, 0,
 598   "Return SYMBOL's function definition.  Error if that is void.")
 599   (symbol)
 600      register Lisp_Object symbol;
 601 {
 602   CHECK_SYMBOL (symbol, 0);
 603   if (EQ (XSYMBOL (symbol)->function, Qunbound))
 604     return Fsignal (Qvoid_function, Fcons (symbol, Qnil));
 605   return XSYMBOL (symbol)->function;
 606 }
 607
 608 DEFUN ("symbol-plist", Fsymbol_plist, Ssymbol_plist, 1, 1, 0, "Return SYMBOL's property list.")
 609   (symbol)
 610      register Lisp_Object symbol;
 611 {
 612   CHECK_SYMBOL (symbol, 0);
 613   return XSYMBOL (symbol)->plist;
 614 }
 615
 616 DEFUN ("symbol-name", Fsymbol_name, Ssymbol_name, 1, 1, 0, "Return SYMBOL's name, a string.")
 617   (symbol)
 618      register Lisp_Object symbol;
 619 {
 620   register Lisp_Object name;
 621
 622   CHECK_SYMBOL (symbol, 0);
 623   XSETSTRING (name, XSYMBOL (symbol)->name);
 624   return name;
 625 }
 626
 627 DEFUN ("fset", Ffset, Sfset, 2, 2, 0,
 628   "Set SYMBOL's function definition to NEWVAL, and return NEWVAL.")
 629   (symbol, newdef)
 630      register Lisp_Object symbol, newdef;
 631 {
 632   CHECK_SYMBOL (symbol, 0);
 633   if (NILP (symbol) || EQ (symbol, Qt))
 634     return Fsignal (Qsetting_constant, Fcons (symbol, Qnil));
 635   if (!NILP (Vautoload_queue) && !EQ (XSYMBOL (symbol)->function, Qunbound))
 636     Vautoload_queue = Fcons (Fcons (symbol, XSYMBOL (symbol)->function),
 637                              Vautoload_queue);
 638   XSYMBOL (symbol)->function = newdef;
 639   /* Handle automatic advice activation */
 640   if (CONSP (XSYMBOL (symbol)->plist) && !NILP (Fget (symbol, Qad_advice_info)))
 641     {
 642       call2 (Qad_activate, symbol, Qnil);
 643       newdef = XSYMBOL (symbol)->function;
 644     }
 645   return newdef;
 646 }
 647
 648 /* This name should be removed once it is eliminated from elsewhere.  */
 649
 650 DEFUN ("defalias", Fdefalias, Sdefalias, 2, 2, 0,
 651   "Set SYMBOL's function definition to NEWDEF, and return NEWDEF.\n\
 652 Associates the function with the current load file, if any.")
 653   (symbol, newdef)
 654      register Lisp_Object symbol, newdef;
 655 {
 656   CHECK_SYMBOL (symbol, 0);
 657   if (!NILP (Vautoload_queue) && !EQ (XSYMBOL (symbol)->function, Qunbound))
 658     Vautoload_queue = Fcons (Fcons (symbol, XSYMBOL (symbol)->function),
 659                              Vautoload_queue);
 660   XSYMBOL (symbol)->function = newdef;
 661   /* Handle automatic advice activation */
 662   if (CONSP (XSYMBOL (symbol)->plist) && !NILP (Fget (symbol, Qad_advice_info)))
 663     {
 664       call2 (Qad_activate, symbol, Qnil);
 665       newdef = XSYMBOL (symbol)->function;
 666     }
 667   LOADHIST_ATTACH (symbol);
 668   return newdef;
 669 }
 670
 671 DEFUN ("define-function", Fdefine_function, Sdefine_function, 2, 2, 0,
 672   "Set SYMBOL's function definition to NEWVAL, and return NEWVAL.\n\
 673 Associates the function with the current load file, if any.")
 674   (symbol, newdef)
 675      register Lisp_Object symbol, newdef;
 676 {
 677   CHECK_SYMBOL (symbol, 0);
 678   if (!NILP (Vautoload_queue) && !EQ (XSYMBOL (symbol)->function, Qunbound))
 679     Vautoload_queue = Fcons (Fcons (symbol, XSYMBOL (symbol)->function),
 680                              Vautoload_queue);
 681   XSYMBOL (symbol)->function = newdef;
 682   /* Handle automatic advice activation */
 683   if (CONSP (XSYMBOL (symbol)->plist) && !NILP (Fget (symbol, Qad_advice_info)))
 684     {
 685       call2 (Qad_activate, symbol, Qnil);
 686       newdef = XSYMBOL (symbol)->function;
 687     }
 688   LOADHIST_ATTACH (symbol);
 689   return newdef;
 690 }
 691
 692 DEFUN ("setplist", Fsetplist, Ssetplist, 2, 2, 0,
 693   "Set SYMBOL's property list to NEWVAL, and return NEWVAL.")
 694   (symbol, newplist)
 695      register Lisp_Object symbol, newplist;
 696 {
 697   CHECK_SYMBOL (symbol, 0);
 698   XSYMBOL (symbol)->plist = newplist;
 699   return newplist;
 700 }
 701
 702 \f
 703 /* Getting and setting values of symbols */
 704
 705 /* Given the raw contents of a symbol value cell,
 706    return the Lisp value of the symbol.
 707    This does not handle buffer-local variables; use
 708    swap_in_symval_forwarding for that.  */
 709
 710 Lisp_Object
 711 do_symval_forwarding (valcontents)
 712      register Lisp_Object valcontents;
 713 {
 714   register Lisp_Object val;
 715   int offset;
 716   if (MISCP (valcontents))
 717     switch (XMISCTYPE (valcontents))
 718       {
 719       case Lisp_Misc_Intfwd:
 720         XSETINT (val, *XINTFWD (valcontents)->intvar);
 721         return val;
 722
 723       case Lisp_Misc_Boolfwd:
 724         return (*XBOOLFWD (valcontents)->boolvar ? Qt : Qnil);
 725
 726       case Lisp_Misc_Objfwd:
 727         return *XOBJFWD (valcontents)->objvar;
 728
 729       case Lisp_Misc_Buffer_Objfwd:
 730         offset = XBUFFER_OBJFWD (valcontents)->offset;
 731         return *(Lisp_Object *)(offset + (char *)current_buffer);
 732
 733       case Lisp_Misc_Kboard_Objfwd:
 734         offset = XKBOARD_OBJFWD (valcontents)->offset;
 735         return *(Lisp_Object *)(offset + (char *)current_kboard);
 736       }
 737   return valcontents;
 738 }
 739
 740 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
 741    of SYMBOL.  If SYMBOL is buffer-local, VALCONTENTS should be the
 742    buffer-independent contents of the value cell: forwarded just one
 743    step past the buffer-localness.  */
 744
 745 void
 746 store_symval_forwarding (symbol, valcontents, newval)
 747      Lisp_Object symbol;
 748      register Lisp_Object valcontents, newval;
 749 {
 750   switch (SWITCH_ENUM_CAST (XTYPE (valcontents)))
 751     {
 752     case Lisp_Misc:
 753       switch (XMISCTYPE (valcontents))
 754         {
 755         case Lisp_Misc_Intfwd:
 756           CHECK_NUMBER (newval, 1);
 757           *XINTFWD (valcontents)->intvar = XINT (newval);
 758           if (*XINTFWD (valcontents)->intvar != XINT (newval))
 759             error ("Value out of range for variable `%s'",
 760                    XSYMBOL (symbol)->name->data);
 761           break;
 762
 763         case Lisp_Misc_Boolfwd:
 764           *XBOOLFWD (valcontents)->boolvar = NILP (newval) ? 0 : 1;
 765           break;
 766
 767         case Lisp_Misc_Objfwd:
 768           *XOBJFWD (valcontents)->objvar = newval;
 769           break;
 770
 771         case Lisp_Misc_Buffer_Objfwd:
 772           {
 773             int offset = XBUFFER_OBJFWD (valcontents)->offset;
 774             Lisp_Object type;
 775
 776             type = *(Lisp_Object *)(offset + (char *)&buffer_local_types);
 777             if (! NILP (type) && ! NILP (newval)
 778                 && XTYPE (newval) != XINT (type))
 779               buffer_slot_type_mismatch (offset);
 780
 781             *(Lisp_Object *)(offset + (char *)current_buffer) = newval;
 782           }
 783           break;
 784
 785         case Lisp_Misc_Kboard_Objfwd:
 786           (*(Lisp_Object *)((char *)current_kboard
 787                             + XKBOARD_OBJFWD (valcontents)->offset))
 788             = newval;
 789           break;
 790
 791         default:
 792           goto def;
 793         }
 794       break;
 795
 796     default:
 797     def:
 798       valcontents = XSYMBOL (symbol)->value;
 799       if (BUFFER_LOCAL_VALUEP (valcontents)
 800           || SOME_BUFFER_LOCAL_VALUEP (valcontents))
 801         XBUFFER_LOCAL_VALUE (valcontents)->car = newval;
 802       else
 803         XSYMBOL (symbol)->value = newval;
 804     }
 805 }
 806
 807 /* Set up the buffer-local symbol SYMBOL for validity in the current
 808    buffer.  VALCONTENTS is the contents of its value cell.
 809    Return the value forwarded one step past the buffer-local indicator.  */
 810
 811 static Lisp_Object
 812 swap_in_symval_forwarding (symbol, valcontents)
 813      Lisp_Object symbol, valcontents;
 814 {
 815   /* valcontents is a pointer to a struct resembling the cons
 816      (REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE)).
 817
 818      CURRENT-ALIST-ELEMENT is a pointer to an element of BUFFER's
 819      local_var_alist, that being the element whose car is this
 820      variable.  Or it can be a pointer to the
 821      (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE), if BUFFER does not have
 822      an element in its alist for this variable.
 823
 824      If the current buffer is not BUFFER, we store the current
 825      REALVALUE value into CURRENT-ALIST-ELEMENT, then find the
 826      appropriate alist element for the buffer now current and set up
 827      CURRENT-ALIST-ELEMENT.  Then we set REALVALUE out of that
 828      element, and store into BUFFER.
 829
 830      Note that REALVALUE can be a forwarding pointer. */
 831
 832   register Lisp_Object tem1;
 833   tem1 = XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->car;
 834
 835   if (NILP (tem1) || current_buffer != XBUFFER (tem1))
 836     {
 837       tem1 = XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->cdr)->car;
 838       Fsetcdr (tem1,
 839                do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents)->car));
 840       tem1 = assq_no_quit (symbol, current_buffer->local_var_alist);
 841       if (NILP (tem1))
 842         tem1 = XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->cdr;
 843       XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->cdr)->car = tem1;
 844       XSETBUFFER (XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->car,
 845                   current_buffer);
 846       store_symval_forwarding (symbol, XBUFFER_LOCAL_VALUE (valcontents)->car,
 847                                Fcdr (tem1));
 848     }
 849   return XBUFFER_LOCAL_VALUE (valcontents)->car;
 850 }
 851 \f
 852 /* Find the value of a symbol, returning Qunbound if it's not bound.
 853    This is helpful for code which just wants to get a variable's value
 854    if it has one, without signaling an error.
 855    Note that it must not be possible to quit
 856    within this function.  Great care is required for this.  */
 857
 858 Lisp_Object
 859 find_symbol_value (symbol)
 860      Lisp_Object symbol;
 861 {
 862   register Lisp_Object valcontents, tem1;
 863   register Lisp_Object val;
 864   CHECK_SYMBOL (symbol, 0);
 865   valcontents = XSYMBOL (symbol)->value;
 866
 867   if (BUFFER_LOCAL_VALUEP (valcontents)
 868       || SOME_BUFFER_LOCAL_VALUEP (valcontents))
 869     valcontents = swap_in_symval_forwarding (symbol, valcontents);
 870
 871   if (MISCP (valcontents))
 872     {
 873       switch (XMISCTYPE (valcontents))
 874         {
 875         case Lisp_Misc_Intfwd:
 876           XSETINT (val, *XINTFWD (valcontents)->intvar);
 877           return val;
 878
 879         case Lisp_Misc_Boolfwd:
 880           return (*XBOOLFWD (valcontents)->boolvar ? Qt : Qnil);
 881
 882         case Lisp_Misc_Objfwd:
 883           return *XOBJFWD (valcontents)->objvar;
 884
 885         case Lisp_Misc_Buffer_Objfwd:
 886           return *(Lisp_Object *)(XBUFFER_OBJFWD (valcontents)->offset
 887                                   + (char *)current_buffer);
 888
 889         case Lisp_Misc_Kboard_Objfwd:
 890           return *(Lisp_Object *)(XKBOARD_OBJFWD (valcontents)->offset
 891                                   + (char *)current_kboard);
 892         }
 893     }
 894
 895   return valcontents;
 896 }
 897
 898 DEFUN ("symbol-value", Fsymbol_value, Ssymbol_value, 1, 1, 0,
 899   "Return SYMBOL's value.  Error if that is void.")
 900   (symbol)
 901      Lisp_Object symbol;
 902 {
 903   Lisp_Object val;
 904
 905   val = find_symbol_value (symbol);
 906   if (EQ (val, Qunbound))
 907     return Fsignal (Qvoid_variable, Fcons (symbol, Qnil));
 908   else
 909     return val;
 910 }
 911
 912 DEFUN ("set", Fset, Sset, 2, 2, 0,
 913   "Set SYMBOL's value to NEWVAL, and return NEWVAL.")
 914   (symbol, newval)
 915      register Lisp_Object symbol, newval;
 916 {
 917   int voide = EQ (newval, Qunbound);
 918
 919   register Lisp_Object valcontents, tem1, current_alist_element;
 920
 921   CHECK_SYMBOL (symbol, 0);
 922   if (NILP (symbol) || EQ (symbol, Qt))
 923     return Fsignal (Qsetting_constant, Fcons (symbol, Qnil));
 924   valcontents = XSYMBOL (symbol)->value;
 925
 926   if (BUFFER_OBJFWDP (valcontents))
 927     {
 928       register int idx = XBUFFER_OBJFWD (valcontents)->offset;
 929       register int mask = XINT (*((Lisp_Object *)
 930                                   (idx + (char *)&buffer_local_flags)));
 931       if (mask > 0)
 932         current_buffer->local_var_flags |= mask;
 933     }
 934
 935   else if (BUFFER_LOCAL_VALUEP (valcontents)
 936            || SOME_BUFFER_LOCAL_VALUEP (valcontents))
 937     {
 938       /* valcontents is actually a pointer to a struct resembling a cons,
 939          with contents something like:
 940          (REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE).
 941
 942          BUFFER is the last buffer for which this symbol's value was
 943          made up to date.
 944
 945          CURRENT-ALIST-ELEMENT is a pointer to an element of BUFFER's
 946          local_var_alist, that being the element whose car is this
 947          variable.  Or it can be a pointer to the
 948          (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE), if BUFFER does not
 949          have an element in its alist for this variable (that is, if
 950          BUFFER sees the default value of this variable).
 951
 952          If we want to examine or set the value and BUFFER is current,
 953          we just examine or set REALVALUE. If BUFFER is not current, we
 954          store the current REALVALUE value into CURRENT-ALIST-ELEMENT,
 955          then find the appropriate alist element for the buffer now
 956          current and set up CURRENT-ALIST-ELEMENT.  Then we set
 957          REALVALUE out of that element, and store into BUFFER.
 958
 959          If we are setting the variable and the current buffer does
 960          not have an alist entry for this variable, an alist entry is
 961          created.
 962
 963          Note that REALVALUE can be a forwarding pointer.  Each time
 964          it is examined or set, forwarding must be done.  */
 965
 966       /* What value are we caching right now?  */
 967       current_alist_element =
 968         XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->cdr)->car;
 969
 970       /* If the current buffer is not the buffer whose binding is
 971          currently cached, or if it's a Lisp_Buffer_Local_Value and
 972          we're looking at the default value, the cache is invalid; we
 973          need to write it out, and find the new CURRENT-ALIST-ELEMENT.  */
 974       if ((current_buffer
 975            != XBUFFER (XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->car))
 976           || (BUFFER_LOCAL_VALUEP (valcontents)
 977               && EQ (XCONS (current_alist_element)->car,
 978                      current_alist_element)))
 979         {
 980           /* Write out the cached value for the old buffer; copy it
 981              back to its alist element.  This works if the current
 982              buffer only sees the default value, too.  */
 983           Fsetcdr (current_alist_element,
 984                    do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents)->car));
 985
 986           /* Find the new value for CURRENT-ALIST-ELEMENT.  */
 987           tem1 = Fassq (symbol, current_buffer->local_var_alist);
 988           if (NILP (tem1))
 989             {
 990               /* This buffer still sees the default value.  */
 991
 992               /* If the variable is a Lisp_Some_Buffer_Local_Value,
 993                  make CURRENT-ALIST-ELEMENT point to itself,
 994                  indicating that we're seeing the default value.  */
 995               if (SOME_BUFFER_LOCAL_VALUEP (valcontents))
 996                 tem1 = XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->cdr;
 997
 998               /* If it's a Lisp_Buffer_Local_Value, give this buffer a
 999                  new assoc for a local value and set
1000                  CURRENT-ALIST-ELEMENT to point to that.  */
1001               else
1002                 {
1003                   tem1 = Fcons (symbol, Fcdr (current_alist_element));
1004                   current_buffer->local_var_alist =
1005                     Fcons (tem1, current_buffer->local_var_alist);
1006                 }
1007             }
1008           /* Cache the new buffer's assoc in CURRENT-ALIST-ELEMENT.  */
1009           XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->cdr)->car
1010             = tem1;
1011
1012           /* Set BUFFER, now that CURRENT-ALIST-ELEMENT is accurate.  */
1013           XSETBUFFER (XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->car,
1014                       current_buffer);
1015         }
1016       valcontents = XBUFFER_LOCAL_VALUE (valcontents)->car;
1017     }
1018
1019   /* If storing void (making the symbol void), forward only through
1020      buffer-local indicator, not through Lisp_Objfwd, etc.  */
1021   if (voide)
1022     store_symval_forwarding (symbol, Qnil, newval);
1023   else
1024     store_symval_forwarding (symbol, valcontents, newval);
1025
1026   return newval;
1027 }
1028 \f
1029 /* Access or set a buffer-local symbol's default value.  */
1030
1031 /* Return the default value of SYMBOL, but don't check for voidness.
1032    Return Qunbound if it is void.  */
1033
1034 Lisp_Object
1035 default_value (symbol)
1036      Lisp_Object symbol;
1037 {
1038   register Lisp_Object valcontents;
1039
1040   CHECK_SYMBOL (symbol, 0);
1041   valcontents = XSYMBOL (symbol)->value;
1042
1043   /* For a built-in buffer-local variable, get the default value
1044      rather than letting do_symval_forwarding get the current value.  */
1045   if (BUFFER_OBJFWDP (valcontents))
1046     {
1047       register int idx = XBUFFER_OBJFWD (valcontents)->offset;
1048
1049       if (XINT (*(Lisp_Object *) (idx + (char *) &buffer_local_flags)) != 0)
1050         return *(Lisp_Object *)(idx + (char *) &buffer_defaults);
1051     }
1052
1053   /* Handle user-created local variables.  */
1054   if (BUFFER_LOCAL_VALUEP (valcontents)
1055       || SOME_BUFFER_LOCAL_VALUEP (valcontents))
1056     {
1057       /* If var is set up for a buffer that lacks a local value for it,
1058          the current value is nominally the default value.
1059          But the current value slot may be more up to date, since
1060          ordinary setq stores just that slot.  So use that.  */
1061       Lisp_Object current_alist_element, alist_element_car;
1062       current_alist_element
1063         = XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->cdr)->car;
1064       alist_element_car = XCONS (current_alist_element)->car;
1065       if (EQ (alist_element_car, current_alist_element))
1066         return do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents)->car);
1067       else
1068         return XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->cdr)->cdr;
1069     }
1070   /* For other variables, get the current value.  */
1071   return do_symval_forwarding (valcontents);
1072 }
1073
1074 DEFUN ("default-boundp", Fdefault_boundp, Sdefault_boundp, 1, 1, 0,
1075   "Return T if SYMBOL has a non-void default value.\n\
1076 This is the value that is seen in buffers that do not have their own values\n\
1077 for this variable.")
1078   (symbol)
1079      Lisp_Object symbol;
1080 {
1081   register Lisp_Object value;
1082
1083   value = default_value (symbol);
1084   return (EQ (value, Qunbound) ? Qnil : Qt);
1085 }
1086
1087 DEFUN ("default-value", Fdefault_value, Sdefault_value, 1, 1, 0,
1088   "Return SYMBOL's default value.\n\
1089 This is the value that is seen in buffers that do not have their own values\n\
1090 for this variable.  The default value is meaningful for variables with\n\
1091 local bindings in certain buffers.")
1092   (symbol)
1093      Lisp_Object symbol;
1094 {
1095   register Lisp_Object value;
1096
1097   value = default_value (symbol);
1098   if (EQ (value, Qunbound))
1099     return Fsignal (Qvoid_variable, Fcons (symbol, Qnil));
1100   return value;
1101 }
1102
1103 DEFUN ("set-default", Fset_default, Sset_default, 2, 2, 0,
1104   "Set SYMBOL's default value to VAL.  SYMBOL and VAL are evaluated.\n\
1105 The default value is seen in buffers that do not have their own values\n\
1106 for this variable.")
1107   (symbol, value)
1108      Lisp_Object symbol, value;
1109 {
1110   register Lisp_Object valcontents, current_alist_element, alist_element_buffer;
1111
1112   CHECK_SYMBOL (symbol, 0);
1113   valcontents = XSYMBOL (symbol)->value;
1114
1115   /* Handle variables like case-fold-search that have special slots
1116      in the buffer.  Make them work apparently like Lisp_Buffer_Local_Value
1117      variables.  */
1118   if (BUFFER_OBJFWDP (valcontents))
1119     {
1120       register int idx = XBUFFER_OBJFWD (valcontents)->offset;
1121       register struct buffer *b;
1122       register int mask = XINT (*((Lisp_Object *)
1123                                   (idx + (char *)&buffer_local_flags)));
1124
1125       if (mask > 0)
1126         {
1127           *(Lisp_Object *)(idx + (char *) &buffer_defaults) = value;
1128           for (b = all_buffers; b; b = b->next)
1129             if (!(b->local_var_flags & mask))
1130               *(Lisp_Object *)(idx + (char *) b) = value;
1131         }
1132       return value;
1133     }
1134
1135   if (!BUFFER_LOCAL_VALUEP (valcontents)
1136       && !SOME_BUFFER_LOCAL_VALUEP (valcontents))
1137     return Fset (symbol, value);
1138
1139   /* Store new value into the DEFAULT-VALUE slot */
1140   XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->cdr)->cdr = value;
1141
1142   /* If that slot is current, we must set the REALVALUE slot too */
1143   current_alist_element
1144     = XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->cdr)->car;
1145   alist_element_buffer = Fcar (current_alist_element);
1146   if (EQ (alist_element_buffer, current_alist_element))
1147     store_symval_forwarding (symbol, XBUFFER_LOCAL_VALUE (valcontents)->car,
1148                              value);
1149
1150   return value;
1151 }
1152
1153 DEFUN ("setq-default", Fsetq_default, Ssetq_default, 2, UNEVALLED, 0,
1154        "Set the default value of variable VAR to VALUE.\n\
1155 VAR, the variable name, is literal (not evaluated);\n\
1156 VALUE is an expression and it is evaluated.\n\
1157 The default value of a variable is seen in buffers\n\
1158 that do not have their own values for the variable.\n\
1159 \n\
1160 More generally, you can use multiple variables and values, as in\n\
1161   (setq-default SYMBOL VALUE SYMBOL VALUE...)\n\
1162 This sets each SYMBOL's default value to the corresponding VALUE.\n\
1163 The VALUE for the Nth SYMBOL can refer to the new default values\n\
1164 of previous SYMs.")
1165   (args)
1166      Lisp_Object args;
1167 {
1168   register Lisp_Object args_left;
1169   register Lisp_Object val, symbol;
1170   struct gcpro gcpro1;
1171
1172   if (NILP (args))
1173     return Qnil;
1174
1175   args_left = args;
1176   GCPRO1 (args);
1177
1178   do
1179     {
1180       val = Feval (Fcar (Fcdr (args_left)));
1181       symbol = Fcar (args_left);
1182       Fset_default (symbol, val);
1183       args_left = Fcdr (Fcdr (args_left));
1184     }
1185   while (!NILP (args_left));
1186
1187   UNGCPRO;
1188   return val;
1189 }
1190 \f
1191 /* Lisp functions for creating and removing buffer-local variables.  */
1192
1193 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local, Smake_variable_buffer_local,
1194   1, 1, "vMake Variable Buffer Local: ",
1195   "Make VARIABLE have a separate value for each buffer.\n\
1196 At any time, the value for the current buffer is in effect.\n\
1197 There is also a default value which is seen in any buffer which has not yet\n\
1198 set its own value.\n\
1199 Using `set' or `setq' to set the variable causes it to have a separate value\n\
1200 for the current buffer if it was previously using the default value.\n\
1201 The function `default-value' gets the default value and `set-default' sets it.")
1202   (variable)
1203      register Lisp_Object variable;
1204 {
1205   register Lisp_Object tem, valcontents, newval;
1206
1207   CHECK_SYMBOL (variable, 0);
1208
1209   valcontents = XSYMBOL (variable)->value;
1210   if (EQ (variable, Qnil) || EQ (variable, Qt) || KBOARD_OBJFWDP (valcontents))
1211     error ("Symbol %s may not be buffer-local", XSYMBOL (variable)->name->data);
1212
1213   if (BUFFER_LOCAL_VALUEP (valcontents) || BUFFER_OBJFWDP (valcontents))
1214     return variable;
1215   if (SOME_BUFFER_LOCAL_VALUEP (valcontents))
1216     {
1217       XMISCTYPE (XSYMBOL (variable)->value) = Lisp_Misc_Buffer_Local_Value;
1218       return variable;
1219     }
1220   if (EQ (valcontents, Qunbound))
1221     XSYMBOL (variable)->value = Qnil;
1222   tem = Fcons (Qnil, Fsymbol_value (variable));
1223   XCONS (tem)->car = tem;
1224   newval = allocate_misc ();
1225   XMISCTYPE (newval) = Lisp_Misc_Buffer_Local_Value;
1226   XBUFFER_LOCAL_VALUE (newval)->car = XSYMBOL (variable)->value;
1227   XBUFFER_LOCAL_VALUE (newval)->cdr = Fcons (Fcurrent_buffer (), tem);
1228   XSYMBOL (variable)->value = newval;
1229   return variable;
1230 }
1231
1232 DEFUN ("make-local-variable", Fmake_local_variable, Smake_local_variable,
1233   1, 1, "vMake Local Variable: ",
1234   "Make VARIABLE have a separate value in the current buffer.\n\
1235 Other buffers will continue to share a common default value.\n\
1236 \(The buffer-local value of VARIABLE starts out as the same value\n\
1237 VARIABLE previously had.  If VARIABLE was void, it remains void.\)\n\
1238 See also `make-variable-buffer-local'.\n\n\
1239 If the variable is already arranged to become local when set,\n\
1240 this function causes a local value to exist for this buffer,\n\
1241 just as setting the variable would do.\n\
1242 \n\
1243 Do not use `make-local-variable' to make a hook variable buffer-local.\n\
1244 Use `make-local-hook' instead.")
1245   (variable)
1246      register Lisp_Object variable;
1247 {
1248   register Lisp_Object tem, valcontents;
1249
1250   CHECK_SYMBOL (variable, 0);
1251
1252   valcontents = XSYMBOL (variable)->value;
1253   if (EQ (variable, Qnil) || EQ (variable, Qt) || KBOARD_OBJFWDP (valcontents))
1254     error ("Symbol %s may not be buffer-local", XSYMBOL (variable)->name->data);
1255
1256   if (BUFFER_LOCAL_VALUEP (valcontents) || BUFFER_OBJFWDP (valcontents))
1257     {
1258       tem = Fboundp (variable);
1259
1260       /* Make sure the symbol has a local value in this particular buffer,
1261          by setting it to the same value it already has.  */
1262       Fset (variable, (EQ (tem, Qt) ? Fsymbol_value (variable) : Qunbound));
1263       return variable;
1264     }
1265   /* Make sure symbol is set up to hold per-buffer values */
1266   if (!SOME_BUFFER_LOCAL_VALUEP (valcontents))
1267     {
1268       Lisp_Object newval;
1269       tem = Fcons (Qnil, do_symval_forwarding (valcontents));
1270       XCONS (tem)->car = tem;
1271       newval = allocate_misc ();
1272       XMISCTYPE (newval) = Lisp_Misc_Some_Buffer_Local_Value;
1273       XBUFFER_LOCAL_VALUE (newval)->car = XSYMBOL (variable)->value;
1274       XBUFFER_LOCAL_VALUE (newval)->cdr = Fcons (Qnil, tem);
1275       XSYMBOL (variable)->value = newval;
1276     }
1277   /* Make sure this buffer has its own value of symbol */
1278   tem = Fassq (variable, current_buffer->local_var_alist);
1279   if (NILP (tem))
1280     {
1281       /* Swap out any local binding for some other buffer, and make
1282          sure the current value is permanently recorded, if it's the
1283          default value.  */
1284       find_symbol_value (variable);
1285
1286       current_buffer->local_var_alist
1287         = Fcons (Fcons (variable, XCONS (XCONS (XBUFFER_LOCAL_VALUE (XSYMBOL (variable)->value)->cdr)->cdr)->cdr),
1288                  current_buffer->local_var_alist);
1289
1290       /* Make sure symbol does not think it is set up for this buffer;
1291          force it to look once again for this buffer's value */
1292       {
1293         Lisp_Object *pvalbuf;
1294
1295         valcontents = XSYMBOL (variable)->value;
1296
1297         pvalbuf = &XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->car;
1298         if (current_buffer == XBUFFER (*pvalbuf))
1299           *pvalbuf = Qnil;
1300       }
1301     }
1302
1303   /* If the symbol forwards into a C variable, then swap in the
1304      variable for this buffer immediately.  If C code modifies the
1305      variable before we swap in, then that new value will clobber the
1306      default value the next time we swap.  */
1307   valcontents = XBUFFER_LOCAL_VALUE (XSYMBOL (variable)->value)->car;
1308   if (INTFWDP (valcontents) || BOOLFWDP (valcontents) || OBJFWDP (valcontents))
1309     swap_in_symval_forwarding (variable, XSYMBOL (variable)->value);
1310
1311   return variable;
1312 }
1313
1314 DEFUN ("kill-local-variable", Fkill_local_variable, Skill_local_variable,
1315   1, 1, "vKill Local Variable: ",
1316   "Make VARIABLE no longer have a separate value in the current buffer.\n\
1317 From now on the default value will apply in this buffer.")
1318   (variable)
1319      register Lisp_Object variable;
1320 {
1321   register Lisp_Object tem, valcontents;
1322
1323   CHECK_SYMBOL (variable, 0);
1324
1325   valcontents = XSYMBOL (variable)->value;
1326
1327   if (BUFFER_OBJFWDP (valcontents))
1328     {
1329       register int idx = XBUFFER_OBJFWD (valcontents)->offset;
1330       register int mask = XINT (*((Lisp_Object*)
1331                                   (idx + (char *)&buffer_local_flags)));
1332
1333       if (mask > 0)
1334         {
1335           *(Lisp_Object *)(idx + (char *) current_buffer)
1336             = *(Lisp_Object *)(idx + (char *) &buffer_defaults);
1337           current_buffer->local_var_flags &= ~mask;
1338         }
1339       return variable;
1340     }
1341
1342   if (!BUFFER_LOCAL_VALUEP (valcontents)
1343       && !SOME_BUFFER_LOCAL_VALUEP (valcontents))
1344     return variable;
1345
1346   /* Get rid of this buffer's alist element, if any */
1347
1348   tem = Fassq (variable, current_buffer->local_var_alist);
1349   if (!NILP (tem))
1350     current_buffer->local_var_alist
1351       = Fdelq (tem, current_buffer->local_var_alist);
1352
1353   /* If the symbol is set up for the current buffer, recompute its
1354      value.  We have to do it now, or else forwarded objects won't
1355      work right. */
1356   {
1357     Lisp_Object *pvalbuf;
1358     valcontents = XSYMBOL (variable)->value;
1359     pvalbuf = &XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->car;
1360     if (current_buffer == XBUFFER (*pvalbuf))
1361       {
1362         *pvalbuf = Qnil;
1363         find_symbol_value (variable);
1364       }
1365   }
1366
1367   return variable;
1368 }
1369
1370 DEFUN ("local-variable-p", Flocal_variable_p, Slocal_variable_p,
1371   1, 2, 0,
1372   "Non-nil if VARIABLE has a local binding in buffer BUFFER.\n\
1373 BUFFER defaults to the current buffer.")
1374   (variable, buffer)
1375      register Lisp_Object variable, buffer;
1376 {
1377   Lisp_Object valcontents;
1378   register struct buffer *buf;
1379
1380   if (NILP (buffer))
1381     buf = current_buffer;
1382   else
1383     {
1384       CHECK_BUFFER (buffer, 0);
1385       buf = XBUFFER (buffer);
1386     }
1387
1388   CHECK_SYMBOL (variable, 0);
1389
1390   valcontents = XSYMBOL (variable)->value;
1391   if (BUFFER_LOCAL_VALUEP (valcontents)
1392       || SOME_BUFFER_LOCAL_VALUEP (valcontents))
1393     {
1394       Lisp_Object tail, elt;
1395       for (tail = buf->local_var_alist; CONSP (tail); tail = XCONS (tail)->cdr)
1396         {
1397           elt = XCONS (tail)->car;
1398           if (EQ (variable, XCONS (elt)->car))
1399             return Qt;
1400         }
1401     }
1402   if (BUFFER_OBJFWDP (valcontents))
1403     {
1404       int offset = XBUFFER_OBJFWD (valcontents)->offset;
1405       int mask = XINT (*(Lisp_Object *)(offset + (char *)&buffer_local_flags));
1406       if (mask == -1 || (buf->local_var_flags & mask))
1407         return Qt;
1408     }
1409   return Qnil;
1410 }
1411
1412 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p, Slocal_variable_if_set_p,
1413   1, 2, 0,
1414   "Non-nil if VARIABLE will be local in buffer BUFFER if it is set there.\n\
1415 BUFFER defaults to the current buffer.")
1416   (variable, buffer)
1417      register Lisp_Object variable, buffer;
1418 {
1419   Lisp_Object valcontents;
1420   register struct buffer *buf;
1421
1422   if (NILP (buffer))
1423     buf = current_buffer;
1424   else
1425     {
1426       CHECK_BUFFER (buffer, 0);
1427       buf = XBUFFER (buffer);
1428     }
1429
1430   CHECK_SYMBOL (variable, 0);
1431
1432   valcontents = XSYMBOL (variable)->value;
1433
1434   /* This means that make-variable-buffer-local was done.  */
1435   if (BUFFER_LOCAL_VALUEP (valcontents))
1436     return Qt;
1437   /* All these slots become local if they are set.  */
1438   if (BUFFER_OBJFWDP (valcontents))
1439     return Qt;
1440   if (SOME_BUFFER_LOCAL_VALUEP (valcontents))
1441     {
1442       Lisp_Object tail, elt;
1443       for (tail = buf->local_var_alist; CONSP (tail); tail = XCONS (tail)->cdr)
1444         {
1445           elt = XCONS (tail)->car;
1446           if (EQ (variable, XCONS (elt)->car))
1447             return Qt;
1448         }
1449     }
1450   return Qnil;
1451 }
1452 \f
1453 /* Find the function at the end of a chain of symbol function indirections.  */
1454
1455 /* If OBJECT is a symbol, find the end of its function chain and
1456    return the value found there.  If OBJECT is not a symbol, just
1457    return it.  If there is a cycle in the function chain, signal a
1458    cyclic-function-indirection error.
1459
1460    This is like Findirect_function, except that it doesn't signal an
1461    error if the chain ends up unbound.  */
1462 Lisp_Object
1463 indirect_function (object)
1464      register Lisp_Object object;
1465 {
1466   Lisp_Object tortoise, hare;
1467
1468   hare = tortoise = object;
1469
1470   for (;;)
1471     {
1472       if (!SYMBOLP (hare) || EQ (hare, Qunbound))
1473         break;
1474       hare = XSYMBOL (hare)->function;
1475       if (!SYMBOLP (hare) || EQ (hare, Qunbound))
1476         break;
1477       hare = XSYMBOL (hare)->function;
1478
1479       tortoise = XSYMBOL (tortoise)->function;
1480
1481       if (EQ (hare, tortoise))
1482         Fsignal (Qcyclic_function_indirection, Fcons (object, Qnil));
1483     }
1484
1485   return hare;
1486 }
1487
1488 DEFUN ("indirect-function", Findirect_function, Sindirect_function, 1, 1, 0,
1489   "Return the function at the end of OBJECT's function chain.\n\
1490 If OBJECT is a symbol, follow all function indirections and return the final\n\
1491 function binding.\n\
1492 If OBJECT is not a symbol, just return it.\n\
1493 Signal a void-function error if the final symbol is unbound.\n\
1494 Signal a cyclic-function-indirection error if there is a loop in the\n\
1495 function chain of symbols.")
1496   (object)
1497     register Lisp_Object object;
1498 {
1499   Lisp_Object result;
1500
1501   result = indirect_function (object);
1502
1503   if (EQ (result, Qunbound))
1504     return Fsignal (Qvoid_function, Fcons (object, Qnil));
1505   return result;
1506 }
1507 \f
1508 /* Extract and set vector and string elements */
1509
1510 DEFUN ("aref", Faref, Saref, 2, 2, 0,
1511   "Return the element of ARRAY at index IDX.\n\
1512 ARRAY may be a vector, a string, a char-table, a bool-vector,\n\
1513 or a byte-code object.  IDX starts at 0.")
1514   (array, idx)
1515      register Lisp_Object array;
1516      Lisp_Object idx;
1517 {
1518   register int idxval;
1519
1520   CHECK_NUMBER (idx, 1);
1521   idxval = XINT (idx);
1522   if (STRINGP (array))
1523     {
1524       Lisp_Object val;
1525       if (idxval < 0 || idxval >= XSTRING (array)->size)
1526         args_out_of_range (array, idx);
1527       XSETFASTINT (val, (unsigned char) XSTRING (array)->data[idxval]);
1528       return val;
1529     }
1530   else if (BOOL_VECTOR_P (array))
1531     {
1532       int val;
1533
1534       if (idxval < 0 || idxval >= XBOOL_VECTOR (array)->size)
1535         args_out_of_range (array, idx);
1536
1537       val = (unsigned char) XBOOL_VECTOR (array)->data[idxval / BITS_PER_CHAR];
1538       return (val & (1 << (idxval % BITS_PER_CHAR)) ? Qt : Qnil);
1539     }
1540   else if (CHAR_TABLE_P (array))
1541     {
1542       Lisp_Object val;
1543
1544       if (idxval < 0)
1545         args_out_of_range (array, idx);
1546 #if 1
1547       if ((unsigned) idxval >= CHAR_TABLE_ORDINARY_SLOTS)
1548         args_out_of_range (array, idx);
1549       return val = XCHAR_TABLE (array)->contents[idxval];
1550 #else /* 0 */
1551       if ((unsigned) idxval < CHAR_TABLE_ORDINARY_SLOTS)
1552         val = XCHAR_TABLE (array)->data[idxval];
1553       else
1554         {
1555           int charset;
1556           unsigned char c1, c2;
1557           Lisp_Object val, temp;
1558
1559           BREAKUP_NON_ASCII_CHAR (idxval, charset, c1, c2);
1560
1561         try_parent_char_table:
1562           val = XCHAR_TABLE (array)->contents[charset];
1563           if (c1 == 0 || !CHAR_TABLE_P (val))
1564             return val;
1565
1566           temp = XCHAR_TABLE (val)->contents[c1];
1567           if (NILP (temp))
1568             val = XCHAR_TABLE (val)->defalt;
1569           else
1570             val = temp;
1571
1572           if (NILP (val) && !NILP (XCHAR_TABLE (array)->parent))
1573             {
1574               array = XCHAR_TABLE (array)->parent;
1575               goto try_parent_char_table;
1576
1577             }
1578
1579           if (c2 == 0 || !CHAR_TABLE_P (val))
1580             return val;
1581
1582           temp = XCHAR_TABLE (val)->contents[c2];
1583           if (NILP (temp))
1584             val = XCHAR_TABLE (val)->defalt;
1585           else
1586             val = temp;
1587
1588           if (NILP (val) && !NILP (XCHAR_TABLE (array)->parent))
1589             {
1590               array = XCHAR_TABLE (array)->parent;
1591               goto try_parent_char_table;
1592             }
1593
1594           return val;
1595         }
1596 #endif /* 0 */
1597     }
1598   else
1599     {
1600       int size;
1601       if (VECTORP (array))
1602         size = XVECTOR (array)->size;
1603       else if (COMPILEDP (array))
1604         size = XVECTOR (array)->size & PSEUDOVECTOR_SIZE_MASK;
1605       else
1606         wrong_type_argument (Qarrayp, array);
1607
1608       if (idxval < 0 || idxval >= size)
1609         args_out_of_range (array, idx);
1610       return XVECTOR (array)->contents[idxval];
1611     }
1612 }
1613
1614 DEFUN ("aset", Faset, Saset, 3, 3, 0,
1615   "Store into the element of ARRAY at index IDX the value NEWELT.\n\
1616 ARRAY may be a vector or a string.  IDX starts at 0.")
1617   (array, idx, newelt)
1618      register Lisp_Object array;
1619      Lisp_Object idx, newelt;
1620 {
1621   register int idxval;
1622
1623   CHECK_NUMBER (idx, 1);
1624   idxval = XINT (idx);
1625   if (!VECTORP (array) && !STRINGP (array) && !BOOL_VECTOR_P (array)
1626       && ! CHAR_TABLE_P (array))
1627     array = wrong_type_argument (Qarrayp, array);
1628   CHECK_IMPURE (array);
1629
1630   if (VECTORP (array))
1631     {
1632       if (idxval < 0 || idxval >= XVECTOR (array)->size)
1633         args_out_of_range (array, idx);
1634       XVECTOR (array)->contents[idxval] = newelt;
1635     }
1636   else if (BOOL_VECTOR_P (array))
1637     {
1638       int val;
1639
1640       if (idxval < 0 || idxval >= XBOOL_VECTOR (array)->size)
1641         args_out_of_range (array, idx);
1642
1643       val = (unsigned char) XBOOL_VECTOR (array)->data[idxval / BITS_PER_CHAR];
1644
1645       if (! NILP (newelt))
1646         val |= 1 << (idxval % BITS_PER_CHAR);
1647       else
1648         val &= ~(1 << (idxval % BITS_PER_CHAR));
1649       XBOOL_VECTOR (array)->data[idxval / BITS_PER_CHAR] = val;
1650     }
1651   else if (CHAR_TABLE_P (array))
1652     {
1653       Lisp_Object val;
1654
1655       if (idxval < 0)
1656         args_out_of_range (array, idx);
1657 #if 1
1658       if (idxval >= CHAR_TABLE_ORDINARY_SLOTS)
1659         args_out_of_range (array, idx);
1660       XCHAR_TABLE (array)->contents[idxval] = newelt;
1661       return newelt;
1662 #else /* 0 */
1663       if (idxval < CHAR_TABLE_ORDINARY_SLOTS)
1664         val = XCHAR_TABLE (array)->contents[idxval];
1665       else
1666         {
1667           int charset;
1668           unsigned char c1, c2;
1669           Lisp_Object val, val2;
1670
1671           BREAKUP_NON_ASCII_CHAR (idxval, charset, c1, c2);
1672
1673           if (c1 == 0)
1674             return XCHAR_TABLE (array)->contents[charset] = newelt;
1675
1676           val = XCHAR_TABLE (array)->contents[charset];
1677           if (!CHAR_TABLE_P (val))
1678             XCHAR_TABLE (array)->contents[charset]
1679               = val = Fmake_char_table (Qnil);
1680
1681           if (c2 == 0)
1682             return XCHAR_TABLE (val)->contents[c1] = newelt;
1683
1684           val2 = XCHAR_TABLE (val)->contents[c2];
1685           if (!CHAR_TABLE_P (val2))
1686             XCHAR_TABLE (val)->contents[charset]
1687               = val2 = Fmake_char_table (Qnil);
1688
1689           return XCHAR_TABLE (val2)->contents[c2] = newelt;
1690         }
1691 #endif /* 0 */
1692     }
1693   else
1694     {
1695       if (idxval < 0 || idxval >= XSTRING (array)->size)
1696         args_out_of_range (array, idx);
1697       CHECK_NUMBER (newelt, 2);
1698       XSTRING (array)->data[idxval] = XINT (newelt);
1699     }
1700
1701   return newelt;
1702 }
1703 \f
1704 /* Arithmetic functions */
1705
1706 enum comparison { equal, notequal, less, grtr, less_or_equal, grtr_or_equal };
1707
1708 Lisp_Object
1709 arithcompare (num1, num2, comparison)
1710      Lisp_Object num1, num2;
1711      enum comparison comparison;
1712 {
1713   double f1, f2;
1714   int floatp = 0;
1715
1716 #ifdef LISP_FLOAT_TYPE
1717   CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1, 0);
1718   CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2, 0);
1719
1720   if (FLOATP (num1) || FLOATP (num2))
1721     {
1722       floatp = 1;
1723       f1 = (FLOATP (num1)) ? XFLOAT (num1)->data : XINT (num1);
1724       f2 = (FLOATP (num2)) ? XFLOAT (num2)->data : XINT (num2);
1725     }
1726 #else
1727   CHECK_NUMBER_COERCE_MARKER (num1, 0);
1728   CHECK_NUMBER_COERCE_MARKER (num2, 0);
1729 #endif /* LISP_FLOAT_TYPE */
1730
1731   switch (comparison)
1732     {
1733     case equal:
1734       if (floatp ? f1 == f2 : XINT (num1) == XINT (num2))
1735         return Qt;
1736       return Qnil;
1737
1738     case notequal:
1739       if (floatp ? f1 != f2 : XINT (num1) != XINT (num2))
1740         return Qt;
1741       return Qnil;
1742
1743     case less:
1744       if (floatp ? f1 < f2 : XINT (num1) < XINT (num2))
1745         return Qt;
1746       return Qnil;
1747
1748     case less_or_equal:
1749       if (floatp ? f1 <= f2 : XINT (num1) <= XINT (num2))
1750         return Qt;
1751       return Qnil;
1752
1753     case grtr:
1754       if (floatp ? f1 > f2 : XINT (num1) > XINT (num2))
1755         return Qt;
1756       return Qnil;
1757
1758     case grtr_or_equal:
1759       if (floatp ? f1 >= f2 : XINT (num1) >= XINT (num2))
1760         return Qt;
1761       return Qnil;
1762
1763     default:
1764       abort ();
1765     }
1766 }
1767
1768 DEFUN ("=", Feqlsign, Seqlsign, 2, 2, 0,
1769   "T if two args, both numbers or markers, are equal.")
1770   (num1, num2)
1771      register Lisp_Object num1, num2;
1772 {
1773   return arithcompare (num1, num2, equal);
1774 }
1775
1776 DEFUN ("<", Flss, Slss, 2, 2, 0,
1777   "T if first arg is less than second arg.  Both must be numbers or markers.")
1778   (num1, num2)
1779      register Lisp_Object num1, num2;
1780 {
1781   return arithcompare (num1, num2, less);
1782 }
1783
1784 DEFUN (">", Fgtr, Sgtr, 2, 2, 0,
1785   "T if first arg is greater than second arg.  Both must be numbers or markers.")
1786   (num1, num2)
1787      register Lisp_Object num1, num2;
1788 {
1789   return arithcompare (num1, num2, grtr);
1790 }
1791
1792 DEFUN ("<=", Fleq, Sleq, 2, 2, 0,
1793   "T if first arg is less than or equal to second arg.\n\
1794 Both must be numbers or markers.")
1795   (num1, num2)
1796      register Lisp_Object num1, num2;
1797 {
1798   return arithcompare (num1, num2, less_or_equal);
1799 }
1800
1801 DEFUN (">=", Fgeq, Sgeq, 2, 2, 0,
1802   "T if first arg is greater than or equal to second arg.\n\
1803 Both must be numbers or markers.")
1804   (num1, num2)
1805      register Lisp_Object num1, num2;
1806 {
1807   return arithcompare (num1, num2, grtr_or_equal);
1808 }
1809
1810 DEFUN ("/=", Fneq, Sneq, 2, 2, 0,
1811   "T if first arg is not equal to second arg.  Both must be numbers or markers.")
1812   (num1, num2)
1813      register Lisp_Object num1, num2;
1814 {
1815   return arithcompare (num1, num2, notequal);
1816 }
1817
1818 DEFUN ("zerop", Fzerop, Szerop, 1, 1, 0, "T if NUMBER is zero.")
1819   (number)
1820      register Lisp_Object number;
1821 {
1822 #ifdef LISP_FLOAT_TYPE
1823   CHECK_NUMBER_OR_FLOAT (number, 0);
1824
1825   if (FLOATP (number))
1826     {
1827       if (XFLOAT(number)->data == 0.0)
1828         return Qt;
1829       return Qnil;
1830     }
1831 #else
1832   CHECK_NUMBER (number, 0);
1833 #endif /* LISP_FLOAT_TYPE */
1834
1835   if (!XINT (number))
1836     return Qt;
1837   return Qnil;
1838 }
1839 \f
1840 /* Convert between long values and pairs of Lisp integers.  */
1841
1842 Lisp_Object
1843 long_to_cons (i)
1844      unsigned long i;
1845 {
1846   unsigned int top = i >> 16;
1847   unsigned int bot = i & 0xFFFF;
1848   if (top == 0)
1849     return make_number (bot);
1850   if (top == (unsigned long)-1 >> 16)
1851     return Fcons (make_number (-1), make_number (bot));
1852   return Fcons (make_number (top), make_number (bot));
1853 }
1854
1855 unsigned long
1856 cons_to_long (c)
1857      Lisp_Object c;
1858 {
1859   Lisp_Object top, bot;
1860   if (INTEGERP (c))
1861     return XINT (c);
1862   top = XCONS (c)->car;
1863   bot = XCONS (c)->cdr;
1864   if (CONSP (bot))
1865     bot = XCONS (bot)->car;
1866   return ((XINT (top) << 16) | XINT (bot));
1867 }
1868 \f
1869 DEFUN ("number-to-string", Fnumber_to_string, Snumber_to_string, 1, 1, 0,
1870   "Convert NUMBER to a string by printing it in decimal.\n\
1871 Uses a minus sign if negative.\n\
1872 NUMBER may be an integer or a floating point number.")
1873   (number)
1874      Lisp_Object number;
1875 {
1876   char buffer[VALBITS];
1877
1878 #ifndef LISP_FLOAT_TYPE
1879   CHECK_NUMBER (number, 0);
1880 #else
1881   CHECK_NUMBER_OR_FLOAT (number, 0);
1882
1883   if (FLOATP (number))
1884     {
1885       char pigbuf[350]; /* see comments in float_to_string */
1886
1887       float_to_string (pigbuf, XFLOAT(number)->data);
1888       return build_string (pigbuf);
1889     }
1890 #endif /* LISP_FLOAT_TYPE */
1891
1892   if (sizeof (int) == sizeof (EMACS_INT))
1893     sprintf (buffer, "%d", XINT (number));
1894   else if (sizeof (long) == sizeof (EMACS_INT))
1895     sprintf (buffer, "%ld", XINT (number));
1896   else
1897     abort ();
1898   return build_string (buffer);
1899 }
1900
1901 DEFUN ("string-to-number", Fstring_to_number, Sstring_to_number, 1, 1, 0,
1902   "Convert STRING to a number by parsing it as a decimal number.\n\
1903 This parses both integers and floating point numbers.\n\
1904 It ignores leading spaces and tabs.")
1905   (string)
1906      register Lisp_Object string;
1907 {
1908   Lisp_Object value;
1909   unsigned char *p;
1910
1911   CHECK_STRING (string, 0);
1912
1913   p = XSTRING (string)->data;
1914
1915   /* Skip any whitespace at the front of the number.  Some versions of
1916      atoi do this anyway, so we might as well make Emacs lisp consistent.  */
1917   while (*p == ' ' || *p == '\t')
1918     p++;
1919
1920 #ifdef LISP_FLOAT_TYPE
1921   if (isfloat_string (p))
1922     return make_float (atof (p));
1923 #endif /* LISP_FLOAT_TYPE */
1924
1925   if (sizeof (int) == sizeof (EMACS_INT))
1926     XSETINT (value, atoi (p));
1927   else if (sizeof (long) == sizeof (EMACS_INT))
1928     XSETINT (value, atol (p));
1929   else
1930     abort ();
1931   return value;
1932 }
1933 \f
1934 enum arithop
1935   { Aadd, Asub, Amult, Adiv, Alogand, Alogior, Alogxor, Amax, Amin };
1936
1937 extern Lisp_Object float_arith_driver ();
1938
1939 Lisp_Object
1940 arith_driver (code, nargs, args)
1941      enum arithop code;
1942      int nargs;
1943      register Lisp_Object *args;
1944 {
1945   register Lisp_Object val;
1946   register int argnum;
1947   register EMACS_INT accum;
1948   register EMACS_INT next;
1949
1950   switch (SWITCH_ENUM_CAST (code))
1951     {
1952     case Alogior:
1953     case Alogxor:
1954     case Aadd:
1955     case Asub:
1956       accum = 0; break;
1957     case Amult:
1958       accum = 1; break;
1959     case Alogand:
1960       accum = -1; break;
1961     }
1962
1963   for (argnum = 0; argnum < nargs; argnum++)
1964     {
1965       val = args[argnum];    /* using args[argnum] as argument to CHECK_NUMBER_... */
1966 #ifdef LISP_FLOAT_TYPE
1967       CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val, argnum);
1968
1969       if (FLOATP (val)) /* time to do serious math */
1970         return (float_arith_driver ((double) accum, argnum, code,
1971                                     nargs, args));
1972 #else
1973       CHECK_NUMBER_COERCE_MARKER (val, argnum);
1974 #endif /* LISP_FLOAT_TYPE */
1975       args[argnum] = val;    /* runs into a compiler bug. */
1976       next = XINT (args[argnum]);
1977       switch (SWITCH_ENUM_CAST (code))
1978         {
1979         case Aadd: accum += next; break;
1980         case Asub:
1981           if (!argnum && nargs != 1)
1982             next = - next;
1983           accum -= next;
1984           break;
1985         case Amult: accum *= next; break;
1986         case Adiv:
1987           if (!argnum) accum = next;
1988           else
1989             {
1990               if (next == 0)
1991                 Fsignal (Qarith_error, Qnil);
1992               accum /= next;
1993             }
1994           break;
1995         case Alogand: accum &= next; break;
1996         case Alogior: accum |= next; break;
1997         case Alogxor: accum ^= next; break;
1998         case Amax: if (!argnum || next > accum) accum = next; break;
1999         case Amin: if (!argnum || next < accum) accum = next; break;
2000         }
2001     }
2002
2003   XSETINT (val, accum);
2004   return val;
2005 }
2006
2007 #ifdef LISP_FLOAT_TYPE
2008
2009 #undef isnan
2010 #define isnan(x) ((x) != (x))
2011
2012 Lisp_Object
2013 float_arith_driver (accum, argnum, code, nargs, args)
2014      double accum;
2015      register int argnum;
2016      enum arithop code;
2017      int nargs;
2018      register Lisp_Object *args;
2019 {
2020   register Lisp_Object val;
2021   double next;
2022
2023   for (; argnum < nargs; argnum++)
2024     {
2025       val = args[argnum];    /* using args[argnum] as argument to CHECK_NUMBER_... */
2026       CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val, argnum);
2027
2028       if (FLOATP (val))
2029         {
2030           next = XFLOAT (val)->data;
2031         }
2032       else
2033         {
2034           args[argnum] = val;    /* runs into a compiler bug. */
2035           next = XINT (args[argnum]);
2036         }
2037       switch (SWITCH_ENUM_CAST (code))
2038         {
2039         case Aadd:
2040           accum += next;
2041           break;
2042         case Asub:
2043           if (!argnum && nargs != 1)
2044             next = - next;
2045           accum -= next;
2046           break;
2047         case Amult:
2048           accum *= next;
2049           break;
2050         case Adiv:
2051           if (!argnum)
2052             accum = next;
2053           else
2054             {
2055               if (next == 0)
2056                 Fsignal (Qarith_error, Qnil);
2057               accum /= next;
2058             }
2059           break;
2060         case Alogand:
2061         case Alogior:
2062         case Alogxor:
2063           return wrong_type_argument (Qinteger_or_marker_p, val);
2064         case Amax:
2065           if (!argnum || isnan (next) || next > accum)
2066             accum = next;
2067           break;
2068         case Amin:
2069           if (!argnum || isnan (next) || next < accum)
2070             accum = next;
2071           break;
2072         }
2073     }
2074
2075   return make_float (accum);
2076 }
2077 #endif /* LISP_FLOAT_TYPE */
2078
2079 DEFUN ("+", Fplus, Splus, 0, MANY, 0,
2080   "Return sum of any number of arguments, which are numbers or markers.")
2081   (nargs, args)
2082      int nargs;
2083      Lisp_Object *args;
2084 {
2085   return arith_driver (Aadd, nargs, args);
2086 }
2087
2088 DEFUN ("-", Fminus, Sminus, 0, MANY, 0,
2089   "Negate number or subtract numbers or markers.\n\
2090 With one arg, negates it.  With more than one arg,\n\
2091 subtracts all but the first from the first.")
2092   (nargs, args)
2093      int nargs;
2094      Lisp_Object *args;
2095 {
2096   return arith_driver (Asub, nargs, args);
2097 }
2098
2099 DEFUN ("*", Ftimes, Stimes, 0, MANY, 0,
2100   "Returns product of any number of arguments, which are numbers or markers.")
2101   (nargs, args)
2102      int nargs;
2103      Lisp_Object *args;
2104 {
2105   return arith_driver (Amult, nargs, args);
2106 }
2107
2108 DEFUN ("/", Fquo, Squo, 2, MANY, 0,
2109   "Returns first argument divided by all the remaining arguments.\n\
2110 The arguments must be numbers or markers.")
2111   (nargs, args)
2112      int nargs;
2113      Lisp_Object *args;
2114 {
2115   return arith_driver (Adiv, nargs, args);
2116 }
2117
2118 DEFUN ("%", Frem, Srem, 2, 2, 0,
2119   "Returns remainder of X divided by Y.\n\
2120 Both must be integers or markers.")
2121   (x, y)
2122      register Lisp_Object x, y;
2123 {
2124   Lisp_Object val;
2125
2126   CHECK_NUMBER_COERCE_MARKER (x, 0);
2127   CHECK_NUMBER_COERCE_MARKER (y, 1);
2128
2129   if (XFASTINT (y) == 0)
2130     Fsignal (Qarith_error, Qnil);
2131
2132   XSETINT (val, XINT (x) % XINT (y));
2133   return val;
2134 }
2135
2136 #ifndef HAVE_FMOD
2137 double
2138 fmod (f1, f2)
2139      double f1, f2;
2140 {
2141   if (f2 < 0.0)
2142     f2 = -f2;
2143   return (f1 - f2 * floor (f1/f2));
2144 }
2145 #endif /* ! HAVE_FMOD */
2146
2147 DEFUN ("mod", Fmod, Smod, 2, 2, 0,
2148   "Returns X modulo Y.\n\
2149 The result falls between zero (inclusive) and Y (exclusive).\n\
2150 Both X and Y must be numbers or markers.")
2151   (x, y)
2152      register Lisp_Object x, y;
2153 {
2154   Lisp_Object val;
2155   EMACS_INT i1, i2;
2156
2157 #ifdef LISP_FLOAT_TYPE
2158   CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x, 0);
2159   CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y, 1);
2160
2161   if (FLOATP (x) || FLOATP (y))
2162     {
2163       double f1, f2;
2164
2165       f1 = FLOATP (x) ? XFLOAT (x)->data : XINT (x);
2166       f2 = FLOATP (y) ? XFLOAT (y)->data : XINT (y);
2167       if (f2 == 0)
2168         Fsignal (Qarith_error, Qnil);
2169
2170       f1 = fmod (f1, f2);
2171       /* If the "remainder" comes out with the wrong sign, fix it.  */
2172       if (f2 < 0 ? f1 > 0 : f1 < 0)
2173         f1 += f2;
2174       return (make_float (f1));
2175     }
2176 #else /* not LISP_FLOAT_TYPE */
2177   CHECK_NUMBER_COERCE_MARKER (x, 0);
2178   CHECK_NUMBER_COERCE_MARKER (y, 1);
2179 #endif /* not LISP_FLOAT_TYPE */
2180
2181   i1 = XINT (x);
2182   i2 = XINT (y);
2183
2184   if (i2 == 0)
2185     Fsignal (Qarith_error, Qnil);
2186
2187   i1 %= i2;
2188
2189   /* If the "remainder" comes out with the wrong sign, fix it.  */
2190   if (i2 < 0 ? i1 > 0 : i1 < 0)
2191     i1 += i2;
2192
2193   XSETINT (val, i1);
2194   return val;
2195 }
2196
2197 DEFUN ("max", Fmax, Smax, 1, MANY, 0,
2198   "Return largest of all the arguments (which must be numbers or markers).\n\
2199 The value is always a number; markers are converted to numbers.")
2200   (nargs, args)
2201      int nargs;
2202      Lisp_Object *args;
2203 {
2204   return arith_driver (Amax, nargs, args);
2205 }
2206
2207 DEFUN ("min", Fmin, Smin, 1, MANY, 0,
2208   "Return smallest of all the arguments (which must be numbers or markers).\n\
2209 The value is always a number; markers are converted to numbers.")
2210   (nargs, args)
2211      int nargs;
2212      Lisp_Object *args;
2213 {
2214   return arith_driver (Amin, nargs, args);
2215 }
2216
2217 DEFUN ("logand", Flogand, Slogand, 0, MANY, 0,
2218   "Return bitwise-and of all the arguments.\n\
2219 Arguments may be integers, or markers converted to integers.")
2220   (nargs, args)
2221      int nargs;
2222      Lisp_Object *args;
2223 {
2224   return arith_driver (Alogand, nargs, args);
2225 }
2226
2227 DEFUN ("logior", Flogior, Slogior, 0, MANY, 0,
2228   "Return bitwise-or of all the arguments.\n\
2229 Arguments may be integers, or markers converted to integers.")
2230   (nargs, args)
2231      int nargs;
2232      Lisp_Object *args;
2233 {
2234   return arith_driver (Alogior, nargs, args);
2235 }
2236
2237 DEFUN ("logxor", Flogxor, Slogxor, 0, MANY, 0,
2238   "Return bitwise-exclusive-or of all the arguments.\n\
2239 Arguments may be integers, or markers converted to integers.")
2240   (nargs, args)
2241      int nargs;
2242      Lisp_Object *args;
2243 {
2244   return arith_driver (Alogxor, nargs, args);
2245 }
2246
2247 DEFUN ("ash", Fash, Sash, 2, 2, 0,
2248   "Return VALUE with its bits shifted left by COUNT.\n\
2249 If COUNT is negative, shifting is actually to the right.\n\
2250 In this case, the sign bit is duplicated.")
2251   (value, count)
2252      register Lisp_Object value, count;
2253 {
2254   register Lisp_Object val;
2255
2256   CHECK_NUMBER (value, 0);
2257   CHECK_NUMBER (count, 1);
2258
2259   if (XINT (count) > 0)
2260     XSETINT (val, XINT (value) << XFASTINT (count));
2261   else
2262     XSETINT (val, XINT (value) >> -XINT (count));
2263   return val;
2264 }
2265
2266 DEFUN ("lsh", Flsh, Slsh, 2, 2, 0,
2267   "Return VALUE with its bits shifted left by COUNT.\n\
2268 If COUNT is negative, shifting is actually to the right.\n\
2269 In this case,  zeros are shifted in on the left.")
2270   (value, count)
2271      register Lisp_Object value, count;
2272 {
2273   register Lisp_Object val;
2274
2275   CHECK_NUMBER (value, 0);
2276   CHECK_NUMBER (count, 1);
2277
2278   if (XINT (count) > 0)
2279     XSETINT (val, (EMACS_UINT) XUINT (value) << XFASTINT (count));
2280   else
2281     XSETINT (val, (EMACS_UINT) XUINT (value) >> -XINT (count));
2282   return val;
2283 }
2284
2285 DEFUN ("1+", Fadd1, Sadd1, 1, 1, 0,
2286   "Return NUMBER plus one.  NUMBER may be a number or a marker.\n\
2287 Markers are converted to integers.")
2288   (number)
2289      register Lisp_Object number;
2290 {
2291 #ifdef LISP_FLOAT_TYPE
2292   CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number, 0);
2293
2294   if (FLOATP (number))
2295     return (make_float (1.0 + XFLOAT (number)->data));
2296 #else
2297   CHECK_NUMBER_COERCE_MARKER (number, 0);
2298 #endif /* LISP_FLOAT_TYPE */
2299
2300   XSETINT (number, XINT (number) + 1);
2301   return number;
2302 }
2303
2304 DEFUN ("1-", Fsub1, Ssub1, 1, 1, 0,
2305   "Return NUMBER minus one.  NUMBER may be a number or a marker.\n\
2306 Markers are converted to integers.")
2307   (number)
2308      register Lisp_Object number;
2309 {
2310 #ifdef LISP_FLOAT_TYPE
2311   CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number, 0);
2312
2313   if (FLOATP (number))
2314     return (make_float (-1.0 + XFLOAT (number)->data));
2315 #else
2316   CHECK_NUMBER_COERCE_MARKER (number, 0);
2317 #endif /* LISP_FLOAT_TYPE */
2318
2319   XSETINT (number, XINT (number) - 1);
2320   return number;
2321 }
2322
2323 DEFUN ("lognot", Flognot, Slognot, 1, 1, 0,
2324   "Return the bitwise complement of NUMBER.  NUMBER must be an integer.")
2325   (number)
2326      register Lisp_Object number;
2327 {
2328   CHECK_NUMBER (number, 0);
2329   XSETINT (number, ~XINT (number));
2330   return number;
2331 }
2332 \f
2333 void
2334 syms_of_data ()
2335 {
2336   Lisp_Object error_tail, arith_tail;
2337
2338   Qquote = intern ("quote");
2339   Qlambda = intern ("lambda");
2340   Qsubr = intern ("subr");
2341   Qerror_conditions = intern ("error-conditions");
2342   Qerror_message = intern ("error-message");
2343   Qtop_level = intern ("top-level");
2344
2345   Qerror = intern ("error");
2346   Qquit = intern ("quit");
2347   Qwrong_type_argument = intern ("wrong-type-argument");
2348   Qargs_out_of_range = intern ("args-out-of-range");
2349   Qvoid_function = intern ("void-function");
2350   Qcyclic_function_indirection = intern ("cyclic-function-indirection");
2351   Qvoid_variable = intern ("void-variable");
2352   Qsetting_constant = intern ("setting-constant");
2353   Qinvalid_read_syntax = intern ("invalid-read-syntax");
2354
2355   Qinvalid_function = intern ("invalid-function");
2356   Qwrong_number_of_arguments = intern ("wrong-number-of-arguments");
2357   Qno_catch = intern ("no-catch");
2358   Qend_of_file = intern ("end-of-file");
2359   Qarith_error = intern ("arith-error");
2360   Qbeginning_of_buffer = intern ("beginning-of-buffer");
2361   Qend_of_buffer = intern ("end-of-buffer");
2362   Qbuffer_read_only = intern ("buffer-read-only");
2363   Qmark_inactive = intern ("mark-inactive");
2364
2365   Qlistp = intern ("listp");
2366   Qconsp = intern ("consp");
2367   Qsymbolp = intern ("symbolp");
2368   Qintegerp = intern ("integerp");
2369   Qnatnump = intern ("natnump");
2370   Qwholenump = intern ("wholenump");
2371   Qstringp = intern ("stringp");
2372   Qarrayp = intern ("arrayp");
2373   Qsequencep = intern ("sequencep");
2374   Qbufferp = intern ("bufferp");
2375   Qvectorp = intern ("vectorp");
2376   Qchar_or_string_p = intern ("char-or-string-p");
2377   Qmarkerp = intern ("markerp");
2378   Qbuffer_or_string_p = intern ("buffer-or-string-p");
2379   Qinteger_or_marker_p = intern ("integer-or-marker-p");
2380   Qboundp = intern ("boundp");
2381   Qfboundp = intern ("fboundp");
2382
2383 #ifdef LISP_FLOAT_TYPE
2384   Qfloatp = intern ("floatp");
2385   Qnumberp = intern ("numberp");
2386   Qnumber_or_marker_p = intern ("number-or-marker-p");
2387 #endif /* LISP_FLOAT_TYPE */
2388
2389   Qchar_table_p = intern ("char-table-p");
2390   Qvector_or_char_table_p = intern ("vector-or-char-table-p");
2391
2392   Qcdr = intern ("cdr");
2393
2394   /* Handle automatic advice activation */
2395   Qad_advice_info = intern ("ad-advice-info");
2396   Qad_activate = intern ("ad-activate");
2397
2398   error_tail = Fcons (Qerror, Qnil);
2399
2400   /* ERROR is used as a signaler for random errors for which nothing else is right */
2401
2402   Fput (Qerror, Qerror_conditions,
2403         error_tail);
2404   Fput (Qerror, Qerror_message,
2405         build_string ("error"));
2406
2407   Fput (Qquit, Qerror_conditions,
2408         Fcons (Qquit, Qnil));
2409   Fput (Qquit, Qerror_message,
2410         build_string ("Quit"));
2411
2412   Fput (Qwrong_type_argument, Qerror_conditions,
2413         Fcons (Qwrong_type_argument, error_tail));
2414   Fput (Qwrong_type_argument, Qerror_message,
2415         build_string ("Wrong type argument"));
2416
2417   Fput (Qargs_out_of_range, Qerror_conditions,
2418         Fcons (Qargs_out_of_range, error_tail));
2419   Fput (Qargs_out_of_range, Qerror_message,
2420         build_string ("Args out of range"));
2421
2422   Fput (Qvoid_function, Qerror_conditions,
2423         Fcons (Qvoid_function, error_tail));
2424   Fput (Qvoid_function, Qerror_message,
2425         build_string ("Symbol's function definition is void"));
2426
2427   Fput (Qcyclic_function_indirection, Qerror_conditions,
2428         Fcons (Qcyclic_function_indirection, error_tail));
2429   Fput (Qcyclic_function_indirection, Qerror_message,
2430         build_string ("Symbol's chain of function indirections contains a loop"));
2431
2432   Fput (Qvoid_variable, Qerror_conditions,
2433         Fcons (Qvoid_variable, error_tail));
2434   Fput (Qvoid_variable, Qerror_message,
2435         build_string ("Symbol's value as variable is void"));
2436
2437   Fput (Qsetting_constant, Qerror_conditions,
2438         Fcons (Qsetting_constant, error_tail));
2439   Fput (Qsetting_constant, Qerror_message,
2440         build_string ("Attempt to set a constant symbol"));
2441
2442   Fput (Qinvalid_read_syntax, Qerror_conditions,
2443         Fcons (Qinvalid_read_syntax, error_tail));
2444   Fput (Qinvalid_read_syntax, Qerror_message,
2445         build_string ("Invalid read syntax"));
2446
2447   Fput (Qinvalid_function, Qerror_conditions,
2448         Fcons (Qinvalid_function, error_tail));
2449   Fput (Qinvalid_function, Qerror_message,
2450         build_string ("Invalid function"));
2451
2452   Fput (Qwrong_number_of_arguments, Qerror_conditions,
2453         Fcons (Qwrong_number_of_arguments, error_tail));
2454   Fput (Qwrong_number_of_arguments, Qerror_message,
2455         build_string ("Wrong number of arguments"));
2456
2457   Fput (Qno_catch, Qerror_conditions,
2458         Fcons (Qno_catch, error_tail));
2459   Fput (Qno_catch, Qerror_message,
2460         build_string ("No catch for tag"));
2461
2462   Fput (Qend_of_file, Qerror_conditions,
2463         Fcons (Qend_of_file, error_tail));
2464   Fput (Qend_of_file, Qerror_message,
2465         build_string ("End of file during parsing"));
2466
2467   arith_tail = Fcons (Qarith_error, error_tail);
2468   Fput (Qarith_error, Qerror_conditions,
2469         arith_tail);
2470   Fput (Qarith_error, Qerror_message,
2471         build_string ("Arithmetic error"));
2472
2473   Fput (Qbeginning_of_buffer, Qerror_conditions,
2474         Fcons (Qbeginning_of_buffer, error_tail));
2475   Fput (Qbeginning_of_buffer, Qerror_message,
2476         build_string ("Beginning of buffer"));
2477
2478   Fput (Qend_of_buffer, Qerror_conditions,
2479         Fcons (Qend_of_buffer, error_tail));
2480   Fput (Qend_of_buffer, Qerror_message,
2481         build_string ("End of buffer"));
2482
2483   Fput (Qbuffer_read_only, Qerror_conditions,
2484         Fcons (Qbuffer_read_only, error_tail));
2485   Fput (Qbuffer_read_only, Qerror_message,
2486         build_string ("Buffer is read-only"));
2487
2488 #ifdef LISP_FLOAT_TYPE
2489   Qrange_error = intern ("range-error");
2490   Qdomain_error = intern ("domain-error");
2491   Qsingularity_error = intern ("singularity-error");
2492   Qoverflow_error = intern ("overflow-error");
2493   Qunderflow_error = intern ("underflow-error");
2494
2495   Fput (Qdomain_error, Qerror_conditions,
2496         Fcons (Qdomain_error, arith_tail));
2497   Fput (Qdomain_error, Qerror_message,
2498         build_string ("Arithmetic domain error"));
2499
2500   Fput (Qrange_error, Qerror_conditions,
2501         Fcons (Qrange_error, arith_tail));
2502   Fput (Qrange_error, Qerror_message,
2503         build_string ("Arithmetic range error"));
2504
2505   Fput (Qsingularity_error, Qerror_conditions,
2506         Fcons (Qsingularity_error, Fcons (Qdomain_error, arith_tail)));
2507   Fput (Qsingularity_error, Qerror_message,
2508         build_string ("Arithmetic singularity error"));
2509
2510   Fput (Qoverflow_error, Qerror_conditions,
2511         Fcons (Qoverflow_error, Fcons (Qdomain_error, arith_tail)));
2512   Fput (Qoverflow_error, Qerror_message,
2513         build_string ("Arithmetic overflow error"));
2514
2515   Fput (Qunderflow_error, Qerror_conditions,
2516         Fcons (Qunderflow_error, Fcons (Qdomain_error, arith_tail)));
2517   Fput (Qunderflow_error, Qerror_message,
2518         build_string ("Arithmetic underflow error"));
2519
2520   staticpro (&Qrange_error);
2521   staticpro (&Qdomain_error);
2522   staticpro (&Qsingularity_error);
2523   staticpro (&Qoverflow_error);
2524   staticpro (&Qunderflow_error);
2525 #endif /* LISP_FLOAT_TYPE */
2526
2527   staticpro (&Qnil);
2528   staticpro (&Qt);
2529   staticpro (&Qquote);
2530   staticpro (&Qlambda);
2531   staticpro (&Qsubr);
2532   staticpro (&Qunbound);
2533   staticpro (&Qerror_conditions);
2534   staticpro (&Qerror_message);
2535   staticpro (&Qtop_level);
2536
2537   staticpro (&Qerror);
2538   staticpro (&Qquit);
2539   staticpro (&Qwrong_type_argument);
2540   staticpro (&Qargs_out_of_range);
2541   staticpro (&Qvoid_function);
2542   staticpro (&Qcyclic_function_indirection);
2543   staticpro (&Qvoid_variable);
2544   staticpro (&Qsetting_constant);
2545   staticpro (&Qinvalid_read_syntax);
2546   staticpro (&Qwrong_number_of_arguments);
2547   staticpro (&Qinvalid_function);
2548   staticpro (&Qno_catch);
2549   staticpro (&Qend_of_file);
2550   staticpro (&Qarith_error);
2551   staticpro (&Qbeginning_of_buffer);
2552   staticpro (&Qend_of_buffer);
2553   staticpro (&Qbuffer_read_only);
2554   staticpro (&Qmark_inactive);
2555
2556   staticpro (&Qlistp);
2557   staticpro (&Qconsp);
2558   staticpro (&Qsymbolp);
2559   staticpro (&Qintegerp);
2560   staticpro (&Qnatnump);
2561   staticpro (&Qwholenump);
2562   staticpro (&Qstringp);
2563   staticpro (&Qarrayp);
2564   staticpro (&Qsequencep);
2565   staticpro (&Qbufferp);
2566   staticpro (&Qvectorp);
2567   staticpro (&Qchar_or_string_p);
2568   staticpro (&Qmarkerp);
2569   staticpro (&Qbuffer_or_string_p);
2570   staticpro (&Qinteger_or_marker_p);
2571 #ifdef LISP_FLOAT_TYPE
2572   staticpro (&Qfloatp);
2573   staticpro (&Qnumberp);
2574   staticpro (&Qnumber_or_marker_p);
2575 #endif /* LISP_FLOAT_TYPE */
2576   staticpro (&Qchar_table_p);
2577   staticpro (&Qvector_or_char_table_p);
2578
2579   staticpro (&Qboundp);
2580   staticpro (&Qfboundp);
2581   staticpro (&Qcdr);
2582   staticpro (&Qad_advice_info);
2583   staticpro (&Qad_activate);
2584
2585   /* Types that type-of returns.  */
2586   Qinteger = intern ("integer");
2587   Qsymbol = intern ("symbol");
2588   Qstring = intern ("string");
2589   Qcons = intern ("cons");
2590   Qmarker = intern ("marker");
2591   Qoverlay = intern ("overlay");
2592   Qfloat = intern ("float");
2593   Qwindow_configuration = intern ("window-configuration");
2594   Qprocess = intern ("process");
2595   Qwindow = intern ("window");
2596   /* Qsubr = intern ("subr"); */
2597   Qcompiled_function = intern ("compiled-function");
2598   Qbuffer = intern ("buffer");
2599   Qframe = intern ("frame");
2600   Qvector = intern ("vector");
2601   Qchar_table = intern ("char-table");
2602   Qbool_vector = intern ("bool-vector");
2603
2604   staticpro (&Qinteger);
2605   staticpro (&Qsymbol);
2606   staticpro (&Qstring);
2607   staticpro (&Qcons);
2608   staticpro (&Qmarker);
2609   staticpro (&Qoverlay);
2610   staticpro (&Qfloat);
2611   staticpro (&Qwindow_configuration);
2612   staticpro (&Qprocess);
2613   staticpro (&Qwindow);
2614   /* staticpro (&Qsubr); */
2615   staticpro (&Qcompiled_function);
2616   staticpro (&Qbuffer);
2617   staticpro (&Qframe);
2618   staticpro (&Qvector);
2619   staticpro (&Qchar_table);
2620   staticpro (&Qbool_vector);
2621
2622   defsubr (&Seq);
2623   defsubr (&Snull);
2624   defsubr (&Stype_of);
2625   defsubr (&Slistp);
2626   defsubr (&Snlistp);
2627   defsubr (&Sconsp);
2628   defsubr (&Satom);
2629   defsubr (&Sintegerp);
2630   defsubr (&Sinteger_or_marker_p);
2631   defsubr (&Snumberp);
2632   defsubr (&Snumber_or_marker_p);
2633 #ifdef LISP_FLOAT_TYPE
2634   defsubr (&Sfloatp);
2635 #endif /* LISP_FLOAT_TYPE */
2636   defsubr (&Snatnump);
2637   defsubr (&Ssymbolp);
2638   defsubr (&Sstringp);
2639   defsubr (&Svectorp);
2640   defsubr (&Schar_table_p);
2641   defsubr (&Svector_or_char_table_p);
2642   defsubr (&Sbool_vector_p);
2643   defsubr (&Sarrayp);
2644   defsubr (&Ssequencep);
2645   defsubr (&Sbufferp);
2646   defsubr (&Smarkerp);
2647   defsubr (&Ssubrp);
2648   defsubr (&Sbyte_code_function_p);
2649   defsubr (&Schar_or_string_p);
2650   defsubr (&Scar);
2651   defsubr (&Scdr);
2652   defsubr (&Scar_safe);
2653   defsubr (&Scdr_safe);
2654   defsubr (&Ssetcar);
2655   defsubr (&Ssetcdr);
2656   defsubr (&Ssymbol_function);
2657   defsubr (&Sindirect_function);
2658   defsubr (&Ssymbol_plist);
2659   defsubr (&Ssymbol_name);
2660   defsubr (&Smakunbound);
2661   defsubr (&Sfmakunbound);
2662   defsubr (&Sboundp);
2663   defsubr (&Sfboundp);
2664   defsubr (&Sfset);
2665   defsubr (&Sdefalias);
2666   defsubr (&Sdefine_function);
2667   defsubr (&Ssetplist);
2668   defsubr (&Ssymbol_value);
2669   defsubr (&Sset);
2670   defsubr (&Sdefault_boundp);
2671   defsubr (&Sdefault_value);
2672   defsubr (&Sset_default);
2673   defsubr (&Ssetq_default);
2674   defsubr (&Smake_variable_buffer_local);
2675   defsubr (&Smake_local_variable);
2676   defsubr (&Skill_local_variable);
2677   defsubr (&Slocal_variable_p);
2678   defsubr (&Slocal_variable_if_set_p);
2679   defsubr (&Saref);
2680   defsubr (&Saset);
2681   defsubr (&Snumber_to_string);
2682   defsubr (&Sstring_to_number);
2683   defsubr (&Seqlsign);
2684   defsubr (&Slss);
2685   defsubr (&Sgtr);
2686   defsubr (&Sleq);
2687   defsubr (&Sgeq);
2688   defsubr (&Sneq);
2689   defsubr (&Szerop);
2690   defsubr (&Splus);
2691   defsubr (&Sminus);
2692   defsubr (&Stimes);
2693   defsubr (&Squo);
2694   defsubr (&Srem);
2695   defsubr (&Smod);
2696   defsubr (&Smax);
2697   defsubr (&Smin);
2698   defsubr (&Slogand);
2699   defsubr (&Slogior);
2700   defsubr (&Slogxor);
2701   defsubr (&Slsh);
2702   defsubr (&Sash);
2703   defsubr (&Sadd1);
2704   defsubr (&Ssub1);
2705   defsubr (&Slognot);
2706
2707   XSYMBOL (Qwholenump)->function = XSYMBOL (Qnatnump)->function;
2708 }
2709
2710 SIGTYPE
2711 arith_error (signo)
2712      int signo;
2713 {
2714 #if defined(USG) && !defined(POSIX_SIGNALS)
2715   /* USG systems forget handlers when they are used;
2716      must reestablish each time */
2717   signal (signo, arith_error);
2718 #endif /* USG */
2719 #ifdef VMS
2720   /* VMS systems are like USG.  */
2721   signal (signo, arith_error);
2722 #endif /* VMS */
2723 #ifdef BSD4_1
2724   sigrelse (SIGFPE);
2725 #else /* not BSD4_1 */
2726   sigsetmask (SIGEMPTYMASK);
2727 #endif /* not BSD4_1 */
2728
2729   Fsignal (Qarith_error, Qnil);
2730 }
2731
2732 init_data ()
2733 {
2734   /* Don't do this if just dumping out.
2735      We don't want to call `signal' in this case
2736      so that we don't have trouble with dumping
2737      signal-delivering routines in an inconsistent state.  */
2738 #ifndef CANNOT_DUMP
2739   if (!initialized)
2740     return;
2741 #endif /* CANNOT_DUMP */
2742   signal (SIGFPE, arith_error);
2743
2744 #ifdef uts
2745   signal (SIGEMT, arith_error);
2746 #endif /* uts */
2747 }