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