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