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