src/data.c

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