src/data.c

   1 /* Primitive operations on Lisp data types for GNU Emacs Lisp interpreter.
   2    Copyright (C) 1985, 1986, 1988, 1992 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.  */
  19
  20
  21 #include <signal.h>
  22
  23 #include "config.h"
  24 #include "lisp.h"
  25 #include "puresize.h"
  26
  27 #ifndef standalone
  28 #include "buffer.h"
  29 #endif
  30
  31 #include "syssignal.h"
  32
  33 #ifdef LISP_FLOAT_TYPE
  34 #include <math.h>
  35 #endif /* LISP_FLOAT_TYPE */
  36
  37 Lisp_Object Qnil, Qt, Qquote, Qlambda, Qsubr, Qunbound;
  38 Lisp_Object Qerror_conditions, Qerror_message, Qtop_level;
  39 Lisp_Object Qerror, Qquit, Qwrong_type_argument, Qargs_out_of_range;
  40 Lisp_Object Qvoid_variable, Qvoid_function, Qcyclic_function_indirection;
  41 Lisp_Object Qsetting_constant, Qinvalid_read_syntax;
  42 Lisp_Object Qinvalid_function, Qwrong_number_of_arguments, Qno_catch;
  43 Lisp_Object Qend_of_file, Qarith_error;
  44 Lisp_Object Qbeginning_of_buffer, Qend_of_buffer, Qbuffer_read_only;
  45 Lisp_Object Qintegerp, Qnatnump, Qsymbolp, Qlistp, Qconsp;
  46 Lisp_Object Qstringp, Qarrayp, Qsequencep, Qbufferp;
  47 Lisp_Object Qchar_or_string_p, Qmarkerp, Qinteger_or_marker_p, Qvectorp;
  48 Lisp_Object Qboundp, Qfboundp;
  49 Lisp_Object Qcdr;
  50
  51 #ifdef LISP_FLOAT_TYPE
  52 Lisp_Object Qfloatp, Qinteger_or_floatp, Qinteger_or_float_or_marker_p;
  53 Lisp_Object Qnumberp, Qnumber_or_marker_p;
  54 #endif
  55
  56 static Lisp_Object swap_in_symval_forwarding ();
  57
  58 Lisp_Object
  59 wrong_type_argument (predicate, value)
  60      register Lisp_Object predicate, value;
  61 {
  62   register Lisp_Object tem;
  63   do
  64     {
  65       if (!EQ (Vmocklisp_arguments, Qt))
  66         {
  67          if (XTYPE (value) == Lisp_String &&
  68              (EQ (predicate, Qintegerp) || EQ (predicate, Qinteger_or_marker_p)))
  69            return Fstring_to_int (value, Qt);
  70          if (XTYPE (value) == Lisp_Int && EQ (predicate, Qstringp))
  71            return Fint_to_string (value);
  72         }
  73       value = Fsignal (Qwrong_type_argument, Fcons (predicate, Fcons (value, Qnil)));
  74       tem = call1 (predicate, value);
  75     }
  76   while (NILP (tem));
  77   return value;
  78 }
  79
  80 pure_write_error ()
  81 {
  82   error ("Attempt to modify read-only object");
  83 }
  84
  85 void
  86 args_out_of_range (a1, a2)
  87      Lisp_Object a1, a2;
  88 {
  89   while (1)
  90     Fsignal (Qargs_out_of_range, Fcons (a1, Fcons (a2, Qnil)));
  91 }
  92
  93 void
  94 args_out_of_range_3 (a1, a2, a3)
  95      Lisp_Object a1, a2, a3;
  96 {
  97   while (1)
  98     Fsignal (Qargs_out_of_range, Fcons (a1, Fcons (a2, Fcons (a3, Qnil))));
  99 }
 100
 101 Lisp_Object
 102 make_number (num)
 103      int num;
 104 {
 105   register Lisp_Object val;
 106   XSET (val, Lisp_Int, num);
 107   return val;
 108 }
 109
 110 /* On some machines, XINT needs a temporary location.
 111    Here it is, in case it is needed.  */
 112
 113 int sign_extend_temp;
 114
 115 /* On a few machines, XINT can only be done by calling this.  */
 116
 117 int
 118 sign_extend_lisp_int (num)
 119      int num;
 120 {
 121   if (num & (1 << (VALBITS - 1)))
 122     return num | ((-1) << VALBITS);
 123   else
 124     return num & ((1 << VALBITS) - 1);
 125 }
 126 \f
 127 /* Data type predicates */
 128
 129 DEFUN ("eq", Feq, Seq, 2, 2, 0,
 130   "T if the two args are the same Lisp object.")
 131   (obj1, obj2)
 132      Lisp_Object obj1, obj2;
 133 {
 134   if (EQ (obj1, obj2))
 135     return Qt;
 136   return Qnil;
 137 }
 138
 139 DEFUN ("null", Fnull, Snull, 1, 1, 0, "T if OBJECT is nil.")
 140   (obj)
 141      Lisp_Object obj;
 142 {
 143   if (NILP (obj))
 144     return Qt;
 145   return Qnil;
 146 }
 147
 148 DEFUN ("consp", Fconsp, Sconsp, 1, 1, 0, "T if OBJECT is a cons cell.")
 149   (obj)
 150      Lisp_Object obj;
 151 {
 152   if (XTYPE (obj) == Lisp_Cons)
 153     return Qt;
 154   return Qnil;
 155 }
 156
 157 DEFUN ("atom", Fatom, Satom, 1, 1, 0, "T if OBJECT is not a cons cell.  This includes nil.")
 158   (obj)
 159      Lisp_Object obj;
 160 {
 161   if (XTYPE (obj) == Lisp_Cons)
 162     return Qnil;
 163   return Qt;
 164 }
 165
 166 DEFUN ("listp", Flistp, Slistp, 1, 1, 0, "T if OBJECT is a list.  This includes nil.")
 167   (obj)
 168      Lisp_Object obj;
 169 {
 170   if (XTYPE (obj) == Lisp_Cons || NILP (obj))
 171     return Qt;
 172   return Qnil;
 173 }
 174
 175 DEFUN ("nlistp", Fnlistp, Snlistp, 1, 1, 0, "T if OBJECT is not a list.  Lists include nil.")
 176   (obj)
 177      Lisp_Object obj;
 178 {
 179   if (XTYPE (obj) == Lisp_Cons || NILP (obj))
 180     return Qnil;
 181   return Qt;
 182 }
 183 \f
 184 DEFUN ("symbolp", Fsymbolp, Ssymbolp, 1, 1, 0, "T if OBJECT is a symbol.")
 185   (obj)
 186      Lisp_Object obj;
 187 {
 188   if (XTYPE (obj) == Lisp_Symbol)
 189     return Qt;
 190   return Qnil;
 191 }
 192
 193 DEFUN ("vectorp", Fvectorp, Svectorp, 1, 1, 0, "T if OBJECT is a vector.")
 194   (obj)
 195      Lisp_Object obj;
 196 {
 197   if (XTYPE (obj) == Lisp_Vector)
 198     return Qt;
 199   return Qnil;
 200 }
 201
 202 DEFUN ("stringp", Fstringp, Sstringp, 1, 1, 0, "T if OBJECT is a string.")
 203   (obj)
 204      Lisp_Object obj;
 205 {
 206   if (XTYPE (obj) == Lisp_String)
 207     return Qt;
 208   return Qnil;
 209 }
 210
 211 DEFUN ("arrayp", Farrayp, Sarrayp, 1, 1, 0, "T if OBJECT is an array (string or vector).")
 212   (obj)
 213      Lisp_Object obj;
 214 {
 215   if (XTYPE (obj) == Lisp_Vector || XTYPE (obj) == Lisp_String)
 216     return Qt;
 217   return Qnil;
 218 }
 219
 220 DEFUN ("sequencep", Fsequencep, Ssequencep, 1, 1, 0,
 221   "T if OBJECT is a sequence (list or array).")
 222   (obj)
 223      register Lisp_Object obj;
 224 {
 225   if (CONSP (obj) || NILP (obj) ||
 226       XTYPE (obj) == Lisp_Vector || XTYPE (obj) == Lisp_String)
 227     return Qt;
 228   return Qnil;
 229 }
 230
 231 DEFUN ("bufferp", Fbufferp, Sbufferp, 1, 1, 0, "T if OBJECT is an editor buffer.")
 232   (obj)
 233      Lisp_Object obj;
 234 {
 235   if (XTYPE (obj) == Lisp_Buffer)
 236     return Qt;
 237   return Qnil;
 238 }
 239
 240 DEFUN ("markerp", Fmarkerp, Smarkerp, 1, 1, 0, "T if OBJECT is a marker (editor pointer).")
 241   (obj)
 242      Lisp_Object obj;
 243 {
 244   if (XTYPE (obj) == Lisp_Marker)
 245     return Qt;
 246   return Qnil;
 247 }
 248
 249 DEFUN ("integer-or-marker-p", Finteger_or_marker_p, Sinteger_or_marker_p, 1, 1, 0,
 250   "T if OBJECT is an integer or a marker (editor pointer).")
 251   (obj)
 252      register Lisp_Object obj;
 253 {
 254   if (XTYPE (obj) == Lisp_Marker || XTYPE (obj) == Lisp_Int)
 255     return Qt;
 256   return Qnil;
 257 }
 258
 259 DEFUN ("subrp", Fsubrp, Ssubrp, 1, 1, 0, "T if OBJECT is a built-in function.")
 260   (obj)
 261      Lisp_Object obj;
 262 {
 263   if (XTYPE (obj) == Lisp_Subr)
 264     return Qt;
 265   return Qnil;
 266 }
 267
 268 DEFUN ("compiled-function-p", Fcompiled_function_p, Scompiled_function_p,
 269        1, 1, 0, "T if OBJECT is a compiled function object.")
 270   (obj)
 271      Lisp_Object obj;
 272 {
 273   if (XTYPE (obj) == Lisp_Compiled)
 274     return Qt;
 275   return Qnil;
 276 }
 277
 278 DEFUN ("char-or-string-p", Fchar_or_string_p, Schar_or_string_p, 1, 1, 0, "T if OBJECT is a character (a number) or a string.")
 279   (obj)
 280      register Lisp_Object obj;
 281 {
 282   if (XTYPE (obj) == Lisp_Int || XTYPE (obj) == Lisp_String)
 283     return Qt;
 284   return Qnil;
 285 }
 286 \f
 287 DEFUN ("integerp", Fintegerp, Sintegerp, 1, 1, 0, "T if OBJECT is a number.")
 288   (obj)
 289      Lisp_Object obj;
 290 {
 291   if (XTYPE (obj) == Lisp_Int)
 292     return Qt;
 293   return Qnil;
 294 }
 295
 296 DEFUN ("natnump", Fnatnump, Snatnump, 1, 1, 0, "T if OBJECT is a nonnegative number.")
 297   (obj)
 298      Lisp_Object obj;
 299 {
 300   if (XTYPE (obj) == Lisp_Int && XINT (obj) >= 0)
 301     return Qt;
 302   return Qnil;
 303 }
 304
 305 #ifdef LISP_FLOAT_TYPE
 306 DEFUN ("floatp", Ffloatp, Sfloatp, 1, 1, 0,
 307        "T if OBJECT is a floating point number.")
 308   (obj)
 309      Lisp_Object obj;
 310 {
 311   if (XTYPE (obj) == Lisp_Float)
 312     return Qt;
 313   return Qnil;
 314 }
 315
 316 DEFUN ("numberp", Fnumberp, Snumberp, 1, 1, 0,
 317        "T if OBJECT is a number (floating point or integer).")
 318   (obj)
 319      Lisp_Object obj;
 320 {
 321   if (XTYPE (obj) == Lisp_Float || XTYPE (obj) == Lisp_Int)
 322     return Qt;
 323   return Qnil;
 324 }
 325
 326 DEFUN ("number-or-marker-p", Fnumber_or_marker_p,
 327        Snumber_or_marker_p, 1, 1, 0,
 328        "T if OBJECT is a number or a marker.")
 329   (obj)
 330      Lisp_Object obj;
 331 {
 332   if (XTYPE (obj) == Lisp_Float
 333       || XTYPE (obj) == Lisp_Int
 334       || XTYPE (obj) == Lisp_Marker)
 335     return Qt;
 336   return Qnil;
 337 }
 338 #endif /* LISP_FLOAT_TYPE */
 339 \f
 340 /* Extract and set components of lists */
 341
 342 DEFUN ("car", Fcar, Scar, 1, 1, 0,
 343   "Return the car of CONSCELL.  If arg is nil, return nil.\n\
 344 Error if arg is not nil and not a cons cell.  See also `car-safe'.")
 345   (list)
 346      register Lisp_Object list;
 347 {
 348   while (1)
 349     {
 350       if (XTYPE (list) == Lisp_Cons)
 351         return XCONS (list)->car;
 352       else if (EQ (list, Qnil))
 353         return Qnil;
 354       else
 355         list = wrong_type_argument (Qlistp, list);
 356     }
 357 }
 358
 359 DEFUN ("car-safe", Fcar_safe, Scar_safe, 1, 1, 0,
 360   "Return the car of OBJECT if it is a cons cell, or else nil.")
 361   (object)
 362      Lisp_Object object;
 363 {
 364   if (XTYPE (object) == Lisp_Cons)
 365     return XCONS (object)->car;
 366   else
 367     return Qnil;
 368 }
 369
 370 DEFUN ("cdr", Fcdr, Scdr, 1, 1, 0,
 371   "Return the cdr of CONSCELL.  If arg is nil, return nil.\n\
 372 Error if arg is not nil and not a cons cell.  See also `cdr-safe'.")
 373
 374   (list)
 375      register Lisp_Object list;
 376 {
 377   while (1)
 378     {
 379       if (XTYPE (list) == Lisp_Cons)
 380         return XCONS (list)->cdr;
 381       else if (EQ (list, Qnil))
 382         return Qnil;
 383       else
 384         list = wrong_type_argument (Qlistp, list);
 385     }
 386 }
 387
 388 DEFUN ("cdr-safe", Fcdr_safe, Scdr_safe, 1, 1, 0,
 389   "Return the cdr of OBJECT if it is a cons cell, or else  nil.")
 390   (object)
 391      Lisp_Object object;
 392 {
 393   if (XTYPE (object) == Lisp_Cons)
 394     return XCONS (object)->cdr;
 395   else
 396     return Qnil;
 397 }
 398
 399 DEFUN ("setcar", Fsetcar, Ssetcar, 2, 2, 0,
 400   "Set the car of CONSCELL to be NEWCAR.  Returns NEWCAR.")
 401   (cell, newcar)
 402      register Lisp_Object cell, newcar;
 403 {
 404   if (XTYPE (cell) != Lisp_Cons)
 405     cell = wrong_type_argument (Qconsp, cell);
 406
 407   CHECK_IMPURE (cell);
 408   XCONS (cell)->car = newcar;
 409   return newcar;
 410 }
 411
 412 DEFUN ("setcdr", Fsetcdr, Ssetcdr, 2, 2, 0,
 413   "Set the cdr of CONSCELL to be NEWCDR.  Returns NEWCDR.")
 414   (cell, newcdr)
 415      register Lisp_Object cell, newcdr;
 416 {
 417   if (XTYPE (cell) != Lisp_Cons)
 418     cell = wrong_type_argument (Qconsp, cell);
 419
 420   CHECK_IMPURE (cell);
 421   XCONS (cell)->cdr = newcdr;
 422   return newcdr;
 423 }
 424 \f
 425 /* Extract and set components of symbols */
 426
 427 DEFUN ("boundp", Fboundp, Sboundp, 1, 1, 0, "T if SYMBOL's value is not void.")
 428   (sym)
 429      register Lisp_Object sym;
 430 {
 431   Lisp_Object valcontents;
 432   CHECK_SYMBOL (sym, 0);
 433
 434   valcontents = XSYMBOL (sym)->value;
 435
 436 #ifdef SWITCH_ENUM_BUG
 437   switch ((int) XTYPE (valcontents))
 438 #else
 439   switch (XTYPE (valcontents))
 440 #endif
 441     {
 442     case Lisp_Buffer_Local_Value:
 443     case Lisp_Some_Buffer_Local_Value:
 444       valcontents = swap_in_symval_forwarding (sym, valcontents);
 445     }
 446
 447   return (XTYPE (valcontents) == Lisp_Void || EQ (valcontents, Qunbound)
 448           ? Qnil : Qt);
 449 }
 450
 451 DEFUN ("fboundp", Ffboundp, Sfboundp, 1, 1, 0, "T if SYMBOL's function definition is not void.")
 452   (sym)
 453      register Lisp_Object sym;
 454 {
 455   CHECK_SYMBOL (sym, 0);
 456   return (XTYPE (XSYMBOL (sym)->function) == Lisp_Void
 457           || EQ (XSYMBOL (sym)->function, Qunbound))
 458          ? Qnil : Qt;
 459 }
 460
 461 DEFUN ("makunbound", Fmakunbound, Smakunbound, 1, 1, 0, "Make SYMBOL's value be void.")
 462   (sym)
 463      register Lisp_Object sym;
 464 {
 465   CHECK_SYMBOL (sym, 0);
 466   if (NILP (sym) || EQ (sym, Qt))
 467     return Fsignal (Qsetting_constant, Fcons (sym, Qnil));
 468   Fset (sym, Qunbound);
 469   return sym;
 470 }
 471
 472 DEFUN ("fmakunbound", Ffmakunbound, Sfmakunbound, 1, 1, 0, "Make SYMBOL's function definition be void.")
 473   (sym)
 474      register Lisp_Object sym;
 475 {
 476   CHECK_SYMBOL (sym, 0);
 477   XSYMBOL (sym)->function = Qunbound;
 478   return sym;
 479 }
 480
 481 DEFUN ("symbol-function", Fsymbol_function, Ssymbol_function, 1, 1, 0,
 482   "Return SYMBOL's function definition.  Error if that is void.")
 483   (symbol)
 484      register Lisp_Object symbol;
 485 {
 486   CHECK_SYMBOL (symbol, 0);
 487   if (EQ (XSYMBOL (symbol)->function, Qunbound))
 488     return Fsignal (Qvoid_function, Fcons (symbol, Qnil));
 489   return XSYMBOL (symbol)->function;
 490 }
 491
 492 DEFUN ("symbol-plist", Fsymbol_plist, Ssymbol_plist, 1, 1, 0, "Return SYMBOL's property list.")
 493   (sym)
 494      register Lisp_Object sym;
 495 {
 496   CHECK_SYMBOL (sym, 0);
 497   return XSYMBOL (sym)->plist;
 498 }
 499
 500 DEFUN ("symbol-name", Fsymbol_name, Ssymbol_name, 1, 1, 0, "Return SYMBOL's name, a string.")
 501   (sym)
 502      register Lisp_Object sym;
 503 {
 504   register Lisp_Object name;
 505
 506   CHECK_SYMBOL (sym, 0);
 507   XSET (name, Lisp_String, XSYMBOL (sym)->name);
 508   return name;
 509 }
 510
 511 DEFUN ("fset", Ffset, Sfset, 2, 2, 0,
 512   "Set SYMBOL's function definition to NEWVAL, and return NEWVAL.")
 513   (sym, newdef)
 514      register Lisp_Object sym, newdef;
 515 {
 516   CHECK_SYMBOL (sym, 0);
 517   if (!NILP (Vautoload_queue) && !EQ (XSYMBOL (sym)->function, Qunbound))
 518     Vautoload_queue = Fcons (Fcons (sym, XSYMBOL (sym)->function),
 519                              Vautoload_queue);
 520   XSYMBOL (sym)->function = newdef;
 521   return newdef;
 522 }
 523
 524 DEFUN ("setplist", Fsetplist, Ssetplist, 2, 2, 0,
 525   "Set SYMBOL's property list to NEWVAL, and return NEWVAL.")
 526   (sym, newplist)
 527      register Lisp_Object sym, newplist;
 528 {
 529   CHECK_SYMBOL (sym, 0);
 530   XSYMBOL (sym)->plist = newplist;
 531   return newplist;
 532 }
 533
 534 \f
 535 /* Getting and setting values of symbols */
 536
 537 /* Given the raw contents of a symbol value cell,
 538    return the Lisp value of the symbol.
 539    This does not handle buffer-local variables; use
 540    swap_in_symval_forwarding for that.  */
 541
 542 Lisp_Object
 543 do_symval_forwarding (valcontents)
 544      register Lisp_Object valcontents;
 545 {
 546   register Lisp_Object val;
 547 #ifdef SWITCH_ENUM_BUG
 548   switch ((int) XTYPE (valcontents))
 549 #else
 550   switch (XTYPE (valcontents))
 551 #endif
 552     {
 553     case Lisp_Intfwd:
 554       XSET (val, Lisp_Int, *XINTPTR (valcontents));
 555       return val;
 556
 557     case Lisp_Boolfwd:
 558       if (*XINTPTR (valcontents))
 559         return Qt;
 560       return Qnil;
 561
 562     case Lisp_Objfwd:
 563       return *XOBJFWD (valcontents);
 564
 565     case Lisp_Buffer_Objfwd:
 566       return *(Lisp_Object *)(XUINT (valcontents) + (char *)current_buffer);
 567     }
 568   return valcontents;
 569 }
 570
 571 /* Store NEWVAL into SYM, where VALCONTENTS is found in the value cell
 572    of SYM.  If SYM is buffer-local, VALCONTENTS should be the
 573    buffer-independent contents of the value cell: forwarded just one
 574    step past the buffer-localness.  */
 575
 576 void
 577 store_symval_forwarding (sym, valcontents, newval)
 578      Lisp_Object sym;
 579      register Lisp_Object valcontents, newval;
 580 {
 581 #ifdef SWITCH_ENUM_BUG
 582   switch ((int) XTYPE (valcontents))
 583 #else
 584   switch (XTYPE (valcontents))
 585 #endif
 586     {
 587     case Lisp_Intfwd:
 588       CHECK_NUMBER (newval, 1);
 589       *XINTPTR (valcontents) = XINT (newval);
 590       break;
 591
 592     case Lisp_Boolfwd:
 593       *XINTPTR (valcontents) = NILP(newval) ? 0 : 1;
 594       break;
 595
 596     case Lisp_Objfwd:
 597       *XOBJFWD (valcontents) = newval;
 598       break;
 599
 600     case Lisp_Buffer_Objfwd:
 601       *(Lisp_Object *)(XUINT (valcontents) + (char *)current_buffer) = newval;
 602       break;
 603
 604     default:
 605       valcontents = XSYMBOL (sym)->value;
 606       if (XTYPE (valcontents) == Lisp_Buffer_Local_Value
 607           || XTYPE (valcontents) == Lisp_Some_Buffer_Local_Value)
 608         XCONS (XSYMBOL (sym)->value)->car = newval;
 609       else
 610         XSYMBOL (sym)->value = newval;
 611     }
 612 }
 613
 614 /* Set up the buffer-local symbol SYM for validity in the current
 615    buffer.  VALCONTENTS is the contents of its value cell.
 616    Return the value forwarded one step past the buffer-local indicator.  */
 617
 618 static Lisp_Object
 619 swap_in_symval_forwarding (sym, valcontents)
 620      Lisp_Object sym, valcontents;
 621 {
 622   /* valcontents is a list
 623      (REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE)).
 624
 625      CURRENT-ALIST-ELEMENT is a pointer to an element of BUFFER's
 626      local_var_alist, that being the element whose car is this variable.
 627      Or it can be a pointer to the (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE), if BUFFER
 628      does not have an element in its alist for this variable.
 629
 630      If the current buffer is not BUFFER, we store the current REALVALUE value into
 631      CURRENT-ALIST-ELEMENT, then find the appropriate alist element for
 632      the buffer now current and set up CURRENT-ALIST-ELEMENT.
 633      Then we set REALVALUE out of that element, and store into BUFFER.
 634      Note that REALVALUE can be a forwarding pointer. */
 635
 636   register Lisp_Object tem1;
 637   tem1 = XCONS (XCONS (valcontents)->cdr)->car;
 638
 639   if (NILP (tem1) || current_buffer != XBUFFER (tem1))
 640     {
 641       tem1 = XCONS (XCONS (XCONS (valcontents)->cdr)->cdr)->car;
 642       Fsetcdr (tem1, do_symval_forwarding (XCONS (valcontents)->car));
 643       tem1 = assq_no_quit (sym, current_buffer->local_var_alist);
 644       if (NILP (tem1))
 645         tem1 = XCONS (XCONS (valcontents)->cdr)->cdr;
 646       XCONS (XCONS (XCONS (valcontents)->cdr)->cdr)->car = tem1;
 647       XSET (XCONS (XCONS (valcontents)->cdr)->car, Lisp_Buffer, current_buffer);
 648       store_symval_forwarding (sym, XCONS (valcontents)->car, Fcdr (tem1));
 649     }
 650   return XCONS (valcontents)->car;
 651 }
 652 \f
 653 /* Find the value of a symbol, returning Qunbound if it's not bound.
 654    This is helpful for code which just wants to get a variable's value
 655    if it has one, without signalling an error.
 656    Note that it must not be possible to quit
 657    within this function.  Great care is required for this.  */
 658
 659 Lisp_Object
 660 find_symbol_value (sym)
 661      Lisp_Object sym;
 662 {
 663   register Lisp_Object valcontents, tem1;
 664   register Lisp_Object val;
 665   CHECK_SYMBOL (sym, 0);
 666   valcontents = XSYMBOL (sym)->value;
 667
 668  retry:
 669 #ifdef SWITCH_ENUM_BUG
 670   switch ((int) XTYPE (valcontents))
 671 #else
 672   switch (XTYPE (valcontents))
 673 #endif
 674     {
 675     case Lisp_Buffer_Local_Value:
 676     case Lisp_Some_Buffer_Local_Value:
 677       valcontents = swap_in_symval_forwarding (sym, valcontents);
 678       goto retry;
 679
 680     case Lisp_Intfwd:
 681       XSET (val, Lisp_Int, *XINTPTR (valcontents));
 682       return val;
 683
 684     case Lisp_Boolfwd:
 685       if (*XINTPTR (valcontents))
 686         return Qt;
 687       return Qnil;
 688
 689     case Lisp_Objfwd:
 690       return *XOBJFWD (valcontents);
 691
 692     case Lisp_Buffer_Objfwd:
 693       return *(Lisp_Object *)(XUINT (valcontents) + (char *)current_buffer);
 694
 695     case Lisp_Void:
 696       return Qunbound;
 697     }
 698
 699   return valcontents;
 700 }
 701
 702 DEFUN ("symbol-value", Fsymbol_value, Ssymbol_value, 1, 1, 0,
 703   "Return SYMBOL's value.  Error if that is void.")
 704   (sym)
 705      Lisp_Object sym;
 706 {
 707   Lisp_Object val = find_symbol_value (sym);
 708
 709   if (EQ (val, Qunbound))
 710     return Fsignal (Qvoid_variable, Fcons (sym, Qnil));
 711   else
 712     return val;
 713 }
 714
 715 DEFUN ("set", Fset, Sset, 2, 2, 0,
 716   "Set SYMBOL's value to NEWVAL, and return NEWVAL.")
 717   (sym, newval)
 718      register Lisp_Object sym, newval;
 719 {
 720   int voide = (XTYPE (newval) == Lisp_Void || EQ (newval, Qunbound));
 721
 722 #ifndef RTPC_REGISTER_BUG
 723   register Lisp_Object valcontents, tem1, current_alist_element;
 724 #else /* RTPC_REGISTER_BUG */
 725   register Lisp_Object tem1;
 726   Lisp_Object valcontents, current_alist_element;
 727 #endif /* RTPC_REGISTER_BUG */
 728
 729   CHECK_SYMBOL (sym, 0);
 730   if (NILP (sym) || EQ (sym, Qt))
 731     return Fsignal (Qsetting_constant, Fcons (sym, Qnil));
 732   valcontents = XSYMBOL (sym)->value;
 733
 734   if (XTYPE (valcontents) == Lisp_Buffer_Objfwd)
 735     {
 736       register int idx = XUINT (valcontents);
 737       register int mask = *(int *)(idx + (char *) &buffer_local_flags);
 738       if (mask > 0)
 739         current_buffer->local_var_flags |= mask;
 740     }
 741
 742   if (XTYPE (valcontents) == Lisp_Buffer_Local_Value
 743       || XTYPE (valcontents) == Lisp_Some_Buffer_Local_Value)
 744     {
 745       /* valcontents is a list
 746         (REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE)).
 747
 748         CURRENT-ALIST-ELEMENT is a pointer to an element of BUFFER's
 749         local_var_alist, that being the element whose car is this variable.
 750         Or it can be a pointer to the (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE), if BUFFER
 751         does not have an element in its alist for this variable.
 752
 753         If the current buffer is not BUFFER, we store the current REALVALUE value into
 754         CURRENT-ALIST-ELEMENT, then find the appropriate alist element for
 755         the buffer now current and set up CURRENT-ALIST-ELEMENT.
 756         Then we set REALVALUE out of that element, and store into BUFFER.
 757         Note that REALVALUE can be a forwarding pointer. */
 758
 759       current_alist_element = XCONS (XCONS (XCONS (valcontents)->cdr)->cdr)->car;
 760       if (current_buffer != ((XTYPE (valcontents) == Lisp_Some_Buffer_Local_Value)
 761                      ? XBUFFER (XCONS (XCONS (valcontents)->cdr)->car)
 762                      : XBUFFER (XCONS (current_alist_element)->car)))
 763         {
 764           Fsetcdr (current_alist_element, do_symval_forwarding (XCONS (valcontents)->car));
 765
 766           tem1 = Fassq (sym, current_buffer->local_var_alist);
 767           if (NILP (tem1))
 768             /* This buffer sees the default value still.
 769                If type is Lisp_Some_Buffer_Local_Value, set the default value.
 770                If type is Lisp_Buffer_Local_Value, give this buffer a local value
 771                 and set that.  */
 772             if (XTYPE (valcontents) == Lisp_Some_Buffer_Local_Value)
 773               tem1 = XCONS (XCONS (valcontents)->cdr)->cdr;
 774             else
 775               {
 776                 tem1 = Fcons (sym, Fcdr (current_alist_element));
 777                 current_buffer->local_var_alist = Fcons (tem1, current_buffer->local_var_alist);
 778               }
 779           XCONS (XCONS (XCONS (valcontents)->cdr)->cdr)->car = tem1;
 780           XSET (XCONS (XCONS (valcontents)->cdr)->car, Lisp_Buffer, current_buffer);
 781         }
 782       valcontents = XCONS (valcontents)->car;
 783     }
 784   /* If storing void (making the symbol void), forward only through
 785      buffer-local indicator, not through Lisp_Objfwd, etc.  */
 786   if (voide)
 787     store_symval_forwarding (sym, Qnil, newval);
 788   else
 789     store_symval_forwarding (sym, valcontents, newval);
 790   return newval;
 791 }
 792 \f
 793 /* Access or set a buffer-local symbol's default value.  */
 794
 795 /* Return the default value of SYM, but don't check for voidness.
 796    Return Qunbound or a Lisp_Void object if it is void.  */
 797
 798 Lisp_Object
 799 default_value (sym)
 800      Lisp_Object sym;
 801 {
 802   register Lisp_Object valcontents;
 803
 804   CHECK_SYMBOL (sym, 0);
 805   valcontents = XSYMBOL (sym)->value;
 806
 807   /* For a built-in buffer-local variable, get the default value
 808      rather than letting do_symval_forwarding get the current value.  */
 809   if (XTYPE (valcontents) == Lisp_Buffer_Objfwd)
 810     {
 811       register int idx = XUINT (valcontents);
 812
 813       if (*(int *) (idx + (char *) &buffer_local_flags) != 0)
 814         return *(Lisp_Object *)(idx + (char *) &buffer_defaults);
 815     }
 816
 817   /* Handle user-created local variables.  */
 818   if (XTYPE (valcontents) == Lisp_Buffer_Local_Value
 819       || XTYPE (valcontents) == Lisp_Some_Buffer_Local_Value)
 820     {
 821       /* If var is set up for a buffer that lacks a local value for it,
 822          the current value is nominally the default value.
 823          But the current value slot may be more up to date, since
 824          ordinary setq stores just that slot.  So use that.  */
 825       Lisp_Object current_alist_element, alist_element_car;
 826       current_alist_element
 827         = XCONS (XCONS (XCONS (valcontents)->cdr)->cdr)->car;
 828       alist_element_car = XCONS (current_alist_element)->car;
 829       if (EQ (alist_element_car, current_alist_element))
 830         return do_symval_forwarding (XCONS (valcontents)->car);
 831       else
 832         return XCONS (XCONS (XCONS (valcontents)->cdr)->cdr)->cdr;
 833     }
 834   /* For other variables, get the current value.  */
 835   return do_symval_forwarding (valcontents);
 836 }
 837
 838 DEFUN ("default-boundp", Fdefault_boundp, Sdefault_boundp, 1, 1, 0,
 839   "Return T if SYMBOL has a non-void default value.\n\
 840 This is the value that is seen in buffers that do not have their own values\n\
 841 for this variable.")
 842   (sym)
 843      Lisp_Object sym;
 844 {
 845   register Lisp_Object value;
 846
 847   value = default_value (sym);
 848   return (XTYPE (value) == Lisp_Void || EQ (value, Qunbound)
 849           ? Qnil : Qt);
 850 }
 851
 852 DEFUN ("default-value", Fdefault_value, Sdefault_value, 1, 1, 0,
 853   "Return SYMBOL's default value.\n\
 854 This is the value that is seen in buffers that do not have their own values\n\
 855 for this variable.  The default value is meaningful for variables with\n\
 856 local bindings in certain buffers.")
 857   (sym)
 858      Lisp_Object sym;
 859 {
 860   register Lisp_Object value;
 861
 862   value = default_value (sym);
 863   if (XTYPE (value) == Lisp_Void || EQ (value, Qunbound))
 864     return Fsignal (Qvoid_variable, Fcons (sym, Qnil));
 865   return value;
 866 }
 867
 868 DEFUN ("set-default", Fset_default, Sset_default, 2, 2, 0,
 869   "Set SYMBOL's default value to VAL.  SYMBOL and VAL are evaluated.\n\
 870 The default value is seen in buffers that do not have their own values\n\
 871 for this variable.")
 872   (sym, value)
 873      Lisp_Object sym, value;
 874 {
 875   register Lisp_Object valcontents, current_alist_element, alist_element_buffer;
 876
 877   CHECK_SYMBOL (sym, 0);
 878   valcontents = XSYMBOL (sym)->value;
 879
 880   /* Handle variables like case-fold-search that have special slots
 881      in the buffer.  Make them work apparently like Lisp_Buffer_Local_Value
 882      variables.  */
 883   if (XTYPE (valcontents) == Lisp_Buffer_Objfwd)
 884     {
 885       register int idx = XUINT (valcontents);
 886 #ifndef RTPC_REGISTER_BUG
 887       register struct buffer *b;
 888 #else
 889       struct buffer *b;
 890 #endif
 891       register int mask = *(int *) (idx + (char *) &buffer_local_flags);
 892
 893       if (mask > 0)
 894         {
 895           *(Lisp_Object *)(idx + (char *) &buffer_defaults) = value;
 896           for (b = all_buffers; b; b = b->next)
 897             if (!(b->local_var_flags & mask))
 898               *(Lisp_Object *)(idx + (char *) b) = value;
 899         }
 900       return value;
 901     }
 902
 903   if (XTYPE (valcontents) != Lisp_Buffer_Local_Value &&
 904       XTYPE (valcontents) != Lisp_Some_Buffer_Local_Value)
 905     return Fset (sym, value);
 906
 907   /* Store new value into the DEFAULT-VALUE slot */
 908   XCONS (XCONS (XCONS (valcontents)->cdr)->cdr)->cdr = value;
 909
 910   /* If that slot is current, we must set the REALVALUE slot too */
 911   current_alist_element = XCONS (XCONS (XCONS (valcontents)->cdr)->cdr)->car;
 912   alist_element_buffer = Fcar (current_alist_element);
 913   if (EQ (alist_element_buffer, current_alist_element))
 914     store_symval_forwarding (sym, XCONS (valcontents)->car, value);
 915
 916   return value;
 917 }
 918
 919 DEFUN ("setq-default", Fsetq_default, Ssetq_default, 2, UNEVALLED, 0,
 920        "\
 921 (setq-default SYM VAL SYM VAL ...): set each SYM's default value to its VAL.\n\
 922 VAL is evaluated; SYM is not.  The default value is seen in buffers that do\n\
 923 not have their own values for this variable.")
 924   (args)
 925      Lisp_Object args;
 926 {
 927   register Lisp_Object args_left;
 928   register Lisp_Object val, sym;
 929   struct gcpro gcpro1;
 930
 931   if (NILP (args))
 932     return Qnil;
 933
 934   args_left = args;
 935   GCPRO1 (args);
 936
 937   do
 938     {
 939       val = Feval (Fcar (Fcdr (args_left)));
 940       sym = Fcar (args_left);
 941       Fset_default (sym, val);
 942       args_left = Fcdr (Fcdr (args_left));
 943     }
 944   while (!NILP (args_left));
 945
 946   UNGCPRO;
 947   return val;
 948 }
 949 \f
 950 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local, Smake_variable_buffer_local,
 951   1, 1, "vMake Variable Buffer Local: ",
 952   "Make VARIABLE have a separate value for each buffer.\n\
 953 At any time, the value for the current buffer is in effect.\n\
 954 There is also a default value which is seen in any buffer which has not yet\n\
 955 set its own value.\n\
 956 Using `set' or `setq' to set the variable causes it to have a separate value\n\
 957 for the current buffer if it was previously using the default value.\n\
 958 The function `default-value' gets the default value and `set-default' sets it.")
 959   (sym)
 960      register Lisp_Object sym;
 961 {
 962   register Lisp_Object tem, valcontents;
 963
 964   CHECK_SYMBOL (sym, 0);
 965
 966   if (EQ (sym, Qnil) || EQ (sym, Qt))
 967     error ("Symbol %s may not be buffer-local", XSYMBOL (sym)->name->data);
 968
 969   valcontents = XSYMBOL (sym)->value;
 970   if ((XTYPE (valcontents) == Lisp_Buffer_Local_Value) ||
 971       (XTYPE (valcontents) == Lisp_Buffer_Objfwd))
 972     return sym;
 973   if (XTYPE (valcontents) == Lisp_Some_Buffer_Local_Value)
 974     {
 975       XSETTYPE (XSYMBOL (sym)->value, Lisp_Buffer_Local_Value);
 976       return sym;
 977     }
 978   if (EQ (valcontents, Qunbound))
 979     XSYMBOL (sym)->value = Qnil;
 980   tem = Fcons (Qnil, Fsymbol_value (sym));
 981   XCONS (tem)->car = tem;
 982   XSYMBOL (sym)->value = Fcons (XSYMBOL (sym)->value, Fcons (Fcurrent_buffer (), tem));
 983   XSETTYPE (XSYMBOL (sym)->value, Lisp_Buffer_Local_Value);
 984   return sym;
 985 }
 986
 987 DEFUN ("make-local-variable", Fmake_local_variable, Smake_local_variable,
 988   1, 1, "vMake Local Variable: ",
 989   "Make VARIABLE have a separate value in the current buffer.\n\
 990 Other buffers will continue to share a common default value.\n\
 991 See also `make-variable-buffer-local'.\n\n\
 992 If the variable is already arranged to become local when set,\n\
 993 this function causes a local value to exist for this buffer,\n\
 994 just as if the variable were set.")
 995   (sym)
 996      register Lisp_Object sym;
 997 {
 998   register Lisp_Object tem, valcontents;
 999
1000   CHECK_SYMBOL (sym, 0);
1001
1002   if (EQ (sym, Qnil) || EQ (sym, Qt))
1003     error ("Symbol %s may not be buffer-local", XSYMBOL (sym)->name->data);
1004
1005   valcontents = XSYMBOL (sym)->value;
1006   if (XTYPE (valcontents) == Lisp_Buffer_Local_Value
1007       || XTYPE (valcontents) == Lisp_Buffer_Objfwd)
1008     {
1009       tem = Fboundp (sym);
1010
1011       /* Make sure the symbol has a local value in this particular buffer,
1012          by setting it to the same value it already has.  */
1013       Fset (sym, (EQ (tem, Qt) ? Fsymbol_value (sym) : Qunbound));
1014       return sym;
1015     }
1016   /* Make sure sym is set up to hold per-buffer values */
1017   if (XTYPE (valcontents) != Lisp_Some_Buffer_Local_Value)
1018     {
1019       if (EQ (valcontents, Qunbound))
1020         XSYMBOL (sym)->value = Qnil;
1021       tem = Fcons (Qnil, do_symval_forwarding (valcontents));
1022       XCONS (tem)->car = tem;
1023       XSYMBOL (sym)->value = Fcons (XSYMBOL (sym)->value, Fcons (Qnil, tem));
1024       XSETTYPE (XSYMBOL (sym)->value, Lisp_Some_Buffer_Local_Value);
1025     }
1026   /* Make sure this buffer has its own value of sym */
1027   tem = Fassq (sym, current_buffer->local_var_alist);
1028   if (NILP (tem))
1029     {
1030       current_buffer->local_var_alist
1031         = Fcons (Fcons (sym, XCONS (XCONS (XCONS (XSYMBOL (sym)->value)->cdr)->cdr)->cdr),
1032                  current_buffer->local_var_alist);
1033
1034       /* Make sure symbol does not think it is set up for this buffer;
1035          force it to look once again for this buffer's value */
1036       {
1037         /* This local variable avoids "expression too complex" on IBM RT.  */
1038         Lisp_Object xs;
1039
1040         xs = XSYMBOL (sym)->value;
1041         if (current_buffer == XBUFFER (XCONS (XCONS (xs)->cdr)->car))
1042           XCONS (XCONS (XSYMBOL (sym)->value)->cdr)->car = Qnil;
1043       }
1044
1045     }
1046   return sym;
1047 }
1048
1049 DEFUN ("kill-local-variable", Fkill_local_variable, Skill_local_variable,
1050   1, 1, "vKill Local Variable: ",
1051   "Make VARIABLE no longer have a separate value in the current buffer.\n\
1052 From now on the default value will apply in this buffer.")
1053   (sym)
1054      register Lisp_Object sym;
1055 {
1056   register Lisp_Object tem, valcontents;
1057
1058   CHECK_SYMBOL (sym, 0);
1059
1060   valcontents = XSYMBOL (sym)->value;
1061
1062   if (XTYPE (valcontents) == Lisp_Buffer_Objfwd)
1063     {
1064       register int idx = XUINT (valcontents);
1065       register int mask = *(int *) (idx + (char *) &buffer_local_flags);
1066
1067       if (mask > 0)
1068         {
1069           *(Lisp_Object *)(idx + (char *) current_buffer)
1070             = *(Lisp_Object *)(idx + (char *) &buffer_defaults);
1071           current_buffer->local_var_flags &= ~mask;
1072         }
1073       return sym;
1074     }
1075
1076   if (XTYPE (valcontents) != Lisp_Buffer_Local_Value &&
1077       XTYPE (valcontents) != Lisp_Some_Buffer_Local_Value)
1078     return sym;
1079
1080   /* Get rid of this buffer's alist element, if any */
1081
1082   tem = Fassq (sym, current_buffer->local_var_alist);
1083   if (!NILP (tem))
1084     current_buffer->local_var_alist = Fdelq (tem, current_buffer->local_var_alist);
1085
1086   /* Make sure symbol does not think it is set up for this buffer;
1087      force it to look once again for this buffer's value */
1088   {
1089     Lisp_Object sv;
1090     sv = XSYMBOL (sym)->value;
1091     if (current_buffer == XBUFFER (XCONS (XCONS (sv)->cdr)->car))
1092       XCONS (XCONS (sv)->cdr)->car = Qnil;
1093   }
1094
1095   return sym;
1096 }
1097 \f
1098 /* Find the function at the end of a chain of symbol function indirections.  */
1099
1100 /* If OBJECT is a symbol, find the end of its function chain and
1101    return the value found there.  If OBJECT is not a symbol, just
1102    return it.  If there is a cycle in the function chain, signal a
1103    cyclic-function-indirection error.
1104
1105    This is like Findirect_function, except that it doesn't signal an
1106    error if the chain ends up unbound.  */
1107 Lisp_Object
1108 indirect_function (object, error)
1109   register Lisp_Object object;
1110 {
1111   Lisp_Object tortise, hare;
1112
1113   hare = tortise = object;
1114
1115   for (;;)
1116     {
1117       if (XTYPE (hare) != Lisp_Symbol || EQ (hare, Qunbound))
1118         break;
1119       hare = XSYMBOL (hare)->function;
1120       if (XTYPE (hare) != Lisp_Symbol || EQ (hare, Qunbound))
1121         break;
1122       hare = XSYMBOL (hare)->function;
1123
1124       tortise = XSYMBOL (tortise)->function;
1125
1126       if (EQ (hare, tortise))
1127         Fsignal (Qcyclic_function_indirection, Fcons (object, Qnil));
1128     }
1129
1130   return hare;
1131 }
1132
1133 DEFUN ("indirect-function", Findirect_function, Sindirect_function, 1, 1, 0,
1134   "Return the function at the end of OBJECT's function chain.\n\
1135 If OBJECT is a symbol, follow all function indirections and return the final\n\
1136 function binding.\n\
1137 If OBJECT is not a symbol, just return it.\n\
1138 Signal a void-function error if the final symbol is unbound.\n\
1139 Signal a cyclic-function-indirection error if there is a loop in the\n\
1140 function chain of symbols.")
1141   (object)
1142     register Lisp_Object object;
1143 {
1144   Lisp_Object result;
1145
1146   result = indirect_function (object);
1147
1148   if (EQ (result, Qunbound))
1149     return Fsignal (Qvoid_function, Fcons (object, Qnil));
1150   return result;
1151 }
1152 \f
1153 /* Extract and set vector and string elements */
1154
1155 DEFUN ("aref", Faref, Saref, 2, 2, 0,
1156   "Return the element of ARRAY at index INDEX.\n\
1157 ARRAY may be a vector or a string, or a byte-code object.  INDEX starts at 0.")
1158   (array, idx)
1159      register Lisp_Object array;
1160      Lisp_Object idx;
1161 {
1162   register int idxval;
1163
1164   CHECK_NUMBER (idx, 1);
1165   idxval = XINT (idx);
1166   if (XTYPE (array) != Lisp_Vector && XTYPE (array) != Lisp_String
1167       && XTYPE (array) != Lisp_Compiled)
1168     array = wrong_type_argument (Qarrayp, array);
1169   if (idxval < 0 || idxval >= XVECTOR (array)->size)
1170     args_out_of_range (array, idx);
1171   if (XTYPE (array) == Lisp_String)
1172     {
1173       Lisp_Object val;
1174       XFASTINT (val) = (unsigned char) XSTRING (array)->data[idxval];
1175       return val;
1176     }
1177   else
1178     return XVECTOR (array)->contents[idxval];
1179 }
1180
1181 DEFUN ("aset", Faset, Saset, 3, 3, 0,
1182   "Store into the element of ARRAY at index INDEX the value NEWVAL.\n\
1183 ARRAY may be a vector or a string.  INDEX starts at 0.")
1184   (array, idx, newelt)
1185      register Lisp_Object array;
1186      Lisp_Object idx, newelt;
1187 {
1188   register int idxval;
1189
1190   CHECK_NUMBER (idx, 1);
1191   idxval = XINT (idx);
1192   if (XTYPE (array) != Lisp_Vector && XTYPE (array) != Lisp_String)
1193     array = wrong_type_argument (Qarrayp, array);
1194   if (idxval < 0 || idxval >= XVECTOR (array)->size)
1195     args_out_of_range (array, idx);
1196   CHECK_IMPURE (array);
1197
1198   if (XTYPE (array) == Lisp_Vector)
1199     XVECTOR (array)->contents[idxval] = newelt;
1200   else
1201     {
1202       CHECK_NUMBER (newelt, 2);
1203       XSTRING (array)->data[idxval] = XINT (newelt);
1204     }
1205
1206   return newelt;
1207 }
1208
1209 Lisp_Object
1210 Farray_length (array)
1211      register Lisp_Object array;
1212 {
1213   register Lisp_Object size;
1214   if (XTYPE (array) != Lisp_Vector && XTYPE (array) != Lisp_String
1215       && XTYPE (array) != Lisp_Compiled)
1216     array = wrong_type_argument (Qarrayp, array);
1217   XFASTINT (size) = XVECTOR (array)->size;
1218   return size;
1219 }
1220 \f
1221 /* Arithmetic functions */
1222
1223 enum comparison { equal, notequal, less, grtr, less_or_equal, grtr_or_equal };
1224
1225 Lisp_Object
1226 arithcompare (num1, num2, comparison)
1227      Lisp_Object num1, num2;
1228      enum comparison comparison;
1229 {
1230   double f1, f2;
1231   int floatp = 0;
1232
1233 #ifdef LISP_FLOAT_TYPE
1234   CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1, 0);
1235   CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2, 0);
1236
1237   if (XTYPE (num1) == Lisp_Float || XTYPE (num2) == Lisp_Float)
1238     {
1239       floatp = 1;
1240       f1 = (XTYPE (num1) == Lisp_Float) ? XFLOAT (num1)->data : XINT (num1);
1241       f2 = (XTYPE (num2) == Lisp_Float) ? XFLOAT (num2)->data : XINT (num2);
1242     }
1243 #else
1244   CHECK_NUMBER_COERCE_MARKER (num1, 0);
1245   CHECK_NUMBER_COERCE_MARKER (num2, 0);
1246 #endif /* LISP_FLOAT_TYPE */
1247
1248   switch (comparison)
1249     {
1250     case equal:
1251       if (floatp ? f1 == f2 : XINT (num1) == XINT (num2))
1252         return Qt;
1253       return Qnil;
1254
1255     case notequal:
1256       if (floatp ? f1 != f2 : XINT (num1) != XINT (num2))
1257         return Qt;
1258       return Qnil;
1259
1260     case less:
1261       if (floatp ? f1 < f2 : XINT (num1) < XINT (num2))
1262         return Qt;
1263       return Qnil;
1264
1265     case less_or_equal:
1266       if (floatp ? f1 <= f2 : XINT (num1) <= XINT (num2))
1267         return Qt;
1268       return Qnil;
1269
1270     case grtr:
1271       if (floatp ? f1 > f2 : XINT (num1) > XINT (num2))
1272         return Qt;
1273       return Qnil;
1274
1275     case grtr_or_equal:
1276       if (floatp ? f1 >= f2 : XINT (num1) >= XINT (num2))
1277         return Qt;
1278       return Qnil;
1279     }
1280 }
1281
1282 DEFUN ("=", Feqlsign, Seqlsign, 2, 2, 0,
1283   "T if two args, both numbers or markers, are equal.")
1284   (num1, num2)
1285      register Lisp_Object num1, num2;
1286 {
1287   return arithcompare (num1, num2, equal);
1288 }
1289
1290 DEFUN ("<", Flss, Slss, 2, 2, 0,
1291   "T if first arg is less than second arg.  Both must be numbers or markers.")
1292   (num1, num2)
1293      register Lisp_Object num1, num2;
1294 {
1295   return arithcompare (num1, num2, less);
1296 }
1297
1298 DEFUN (">", Fgtr, Sgtr, 2, 2, 0,
1299   "T if first arg is greater than second arg.  Both must be numbers or markers.")
1300   (num1, num2)
1301      register Lisp_Object num1, num2;
1302 {
1303   return arithcompare (num1, num2, grtr);
1304 }
1305
1306 DEFUN ("<=", Fleq, Sleq, 2, 2, 0,
1307   "T if first arg is less than or equal to second arg.\n\
1308 Both must be numbers or markers.")
1309   (num1, num2)
1310      register Lisp_Object num1, num2;
1311 {
1312   return arithcompare (num1, num2, less_or_equal);
1313 }
1314
1315 DEFUN (">=", Fgeq, Sgeq, 2, 2, 0,
1316   "T if first arg is greater than or equal to second arg.\n\
1317 Both must be numbers or markers.")
1318   (num1, num2)
1319      register Lisp_Object num1, num2;
1320 {
1321   return arithcompare (num1, num2, grtr_or_equal);
1322 }
1323
1324 DEFUN ("/=", Fneq, Sneq, 2, 2, 0,
1325   "T if first arg is not equal to second arg.  Both must be numbers or markers.")
1326   (num1, num2)
1327      register Lisp_Object num1, num2;
1328 {
1329   return arithcompare (num1, num2, notequal);
1330 }
1331
1332 DEFUN ("zerop", Fzerop, Szerop, 1, 1, 0, "T if NUMBER is zero.")
1333   (num)
1334      register Lisp_Object num;
1335 {
1336 #ifdef LISP_FLOAT_TYPE
1337   CHECK_NUMBER_OR_FLOAT (num, 0);
1338
1339   if (XTYPE(num) == Lisp_Float)
1340     {
1341       if (XFLOAT(num)->data == 0.0)
1342         return Qt;
1343       return Qnil;
1344     }
1345 #else
1346   CHECK_NUMBER (num, 0);
1347 #endif /* LISP_FLOAT_TYPE */
1348
1349   if (!XINT (num))
1350     return Qt;
1351   return Qnil;
1352 }
1353 \f
1354 DEFUN ("int-to-string", Fint_to_string, Sint_to_string, 1, 1, 0,
1355   "Convert INT to a string by printing it in decimal.\n\
1356 Uses a minus sign if negative.")
1357   (num)
1358      Lisp_Object num;
1359 {
1360   char buffer[20];
1361
1362 #ifndef LISP_FLOAT_TYPE
1363   CHECK_NUMBER (num, 0);
1364 #else
1365   CHECK_NUMBER_OR_FLOAT (num, 0);
1366
1367   if (XTYPE(num) == Lisp_Float)
1368     {
1369       char pigbuf[350]; /* see comments in float_to_string */
1370
1371       float_to_string (pigbuf, XFLOAT(num)->data);
1372       return build_string (pigbuf);
1373     }
1374 #endif /* LISP_FLOAT_TYPE */
1375
1376   sprintf (buffer, "%d", XINT (num));
1377   return build_string (buffer);
1378 }
1379
1380 DEFUN ("string-to-int", Fstring_to_int, Sstring_to_int, 1, 1, 0,
1381   "Convert STRING to an integer by parsing it as a decimal number.")
1382   (str)
1383      register Lisp_Object str;
1384 {
1385   CHECK_STRING (str, 0);
1386
1387 #ifdef LISP_FLOAT_TYPE
1388   if (isfloat_string (XSTRING (str)->data))
1389     return make_float (atof (XSTRING (str)->data));
1390 #endif /* LISP_FLOAT_TYPE */
1391
1392   return make_number (atoi (XSTRING (str)->data));
1393 }
1394 \f
1395 enum arithop
1396   { Aadd, Asub, Amult, Adiv, Alogand, Alogior, Alogxor, Amax, Amin };
1397
1398 Lisp_Object
1399 arith_driver
1400   (code, nargs, args)
1401      enum arithop code;
1402      int nargs;
1403      register Lisp_Object *args;
1404 {
1405   register Lisp_Object val;
1406   register int argnum;
1407   register int accum;
1408   register int next;
1409
1410 #ifdef SWITCH_ENUM_BUG
1411   switch ((int) code)
1412 #else
1413   switch (code)
1414 #endif
1415     {
1416     case Alogior:
1417     case Alogxor:
1418     case Aadd:
1419     case Asub:
1420       accum = 0; break;
1421     case Amult:
1422       accum = 1; break;
1423     case Alogand:
1424       accum = -1; break;
1425     }
1426
1427   for (argnum = 0; argnum < nargs; argnum++)
1428     {
1429       val = args[argnum];    /* using args[argnum] as argument to CHECK_NUMBER_... */
1430 #ifdef LISP_FLOAT_TYPE
1431       CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val, argnum);
1432
1433       if (XTYPE (val) == Lisp_Float) /* time to do serious math */
1434         return (float_arith_driver ((double) accum, argnum, code,
1435                                     nargs, args));
1436 #else
1437       CHECK_NUMBER_COERCE_MARKER (val, argnum);
1438 #endif /* LISP_FLOAT_TYPE */
1439       args[argnum] = val;    /* runs into a compiler bug. */
1440       next = XINT (args[argnum]);
1441 #ifdef SWITCH_ENUM_BUG
1442       switch ((int) code)
1443 #else
1444       switch (code)
1445 #endif
1446         {
1447         case Aadd: accum += next; break;
1448         case Asub:
1449           if (!argnum && nargs != 1)
1450             next = - next;
1451           accum -= next;
1452           break;
1453         case Amult: accum *= next; break;
1454         case Adiv:
1455           if (!argnum) accum = next;
1456           else accum /= next;
1457           break;
1458         case Alogand: accum &= next; break;
1459         case Alogior: accum |= next; break;
1460         case Alogxor: accum ^= next; break;
1461         case Amax: if (!argnum || next > accum) accum = next; break;
1462         case Amin: if (!argnum || next < accum) accum = next; break;
1463         }
1464     }
1465
1466   XSET (val, Lisp_Int, accum);
1467   return val;
1468 }
1469
1470 #ifdef LISP_FLOAT_TYPE
1471 Lisp_Object
1472 float_arith_driver (accum, argnum, code, nargs, args)
1473      double accum;
1474      register int argnum;
1475      enum arithop code;
1476      int nargs;
1477      register Lisp_Object *args;
1478 {
1479   register Lisp_Object val;
1480   double next;
1481
1482   for (; argnum < nargs; argnum++)
1483     {
1484       val = args[argnum];    /* using args[argnum] as argument to CHECK_NUMBER_... */
1485       CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val, argnum);
1486
1487       if (XTYPE (val) == Lisp_Float)
1488         {
1489           next = XFLOAT (val)->data;
1490         }
1491       else
1492         {
1493           args[argnum] = val;    /* runs into a compiler bug. */
1494           next = XINT (args[argnum]);
1495         }
1496 #ifdef SWITCH_ENUM_BUG
1497       switch ((int) code)
1498 #else
1499       switch (code)
1500 #endif
1501         {
1502         case Aadd:
1503           accum += next;
1504           break;
1505         case Asub:
1506           if (!argnum && nargs != 1)
1507             next = - next;
1508           accum -= next;
1509           break;
1510         case Amult:
1511           accum *= next;
1512           break;
1513         case Adiv:
1514           if (!argnum)
1515             accum = next;
1516           else
1517             accum /= next;
1518           break;
1519         case Alogand:
1520         case Alogior:
1521         case Alogxor:
1522           return wrong_type_argument (Qinteger_or_marker_p, val);
1523         case Amax:
1524           if (!argnum || next > accum)
1525             accum = next;
1526           break;
1527         case Amin:
1528           if (!argnum || next < accum)
1529             accum = next;
1530           break;
1531         }
1532     }
1533
1534   return make_float (accum);
1535 }
1536 #endif /* LISP_FLOAT_TYPE */
1537
1538 DEFUN ("+", Fplus, Splus, 0, MANY, 0,
1539   "Return sum of any number of arguments, which are numbers or markers.")
1540   (nargs, args)
1541      int nargs;
1542      Lisp_Object *args;
1543 {
1544   return arith_driver (Aadd, nargs, args);
1545 }
1546
1547 DEFUN ("-", Fminus, Sminus, 0, MANY, 0,
1548   "Negate number or subtract numbers or markers.\n\
1549 With one arg, negates it.  With more than one arg,\n\
1550 subtracts all but the first from the first.")
1551   (nargs, args)
1552      int nargs;
1553      Lisp_Object *args;
1554 {
1555   return arith_driver (Asub, nargs, args);
1556 }
1557
1558 DEFUN ("*", Ftimes, Stimes, 0, MANY, 0,
1559   "Returns product of any number of arguments, which are numbers or markers.")
1560   (nargs, args)
1561      int nargs;
1562      Lisp_Object *args;
1563 {
1564   return arith_driver (Amult, nargs, args);
1565 }
1566
1567 DEFUN ("/", Fquo, Squo, 2, MANY, 0,
1568   "Returns first argument divided by all the remaining arguments.\n\
1569 The arguments must be numbers or markers.")
1570   (nargs, args)
1571      int nargs;
1572      Lisp_Object *args;
1573 {
1574   return arith_driver (Adiv, nargs, args);
1575 }
1576
1577 DEFUN ("%", Frem, Srem, 2, 2, 0,
1578   "Returns remainder of first arg divided by second.\n\
1579 Both must be numbers or markers.")
1580   (num1, num2)
1581      register Lisp_Object num1, num2;
1582 {
1583   Lisp_Object val;
1584
1585 #ifdef LISP_FLOAT_TYPE
1586   CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1, 0);
1587   CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2, 0);
1588
1589   if (XTYPE (num1) == Lisp_Float || XTYPE (num2) == Lisp_Float)
1590     {
1591       double f1, f2;
1592
1593       f1 = XTYPE (num1) == Lisp_Float ? XFLOAT (num1)->data : XINT (num1);
1594       f2 = XTYPE (num2) == Lisp_Float ? XFLOAT (num2)->data : XINT (num2);
1595       return (make_float (drem (f1,f2)));
1596     }
1597 #else /* not LISP_FLOAT_TYPE */
1598   CHECK_NUMBER_COERCE_MARKER (num1, 0);
1599   CHECK_NUMBER_COERCE_MARKER (num2, 1);
1600 #endif /* not LISP_FLOAT_TYPE */
1601
1602   XSET (val, Lisp_Int, XINT (num1) % XINT (num2));
1603   return val;
1604 }
1605
1606 DEFUN ("max", Fmax, Smax, 1, MANY, 0,
1607   "Return largest of all the arguments (which must be numbers or markers).\n\
1608 The value is always a number; markers are converted to numbers.")
1609   (nargs, args)
1610      int nargs;
1611      Lisp_Object *args;
1612 {
1613   return arith_driver (Amax, nargs, args);
1614 }
1615
1616 DEFUN ("min", Fmin, Smin, 1, MANY, 0,
1617   "Return smallest of all the arguments (which must be numbers or markers).\n\
1618 The value is always a number; markers are converted to numbers.")
1619   (nargs, args)
1620      int nargs;
1621      Lisp_Object *args;
1622 {
1623   return arith_driver (Amin, nargs, args);
1624 }
1625
1626 DEFUN ("logand", Flogand, Slogand, 0, MANY, 0,
1627   "Return bitwise-and of all the arguments.\n\
1628 Arguments may be integers, or markers converted to integers.")
1629   (nargs, args)
1630      int nargs;
1631      Lisp_Object *args;
1632 {
1633   return arith_driver (Alogand, nargs, args);
1634 }
1635
1636 DEFUN ("logior", Flogior, Slogior, 0, MANY, 0,
1637   "Return bitwise-or of all the arguments.\n\
1638 Arguments may be integers, or markers converted to integers.")
1639   (nargs, args)
1640      int nargs;
1641      Lisp_Object *args;
1642 {
1643   return arith_driver (Alogior, nargs, args);
1644 }
1645
1646 DEFUN ("logxor", Flogxor, Slogxor, 0, MANY, 0,
1647   "Return bitwise-exclusive-or of all the arguments.\n\
1648 Arguments may be integers, or markers converted to integers.")
1649   (nargs, args)
1650      int nargs;
1651      Lisp_Object *args;
1652 {
1653   return arith_driver (Alogxor, nargs, args);
1654 }
1655
1656 DEFUN ("ash", Fash, Sash, 2, 2, 0,
1657   "Return VALUE with its bits shifted left by COUNT.\n\
1658 If COUNT is negative, shifting is actually to the right.\n\
1659 In this case, the sign bit is duplicated.")
1660   (num1, num2)
1661      register Lisp_Object num1, num2;
1662 {
1663   register Lisp_Object val;
1664
1665   CHECK_NUMBER (num1, 0);
1666   CHECK_NUMBER (num2, 1);
1667
1668   if (XINT (num2) > 0)
1669     XSET (val, Lisp_Int, XINT (num1) << XFASTINT (num2));
1670   else
1671     XSET (val, Lisp_Int, XINT (num1) >> -XINT (num2));
1672   return val;
1673 }
1674
1675 DEFUN ("lsh", Flsh, Slsh, 2, 2, 0,
1676   "Return VALUE with its bits shifted left by COUNT.\n\
1677 If COUNT is negative, shifting is actually to the right.\n\
1678 In this case,  zeros are shifted in on the left.")
1679   (num1, num2)
1680      register Lisp_Object num1, num2;
1681 {
1682   register Lisp_Object val;
1683
1684   CHECK_NUMBER (num1, 0);
1685   CHECK_NUMBER (num2, 1);
1686
1687   if (XINT (num2) > 0)
1688     XSET (val, Lisp_Int, (unsigned) XFASTINT (num1) << XFASTINT (num2));
1689   else
1690     XSET (val, Lisp_Int, (unsigned) XFASTINT (num1) >> -XINT (num2));
1691   return val;
1692 }
1693
1694 DEFUN ("1+", Fadd1, Sadd1, 1, 1, 0,
1695   "Return NUMBER plus one.  NUMBER may be a number or a marker.\n\
1696 Markers are converted to integers.")
1697   (num)
1698      register Lisp_Object num;
1699 {
1700 #ifdef LISP_FLOAT_TYPE
1701   CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num, 0);
1702
1703   if (XTYPE (num) == Lisp_Float)
1704     return (make_float (1.0 + XFLOAT (num)->data));
1705 #else
1706   CHECK_NUMBER_COERCE_MARKER (num, 0);
1707 #endif /* LISP_FLOAT_TYPE */
1708
1709   XSETINT (num, XFASTINT (num) + 1);
1710   return num;
1711 }
1712
1713 DEFUN ("1-", Fsub1, Ssub1, 1, 1, 0,
1714   "Return NUMBER minus one.  NUMBER may be a number or a marker.\n\
1715 Markers are converted to integers.")
1716   (num)
1717      register Lisp_Object num;
1718 {
1719 #ifdef LISP_FLOAT_TYPE
1720   CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num, 0);
1721
1722   if (XTYPE (num) == Lisp_Float)
1723     return (make_float (-1.0 + XFLOAT (num)->data));
1724 #else
1725   CHECK_NUMBER_COERCE_MARKER (num, 0);
1726 #endif /* LISP_FLOAT_TYPE */
1727
1728   XSETINT (num, XFASTINT (num) - 1);
1729   return num;
1730 }
1731
1732 DEFUN ("lognot", Flognot, Slognot, 1, 1, 0,
1733   "Return the bitwise complement of ARG.  ARG must be an integer.")
1734   (num)
1735      register Lisp_Object num;
1736 {
1737   CHECK_NUMBER (num, 0);
1738   XSETINT (num, ~XFASTINT (num));
1739   return num;
1740 }
1741 \f
1742 void
1743 syms_of_data ()
1744 {
1745   Qquote = intern ("quote");
1746   Qlambda = intern ("lambda");
1747   Qsubr = intern ("subr");
1748   Qerror_conditions = intern ("error-conditions");
1749   Qerror_message = intern ("error-message");
1750   Qtop_level = intern ("top-level");
1751
1752   Qerror = intern ("error");
1753   Qquit = intern ("quit");
1754   Qwrong_type_argument = intern ("wrong-type-argument");
1755   Qargs_out_of_range = intern ("args-out-of-range");
1756   Qvoid_function = intern ("void-function");
1757   Qcyclic_function_indirection = intern ("cyclic-function-indirection");
1758   Qvoid_variable = intern ("void-variable");
1759   Qsetting_constant = intern ("setting-constant");
1760   Qinvalid_read_syntax = intern ("invalid-read-syntax");
1761
1762   Qinvalid_function = intern ("invalid-function");
1763   Qwrong_number_of_arguments = intern ("wrong-number-of-arguments");
1764   Qno_catch = intern ("no-catch");
1765   Qend_of_file = intern ("end-of-file");
1766   Qarith_error = intern ("arith-error");
1767   Qbeginning_of_buffer = intern ("beginning-of-buffer");
1768   Qend_of_buffer = intern ("end-of-buffer");
1769   Qbuffer_read_only = intern ("buffer-read-only");
1770
1771   Qlistp = intern ("listp");
1772   Qconsp = intern ("consp");
1773   Qsymbolp = intern ("symbolp");
1774   Qintegerp = intern ("integerp");
1775   Qnatnump = intern ("natnump");
1776   Qstringp = intern ("stringp");
1777   Qarrayp = intern ("arrayp");
1778   Qsequencep = intern ("sequencep");
1779   Qbufferp = intern ("bufferp");
1780   Qvectorp = intern ("vectorp");
1781   Qchar_or_string_p = intern ("char-or-string-p");
1782   Qmarkerp = intern ("markerp");
1783   Qinteger_or_marker_p = intern ("integer-or-marker-p");
1784   Qboundp = intern ("boundp");
1785   Qfboundp = intern ("fboundp");
1786
1787 #ifdef LISP_FLOAT_TYPE
1788   Qfloatp = intern ("floatp");
1789   Qnumberp = intern ("numberp");
1790   Qnumber_or_marker_p = intern ("number-or-marker-p");
1791 #endif /* LISP_FLOAT_TYPE */
1792
1793   Qcdr = intern ("cdr");
1794
1795   /* ERROR is used as a signaler for random errors for which nothing else is right */
1796
1797   Fput (Qerror, Qerror_conditions,
1798         Fcons (Qerror, Qnil));
1799   Fput (Qerror, Qerror_message,
1800         build_string ("error"));
1801
1802   Fput (Qquit, Qerror_conditions,
1803         Fcons (Qquit, Qnil));
1804   Fput (Qquit, Qerror_message,
1805         build_string ("Quit"));
1806
1807   Fput (Qwrong_type_argument, Qerror_conditions,
1808         Fcons (Qwrong_type_argument, Fcons (Qerror, Qnil)));
1809   Fput (Qwrong_type_argument, Qerror_message,
1810         build_string ("Wrong type argument"));
1811
1812   Fput (Qargs_out_of_range, Qerror_conditions,
1813         Fcons (Qargs_out_of_range, Fcons (Qerror, Qnil)));
1814   Fput (Qargs_out_of_range, Qerror_message,
1815         build_string ("Args out of range"));
1816
1817   Fput (Qvoid_function, Qerror_conditions,
1818         Fcons (Qvoid_function, Fcons (Qerror, Qnil)));
1819   Fput (Qvoid_function, Qerror_message,
1820         build_string ("Symbol's function definition is void"));
1821
1822   Fput (Qcyclic_function_indirection, Qerror_conditions,
1823         Fcons (Qcyclic_function_indirection, Fcons (Qerror, Qnil)));
1824   Fput (Qcyclic_function_indirection, Qerror_message,
1825         build_string ("Symbol's chain of function indirections contains a loop"));
1826
1827   Fput (Qvoid_variable, Qerror_conditions,
1828         Fcons (Qvoid_variable, Fcons (Qerror, Qnil)));
1829   Fput (Qvoid_variable, Qerror_message,
1830         build_string ("Symbol's value as variable is void"));
1831
1832   Fput (Qsetting_constant, Qerror_conditions,
1833         Fcons (Qsetting_constant, Fcons (Qerror, Qnil)));
1834   Fput (Qsetting_constant, Qerror_message,
1835         build_string ("Attempt to set a constant symbol"));
1836
1837   Fput (Qinvalid_read_syntax, Qerror_conditions,
1838         Fcons (Qinvalid_read_syntax, Fcons (Qerror, Qnil)));
1839   Fput (Qinvalid_read_syntax, Qerror_message,
1840         build_string ("Invalid read syntax"));
1841
1842   Fput (Qinvalid_function, Qerror_conditions,
1843         Fcons (Qinvalid_function, Fcons (Qerror, Qnil)));
1844   Fput (Qinvalid_function, Qerror_message,
1845         build_string ("Invalid function"));
1846
1847   Fput (Qwrong_number_of_arguments, Qerror_conditions,
1848         Fcons (Qwrong_number_of_arguments, Fcons (Qerror, Qnil)));
1849   Fput (Qwrong_number_of_arguments, Qerror_message,
1850         build_string ("Wrong number of arguments"));
1851
1852   Fput (Qno_catch, Qerror_conditions,
1853         Fcons (Qno_catch, Fcons (Qerror, Qnil)));
1854   Fput (Qno_catch, Qerror_message,
1855         build_string ("No catch for tag"));
1856
1857   Fput (Qend_of_file, Qerror_conditions,
1858         Fcons (Qend_of_file, Fcons (Qerror, Qnil)));
1859   Fput (Qend_of_file, Qerror_message,
1860         build_string ("End of file during parsing"));
1861
1862   Fput (Qarith_error, Qerror_conditions,
1863         Fcons (Qarith_error, Fcons (Qerror, Qnil)));
1864   Fput (Qarith_error, Qerror_message,
1865         build_string ("Arithmetic error"));
1866
1867   Fput (Qbeginning_of_buffer, Qerror_conditions,
1868         Fcons (Qbeginning_of_buffer, Fcons (Qerror, Qnil)));
1869   Fput (Qbeginning_of_buffer, Qerror_message,
1870         build_string ("Beginning of buffer"));
1871
1872   Fput (Qend_of_buffer, Qerror_conditions,
1873         Fcons (Qend_of_buffer, Fcons (Qerror, Qnil)));
1874   Fput (Qend_of_buffer, Qerror_message,
1875         build_string ("End of buffer"));
1876
1877   Fput (Qbuffer_read_only, Qerror_conditions,
1878         Fcons (Qbuffer_read_only, Fcons (Qerror, Qnil)));
1879   Fput (Qbuffer_read_only, Qerror_message,
1880         build_string ("Buffer is read-only"));
1881
1882   staticpro (&Qnil);
1883   staticpro (&Qt);
1884   staticpro (&Qquote);
1885   staticpro (&Qlambda);
1886   staticpro (&Qsubr);
1887   staticpro (&Qunbound);
1888   staticpro (&Qerror_conditions);
1889   staticpro (&Qerror_message);
1890   staticpro (&Qtop_level);
1891
1892   staticpro (&Qerror);
1893   staticpro (&Qquit);
1894   staticpro (&Qwrong_type_argument);
1895   staticpro (&Qargs_out_of_range);
1896   staticpro (&Qvoid_function);
1897   staticpro (&Qcyclic_function_indirection);
1898   staticpro (&Qvoid_variable);
1899   staticpro (&Qsetting_constant);
1900   staticpro (&Qinvalid_read_syntax);
1901   staticpro (&Qwrong_number_of_arguments);
1902   staticpro (&Qinvalid_function);
1903   staticpro (&Qno_catch);
1904   staticpro (&Qend_of_file);
1905   staticpro (&Qarith_error);
1906   staticpro (&Qbeginning_of_buffer);
1907   staticpro (&Qend_of_buffer);
1908   staticpro (&Qbuffer_read_only);
1909
1910   staticpro (&Qlistp);
1911   staticpro (&Qconsp);
1912   staticpro (&Qsymbolp);
1913   staticpro (&Qintegerp);
1914   staticpro (&Qnatnump);
1915   staticpro (&Qstringp);
1916   staticpro (&Qarrayp);
1917   staticpro (&Qsequencep);
1918   staticpro (&Qbufferp);
1919   staticpro (&Qvectorp);
1920   staticpro (&Qchar_or_string_p);
1921   staticpro (&Qmarkerp);
1922   staticpro (&Qinteger_or_marker_p);
1923 #ifdef LISP_FLOAT_TYPE
1924   staticpro (&Qfloatp);
1925   staticpro (&Qinteger_or_floatp);
1926   staticpro (&Qinteger_or_float_or_marker_p);
1927 #endif /* LISP_FLOAT_TYPE */
1928
1929   staticpro (&Qboundp);
1930   staticpro (&Qfboundp);
1931   staticpro (&Qcdr);
1932
1933   defsubr (&Seq);
1934   defsubr (&Snull);
1935   defsubr (&Slistp);
1936   defsubr (&Snlistp);
1937   defsubr (&Sconsp);
1938   defsubr (&Satom);
1939   defsubr (&Sintegerp);
1940 #ifdef LISP_FLOAT_TYPE
1941   defsubr (&Sfloatp);
1942   defsubr (&Snumberp);
1943   defsubr (&Snumber_or_marker_p);
1944 #endif /* LISP_FLOAT_TYPE */
1945   defsubr (&Snatnump);
1946   defsubr (&Ssymbolp);
1947   defsubr (&Sstringp);
1948   defsubr (&Svectorp);
1949   defsubr (&Sarrayp);
1950   defsubr (&Ssequencep);
1951   defsubr (&Sbufferp);
1952   defsubr (&Smarkerp);
1953   defsubr (&Sinteger_or_marker_p);
1954   defsubr (&Ssubrp);
1955   defsubr (&Scompiled_function_p);
1956   defsubr (&Schar_or_string_p);
1957   defsubr (&Scar);
1958   defsubr (&Scdr);
1959   defsubr (&Scar_safe);
1960   defsubr (&Scdr_safe);
1961   defsubr (&Ssetcar);
1962   defsubr (&Ssetcdr);
1963   defsubr (&Ssymbol_function);
1964   defsubr (&Sindirect_function);
1965   defsubr (&Ssymbol_plist);
1966   defsubr (&Ssymbol_name);
1967   defsubr (&Smakunbound);
1968   defsubr (&Sfmakunbound);
1969   defsubr (&Sboundp);
1970   defsubr (&Sfboundp);
1971   defsubr (&Sfset);
1972   defsubr (&Ssetplist);
1973   defsubr (&Ssymbol_value);
1974   defsubr (&Sset);
1975   defsubr (&Sdefault_boundp);
1976   defsubr (&Sdefault_value);
1977   defsubr (&Sset_default);
1978   defsubr (&Ssetq_default);
1979   defsubr (&Smake_variable_buffer_local);
1980   defsubr (&Smake_local_variable);
1981   defsubr (&Skill_local_variable);
1982   defsubr (&Saref);
1983   defsubr (&Saset);
1984   defsubr (&Sint_to_string);
1985   defsubr (&Sstring_to_int);
1986   defsubr (&Seqlsign);
1987   defsubr (&Slss);
1988   defsubr (&Sgtr);
1989   defsubr (&Sleq);
1990   defsubr (&Sgeq);
1991   defsubr (&Sneq);
1992   defsubr (&Szerop);
1993   defsubr (&Splus);
1994   defsubr (&Sminus);
1995   defsubr (&Stimes);
1996   defsubr (&Squo);
1997   defsubr (&Srem);
1998   defsubr (&Smax);
1999   defsubr (&Smin);
2000   defsubr (&Slogand);
2001   defsubr (&Slogior);
2002   defsubr (&Slogxor);
2003   defsubr (&Slsh);
2004   defsubr (&Sash);
2005   defsubr (&Sadd1);
2006   defsubr (&Ssub1);
2007   defsubr (&Slognot);
2008 }
2009
2010 SIGTYPE
2011 arith_error (signo)
2012      int signo;
2013 {
2014 #ifdef USG
2015   /* USG systems forget handlers when they are used;
2016      must reestablish each time */
2017   signal (signo, arith_error);
2018 #endif /* USG */
2019 #ifdef VMS
2020   /* VMS systems are like USG.  */
2021   signal (signo, arith_error);
2022 #endif /* VMS */
2023 #ifdef BSD4_1
2024   sigrelse (SIGFPE);
2025 #else /* not BSD4_1 */
2026   sigsetmask (SIGEMPTYMASK);
2027 #endif /* not BSD4_1 */
2028
2029   Fsignal (Qarith_error, Qnil);
2030 }
2031
2032 init_data ()
2033 {
2034   /* Don't do this if just dumping out.
2035      We don't want to call `signal' in this case
2036      so that we don't have trouble with dumping
2037      signal-delivering routines in an inconsistent state.  */
2038 #ifndef CANNOT_DUMP
2039   if (!initialized)
2040     return;
2041 #endif /* CANNOT_DUMP */
2042   signal (SIGFPE, arith_error);
2043
2044 #ifdef uts
2045   signal (SIGEMT, arith_error);
2046 #endif /* uts */
2047 }