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