1/* Primitive operations on Lisp data types for GNU Emacs Lisp interpreter. 2 Copyright (C) 1985, 1986, 1988, 1993, 1994, 1995, 1997, 1998, 1999, 2000, 3 2001, 2002, 2003, 2004, 2005, 2006, 2007 Free Software Foundation, Inc. 4 5This file is part of GNU Emacs. 6 7GNU Emacs is free software; you can redistribute it and/or modify 8it under the terms of the GNU General Public License as published by 9the Free Software Foundation; either version 2, or (at your option) 10any later version. 11 12GNU Emacs is distributed in the hope that it will be useful, 13but WITHOUT ANY WARRANTY; without even the implied warranty of 14MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15GNU General Public License for more details. 16 17You should have received a copy of the GNU General Public License 18along with GNU Emacs; see the file COPYING. If not, write to 19the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, 20Boston, MA 02110-1301, USA. */ 21 22 23#include <config.h> 24#include <signal.h> 25#include <stdio.h> 26#include "lisp.h" 27#include "puresize.h" 28#include "charset.h" 29#include "buffer.h" 30#include "keyboard.h" 31#include "frame.h" 32#include "syssignal.h" 33 34#ifdef STDC_HEADERS 35#include <float.h> 36#endif 37 38/* If IEEE_FLOATING_POINT isn't defined, default it from FLT_*. */ 39#ifndef IEEE_FLOATING_POINT 40#if (FLT_RADIX == 2 && FLT_MANT_DIG == 24 \ 41 && FLT_MIN_EXP == -125 && FLT_MAX_EXP == 128) 42#define IEEE_FLOATING_POINT 1 43#else 44#define IEEE_FLOATING_POINT 0 45#endif 46#endif 47 48/* Work around a problem that happens because math.h on hpux 7 49 defines two static variables--which, in Emacs, are not really static, 50 because `static' is defined as nothing. The problem is that they are 51 here, in floatfns.c, and in lread.c. 52 These macros prevent the name conflict. */ 53#if defined (HPUX) && !defined (HPUX8) 54#define _MAXLDBL data_c_maxldbl 55#define _NMAXLDBL data_c_nmaxldbl 56#endif 57 58#include <math.h> 59 60#if !defined (atof) 61extern double atof (); 62#endif /* !atof */ 63 64Lisp_Object Qnil, Qt, Qquote, Qlambda, Qsubr, Qunbound; 65Lisp_Object Qerror_conditions, Qerror_message, Qtop_level; 66Lisp_Object Qerror, Qquit, Qwrong_type_argument, Qargs_out_of_range; 67Lisp_Object Qvoid_variable, Qvoid_function, Qcyclic_function_indirection; 68Lisp_Object Qcyclic_variable_indirection, Qcircular_list; 69Lisp_Object Qsetting_constant, Qinvalid_read_syntax; 70Lisp_Object Qinvalid_function, Qwrong_number_of_arguments, Qno_catch; 71Lisp_Object Qend_of_file, Qarith_error, Qmark_inactive; 72Lisp_Object Qbeginning_of_buffer, Qend_of_buffer, Qbuffer_read_only; 73Lisp_Object Qtext_read_only; 74 75Lisp_Object Qintegerp, Qnatnump, Qwholenump, Qsymbolp, Qlistp, Qconsp; 76Lisp_Object Qstringp, Qarrayp, Qsequencep, Qbufferp; 77Lisp_Object Qchar_or_string_p, Qmarkerp, Qinteger_or_marker_p, Qvectorp; 78Lisp_Object Qbuffer_or_string_p, Qkeywordp; 79Lisp_Object Qboundp, Qfboundp; 80Lisp_Object Qchar_table_p, Qvector_or_char_table_p; 81 82Lisp_Object Qcdr; 83Lisp_Object Qad_advice_info, Qad_activate_internal; 84 85Lisp_Object Qrange_error, Qdomain_error, Qsingularity_error; 86Lisp_Object Qoverflow_error, Qunderflow_error; 87 88Lisp_Object Qfloatp; 89Lisp_Object Qnumberp, Qnumber_or_marker_p; 90 91Lisp_Object Qinteger; 92static Lisp_Object Qsymbol, Qstring, Qcons, Qmarker, Qoverlay; 93static Lisp_Object Qfloat, Qwindow_configuration, Qwindow; 94Lisp_Object Qprocess; 95static Lisp_Object Qcompiled_function, Qbuffer, Qframe, Qvector; 96static Lisp_Object Qchar_table, Qbool_vector, Qhash_table; 97static Lisp_Object Qsubrp, Qmany, Qunevalled; 98 99static Lisp_Object swap_in_symval_forwarding P_ ((Lisp_Object, Lisp_Object)); 100 101Lisp_Object Vmost_positive_fixnum, Vmost_negative_fixnum; 102 103 104void 105circular_list_error (list) 106 Lisp_Object list; 107{ 108 xsignal (Qcircular_list, list); 109} 110 111 112Lisp_Object 113wrong_type_argument (predicate, value) 114 register Lisp_Object predicate, value; 115{ 116 /* If VALUE is not even a valid Lisp object, abort here 117 where we can get a backtrace showing where it came from. */ 118 if ((unsigned int) XGCTYPE (value) >= Lisp_Type_Limit) 119 abort (); 120 121 xsignal2 (Qwrong_type_argument, predicate, value); 122} 123 124void 125pure_write_error () 126{ 127 error ("Attempt to modify read-only object"); 128} 129 130void 131args_out_of_range (a1, a2) 132 Lisp_Object a1, a2; 133{ 134 xsignal2 (Qargs_out_of_range, a1, a2); 135} 136 137void 138args_out_of_range_3 (a1, a2, a3) 139 Lisp_Object a1, a2, a3; 140{ 141 xsignal3 (Qargs_out_of_range, a1, a2, a3); 142} 143 144/* On some machines, XINT needs a temporary location. 145 Here it is, in case it is needed. */ 146 147int sign_extend_temp; 148 149/* On a few machines, XINT can only be done by calling this. */ 150 151int 152sign_extend_lisp_int (num) 153 EMACS_INT num; 154{ 155 if (num & (((EMACS_INT) 1) << (VALBITS - 1))) 156 return num | (((EMACS_INT) (-1)) << VALBITS); 157 else 158 return num & ((((EMACS_INT) 1) << VALBITS) - 1); 159} 160 161/* Data type predicates */ 162 163DEFUN ("eq", Feq, Seq, 2, 2, 0, 164 doc: /* Return t if the two args are the same Lisp object. */) 165 (obj1, obj2) 166 Lisp_Object obj1, obj2; 167{ 168 if (EQ (obj1, obj2)) 169 return Qt; 170 return Qnil; 171} 172 173DEFUN ("null", Fnull, Snull, 1, 1, 0, 174 doc: /* Return t if OBJECT is nil. */) 175 (object) 176 Lisp_Object object; 177{ 178 if (NILP (object)) 179 return Qt; 180 return Qnil; 181} 182 183DEFUN ("type-of", Ftype_of, Stype_of, 1, 1, 0, 184 doc: /* Return a symbol representing the type of OBJECT. 185The symbol returned names the object's basic type; 186for example, (type-of 1) returns `integer'. */) 187 (object) 188 Lisp_Object object; 189{ 190 switch (XGCTYPE (object)) 191 { 192 case Lisp_Int: 193 return Qinteger; 194 195 case Lisp_Symbol: 196 return Qsymbol; 197 198 case Lisp_String: 199 return Qstring; 200 201 case Lisp_Cons: 202 return Qcons; 203 204 case Lisp_Misc: 205 switch (XMISCTYPE (object)) 206 { 207 case Lisp_Misc_Marker: 208 return Qmarker; 209 case Lisp_Misc_Overlay: 210 return Qoverlay; 211 case Lisp_Misc_Float: 212 return Qfloat; 213 } 214 abort (); 215 216 case Lisp_Vectorlike: 217 if (GC_WINDOW_CONFIGURATIONP (object)) 218 return Qwindow_configuration; 219 if (GC_PROCESSP (object)) 220 return Qprocess; 221 if (GC_WINDOWP (object)) 222 return Qwindow; 223 if (GC_SUBRP (object)) 224 return Qsubr; 225 if (GC_COMPILEDP (object)) 226 return Qcompiled_function; 227 if (GC_BUFFERP (object)) 228 return Qbuffer; 229 if (GC_CHAR_TABLE_P (object)) 230 return Qchar_table; 231 if (GC_BOOL_VECTOR_P (object)) 232 return Qbool_vector; 233 if (GC_FRAMEP (object)) 234 return Qframe; 235 if (GC_HASH_TABLE_P (object)) 236 return Qhash_table; 237 return Qvector; 238 239 case Lisp_Float: 240 return Qfloat; 241 242 default: 243 abort (); 244 } 245} 246 247DEFUN ("consp", Fconsp, Sconsp, 1, 1, 0, 248 doc: /* Return t if OBJECT is a cons cell. */) 249 (object) 250 Lisp_Object object; 251{ 252 if (CONSP (object)) 253 return Qt; 254 return Qnil; 255} 256 257DEFUN ("atom", Fatom, Satom, 1, 1, 0, 258 doc: /* Return t if OBJECT is not a cons cell. This includes nil. */) 259 (object) 260 Lisp_Object object; 261{ 262 if (CONSP (object)) 263 return Qnil; 264 return Qt; 265} 266 267DEFUN ("listp", Flistp, Slistp, 1, 1, 0, 268 doc: /* Return t if OBJECT is a list, that is, a cons cell or nil. 269Otherwise, return nil. */) 270 (object) 271 Lisp_Object object; 272{ 273 if (CONSP (object) || NILP (object)) 274 return Qt; 275 return Qnil; 276} 277 278DEFUN ("nlistp", Fnlistp, Snlistp, 1, 1, 0, 279 doc: /* Return t if OBJECT is not a list. Lists include nil. */) 280 (object) 281 Lisp_Object object; 282{ 283 if (CONSP (object) || NILP (object)) 284 return Qnil; 285 return Qt; 286} 287 288DEFUN ("symbolp", Fsymbolp, Ssymbolp, 1, 1, 0, 289 doc: /* Return 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/* Define this in C to avoid unnecessarily consing up the symbol 299 name. */ 300DEFUN ("keywordp", Fkeywordp, Skeywordp, 1, 1, 0, 301 doc: /* Return t if OBJECT is a keyword. 302This means that it is a symbol with a print name beginning with `:' 303interned in the initial obarray. */) 304 (object) 305 Lisp_Object object; 306{ 307 if (SYMBOLP (object) 308 && SREF (SYMBOL_NAME (object), 0) == ':' 309 && SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (object)) 310 return Qt; 311 return Qnil; 312} 313 314DEFUN ("vectorp", Fvectorp, Svectorp, 1, 1, 0, 315 doc: /* Return t if OBJECT is a vector. */) 316 (object) 317 Lisp_Object object; 318{ 319 if (VECTORP (object)) 320 return Qt; 321 return Qnil; 322} 323 324DEFUN ("stringp", Fstringp, Sstringp, 1, 1, 0, 325 doc: /* Return t if OBJECT is a string. */) 326 (object) 327 Lisp_Object object; 328{ 329 if (STRINGP (object)) 330 return Qt; 331 return Qnil; 332} 333 334DEFUN ("multibyte-string-p", Fmultibyte_string_p, Smultibyte_string_p, 335 1, 1, 0, 336 doc: /* Return t if OBJECT is a multibyte string. */) 337 (object) 338 Lisp_Object object; 339{ 340 if (STRINGP (object) && STRING_MULTIBYTE (object)) 341 return Qt; 342 return Qnil; 343} 344 345DEFUN ("char-table-p", Fchar_table_p, Schar_table_p, 1, 1, 0, 346 doc: /* Return t if OBJECT is a char-table. */) 347 (object) 348 Lisp_Object object; 349{ 350 if (CHAR_TABLE_P (object)) 351 return Qt; 352 return Qnil; 353} 354 355DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p, 356 Svector_or_char_table_p, 1, 1, 0, 357 doc: /* Return t if OBJECT is a char-table or vector. */) 358 (object) 359 Lisp_Object object; 360{ 361 if (VECTORP (object) || CHAR_TABLE_P (object)) 362 return Qt; 363 return Qnil; 364} 365 366DEFUN ("bool-vector-p", Fbool_vector_p, Sbool_vector_p, 1, 1, 0, 367 doc: /* Return t if OBJECT is a bool-vector. */) 368 (object) 369 Lisp_Object object; 370{ 371 if (BOOL_VECTOR_P (object)) 372 return Qt; 373 return Qnil; 374} 375 376DEFUN ("arrayp", Farrayp, Sarrayp, 1, 1, 0, 377 doc: /* Return t if OBJECT is an array (string or vector). */) 378 (object) 379 Lisp_Object object; 380{ 381 if (ARRAYP (object)) 382 return Qt; 383 return Qnil; 384} 385 386DEFUN ("sequencep", Fsequencep, Ssequencep, 1, 1, 0, 387 doc: /* Return t if OBJECT is a sequence (list or array). */) 388 (object) 389 register Lisp_Object object; 390{ 391 if (CONSP (object) || NILP (object) || ARRAYP (object)) 392 return Qt; 393 return Qnil; 394} 395 396DEFUN ("bufferp", Fbufferp, Sbufferp, 1, 1, 0, 397 doc: /* Return t if OBJECT is an editor buffer. */) 398 (object) 399 Lisp_Object object; 400{ 401 if (BUFFERP (object)) 402 return Qt; 403 return Qnil; 404} 405 406DEFUN ("markerp", Fmarkerp, Smarkerp, 1, 1, 0, 407 doc: /* Return t if OBJECT is a marker (editor pointer). */) 408 (object) 409 Lisp_Object object; 410{ 411 if (MARKERP (object)) 412 return Qt; 413 return Qnil; 414} 415 416DEFUN ("subrp", Fsubrp, Ssubrp, 1, 1, 0, 417 doc: /* Return t if OBJECT is a built-in function. */) 418 (object) 419 Lisp_Object object; 420{ 421 if (SUBRP (object)) 422 return Qt; 423 return Qnil; 424} 425 426DEFUN ("byte-code-function-p", Fbyte_code_function_p, Sbyte_code_function_p, 427 1, 1, 0, 428 doc: /* Return t if OBJECT is a byte-compiled function object. */) 429 (object) 430 Lisp_Object object; 431{ 432 if (COMPILEDP (object)) 433 return Qt; 434 return Qnil; 435} 436 437DEFUN ("char-or-string-p", Fchar_or_string_p, Schar_or_string_p, 1, 1, 0, 438 doc: /* Return t if OBJECT is a character (an integer) or a string. */) 439 (object) 440 register Lisp_Object object; 441{ 442 if (INTEGERP (object) || STRINGP (object)) 443 return Qt; 444 return Qnil; 445} 446 447DEFUN ("integerp", Fintegerp, Sintegerp, 1, 1, 0, 448 doc: /* Return t if OBJECT is an integer. */) 449 (object) 450 Lisp_Object object; 451{ 452 if (INTEGERP (object)) 453 return Qt; 454 return Qnil; 455} 456 457DEFUN ("integer-or-marker-p", Finteger_or_marker_p, Sinteger_or_marker_p, 1, 1, 0, 458 doc: /* Return t if OBJECT is an integer or a marker (editor pointer). */) 459 (object) 460 register Lisp_Object object; 461{ 462 if (MARKERP (object) || INTEGERP (object)) 463 return Qt; 464 return Qnil; 465} 466 467DEFUN ("natnump", Fnatnump, Snatnump, 1, 1, 0, 468 doc: /* Return t if OBJECT is a nonnegative integer. */) 469 (object) 470 Lisp_Object object; 471{ 472 if (NATNUMP (object)) 473 return Qt; 474 return Qnil; 475} 476 477DEFUN ("numberp", Fnumberp, Snumberp, 1, 1, 0, 478 doc: /* Return t if OBJECT is a number (floating point or integer). */) 479 (object) 480 Lisp_Object object; 481{ 482 if (NUMBERP (object)) 483 return Qt; 484 else 485 return Qnil; 486} 487 488DEFUN ("number-or-marker-p", Fnumber_or_marker_p, 489 Snumber_or_marker_p, 1, 1, 0, 490 doc: /* Return t if OBJECT is a number or a marker. */) 491 (object) 492 Lisp_Object object; 493{ 494 if (NUMBERP (object) || MARKERP (object)) 495 return Qt; 496 return Qnil; 497} 498 499DEFUN ("floatp", Ffloatp, Sfloatp, 1, 1, 0, 500 doc: /* Return t if OBJECT is a floating point number. */) 501 (object) 502 Lisp_Object object; 503{ 504 if (FLOATP (object)) 505 return Qt; 506 return Qnil; 507} 508 509 510/* Extract and set components of lists */ 511 512DEFUN ("car", Fcar, Scar, 1, 1, 0, 513 doc: /* Return the car of LIST. If arg is nil, return nil. 514Error if arg is not nil and not a cons cell. See also `car-safe'. 515 516See Info node `(elisp)Cons Cells' for a discussion of related basic 517Lisp concepts such as car, cdr, cons cell and list. */) 518 (list) 519 register Lisp_Object list; 520{ 521 return CAR (list); 522} 523 524DEFUN ("car-safe", Fcar_safe, Scar_safe, 1, 1, 0, 525 doc: /* Return the car of OBJECT if it is a cons cell, or else nil. */) 526 (object) 527 Lisp_Object object; 528{ 529 return CAR_SAFE (object); 530} 531 532DEFUN ("cdr", Fcdr, Scdr, 1, 1, 0, 533 doc: /* Return the cdr of LIST. If arg is nil, return nil. 534Error if arg is not nil and not a cons cell. See also `cdr-safe'. 535 536See Info node `(elisp)Cons Cells' for a discussion of related basic 537Lisp concepts such as cdr, car, cons cell and list. */) 538 (list) 539 register Lisp_Object list; 540{ 541 return CDR (list); 542} 543 544DEFUN ("cdr-safe", Fcdr_safe, Scdr_safe, 1, 1, 0, 545 doc: /* Return the cdr of OBJECT if it is a cons cell, or else nil. */) 546 (object) 547 Lisp_Object object; 548{ 549 return CDR_SAFE (object); 550} 551 552DEFUN ("setcar", Fsetcar, Ssetcar, 2, 2, 0, 553 doc: /* Set the car of CELL to be NEWCAR. Returns NEWCAR. */) 554 (cell, newcar) 555 register Lisp_Object cell, newcar; 556{ 557 CHECK_CONS (cell); 558 CHECK_IMPURE (cell); 559 XSETCAR (cell, newcar); 560 return newcar; 561} 562 563DEFUN ("setcdr", Fsetcdr, Ssetcdr, 2, 2, 0, 564 doc: /* Set the cdr of CELL to be NEWCDR. Returns NEWCDR. */) 565 (cell, newcdr) 566 register Lisp_Object cell, newcdr; 567{ 568 CHECK_CONS (cell); 569 CHECK_IMPURE (cell); 570 XSETCDR (cell, newcdr); 571 return newcdr; 572} 573 574/* Extract and set components of symbols */ 575 576DEFUN ("boundp", Fboundp, Sboundp, 1, 1, 0, 577 doc: /* Return t if SYMBOL's value is not void. */) 578 (symbol) 579 register Lisp_Object symbol; 580{ 581 Lisp_Object valcontents; 582 CHECK_SYMBOL (symbol); 583 584 valcontents = SYMBOL_VALUE (symbol); 585 586 if (BUFFER_LOCAL_VALUEP (valcontents) 587 || SOME_BUFFER_LOCAL_VALUEP (valcontents)) 588 valcontents = swap_in_symval_forwarding (symbol, valcontents); 589 590 return (EQ (valcontents, Qunbound) ? Qnil : Qt); 591} 592 593DEFUN ("fboundp", Ffboundp, Sfboundp, 1, 1, 0, 594 doc: /* Return t if SYMBOL's function definition is not void. */) 595 (symbol) 596 register Lisp_Object symbol; 597{ 598 CHECK_SYMBOL (symbol); 599 return (EQ (XSYMBOL (symbol)->function, Qunbound) ? Qnil : Qt); 600} 601 602DEFUN ("makunbound", Fmakunbound, Smakunbound, 1, 1, 0, 603 doc: /* Make SYMBOL's value be void. 604Return SYMBOL. */) 605 (symbol) 606 register Lisp_Object symbol; 607{ 608 CHECK_SYMBOL (symbol); 609 if (SYMBOL_CONSTANT_P (symbol)) 610 xsignal1 (Qsetting_constant, symbol); 611 Fset (symbol, Qunbound); 612 return symbol; 613} 614 615DEFUN ("fmakunbound", Ffmakunbound, Sfmakunbound, 1, 1, 0, 616 doc: /* Make SYMBOL's function definition be void. 617Return SYMBOL. */) 618 (symbol) 619 register Lisp_Object symbol; 620{ 621 CHECK_SYMBOL (symbol); 622 if (NILP (symbol) || EQ (symbol, Qt)) 623 xsignal1 (Qsetting_constant, symbol); 624 XSYMBOL (symbol)->function = Qunbound; 625 return symbol; 626} 627 628DEFUN ("symbol-function", Fsymbol_function, Ssymbol_function, 1, 1, 0, 629 doc: /* Return SYMBOL's function definition. Error if that is void. */) 630 (symbol) 631 register Lisp_Object symbol; 632{ 633 CHECK_SYMBOL (symbol); 634 if (!EQ (XSYMBOL (symbol)->function, Qunbound)) 635 return XSYMBOL (symbol)->function; 636 xsignal1 (Qvoid_function, symbol); 637} 638 639DEFUN ("symbol-plist", Fsymbol_plist, Ssymbol_plist, 1, 1, 0, 640 doc: /* Return SYMBOL's property list. */) 641 (symbol) 642 register Lisp_Object symbol; 643{ 644 CHECK_SYMBOL (symbol); 645 return XSYMBOL (symbol)->plist; 646} 647 648DEFUN ("symbol-name", Fsymbol_name, Ssymbol_name, 1, 1, 0, 649 doc: /* Return SYMBOL's name, a string. */) 650 (symbol) 651 register Lisp_Object symbol; 652{ 653 register Lisp_Object name; 654 655 CHECK_SYMBOL (symbol); 656 name = SYMBOL_NAME (symbol); 657 return name; 658} 659 660DEFUN ("fset", Ffset, Sfset, 2, 2, 0, 661 doc: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION. */) 662 (symbol, definition) 663 register Lisp_Object symbol, definition; 664{ 665 CHECK_SYMBOL (symbol); 666 if (NILP (symbol) || EQ (symbol, Qt)) 667 xsignal1 (Qsetting_constant, symbol); 668 if (!NILP (Vautoload_queue) && !EQ (XSYMBOL (symbol)->function, Qunbound)) 669 Vautoload_queue = Fcons (Fcons (symbol, XSYMBOL (symbol)->function), 670 Vautoload_queue); 671 XSYMBOL (symbol)->function = definition; 672 /* Handle automatic advice activation */ 673 if (CONSP (XSYMBOL (symbol)->plist) && !NILP (Fget (symbol, Qad_advice_info))) 674 { 675 call2 (Qad_activate_internal, symbol, Qnil); 676 definition = XSYMBOL (symbol)->function; 677 } 678 return definition; 679} 680 681extern Lisp_Object Qfunction_documentation; 682 683DEFUN ("defalias", Fdefalias, Sdefalias, 2, 3, 0, 684 doc: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION. 685Associates the function with the current load file, if any. 686The optional third argument DOCSTRING specifies the documentation string 687for SYMBOL; if it is omitted or nil, SYMBOL uses the documentation string 688determined by DEFINITION. */) 689 (symbol, definition, docstring) 690 register Lisp_Object symbol, definition, docstring; 691{ 692 CHECK_SYMBOL (symbol); 693 if (CONSP (XSYMBOL (symbol)->function) 694 && EQ (XCAR (XSYMBOL (symbol)->function), Qautoload)) 695 LOADHIST_ATTACH (Fcons (Qt, symbol)); 696 definition = Ffset (symbol, definition); 697 LOADHIST_ATTACH (Fcons (Qdefun, symbol)); 698 if (!NILP (docstring)) 699 Fput (symbol, Qfunction_documentation, docstring); 700 return definition; 701} 702 703DEFUN ("setplist", Fsetplist, Ssetplist, 2, 2, 0, 704 doc: /* Set SYMBOL's property list to NEWPLIST, and return NEWPLIST. */) 705 (symbol, newplist) 706 register Lisp_Object symbol, newplist; 707{ 708 CHECK_SYMBOL (symbol); 709 XSYMBOL (symbol)->plist = newplist; 710 return newplist; 711} 712 713DEFUN ("subr-arity", Fsubr_arity, Ssubr_arity, 1, 1, 0, 714 doc: /* Return minimum and maximum number of args allowed for SUBR. 715SUBR must be a built-in function. 716The returned value is a pair (MIN . MAX). MIN is the minimum number 717of args. MAX is the maximum number or the symbol `many', for a 718function with `&rest' args, or `unevalled' for a special form. */) 719 (subr) 720 Lisp_Object subr; 721{ 722 short minargs, maxargs; 723 CHECK_SUBR (subr); 724 minargs = XSUBR (subr)->min_args; 725 maxargs = XSUBR (subr)->max_args; 726 if (maxargs == MANY) 727 return Fcons (make_number (minargs), Qmany); 728 else if (maxargs == UNEVALLED) 729 return Fcons (make_number (minargs), Qunevalled); 730 else 731 return Fcons (make_number (minargs), make_number (maxargs)); 732} 733 734DEFUN ("subr-name", Fsubr_name, Ssubr_name, 1, 1, 0, 735 doc: /* Return name of subroutine SUBR. 736SUBR must be a built-in function. */) 737 (subr) 738 Lisp_Object subr; 739{ 740 const char *name; 741 CHECK_SUBR (subr); 742 name = XSUBR (subr)->symbol_name; 743 return make_string (name, strlen (name)); 744} 745 746DEFUN ("interactive-form", Finteractive_form, Sinteractive_form, 1, 1, 0, 747 doc: /* Return the interactive form of CMD or nil if none. 748If CMD is not a command, the return value is nil. 749Value, if non-nil, is a list \(interactive SPEC). */) 750 (cmd) 751 Lisp_Object cmd; 752{ 753 Lisp_Object fun = indirect_function (cmd); 754 755 if (SUBRP (fun)) 756 { 757 if (XSUBR (fun)->prompt) 758 return list2 (Qinteractive, build_string (XSUBR (fun)->prompt)); 759 } 760 else if (COMPILEDP (fun)) 761 { 762 if ((ASIZE (fun) & PSEUDOVECTOR_SIZE_MASK) > COMPILED_INTERACTIVE) 763 return list2 (Qinteractive, AREF (fun, COMPILED_INTERACTIVE)); 764 } 765 else if (CONSP (fun)) 766 { 767 Lisp_Object funcar = XCAR (fun); 768 if (EQ (funcar, Qlambda)) 769 return Fassq (Qinteractive, Fcdr (XCDR (fun))); 770 else if (EQ (funcar, Qautoload)) 771 { 772 struct gcpro gcpro1; 773 GCPRO1 (cmd); 774 do_autoload (fun, cmd); 775 UNGCPRO; 776 return Finteractive_form (cmd); 777 } 778 } 779 return Qnil; 780} 781 782 783/*********************************************************************** 784 Getting and Setting Values of Symbols 785 ***********************************************************************/ 786 787/* Return the symbol holding SYMBOL's value. Signal 788 `cyclic-variable-indirection' if SYMBOL's chain of variable 789 indirections contains a loop. */ 790 791Lisp_Object 792indirect_variable (symbol) 793 Lisp_Object symbol; 794{ 795 Lisp_Object tortoise, hare; 796 797 hare = tortoise = symbol; 798 799 while (XSYMBOL (hare)->indirect_variable) 800 { 801 hare = XSYMBOL (hare)->value; 802 if (!XSYMBOL (hare)->indirect_variable) 803 break; 804 805 hare = XSYMBOL (hare)->value; 806 tortoise = XSYMBOL (tortoise)->value; 807 808 if (EQ (hare, tortoise)) 809 xsignal1 (Qcyclic_variable_indirection, symbol); 810 } 811 812 return hare; 813} 814 815 816DEFUN ("indirect-variable", Findirect_variable, Sindirect_variable, 1, 1, 0, 817 doc: /* Return the variable at the end of OBJECT's variable chain. 818If OBJECT is a symbol, follow all variable indirections and return the final 819variable. If OBJECT is not a symbol, just return it. 820Signal a cyclic-variable-indirection error if there is a loop in the 821variable chain of symbols. */) 822 (object) 823 Lisp_Object object; 824{ 825 if (SYMBOLP (object)) 826 object = indirect_variable (object); 827 return object; 828} 829 830 831/* Given the raw contents of a symbol value cell, 832 return the Lisp value of the symbol. 833 This does not handle buffer-local variables; use 834 swap_in_symval_forwarding for that. */ 835 836Lisp_Object 837do_symval_forwarding (valcontents) 838 register Lisp_Object valcontents; 839{ 840 register Lisp_Object val; 841 int offset; 842 if (MISCP (valcontents)) 843 switch (XMISCTYPE (valcontents)) 844 { 845 case Lisp_Misc_Intfwd: 846 XSETINT (val, *XINTFWD (valcontents)->intvar); 847 return val; 848 849 case Lisp_Misc_Boolfwd: 850 return (*XBOOLFWD (valcontents)->boolvar ? Qt : Qnil); 851 852 case Lisp_Misc_Objfwd: 853 return *XOBJFWD (valcontents)->objvar; 854 855 case Lisp_Misc_Buffer_Objfwd: 856 offset = XBUFFER_OBJFWD (valcontents)->offset; 857 return PER_BUFFER_VALUE (current_buffer, offset); 858 859 case Lisp_Misc_Kboard_Objfwd: 860 offset = XKBOARD_OBJFWD (valcontents)->offset; 861 return *(Lisp_Object *)(offset + (char *)current_kboard); 862 } 863 return valcontents; 864} 865 866/* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell 867 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the 868 buffer-independent contents of the value cell: forwarded just one 869 step past the buffer-localness. 870 871 BUF non-zero means set the value in buffer BUF instead of the 872 current buffer. This only plays a role for per-buffer variables. */ 873 874void 875store_symval_forwarding (symbol, valcontents, newval, buf) 876 Lisp_Object symbol; 877 register Lisp_Object valcontents, newval; 878 struct buffer *buf; 879{ 880 switch (SWITCH_ENUM_CAST (XTYPE (valcontents))) 881 { 882 case Lisp_Misc: 883 switch (XMISCTYPE (valcontents)) 884 { 885 case Lisp_Misc_Intfwd: 886 CHECK_NUMBER (newval); 887 *XINTFWD (valcontents)->intvar = XINT (newval); 888 if (*XINTFWD (valcontents)->intvar != XINT (newval)) 889 error ("Value out of range for variable `%s'", 890 SDATA (SYMBOL_NAME (symbol))); 891 break; 892 893 case Lisp_Misc_Boolfwd: 894 *XBOOLFWD (valcontents)->boolvar = NILP (newval) ? 0 : 1; 895 break; 896 897 case Lisp_Misc_Objfwd: 898 *XOBJFWD (valcontents)->objvar = newval; 899 900 /* If this variable is a default for something stored 901 in the buffer itself, such as default-fill-column, 902 find the buffers that don't have local values for it 903 and update them. */ 904 if (XOBJFWD (valcontents)->objvar > (Lisp_Object *) &buffer_defaults 905 && XOBJFWD (valcontents)->objvar < (Lisp_Object *) (&buffer_defaults + 1)) 906 { 907 int offset = ((char *) XOBJFWD (valcontents)->objvar 908 - (char *) &buffer_defaults); 909 int idx = PER_BUFFER_IDX (offset); 910 911 Lisp_Object tail; 912 913 if (idx <= 0) 914 break; 915 916 for (tail = Vbuffer_alist; CONSP (tail); tail = XCDR (tail)) 917 { 918 Lisp_Object buf; 919 struct buffer *b; 920 921 buf = Fcdr (XCAR (tail)); 922 if (!BUFFERP (buf)) continue; 923 b = XBUFFER (buf); 924 925 if (! PER_BUFFER_VALUE_P (b, idx)) 926 PER_BUFFER_VALUE (b, offset) = newval; 927 } 928 } 929 break; 930 931 case Lisp_Misc_Buffer_Objfwd: 932 { 933 int offset = XBUFFER_OBJFWD (valcontents)->offset; 934 Lisp_Object type; 935 936 type = PER_BUFFER_TYPE (offset); 937 if (! NILP (type) && ! NILP (newval) 938 && XTYPE (newval) != XINT (type)) 939 buffer_slot_type_mismatch (offset); 940 941 if (buf == NULL) 942 buf = current_buffer; 943 PER_BUFFER_VALUE (buf, offset) = newval; 944 } 945 break; 946 947 case Lisp_Misc_Kboard_Objfwd: 948 { 949 char *base = (char *) current_kboard; 950 char *p = base + XKBOARD_OBJFWD (valcontents)->offset; 951 *(Lisp_Object *) p = newval; 952 } 953 break; 954 955 default: 956 goto def; 957 } 958 break; 959 960 default: 961 def: 962 valcontents = SYMBOL_VALUE (symbol); 963 if (BUFFER_LOCAL_VALUEP (valcontents) 964 || SOME_BUFFER_LOCAL_VALUEP (valcontents)) 965 XBUFFER_LOCAL_VALUE (valcontents)->realvalue = newval; 966 else 967 SET_SYMBOL_VALUE (symbol, newval); 968 } 969} 970 971/* Set up SYMBOL to refer to its global binding. 972 This makes it safe to alter the status of other bindings. */ 973 974void 975swap_in_global_binding (symbol) 976 Lisp_Object symbol; 977{ 978 Lisp_Object valcontents, cdr; 979 980 valcontents = SYMBOL_VALUE (symbol); 981 if (!BUFFER_LOCAL_VALUEP (valcontents) 982 && !SOME_BUFFER_LOCAL_VALUEP (valcontents)) 983 abort (); 984 cdr = XBUFFER_LOCAL_VALUE (valcontents)->cdr; 985 986 /* Unload the previously loaded binding. */ 987 Fsetcdr (XCAR (cdr), 988 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents)->realvalue)); 989 990 /* Select the global binding in the symbol. */ 991 XSETCAR (cdr, cdr); 992 store_symval_forwarding (symbol, valcontents, XCDR (cdr), NULL); 993 994 /* Indicate that the global binding is set up now. */ 995 XBUFFER_LOCAL_VALUE (valcontents)->frame = Qnil; 996 XBUFFER_LOCAL_VALUE (valcontents)->buffer = Qnil; 997 XBUFFER_LOCAL_VALUE (valcontents)->found_for_frame = 0; 998 XBUFFER_LOCAL_VALUE (valcontents)->found_for_buffer = 0; 999} 1000 1001/* Set up the buffer-local symbol SYMBOL for validity in the current buffer. 1002 VALCONTENTS is the contents of its value cell, 1003 which points to a struct Lisp_Buffer_Local_Value. 1004 1005 Return the value forwarded one step past the buffer-local stage. 1006 This could be another forwarding pointer. */ 1007 1008static Lisp_Object 1009swap_in_symval_forwarding (symbol, valcontents) 1010 Lisp_Object symbol, valcontents; 1011{ 1012 register Lisp_Object tem1; 1013 1014 tem1 = XBUFFER_LOCAL_VALUE (valcontents)->buffer; 1015 1016 if (NILP (tem1) 1017 || current_buffer != XBUFFER (tem1) 1018 || (XBUFFER_LOCAL_VALUE (valcontents)->check_frame 1019 && ! EQ (selected_frame, XBUFFER_LOCAL_VALUE (valcontents)->frame))) 1020 { 1021 if (XSYMBOL (symbol)->indirect_variable) 1022 symbol = indirect_variable (symbol); 1023 1024 /* Unload the previously loaded binding. */ 1025 tem1 = XCAR (XBUFFER_LOCAL_VALUE (valcontents)->cdr); 1026 Fsetcdr (tem1, 1027 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents)->realvalue)); 1028 /* Choose the new binding. */ 1029 tem1 = assq_no_quit (symbol, current_buffer->local_var_alist); 1030 XBUFFER_LOCAL_VALUE (valcontents)->found_for_frame = 0; 1031 XBUFFER_LOCAL_VALUE (valcontents)->found_for_buffer = 0; 1032 if (NILP (tem1)) 1033 { 1034 if (XBUFFER_LOCAL_VALUE (valcontents)->check_frame) 1035 tem1 = assq_no_quit (symbol, XFRAME (selected_frame)->param_alist); 1036 if (! NILP (tem1)) 1037 XBUFFER_LOCAL_VALUE (valcontents)->found_for_frame = 1; 1038 else 1039 tem1 = XBUFFER_LOCAL_VALUE (valcontents)->cdr; 1040 } 1041 else 1042 XBUFFER_LOCAL_VALUE (valcontents)->found_for_buffer = 1; 1043 1044 /* Load the new binding. */ 1045 XSETCAR (XBUFFER_LOCAL_VALUE (valcontents)->cdr, tem1); 1046 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents)->buffer, current_buffer); 1047 XBUFFER_LOCAL_VALUE (valcontents)->frame = selected_frame; 1048 store_symval_forwarding (symbol, 1049 XBUFFER_LOCAL_VALUE (valcontents)->realvalue, 1050 Fcdr (tem1), NULL); 1051 } 1052 return XBUFFER_LOCAL_VALUE (valcontents)->realvalue; 1053} 1054 1055/* Find the value of a symbol, returning Qunbound if it's not bound. 1056 This is helpful for code which just wants to get a variable's value 1057 if it has one, without signaling an error. 1058 Note that it must not be possible to quit 1059 within this function. Great care is required for this. */ 1060 1061Lisp_Object 1062find_symbol_value (symbol) 1063 Lisp_Object symbol; 1064{ 1065 register Lisp_Object valcontents; 1066 register Lisp_Object val; 1067 1068 CHECK_SYMBOL (symbol); 1069 valcontents = SYMBOL_VALUE (symbol); 1070 1071 if (BUFFER_LOCAL_VALUEP (valcontents) 1072 || SOME_BUFFER_LOCAL_VALUEP (valcontents)) 1073 valcontents = swap_in_symval_forwarding (symbol, valcontents); 1074 1075 if (MISCP (valcontents)) 1076 { 1077 switch (XMISCTYPE (valcontents)) 1078 { 1079 case Lisp_Misc_Intfwd: 1080 XSETINT (val, *XINTFWD (valcontents)->intvar); 1081 return val; 1082 1083 case Lisp_Misc_Boolfwd: 1084 return (*XBOOLFWD (valcontents)->boolvar ? Qt : Qnil); 1085 1086 case Lisp_Misc_Objfwd: 1087 return *XOBJFWD (valcontents)->objvar; 1088 1089 case Lisp_Misc_Buffer_Objfwd: 1090 return PER_BUFFER_VALUE (current_buffer, 1091 XBUFFER_OBJFWD (valcontents)->offset); 1092 1093 case Lisp_Misc_Kboard_Objfwd: 1094 return *(Lisp_Object *)(XKBOARD_OBJFWD (valcontents)->offset 1095 + (char *)current_kboard); 1096 } 1097 } 1098 1099 return valcontents; 1100} 1101 1102DEFUN ("symbol-value", Fsymbol_value, Ssymbol_value, 1, 1, 0, 1103 doc: /* Return SYMBOL's value. Error if that is void. */) 1104 (symbol) 1105 Lisp_Object symbol; 1106{ 1107 Lisp_Object val; 1108 1109 val = find_symbol_value (symbol); 1110 if (!EQ (val, Qunbound)) 1111 return val; 1112 1113 xsignal1 (Qvoid_variable, symbol); 1114} 1115 1116DEFUN ("set", Fset, Sset, 2, 2, 0, 1117 doc: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */) 1118 (symbol, newval) 1119 register Lisp_Object symbol, newval; 1120{ 1121 return set_internal (symbol, newval, current_buffer, 0); 1122} 1123 1124/* Return 1 if SYMBOL currently has a let-binding 1125 which was made in the buffer that is now current. */ 1126 1127static int 1128let_shadows_buffer_binding_p (symbol) 1129 Lisp_Object symbol; 1130{ 1131 volatile struct specbinding *p; 1132 1133 for (p = specpdl_ptr - 1; p >= specpdl; p--) 1134 if (p->func == NULL 1135 && CONSP (p->symbol)) 1136 { 1137 Lisp_Object let_bound_symbol = XCAR (p->symbol); 1138 if ((EQ (symbol, let_bound_symbol) 1139 || (XSYMBOL (let_bound_symbol)->indirect_variable 1140 && EQ (symbol, indirect_variable (let_bound_symbol)))) 1141 && XBUFFER (XCDR (XCDR (p->symbol))) == current_buffer) 1142 break; 1143 } 1144 1145 return p >= specpdl; 1146} 1147 1148/* Store the value NEWVAL into SYMBOL. 1149 If buffer-locality is an issue, BUF specifies which buffer to use. 1150 (0 stands for the current buffer.) 1151 1152 If BINDFLAG is zero, then if this symbol is supposed to become 1153 local in every buffer where it is set, then we make it local. 1154 If BINDFLAG is nonzero, we don't do that. */ 1155 1156Lisp_Object 1157set_internal (symbol, newval, buf, bindflag) 1158 register Lisp_Object symbol, newval; 1159 struct buffer *buf; 1160 int bindflag; 1161{ 1162 int voide = EQ (newval, Qunbound); 1163 1164 register Lisp_Object valcontents, innercontents, tem1, current_alist_element; 1165 1166 if (buf == 0) 1167 buf = current_buffer; 1168 1169 /* If restoring in a dead buffer, do nothing. */ 1170 if (NILP (buf->name)) 1171 return newval; 1172 1173 CHECK_SYMBOL (symbol); 1174 if (SYMBOL_CONSTANT_P (symbol) 1175 && (NILP (Fkeywordp (symbol)) 1176 || !EQ (newval, SYMBOL_VALUE (symbol)))) 1177 xsignal1 (Qsetting_constant, symbol); 1178 1179 innercontents = valcontents = SYMBOL_VALUE (symbol); 1180 1181 if (BUFFER_OBJFWDP (valcontents)) 1182 { 1183 int offset = XBUFFER_OBJFWD (valcontents)->offset; 1184 int idx = PER_BUFFER_IDX (offset); 1185 if (idx > 0 1186 && !bindflag 1187 && !let_shadows_buffer_binding_p (symbol)) 1188 SET_PER_BUFFER_VALUE_P (buf, idx, 1); 1189 } 1190 else if (BUFFER_LOCAL_VALUEP (valcontents) 1191 || SOME_BUFFER_LOCAL_VALUEP (valcontents)) 1192 { 1193 /* valcontents is a struct Lisp_Buffer_Local_Value. */ 1194 if (XSYMBOL (symbol)->indirect_variable) 1195 symbol = indirect_variable (symbol); 1196 1197 /* What binding is loaded right now? */ 1198 current_alist_element 1199 = XCAR (XBUFFER_LOCAL_VALUE (valcontents)->cdr); 1200 1201 /* If the current buffer is not the buffer whose binding is 1202 loaded, or if there may be frame-local bindings and the frame 1203 isn't the right one, or if it's a Lisp_Buffer_Local_Value and 1204 the default binding is loaded, the loaded binding may be the 1205 wrong one. */ 1206 if (!BUFFERP (XBUFFER_LOCAL_VALUE (valcontents)->buffer) 1207 || buf != XBUFFER (XBUFFER_LOCAL_VALUE (valcontents)->buffer) 1208 || (XBUFFER_LOCAL_VALUE (valcontents)->check_frame 1209 && !EQ (selected_frame, XBUFFER_LOCAL_VALUE (valcontents)->frame)) 1210 || (BUFFER_LOCAL_VALUEP (valcontents) 1211 && EQ (XCAR (current_alist_element), 1212 current_alist_element))) 1213 { 1214 /* The currently loaded binding is not necessarily valid. 1215 We need to unload it, and choose a new binding. */ 1216 1217 /* Write out `realvalue' to the old loaded binding. */ 1218 Fsetcdr (current_alist_element, 1219 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents)->realvalue)); 1220 1221 /* Find the new binding. */ 1222 tem1 = Fassq (symbol, buf->local_var_alist); 1223 XBUFFER_LOCAL_VALUE (valcontents)->found_for_buffer = 1; 1224 XBUFFER_LOCAL_VALUE (valcontents)->found_for_frame = 0; 1225 1226 if (NILP (tem1)) 1227 { 1228 /* This buffer still sees the default value. */ 1229 1230 /* If the variable is a Lisp_Some_Buffer_Local_Value, 1231 or if this is `let' rather than `set', 1232 make CURRENT-ALIST-ELEMENT point to itself, 1233 indicating that we're seeing the default value. 1234 Likewise if the variable has been let-bound 1235 in the current buffer. */ 1236 if (bindflag || SOME_BUFFER_LOCAL_VALUEP (valcontents) 1237 || let_shadows_buffer_binding_p (symbol)) 1238 { 1239 XBUFFER_LOCAL_VALUE (valcontents)->found_for_buffer = 0; 1240 1241 if (XBUFFER_LOCAL_VALUE (valcontents)->check_frame) 1242 tem1 = Fassq (symbol, 1243 XFRAME (selected_frame)->param_alist); 1244 1245 if (! NILP (tem1)) 1246 XBUFFER_LOCAL_VALUE (valcontents)->found_for_frame = 1; 1247 else 1248 tem1 = XBUFFER_LOCAL_VALUE (valcontents)->cdr; 1249 } 1250 /* If it's a Lisp_Buffer_Local_Value, being set not bound, 1251 and we're not within a let that was made for this buffer, 1252 create a new buffer-local binding for the variable. 1253 That means, give this buffer a new assoc for a local value 1254 and load that binding. */ 1255 else 1256 { 1257 tem1 = Fcons (symbol, XCDR (current_alist_element)); 1258 buf->local_var_alist 1259 = Fcons (tem1, buf->local_var_alist); 1260 } 1261 } 1262 1263 /* Record which binding is now loaded. */ 1264 XSETCAR (XBUFFER_LOCAL_VALUE (valcontents)->cdr, 1265 tem1); 1266 1267 /* Set `buffer' and `frame' slots for the binding now loaded. */ 1268 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents)->buffer, buf); 1269 XBUFFER_LOCAL_VALUE (valcontents)->frame = selected_frame; 1270 } 1271 innercontents = XBUFFER_LOCAL_VALUE (valcontents)->realvalue; 1272 } 1273 1274 /* If storing void (making the symbol void), forward only through 1275 buffer-local indicator, not through Lisp_Objfwd, etc. */ 1276 if (voide) 1277 store_symval_forwarding (symbol, Qnil, newval, buf); 1278 else 1279 store_symval_forwarding (symbol, innercontents, newval, buf); 1280 1281 /* If we just set a variable whose current binding is frame-local, 1282 store the new value in the frame parameter too. */ 1283 1284 if (BUFFER_LOCAL_VALUEP (valcontents) 1285 || SOME_BUFFER_LOCAL_VALUEP (valcontents)) 1286 { 1287 /* What binding is loaded right now? */ 1288 current_alist_element 1289 = XCAR (XBUFFER_LOCAL_VALUE (valcontents)->cdr); 1290 1291 /* If the current buffer is not the buffer whose binding is 1292 loaded, or if there may be frame-local bindings and the frame 1293 isn't the right one, or if it's a Lisp_Buffer_Local_Value and 1294 the default binding is loaded, the loaded binding may be the 1295 wrong one. */ 1296 if (XBUFFER_LOCAL_VALUE (valcontents)->found_for_frame) 1297 XSETCDR (current_alist_element, newval); 1298 } 1299 1300 return newval; 1301} 1302 1303/* Access or set a buffer-local symbol's default value. */ 1304 1305/* Return the default value of SYMBOL, but don't check for voidness. 1306 Return Qunbound if it is void. */ 1307 1308Lisp_Object 1309default_value (symbol) 1310 Lisp_Object symbol; 1311{ 1312 register Lisp_Object valcontents; 1313 1314 CHECK_SYMBOL (symbol); 1315 valcontents = SYMBOL_VALUE (symbol); 1316 1317 /* For a built-in buffer-local variable, get the default value 1318 rather than letting do_symval_forwarding get the current value. */ 1319 if (BUFFER_OBJFWDP (valcontents)) 1320 { 1321 int offset = XBUFFER_OBJFWD (valcontents)->offset; 1322 if (PER_BUFFER_IDX (offset) != 0) 1323 return PER_BUFFER_DEFAULT (offset); 1324 } 1325 1326 /* Handle user-created local variables. */ 1327 if (BUFFER_LOCAL_VALUEP (valcontents) 1328 || SOME_BUFFER_LOCAL_VALUEP (valcontents)) 1329 { 1330 /* If var is set up for a buffer that lacks a local value for it, 1331 the current value is nominally the default value. 1332 But the `realvalue' slot may be more up to date, since 1333 ordinary setq stores just that slot. So use that. */ 1334 Lisp_Object current_alist_element, alist_element_car; 1335 current_alist_element 1336 = XCAR (XBUFFER_LOCAL_VALUE (valcontents)->cdr); 1337 alist_element_car = XCAR (current_alist_element); 1338 if (EQ (alist_element_car, current_alist_element)) 1339 return do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents)->realvalue); 1340 else 1341 return XCDR (XBUFFER_LOCAL_VALUE (valcontents)->cdr); 1342 } 1343 /* For other variables, get the current value. */ 1344 return do_symval_forwarding (valcontents); 1345} 1346 1347DEFUN ("default-boundp", Fdefault_boundp, Sdefault_boundp, 1, 1, 0, 1348 doc: /* Return t if SYMBOL has a non-void default value. 1349This is the value that is seen in buffers that do not have their own values 1350for this variable. */) 1351 (symbol) 1352 Lisp_Object symbol; 1353{ 1354 register Lisp_Object value; 1355 1356 value = default_value (symbol); 1357 return (EQ (value, Qunbound) ? Qnil : Qt); 1358} 1359 1360DEFUN ("default-value", Fdefault_value, Sdefault_value, 1, 1, 0, 1361 doc: /* Return SYMBOL's default value. 1362This is the value that is seen in buffers that do not have their own values 1363for this variable. The default value is meaningful for variables with 1364local bindings in certain buffers. */) 1365 (symbol) 1366 Lisp_Object symbol; 1367{ 1368 register Lisp_Object value; 1369 1370 value = default_value (symbol); 1371 if (!EQ (value, Qunbound)) 1372 return value; 1373 1374 xsignal1 (Qvoid_variable, symbol); 1375} 1376 1377DEFUN ("set-default", Fset_default, Sset_default, 2, 2, 0, 1378 doc: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are evaluated. 1379The default value is seen in buffers that do not have their own values 1380for this variable. */) 1381 (symbol, value) 1382 Lisp_Object symbol, value; 1383{ 1384 register Lisp_Object valcontents, current_alist_element, alist_element_buffer; 1385 1386 CHECK_SYMBOL (symbol); 1387 valcontents = SYMBOL_VALUE (symbol); 1388 1389 /* Handle variables like case-fold-search that have special slots 1390 in the buffer. Make them work apparently like Lisp_Buffer_Local_Value 1391 variables. */ 1392 if (BUFFER_OBJFWDP (valcontents)) 1393 { 1394 int offset = XBUFFER_OBJFWD (valcontents)->offset; 1395 int idx = PER_BUFFER_IDX (offset); 1396 1397 PER_BUFFER_DEFAULT (offset) = value; 1398 1399 /* If this variable is not always local in all buffers, 1400 set it in the buffers that don't nominally have a local value. */ 1401 if (idx > 0) 1402 { 1403 struct buffer *b; 1404 1405 for (b = all_buffers; b; b = b->next) 1406 if (!PER_BUFFER_VALUE_P (b, idx)) 1407 PER_BUFFER_VALUE (b, offset) = value; 1408 } 1409 return value; 1410 } 1411 1412 if (!BUFFER_LOCAL_VALUEP (valcontents) 1413 && !SOME_BUFFER_LOCAL_VALUEP (valcontents)) 1414 return Fset (symbol, value); 1415 1416 /* Store new value into the DEFAULT-VALUE slot. */ 1417 XSETCDR (XBUFFER_LOCAL_VALUE (valcontents)->cdr, value); 1418 1419 /* If the default binding is now loaded, set the REALVALUE slot too. */ 1420 current_alist_element 1421 = XCAR (XBUFFER_LOCAL_VALUE (valcontents)->cdr); 1422 alist_element_buffer = Fcar (current_alist_element); 1423 if (EQ (alist_element_buffer, current_alist_element)) 1424 store_symval_forwarding (symbol, 1425 XBUFFER_LOCAL_VALUE (valcontents)->realvalue, 1426 value, NULL); 1427 1428 return value; 1429} 1430 1431DEFUN ("setq-default", Fsetq_default, Ssetq_default, 0, UNEVALLED, 0, 1432 doc: /* Set the default value of variable VAR to VALUE. 1433VAR, the variable name, is literal (not evaluated); 1434VALUE is an expression: it is evaluated and its value returned. 1435The default value of a variable is seen in buffers 1436that do not have their own values for the variable. 1437 1438More generally, you can use multiple variables and values, as in 1439 (setq-default VAR VALUE VAR VALUE...) 1440This sets each VAR's default value to the corresponding VALUE. 1441The VALUE for the Nth VAR can refer to the new default values 1442of previous VARs. 1443usage: (setq-default [VAR VALUE...]) */) 1444 (args) 1445 Lisp_Object args; 1446{ 1447 register Lisp_Object args_left; 1448 register Lisp_Object val, symbol; 1449 struct gcpro gcpro1; 1450 1451 if (NILP (args)) 1452 return Qnil; 1453 1454 args_left = args; 1455 GCPRO1 (args); 1456 1457 do 1458 { 1459 val = Feval (Fcar (Fcdr (args_left))); 1460 symbol = XCAR (args_left); 1461 Fset_default (symbol, val); 1462 args_left = Fcdr (XCDR (args_left)); 1463 } 1464 while (!NILP (args_left)); 1465 1466 UNGCPRO; 1467 return val; 1468} 1469 1470/* Lisp functions for creating and removing buffer-local variables. */ 1471 1472DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local, Smake_variable_buffer_local, 1473 1, 1, "vMake Variable Buffer Local: ", 1474 doc: /* Make VARIABLE become buffer-local whenever it is set. 1475At any time, the value for the current buffer is in effect, 1476unless the variable has never been set in this buffer, 1477in which case the default value is in effect. 1478Note that binding the variable with `let', or setting it while 1479a `let'-style binding made in this buffer is in effect, 1480does not make the variable buffer-local. Return VARIABLE. 1481 1482In most cases it is better to use `make-local-variable', 1483which makes a variable local in just one buffer. 1484 1485The function `default-value' gets the default value and `set-default' sets it. */) 1486 (variable) 1487 register Lisp_Object variable; 1488{ 1489 register Lisp_Object tem, valcontents, newval; 1490 1491 CHECK_SYMBOL (variable); 1492 variable = indirect_variable (variable); 1493 1494 valcontents = SYMBOL_VALUE (variable); 1495 if (EQ (variable, Qnil) || EQ (variable, Qt) || KBOARD_OBJFWDP (valcontents)) 1496 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable))); 1497 1498 if (BUFFER_LOCAL_VALUEP (valcontents) || BUFFER_OBJFWDP (valcontents)) 1499 return variable; 1500 if (SOME_BUFFER_LOCAL_VALUEP (valcontents)) 1501 { 1502 XMISCTYPE (SYMBOL_VALUE (variable)) = Lisp_Misc_Buffer_Local_Value; 1503 return variable; 1504 } 1505 if (EQ (valcontents, Qunbound)) 1506 SET_SYMBOL_VALUE (variable, Qnil); 1507 tem = Fcons (Qnil, Fsymbol_value (variable)); 1508 XSETCAR (tem, tem); 1509 newval = allocate_misc (); 1510 XMISCTYPE (newval) = Lisp_Misc_Buffer_Local_Value; 1511 XBUFFER_LOCAL_VALUE (newval)->realvalue = SYMBOL_VALUE (variable); 1512 XBUFFER_LOCAL_VALUE (newval)->buffer = Fcurrent_buffer (); 1513 XBUFFER_LOCAL_VALUE (newval)->frame = Qnil; 1514 XBUFFER_LOCAL_VALUE (newval)->found_for_buffer = 0; 1515 XBUFFER_LOCAL_VALUE (newval)->found_for_frame = 0; 1516 XBUFFER_LOCAL_VALUE (newval)->check_frame = 0; 1517 XBUFFER_LOCAL_VALUE (newval)->cdr = tem; 1518 SET_SYMBOL_VALUE (variable, newval); 1519 return variable; 1520} 1521 1522DEFUN ("make-local-variable", Fmake_local_variable, Smake_local_variable, 1523 1, 1, "vMake Local Variable: ", 1524 doc: /* Make VARIABLE have a separate value in the current buffer. 1525Other buffers will continue to share a common default value. 1526\(The buffer-local value of VARIABLE starts out as the same value 1527VARIABLE previously had. If VARIABLE was void, it remains void.\) 1528Return VARIABLE. 1529 1530If the variable is already arranged to become local when set, 1531this function causes a local value to exist for this buffer, 1532just as setting the variable would do. 1533 1534This function returns VARIABLE, and therefore 1535 (set (make-local-variable 'VARIABLE) VALUE-EXP) 1536works. 1537 1538See also `make-variable-buffer-local'. 1539 1540Do not use `make-local-variable' to make a hook variable buffer-local. 1541Instead, use `add-hook' and specify t for the LOCAL argument. */) 1542 (variable) 1543 register Lisp_Object variable; 1544{ 1545 register Lisp_Object tem, valcontents; 1546 1547 CHECK_SYMBOL (variable); 1548 variable = indirect_variable (variable); 1549 1550 valcontents = SYMBOL_VALUE (variable); 1551 if (EQ (variable, Qnil) || EQ (variable, Qt) || KBOARD_OBJFWDP (valcontents)) 1552 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable))); 1553 1554 if (BUFFER_LOCAL_VALUEP (valcontents) || BUFFER_OBJFWDP (valcontents)) 1555 { 1556 tem = Fboundp (variable); 1557 1558 /* Make sure the symbol has a local value in this particular buffer, 1559 by setting it to the same value it already has. */ 1560 Fset (variable, (EQ (tem, Qt) ? Fsymbol_value (variable) : Qunbound)); 1561 return variable; 1562 } 1563 /* Make sure symbol is set up to hold per-buffer values. */ 1564 if (!SOME_BUFFER_LOCAL_VALUEP (valcontents)) 1565 { 1566 Lisp_Object newval; 1567 tem = Fcons (Qnil, do_symval_forwarding (valcontents)); 1568 XSETCAR (tem, tem); 1569 newval = allocate_misc (); 1570 XMISCTYPE (newval) = Lisp_Misc_Some_Buffer_Local_Value; 1571 XBUFFER_LOCAL_VALUE (newval)->realvalue = SYMBOL_VALUE (variable); 1572 XBUFFER_LOCAL_VALUE (newval)->buffer = Qnil; 1573 XBUFFER_LOCAL_VALUE (newval)->frame = Qnil; 1574 XBUFFER_LOCAL_VALUE (newval)->found_for_buffer = 0; 1575 XBUFFER_LOCAL_VALUE (newval)->found_for_frame = 0; 1576 XBUFFER_LOCAL_VALUE (newval)->check_frame = 0; 1577 XBUFFER_LOCAL_VALUE (newval)->cdr = tem; 1578 SET_SYMBOL_VALUE (variable, newval);; 1579 } 1580 /* Make sure this buffer has its own value of symbol. */ 1581 tem = Fassq (variable, current_buffer->local_var_alist); 1582 if (NILP (tem)) 1583 { 1584 /* Swap out any local binding for some other buffer, and make 1585 sure the current value is permanently recorded, if it's the 1586 default value. */ 1587 find_symbol_value (variable); 1588 1589 current_buffer->local_var_alist 1590 = Fcons (Fcons (variable, XCDR (XBUFFER_LOCAL_VALUE (SYMBOL_VALUE (variable))->cdr)), 1591 current_buffer->local_var_alist); 1592 1593 /* Make sure symbol does not think it is set up for this buffer; 1594 force it to look once again for this buffer's value. */ 1595 { 1596 Lisp_Object *pvalbuf; 1597 1598 valcontents = SYMBOL_VALUE (variable); 1599 1600 pvalbuf = &XBUFFER_LOCAL_VALUE (valcontents)->buffer; 1601 if (current_buffer == XBUFFER (*pvalbuf)) 1602 *pvalbuf = Qnil; 1603 XBUFFER_LOCAL_VALUE (valcontents)->found_for_buffer = 0; 1604 } 1605 } 1606 1607 /* If the symbol forwards into a C variable, then load the binding 1608 for this buffer now. If C code modifies the variable before we 1609 load the binding in, then that new value will clobber the default 1610 binding the next time we unload it. */ 1611 valcontents = XBUFFER_LOCAL_VALUE (SYMBOL_VALUE (variable))->realvalue; 1612 if (INTFWDP (valcontents) || BOOLFWDP (valcontents) || OBJFWDP (valcontents)) 1613 swap_in_symval_forwarding (variable, SYMBOL_VALUE (variable)); 1614 1615 return variable; 1616} 1617 1618DEFUN ("kill-local-variable", Fkill_local_variable, Skill_local_variable, 1619 1, 1, "vKill Local Variable: ", 1620 doc: /* Make VARIABLE no longer have a separate value in the current buffer. 1621From now on the default value will apply in this buffer. Return VARIABLE. */) 1622 (variable) 1623 register Lisp_Object variable; 1624{ 1625 register Lisp_Object tem, valcontents; 1626 1627 CHECK_SYMBOL (variable); 1628 variable = indirect_variable (variable); 1629 1630 valcontents = SYMBOL_VALUE (variable); 1631 1632 if (BUFFER_OBJFWDP (valcontents)) 1633 { 1634 int offset = XBUFFER_OBJFWD (valcontents)->offset; 1635 int idx = PER_BUFFER_IDX (offset); 1636 1637 if (idx > 0) 1638 { 1639 SET_PER_BUFFER_VALUE_P (current_buffer, idx, 0); 1640 PER_BUFFER_VALUE (current_buffer, offset) 1641 = PER_BUFFER_DEFAULT (offset); 1642 } 1643 return variable; 1644 } 1645 1646 if (!BUFFER_LOCAL_VALUEP (valcontents) 1647 && !SOME_BUFFER_LOCAL_VALUEP (valcontents)) 1648 return variable; 1649 1650 /* Get rid of this buffer's alist element, if any. */ 1651 1652 tem = Fassq (variable, current_buffer->local_var_alist); 1653 if (!NILP (tem)) 1654 current_buffer->local_var_alist 1655 = Fdelq (tem, current_buffer->local_var_alist); 1656 1657 /* If the symbol is set up with the current buffer's binding 1658 loaded, recompute its value. We have to do it now, or else 1659 forwarded objects won't work right. */ 1660 { 1661 Lisp_Object *pvalbuf, buf; 1662 valcontents = SYMBOL_VALUE (variable); 1663 pvalbuf = &XBUFFER_LOCAL_VALUE (valcontents)->buffer; 1664 XSETBUFFER (buf, current_buffer); 1665 if (EQ (buf, *pvalbuf)) 1666 { 1667 *pvalbuf = Qnil; 1668 XBUFFER_LOCAL_VALUE (valcontents)->found_for_buffer = 0; 1669 find_symbol_value (variable); 1670 } 1671 } 1672 1673 return variable; 1674} 1675 1676/* Lisp functions for creating and removing buffer-local variables. */ 1677 1678DEFUN ("make-variable-frame-local", Fmake_variable_frame_local, Smake_variable_frame_local, 1679 1, 1, "vMake Variable Frame Local: ", 1680 doc: /* Enable VARIABLE to have frame-local bindings. 1681This does not create any frame-local bindings for VARIABLE, 1682it just makes them possible. 1683 1684A frame-local binding is actually a frame parameter value. 1685If a frame F has a value for the frame parameter named VARIABLE, 1686that also acts as a frame-local binding for VARIABLE in F-- 1687provided this function has been called to enable VARIABLE 1688to have frame-local bindings at all. 1689 1690The only way to create a frame-local binding for VARIABLE in a frame 1691is to set the VARIABLE frame parameter of that frame. See 1692`modify-frame-parameters' for how to set frame parameters. 1693 1694Buffer-local bindings take precedence over frame-local bindings. */) 1695 (variable) 1696 register Lisp_Object variable; 1697{ 1698 register Lisp_Object tem, valcontents, newval; 1699 1700 CHECK_SYMBOL (variable); 1701 variable = indirect_variable (variable); 1702 1703 valcontents = SYMBOL_VALUE (variable); 1704 if (EQ (variable, Qnil) || EQ (variable, Qt) || KBOARD_OBJFWDP (valcontents) 1705 || BUFFER_OBJFWDP (valcontents)) 1706 error ("Symbol %s may not be frame-local", SDATA (SYMBOL_NAME (variable))); 1707 1708 if (BUFFER_LOCAL_VALUEP (valcontents) 1709 || SOME_BUFFER_LOCAL_VALUEP (valcontents)) 1710 { 1711 XBUFFER_LOCAL_VALUE (valcontents)->check_frame = 1; 1712 return variable; 1713 } 1714 1715 if (EQ (valcontents, Qunbound)) 1716 SET_SYMBOL_VALUE (variable, Qnil); 1717 tem = Fcons (Qnil, Fsymbol_value (variable)); 1718 XSETCAR (tem, tem); 1719 newval = allocate_misc (); 1720 XMISCTYPE (newval) = Lisp_Misc_Some_Buffer_Local_Value; 1721 XBUFFER_LOCAL_VALUE (newval)->realvalue = SYMBOL_VALUE (variable); 1722 XBUFFER_LOCAL_VALUE (newval)->buffer = Qnil; 1723 XBUFFER_LOCAL_VALUE (newval)->frame = Qnil; 1724 XBUFFER_LOCAL_VALUE (newval)->found_for_buffer = 0; 1725 XBUFFER_LOCAL_VALUE (newval)->found_for_frame = 0; 1726 XBUFFER_LOCAL_VALUE (newval)->check_frame = 1; 1727 XBUFFER_LOCAL_VALUE (newval)->cdr = tem; 1728 SET_SYMBOL_VALUE (variable, newval); 1729 return variable; 1730} 1731 1732DEFUN ("local-variable-p", Flocal_variable_p, Slocal_variable_p, 1733 1, 2, 0, 1734 doc: /* Non-nil if VARIABLE has a local binding in buffer BUFFER. 1735BUFFER defaults to the current buffer. */) 1736 (variable, buffer) 1737 register Lisp_Object variable, buffer; 1738{ 1739 Lisp_Object valcontents; 1740 register struct buffer *buf; 1741 1742 if (NILP (buffer)) 1743 buf = current_buffer; 1744 else 1745 { 1746 CHECK_BUFFER (buffer); 1747 buf = XBUFFER (buffer); 1748 } 1749 1750 CHECK_SYMBOL (variable); 1751 variable = indirect_variable (variable); 1752 1753 valcontents = SYMBOL_VALUE (variable); 1754 if (BUFFER_LOCAL_VALUEP (valcontents) 1755 || SOME_BUFFER_LOCAL_VALUEP (valcontents)) 1756 { 1757 Lisp_Object tail, elt; 1758 1759 for (tail = buf->local_var_alist; CONSP (tail); tail = XCDR (tail)) 1760 { 1761 elt = XCAR (tail); 1762 if (EQ (variable, XCAR (elt))) 1763 return Qt; 1764 } 1765 } 1766 if (BUFFER_OBJFWDP (valcontents)) 1767 { 1768 int offset = XBUFFER_OBJFWD (valcontents)->offset; 1769 int idx = PER_BUFFER_IDX (offset); 1770 if (idx == -1 || PER_BUFFER_VALUE_P (buf, idx)) 1771 return Qt; 1772 } 1773 return Qnil; 1774} 1775 1776DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p, Slocal_variable_if_set_p, 1777 1, 2, 0, 1778 doc: /* Non-nil if VARIABLE will be local in buffer BUFFER when set there. 1779More precisely, this means that setting the variable \(with `set' or`setq'), 1780while it does not have a `let'-style binding that was made in BUFFER, 1781will produce a buffer local binding. See Info node 1782`(elisp)Creating Buffer-Local'. 1783BUFFER defaults to the current buffer. */) 1784 (variable, buffer) 1785 register Lisp_Object variable, buffer; 1786{ 1787 Lisp_Object valcontents; 1788 register struct buffer *buf; 1789 1790 if (NILP (buffer)) 1791 buf = current_buffer; 1792 else 1793 { 1794 CHECK_BUFFER (buffer); 1795 buf = XBUFFER (buffer); 1796 } 1797 1798 CHECK_SYMBOL (variable); 1799 variable = indirect_variable (variable); 1800 1801 valcontents = SYMBOL_VALUE (variable); 1802 1803 /* This means that make-variable-buffer-local was done. */ 1804 if (BUFFER_LOCAL_VALUEP (valcontents)) 1805 return Qt; 1806 /* All these slots become local if they are set. */ 1807 if (BUFFER_OBJFWDP (valcontents)) 1808 return Qt; 1809 if (SOME_BUFFER_LOCAL_VALUEP (valcontents)) 1810 { 1811 Lisp_Object tail, elt; 1812 for (tail = buf->local_var_alist; CONSP (tail); tail = XCDR (tail)) 1813 { 1814 elt = XCAR (tail); 1815 if (EQ (variable, XCAR (elt))) 1816 return Qt; 1817 } 1818 } 1819 return Qnil; 1820} 1821 1822DEFUN ("variable-binding-locus", Fvariable_binding_locus, Svariable_binding_locus, 1823 1, 1, 0, 1824 doc: /* Return a value indicating where VARIABLE's current binding comes from. 1825If the current binding is buffer-local, the value is the current buffer. 1826If the current binding is frame-local, the value is the selected frame. 1827If the current binding is global (the default), the value is nil. */) 1828 (variable) 1829 register Lisp_Object variable; 1830{ 1831 Lisp_Object valcontents; 1832 1833 CHECK_SYMBOL (variable); 1834 variable = indirect_variable (variable); 1835 1836 /* Make sure the current binding is actually swapped in. */ 1837 find_symbol_value (variable); 1838 1839 valcontents = XSYMBOL (variable)->value; 1840 1841 if (BUFFER_LOCAL_VALUEP (valcontents) 1842 || SOME_BUFFER_LOCAL_VALUEP (valcontents) 1843 || BUFFER_OBJFWDP (valcontents)) 1844 { 1845 /* For a local variable, record both the symbol and which 1846 buffer's or frame's value we are saving. */ 1847 if (!NILP (Flocal_variable_p (variable, Qnil))) 1848 return Fcurrent_buffer (); 1849 else if (!BUFFER_OBJFWDP (valcontents) 1850 && XBUFFER_LOCAL_VALUE (valcontents)->found_for_frame) 1851 return XBUFFER_LOCAL_VALUE (valcontents)->frame; 1852 } 1853 1854 return Qnil; 1855} 1856 1857/* Find the function at the end of a chain of symbol function indirections. */ 1858 1859/* If OBJECT is a symbol, find the end of its function chain and 1860 return the value found there. If OBJECT is not a symbol, just 1861 return it. If there is a cycle in the function chain, signal a 1862 cyclic-function-indirection error. 1863 1864 This is like Findirect_function, except that it doesn't signal an 1865 error if the chain ends up unbound. */ 1866Lisp_Object 1867indirect_function (object) 1868 register Lisp_Object object; 1869{ 1870 Lisp_Object tortoise, hare; 1871 1872 hare = tortoise = object; 1873 1874 for (;;) 1875 { 1876 if (!SYMBOLP (hare) || EQ (hare, Qunbound)) 1877 break; 1878 hare = XSYMBOL (hare)->function; 1879 if (!SYMBOLP (hare) || EQ (hare, Qunbound)) 1880 break; 1881 hare = XSYMBOL (hare)->function; 1882 1883 tortoise = XSYMBOL (tortoise)->function; 1884 1885 if (EQ (hare, tortoise)) 1886 xsignal1 (Qcyclic_function_indirection, object); 1887 } 1888 1889 return hare; 1890} 1891 1892DEFUN ("indirect-function", Findirect_function, Sindirect_function, 1, 2, 0, 1893 doc: /* Return the function at the end of OBJECT's function chain. 1894If OBJECT is not a symbol, just return it. Otherwise, follow all 1895function indirections to find the final function binding and return it. 1896If the final symbol in the chain is unbound, signal a void-function error. 1897Optional arg NOERROR non-nil means to return nil instead of signalling. 1898Signal a cyclic-function-indirection error if there is a loop in the 1899function chain of symbols. */) 1900 (object, noerror) 1901 register Lisp_Object object; 1902 Lisp_Object noerror; 1903{ 1904 Lisp_Object result; 1905 1906 /* Optimize for no indirection. */ 1907 result = object; 1908 if (SYMBOLP (result) && !EQ (result, Qunbound) 1909 && (result = XSYMBOL (result)->function, SYMBOLP (result))) 1910 result = indirect_function (result); 1911 if (!EQ (result, Qunbound)) 1912 return result; 1913 1914 if (NILP (noerror)) 1915 xsignal1 (Qvoid_function, object); 1916 1917 return Qnil; 1918} 1919 1920/* Extract and set vector and string elements */ 1921 1922DEFUN ("aref", Faref, Saref, 2, 2, 0, 1923 doc: /* Return the element of ARRAY at index IDX. 1924ARRAY may be a vector, a string, a char-table, a bool-vector, 1925or a byte-code object. IDX starts at 0. */) 1926 (array, idx) 1927 register Lisp_Object array; 1928 Lisp_Object idx; 1929{ 1930 register int idxval; 1931 1932 CHECK_NUMBER (idx); 1933 idxval = XINT (idx); 1934 if (STRINGP (array)) 1935 { 1936 int c, idxval_byte; 1937 1938 if (idxval < 0 || idxval >= SCHARS (array)) 1939 args_out_of_range (array, idx); 1940 if (! STRING_MULTIBYTE (array)) 1941 return make_number ((unsigned char) SREF (array, idxval)); 1942 idxval_byte = string_char_to_byte (array, idxval); 1943 1944 c = STRING_CHAR (SDATA (array) + idxval_byte, 1945 SBYTES (array) - idxval_byte); 1946 return make_number (c); 1947 } 1948 else if (BOOL_VECTOR_P (array)) 1949 { 1950 int val; 1951 1952 if (idxval < 0 || idxval >= XBOOL_VECTOR (array)->size) 1953 args_out_of_range (array, idx); 1954 1955 val = (unsigned char) XBOOL_VECTOR (array)->data[idxval / BOOL_VECTOR_BITS_PER_CHAR]; 1956 return (val & (1 << (idxval % BOOL_VECTOR_BITS_PER_CHAR)) ? Qt : Qnil); 1957 } 1958 else if (CHAR_TABLE_P (array)) 1959 { 1960 Lisp_Object val; 1961 1962 val = Qnil; 1963 1964 if (idxval < 0) 1965 args_out_of_range (array, idx); 1966 if (idxval < CHAR_TABLE_ORDINARY_SLOTS) 1967 { 1968 if (! SINGLE_BYTE_CHAR_P (idxval)) 1969 args_out_of_range (array, idx); 1970 /* For ASCII and 8-bit European characters, the element is 1971 stored in the top table. */ 1972 val = XCHAR_TABLE (array)->contents[idxval]; 1973 if (NILP (val)) 1974 { 1975 int default_slot 1976 = (idxval < 0x80 ? CHAR_TABLE_DEFAULT_SLOT_ASCII 1977 : idxval < 0xA0 ? CHAR_TABLE_DEFAULT_SLOT_8_BIT_CONTROL 1978 : CHAR_TABLE_DEFAULT_SLOT_8_BIT_GRAPHIC); 1979 val = XCHAR_TABLE (array)->contents[default_slot]; 1980 } 1981 if (NILP (val)) 1982 val = XCHAR_TABLE (array)->defalt; 1983 while (NILP (val)) /* Follow parents until we find some value. */ 1984 { 1985 array = XCHAR_TABLE (array)->parent; 1986 if (NILP (array)) 1987 return Qnil; 1988 val = XCHAR_TABLE (array)->contents[idxval]; 1989 if (NILP (val)) 1990 val = XCHAR_TABLE (array)->defalt; 1991 } 1992 return val; 1993 } 1994 else 1995 { 1996 int code[4], i; 1997 Lisp_Object sub_table; 1998 Lisp_Object current_default; 1999 2000 SPLIT_CHAR (idxval, code[0], code[1], code[2]); 2001 if (code[1] < 32) code[1] = -1; 2002 else if (code[2] < 32) code[2] = -1; 2003 2004 /* Here, the possible range of CODE[0] (== charset ID) is 2005 128..MAX_CHARSET. Since the top level char table contains 2006 data for multibyte characters after 256th element, we must 2007 increment CODE[0] by 128 to get a correct index. */ 2008 code[0] += 128; 2009 code[3] = -1; /* anchor */ 2010 2011 try_parent_char_table: 2012 current_default = XCHAR_TABLE (array)->defalt; 2013 sub_table = array; 2014 for (i = 0; code[i] >= 0; i++) 2015 { 2016 val = XCHAR_TABLE (sub_table)->contents[code[i]]; 2017 if (SUB_CHAR_TABLE_P (val)) 2018 { 2019 sub_table = val; 2020 if (! NILP (XCHAR_TABLE (sub_table)->defalt)) 2021 current_default = XCHAR_TABLE (sub_table)->defalt; 2022 } 2023 else 2024 { 2025 if (NILP (val)) 2026 val = current_default; 2027 if (NILP (val)) 2028 { 2029 array = XCHAR_TABLE (array)->parent; 2030 if (!NILP (array)) 2031 goto try_parent_char_table; 2032 } 2033 return val; 2034 } 2035 } 2036 /* Reaching here means IDXVAL is a generic character in 2037 which each character or a group has independent value. 2038 Essentially it's nonsense to get a value for such a 2039 generic character, but for backward compatibility, we try 2040 the default value and parent. */ 2041 val = current_default; 2042 if (NILP (val)) 2043 { 2044 array = XCHAR_TABLE (array)->parent; 2045 if (!NILP (array)) 2046 goto try_parent_char_table; 2047 } 2048 return val; 2049 } 2050 } 2051 else 2052 { 2053 int size = 0; 2054 if (VECTORP (array)) 2055 size = XVECTOR (array)->size; 2056 else if (COMPILEDP (array)) 2057 size = XVECTOR (array)->size & PSEUDOVECTOR_SIZE_MASK; 2058 else 2059 wrong_type_argument (Qarrayp, array); 2060 2061 if (idxval < 0 || idxval >= size) 2062 args_out_of_range (array, idx); 2063 return XVECTOR (array)->contents[idxval]; 2064 } 2065} 2066 2067DEFUN ("aset", Faset, Saset, 3, 3, 0, 2068 doc: /* Store into the element of ARRAY at index IDX the value NEWELT. 2069Return NEWELT. ARRAY may be a vector, a string, a char-table or a 2070bool-vector. IDX starts at 0. */) 2071 (array, idx, newelt) 2072 register Lisp_Object array; 2073 Lisp_Object idx, newelt; 2074{ 2075 register int idxval; 2076 2077 CHECK_NUMBER (idx); 2078 idxval = XINT (idx); 2079 CHECK_ARRAY (array, Qarrayp); 2080 CHECK_IMPURE (array); 2081 2082 if (VECTORP (array)) 2083 { 2084 if (idxval < 0 || idxval >= XVECTOR (array)->size) 2085 args_out_of_range (array, idx); 2086 XVECTOR (array)->contents[idxval] = newelt; 2087 } 2088 else if (BOOL_VECTOR_P (array)) 2089 { 2090 int val; 2091 2092 if (idxval < 0 || idxval >= XBOOL_VECTOR (array)->size) 2093 args_out_of_range (array, idx); 2094 2095 val = (unsigned char) XBOOL_VECTOR (array)->data[idxval / BOOL_VECTOR_BITS_PER_CHAR]; 2096 2097 if (! NILP (newelt)) 2098 val |= 1 << (idxval % BOOL_VECTOR_BITS_PER_CHAR); 2099 else 2100 val &= ~(1 << (idxval % BOOL_VECTOR_BITS_PER_CHAR)); 2101 XBOOL_VECTOR (array)->data[idxval / BOOL_VECTOR_BITS_PER_CHAR] = val; 2102 } 2103 else if (CHAR_TABLE_P (array)) 2104 { 2105 if (idxval < 0) 2106 args_out_of_range (array, idx); 2107 if (idxval < CHAR_TABLE_ORDINARY_SLOTS) 2108 { 2109 if (! SINGLE_BYTE_CHAR_P (idxval)) 2110 args_out_of_range (array, idx); 2111 XCHAR_TABLE (array)->contents[idxval] = newelt; 2112 } 2113 else 2114 { 2115 int code[4], i; 2116 Lisp_Object val; 2117 2118 SPLIT_CHAR (idxval, code[0], code[1], code[2]); 2119 if (code[1] < 32) code[1] = -1; 2120 else if (code[2] < 32) code[2] = -1; 2121 2122 /* See the comment of the corresponding part in Faref. */ 2123 code[0] += 128; 2124 code[3] = -1; /* anchor */ 2125 for (i = 0; code[i + 1] >= 0; i++) 2126 { 2127 val = XCHAR_TABLE (array)->contents[code[i]]; 2128 if (SUB_CHAR_TABLE_P (val)) 2129 array = val; 2130 else 2131 { 2132 Lisp_Object temp; 2133 2134 /* VAL is a leaf. Create a sub char table with the 2135 initial value VAL and look into it. */ 2136 2137 temp = make_sub_char_table (val); 2138 XCHAR_TABLE (array)->contents[code[i]] = temp; 2139 array = temp; 2140 } 2141 } 2142 XCHAR_TABLE (array)->contents[code[i]] = newelt; 2143 } 2144 } 2145 else if (STRING_MULTIBYTE (array)) 2146 { 2147 int idxval_byte, prev_bytes, new_bytes, nbytes; 2148 unsigned char workbuf[MAX_MULTIBYTE_LENGTH], *p0 = workbuf, *p1; 2149 2150 if (idxval < 0 || idxval >= SCHARS (array)) 2151 args_out_of_range (array, idx); 2152 CHECK_NUMBER (newelt); 2153 2154 nbytes = SBYTES (array); 2155 2156 idxval_byte = string_char_to_byte (array, idxval); 2157 p1 = SDATA (array) + idxval_byte; 2158 PARSE_MULTIBYTE_SEQ (p1, nbytes - idxval_byte, prev_bytes); 2159 new_bytes = CHAR_STRING (XINT (newelt), p0); 2160 if (prev_bytes != new_bytes) 2161 { 2162 /* We must relocate the string data. */ 2163 int nchars = SCHARS (array); 2164 unsigned char *str; 2165 USE_SAFE_ALLOCA; 2166 2167 SAFE_ALLOCA (str, unsigned char *, nbytes); 2168 bcopy (SDATA (array), str, nbytes); 2169 allocate_string_data (XSTRING (array), nchars, 2170 nbytes + new_bytes - prev_bytes); 2171 bcopy (str, SDATA (array), idxval_byte); 2172 p1 = SDATA (array) + idxval_byte; 2173 bcopy (str + idxval_byte + prev_bytes, p1 + new_bytes, 2174 nbytes - (idxval_byte + prev_bytes)); 2175 SAFE_FREE (); 2176 clear_string_char_byte_cache (); 2177 } 2178 while (new_bytes--) 2179 *p1++ = *p0++; 2180 } 2181 else 2182 { 2183 if (idxval < 0 || idxval >= SCHARS (array)) 2184 args_out_of_range (array, idx); 2185 CHECK_NUMBER (newelt); 2186 2187 if (XINT (newelt) < 0 || SINGLE_BYTE_CHAR_P (XINT (newelt))) 2188 SSET (array, idxval, XINT (newelt)); 2189 else 2190 { 2191 /* We must relocate the string data while converting it to 2192 multibyte. */ 2193 int idxval_byte, prev_bytes, new_bytes; 2194 unsigned char workbuf[MAX_MULTIBYTE_LENGTH], *p0 = workbuf, *p1; 2195 unsigned char *origstr = SDATA (array), *str; 2196 int nchars, nbytes; 2197 USE_SAFE_ALLOCA; 2198 2199 nchars = SCHARS (array); 2200 nbytes = idxval_byte = count_size_as_multibyte (origstr, idxval); 2201 nbytes += count_size_as_multibyte (origstr + idxval, 2202 nchars - idxval); 2203 SAFE_ALLOCA (str, unsigned char *, nbytes); 2204 copy_text (SDATA (array), str, nchars, 0, 1); 2205 PARSE_MULTIBYTE_SEQ (str + idxval_byte, nbytes - idxval_byte, 2206 prev_bytes); 2207 new_bytes = CHAR_STRING (XINT (newelt), p0); 2208 allocate_string_data (XSTRING (array), nchars, 2209 nbytes + new_bytes - prev_bytes); 2210 bcopy (str, SDATA (array), idxval_byte); 2211 p1 = SDATA (array) + idxval_byte; 2212 while (new_bytes--) 2213 *p1++ = *p0++; 2214 bcopy (str + idxval_byte + prev_bytes, p1, 2215 nbytes - (idxval_byte + prev_bytes)); 2216 SAFE_FREE (); 2217 clear_string_char_byte_cache (); 2218 } 2219 } 2220 2221 return newelt; 2222} 2223 2224/* Arithmetic functions */ 2225 2226enum comparison { equal, notequal, less, grtr, less_or_equal, grtr_or_equal }; 2227 2228Lisp_Object 2229arithcompare (num1, num2, comparison) 2230 Lisp_Object num1, num2; 2231 enum comparison comparison; 2232{ 2233 double f1 = 0, f2 = 0; 2234 int floatp = 0; 2235 2236 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1); 2237 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2); 2238 2239 if (FLOATP (num1) || FLOATP (num2)) 2240 { 2241 floatp = 1; 2242 f1 = (FLOATP (num1)) ? XFLOAT_DATA (num1) : XINT (num1); 2243 f2 = (FLOATP (num2)) ? XFLOAT_DATA (num2) : XINT (num2); 2244 } 2245 2246 switch (comparison) 2247 { 2248 case equal: 2249 if (floatp ? f1 == f2 : XINT (num1) == XINT (num2)) 2250 return Qt; 2251 return Qnil; 2252 2253 case notequal: 2254 if (floatp ? f1 != f2 : XINT (num1) != XINT (num2)) 2255 return Qt; 2256 return Qnil; 2257 2258 case less: 2259 if (floatp ? f1 < f2 : XINT (num1) < XINT (num2)) 2260 return Qt; 2261 return Qnil; 2262 2263 case less_or_equal: 2264 if (floatp ? f1 <= f2 : XINT (num1) <= XINT (num2)) 2265 return Qt; 2266 return Qnil; 2267 2268 case grtr: 2269 if (floatp ? f1 > f2 : XINT (num1) > XINT (num2)) 2270 return Qt; 2271 return Qnil; 2272 2273 case grtr_or_equal: 2274 if (floatp ? f1 >= f2 : XINT (num1) >= XINT (num2)) 2275 return Qt; 2276 return Qnil; 2277 2278 default: 2279 abort (); 2280 } 2281} 2282 2283DEFUN ("=", Feqlsign, Seqlsign, 2, 2, 0, 2284 doc: /* Return t if two args, both numbers or markers, are equal. */) 2285 (num1, num2) 2286 register Lisp_Object num1, num2; 2287{ 2288 return arithcompare (num1, num2, equal); 2289} 2290 2291DEFUN ("<", Flss, Slss, 2, 2, 0, 2292 doc: /* Return t if first arg is less than second arg. Both must be numbers or markers. */) 2293 (num1, num2) 2294 register Lisp_Object num1, num2; 2295{ 2296 return arithcompare (num1, num2, less); 2297} 2298 2299DEFUN (">", Fgtr, Sgtr, 2, 2, 0, 2300 doc: /* Return t if first arg is greater than second arg. Both must be numbers or markers. */) 2301 (num1, num2) 2302 register Lisp_Object num1, num2; 2303{ 2304 return arithcompare (num1, num2, grtr); 2305} 2306 2307DEFUN ("<=", Fleq, Sleq, 2, 2, 0, 2308 doc: /* Return t if first arg is less than or equal to second arg. 2309Both must be numbers or markers. */) 2310 (num1, num2) 2311 register Lisp_Object num1, num2; 2312{ 2313 return arithcompare (num1, num2, less_or_equal); 2314} 2315 2316DEFUN (">=", Fgeq, Sgeq, 2, 2, 0, 2317 doc: /* Return t if first arg is greater than or equal to second arg. 2318Both must be numbers or markers. */) 2319 (num1, num2) 2320 register Lisp_Object num1, num2; 2321{ 2322 return arithcompare (num1, num2, grtr_or_equal); 2323} 2324 2325DEFUN ("/=", Fneq, Sneq, 2, 2, 0, 2326 doc: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */) 2327 (num1, num2) 2328 register Lisp_Object num1, num2; 2329{ 2330 return arithcompare (num1, num2, notequal); 2331} 2332 2333DEFUN ("zerop", Fzerop, Szerop, 1, 1, 0, 2334 doc: /* Return t if NUMBER is zero. */) 2335 (number) 2336 register Lisp_Object number; 2337{ 2338 CHECK_NUMBER_OR_FLOAT (number); 2339 2340 if (FLOATP (number)) 2341 { 2342 if (XFLOAT_DATA (number) == 0.0) 2343 return Qt; 2344 return Qnil; 2345 } 2346 2347 if (!XINT (number)) 2348 return Qt; 2349 return Qnil; 2350} 2351 2352/* Convert between long values and pairs of Lisp integers. */ 2353 2354Lisp_Object 2355long_to_cons (i) 2356 unsigned long i; 2357{ 2358 unsigned long top = i >> 16; 2359 unsigned int bot = i & 0xFFFF; 2360 if (top == 0) 2361 return make_number (bot); 2362 if (top == (unsigned long)-1 >> 16) 2363 return Fcons (make_number (-1), make_number (bot)); 2364 return Fcons (make_number (top), make_number (bot)); 2365} 2366 2367unsigned long 2368cons_to_long (c) 2369 Lisp_Object c; 2370{ 2371 Lisp_Object top, bot; 2372 if (INTEGERP (c)) 2373 return XINT (c); 2374 top = XCAR (c); 2375 bot = XCDR (c); 2376 if (CONSP (bot)) 2377 bot = XCAR (bot); 2378 return ((XINT (top) << 16) | XINT (bot)); 2379} 2380 2381DEFUN ("number-to-string", Fnumber_to_string, Snumber_to_string, 1, 1, 0, 2382 doc: /* Return the decimal representation of NUMBER as a string. 2383Uses a minus sign if negative. 2384NUMBER may be an integer or a floating point number. */) 2385 (number) 2386 Lisp_Object number; 2387{ 2388 char buffer[VALBITS]; 2389 2390 CHECK_NUMBER_OR_FLOAT (number); 2391 2392 if (FLOATP (number)) 2393 { 2394 char pigbuf[350]; /* see comments in float_to_string */ 2395 2396 float_to_string (pigbuf, XFLOAT_DATA (number)); 2397 return build_string (pigbuf); 2398 } 2399 2400 if (sizeof (int) == sizeof (EMACS_INT)) 2401 sprintf (buffer, "%d", XINT (number)); 2402 else if (sizeof (long) == sizeof (EMACS_INT)) 2403 sprintf (buffer, "%ld", (long) XINT (number)); 2404 else 2405 abort (); 2406 return build_string (buffer); 2407} 2408 2409INLINE static int 2410digit_to_number (character, base) 2411 int character, base; 2412{ 2413 int digit; 2414 2415 if (character >= '0' && character <= '9') 2416 digit = character - '0'; 2417 else if (character >= 'a' && character <= 'z') 2418 digit = character - 'a' + 10; 2419 else if (character >= 'A' && character <= 'Z') 2420 digit = character - 'A' + 10; 2421 else 2422 return -1; 2423 2424 if (digit >= base) 2425 return -1; 2426 else 2427 return digit; 2428} 2429 2430DEFUN ("string-to-number", Fstring_to_number, Sstring_to_number, 1, 2, 0, 2431 doc: /* Parse STRING as a decimal number and return the number. 2432This parses both integers and floating point numbers. 2433It ignores leading spaces and tabs. 2434 2435If BASE, interpret STRING as a number in that base. If BASE isn't 2436present, base 10 is used. BASE must be between 2 and 16 (inclusive). 2437If the base used is not 10, floating point is not recognized. */) 2438 (string, base) 2439 register Lisp_Object string, base; 2440{ 2441 register unsigned char *p; 2442 register int b; 2443 int sign = 1; 2444 Lisp_Object val; 2445 2446 CHECK_STRING (string); 2447 2448 if (NILP (base)) 2449 b = 10; 2450 else 2451 { 2452 CHECK_NUMBER (base); 2453 b = XINT (base); 2454 if (b < 2 || b > 16) 2455 xsignal1 (Qargs_out_of_range, base); 2456 } 2457 2458 /* Skip any whitespace at the front of the number. Some versions of 2459 atoi do this anyway, so we might as well make Emacs lisp consistent. */ 2460 p = SDATA (string); 2461 while (*p == ' ' || *p == '\t') 2462 p++; 2463 2464 if (*p == '-') 2465 { 2466 sign = -1; 2467 p++; 2468 } 2469 else if (*p == '+') 2470 p++; 2471 2472 if (isfloat_string (p) && b == 10) 2473 val = make_float (sign * atof (p)); 2474 else 2475 { 2476 double v = 0; 2477 2478 while (1) 2479 { 2480 int digit = digit_to_number (*p++, b); 2481 if (digit < 0) 2482 break; 2483 v = v * b + digit; 2484 } 2485 2486 val = make_fixnum_or_float (sign * v); 2487 } 2488 2489 return val; 2490} 2491 2492 2493enum arithop 2494 { 2495 Aadd, 2496 Asub, 2497 Amult, 2498 Adiv, 2499 Alogand, 2500 Alogior, 2501 Alogxor, 2502 Amax, 2503 Amin 2504 }; 2505 2506static Lisp_Object float_arith_driver P_ ((double, int, enum arithop, 2507 int, Lisp_Object *)); 2508extern Lisp_Object fmod_float (); 2509 2510Lisp_Object 2511arith_driver (code, nargs, args) 2512 enum arithop code; 2513 int nargs; 2514 register Lisp_Object *args; 2515{ 2516 register Lisp_Object val; 2517 register int argnum; 2518 register EMACS_INT accum = 0; 2519 register EMACS_INT next; 2520 2521 switch (SWITCH_ENUM_CAST (code)) 2522 { 2523 case Alogior: 2524 case Alogxor: 2525 case Aadd: 2526 case Asub: 2527 accum = 0; 2528 break; 2529 case Amult: 2530 accum = 1; 2531 break; 2532 case Alogand: 2533 accum = -1; 2534 break; 2535 default: 2536 break; 2537 } 2538 2539 for (argnum = 0; argnum < nargs; argnum++) 2540 { 2541 /* Using args[argnum] as argument to CHECK_NUMBER_... */ 2542 val = args[argnum]; 2543 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val); 2544 2545 if (FLOATP (val)) 2546 return float_arith_driver ((double) accum, argnum, code, 2547 nargs, args); 2548 args[argnum] = val; 2549 next = XINT (args[argnum]); 2550 switch (SWITCH_ENUM_CAST (code)) 2551 { 2552 case Aadd: 2553 accum += next; 2554 break; 2555 case Asub: 2556 accum = argnum ? accum - next : nargs == 1 ? - next : next; 2557 break; 2558 case Amult: 2559 accum *= next; 2560 break; 2561 case Adiv: 2562 if (!argnum) 2563 accum = next; 2564 else 2565 { 2566 if (next == 0) 2567 xsignal0 (Qarith_error); 2568 accum /= next; 2569 } 2570 break; 2571 case Alogand: 2572 accum &= next; 2573 break; 2574 case Alogior: 2575 accum |= next; 2576 break; 2577 case Alogxor: 2578 accum ^= next; 2579 break; 2580 case Amax: 2581 if (!argnum || next > accum) 2582 accum = next; 2583 break; 2584 case Amin: 2585 if (!argnum || next < accum) 2586 accum = next; 2587 break; 2588 } 2589 } 2590 2591 XSETINT (val, accum); 2592 return val; 2593} 2594 2595#undef isnan 2596#define isnan(x) ((x) != (x)) 2597 2598static Lisp_Object 2599float_arith_driver (accum, argnum, code, nargs, args) 2600 double accum; 2601 register int argnum; 2602 enum arithop code; 2603 int nargs; 2604 register Lisp_Object *args; 2605{ 2606 register Lisp_Object val; 2607 double next; 2608 2609 for (; argnum < nargs; argnum++) 2610 { 2611 val = args[argnum]; /* using args[argnum] as argument to CHECK_NUMBER_... */ 2612 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val); 2613 2614 if (FLOATP (val)) 2615 { 2616 next = XFLOAT_DATA (val); 2617 } 2618 else 2619 { 2620 args[argnum] = val; /* runs into a compiler bug. */ 2621 next = XINT (args[argnum]); 2622 } 2623 switch (SWITCH_ENUM_CAST (code)) 2624 { 2625 case Aadd: 2626 accum += next; 2627 break; 2628 case Asub: 2629 accum = argnum ? accum - next : nargs == 1 ? - next : next; 2630 break; 2631 case Amult: 2632 accum *= next; 2633 break; 2634 case Adiv: 2635 if (!argnum) 2636 accum = next; 2637 else 2638 { 2639 if (! IEEE_FLOATING_POINT && next == 0) 2640 xsignal0 (Qarith_error); 2641 accum /= next; 2642 } 2643 break; 2644 case Alogand: 2645 case Alogior: 2646 case Alogxor: 2647 return wrong_type_argument (Qinteger_or_marker_p, val); 2648 case Amax: 2649 if (!argnum || isnan (next) || next > accum) 2650 accum = next; 2651 break; 2652 case Amin: 2653 if (!argnum || isnan (next) || next < accum) 2654 accum = next; 2655 break; 2656 } 2657 } 2658 2659 return make_float (accum); 2660} 2661 2662 2663DEFUN ("+", Fplus, Splus, 0, MANY, 0, 2664 doc: /* Return sum of any number of arguments, which are numbers or markers. 2665usage: (+ &rest NUMBERS-OR-MARKERS) */) 2666 (nargs, args) 2667 int nargs; 2668 Lisp_Object *args; 2669{ 2670 return arith_driver (Aadd, nargs, args); 2671} 2672 2673DEFUN ("-", Fminus, Sminus, 0, MANY, 0, 2674 doc: /* Negate number or subtract numbers or markers and return the result. 2675With one arg, negates it. With more than one arg, 2676subtracts all but the first from the first. 2677usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */) 2678 (nargs, args) 2679 int nargs; 2680 Lisp_Object *args; 2681{ 2682 return arith_driver (Asub, nargs, args); 2683} 2684 2685DEFUN ("*", Ftimes, Stimes, 0, MANY, 0, 2686 doc: /* Return product of any number of arguments, which are numbers or markers. 2687usage: (* &rest NUMBERS-OR-MARKERS) */) 2688 (nargs, args) 2689 int nargs; 2690 Lisp_Object *args; 2691{ 2692 return arith_driver (Amult, nargs, args); 2693} 2694 2695DEFUN ("/", Fquo, Squo, 2, MANY, 0, 2696 doc: /* Return first argument divided by all the remaining arguments. 2697The arguments must be numbers or markers. 2698usage: (/ DIVIDEND DIVISOR &rest DIVISORS) */) 2699 (nargs, args) 2700 int nargs; 2701 Lisp_Object *args; 2702{ 2703 int argnum; 2704 for (argnum = 2; argnum < nargs; argnum++) 2705 if (FLOATP (args[argnum])) 2706 return float_arith_driver (0, 0, Adiv, nargs, args); 2707 return arith_driver (Adiv, nargs, args); 2708} 2709 2710DEFUN ("%", Frem, Srem, 2, 2, 0, 2711 doc: /* Return remainder of X divided by Y. 2712Both must be integers or markers. */) 2713 (x, y) 2714 register Lisp_Object x, y; 2715{ 2716 Lisp_Object val; 2717 2718 CHECK_NUMBER_COERCE_MARKER (x); 2719 CHECK_NUMBER_COERCE_MARKER (y); 2720 2721 if (XFASTINT (y) == 0) 2722 xsignal0 (Qarith_error); 2723 2724 XSETINT (val, XINT (x) % XINT (y)); 2725 return val; 2726} 2727 2728#ifndef HAVE_FMOD 2729double 2730fmod (f1, f2) 2731 double f1, f2; 2732{ 2733 double r = f1; 2734 2735 if (f2 < 0.0) 2736 f2 = -f2; 2737 2738 /* If the magnitude of the result exceeds that of the divisor, or 2739 the sign of the result does not agree with that of the dividend, 2740 iterate with the reduced value. This does not yield a 2741 particularly accurate result, but at least it will be in the 2742 range promised by fmod. */ 2743 do 2744 r -= f2 * floor (r / f2); 2745 while (f2 <= (r < 0 ? -r : r) || ((r < 0) != (f1 < 0) && ! isnan (r))); 2746 2747 return r; 2748} 2749#endif /* ! HAVE_FMOD */ 2750 2751DEFUN ("mod", Fmod, Smod, 2, 2, 0, 2752 doc: /* Return X modulo Y. 2753The result falls between zero (inclusive) and Y (exclusive). 2754Both X and Y must be numbers or markers. */) 2755 (x, y) 2756 register Lisp_Object x, y; 2757{ 2758 Lisp_Object val; 2759 EMACS_INT i1, i2; 2760 2761 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x); 2762 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y); 2763 2764 if (FLOATP (x) || FLOATP (y)) 2765 return fmod_float (x, y); 2766 2767 i1 = XINT (x); 2768 i2 = XINT (y); 2769 2770 if (i2 == 0) 2771 xsignal0 (Qarith_error); 2772 2773 i1 %= i2; 2774 2775 /* If the "remainder" comes out with the wrong sign, fix it. */ 2776 if (i2 < 0 ? i1 > 0 : i1 < 0) 2777 i1 += i2; 2778 2779 XSETINT (val, i1); 2780 return val; 2781} 2782 2783DEFUN ("max", Fmax, Smax, 1, MANY, 0, 2784 doc: /* Return largest of all the arguments (which must be numbers or markers). 2785The value is always a number; markers are converted to numbers. 2786usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */) 2787 (nargs, args) 2788 int nargs; 2789 Lisp_Object *args; 2790{ 2791 return arith_driver (Amax, nargs, args); 2792} 2793 2794DEFUN ("min", Fmin, Smin, 1, MANY, 0, 2795 doc: /* Return smallest of all the arguments (which must be numbers or markers). 2796The value is always a number; markers are converted to numbers. 2797usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */) 2798 (nargs, args) 2799 int nargs; 2800 Lisp_Object *args; 2801{ 2802 return arith_driver (Amin, nargs, args); 2803} 2804 2805DEFUN ("logand", Flogand, Slogand, 0, MANY, 0, 2806 doc: /* Return bitwise-and of all the arguments. 2807Arguments may be integers, or markers converted to integers. 2808usage: (logand &rest INTS-OR-MARKERS) */) 2809 (nargs, args) 2810 int nargs; 2811 Lisp_Object *args; 2812{ 2813 return arith_driver (Alogand, nargs, args); 2814} 2815 2816DEFUN ("logior", Flogior, Slogior, 0, MANY, 0, 2817 doc: /* Return bitwise-or of all the arguments. 2818Arguments may be integers, or markers converted to integers. 2819usage: (logior &rest INTS-OR-MARKERS) */) 2820 (nargs, args) 2821 int nargs; 2822 Lisp_Object *args; 2823{ 2824 return arith_driver (Alogior, nargs, args); 2825} 2826 2827DEFUN ("logxor", Flogxor, Slogxor, 0, MANY, 0, 2828 doc: /* Return bitwise-exclusive-or of all the arguments. 2829Arguments may be integers, or markers converted to integers. 2830usage: (logxor &rest INTS-OR-MARKERS) */) 2831 (nargs, args) 2832 int nargs; 2833 Lisp_Object *args; 2834{ 2835 return arith_driver (Alogxor, nargs, args); 2836} 2837 2838DEFUN ("ash", Fash, Sash, 2, 2, 0, 2839 doc: /* Return VALUE with its bits shifted left by COUNT. 2840If COUNT is negative, shifting is actually to the right. 2841In this case, the sign bit is duplicated. */) 2842 (value, count) 2843 register Lisp_Object value, count; 2844{ 2845 register Lisp_Object val; 2846 2847 CHECK_NUMBER (value); 2848 CHECK_NUMBER (count); 2849 2850 if (XINT (count) >= BITS_PER_EMACS_INT) 2851 XSETINT (val, 0); 2852 else if (XINT (count) > 0) 2853 XSETINT (val, XINT (value) << XFASTINT (count)); 2854 else if (XINT (count) <= -BITS_PER_EMACS_INT) 2855 XSETINT (val, XINT (value) < 0 ? -1 : 0); 2856 else 2857 XSETINT (val, XINT (value) >> -XINT (count)); 2858 return val; 2859} 2860 2861DEFUN ("lsh", Flsh, Slsh, 2, 2, 0, 2862 doc: /* Return VALUE with its bits shifted left by COUNT. 2863If COUNT is negative, shifting is actually to the right. 2864In this case, zeros are shifted in on the left. */) 2865 (value, count) 2866 register Lisp_Object value, count; 2867{ 2868 register Lisp_Object val; 2869 2870 CHECK_NUMBER (value); 2871 CHECK_NUMBER (count); 2872 2873 if (XINT (count) >= BITS_PER_EMACS_INT) 2874 XSETINT (val, 0); 2875 else if (XINT (count) > 0) 2876 XSETINT (val, (EMACS_UINT) XUINT (value) << XFASTINT (count)); 2877 else if (XINT (count) <= -BITS_PER_EMACS_INT) 2878 XSETINT (val, 0); 2879 else 2880 XSETINT (val, (EMACS_UINT) XUINT (value) >> -XINT (count)); 2881 return val; 2882} 2883 2884DEFUN ("1+", Fadd1, Sadd1, 1, 1, 0, 2885 doc: /* Return NUMBER plus one. NUMBER may be a number or a marker. 2886Markers are converted to integers. */) 2887 (number) 2888 register Lisp_Object number; 2889{ 2890 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number); 2891 2892 if (FLOATP (number)) 2893 return (make_float (1.0 + XFLOAT_DATA (number))); 2894 2895 XSETINT (number, XINT (number) + 1); 2896 return number; 2897} 2898 2899DEFUN ("1-", Fsub1, Ssub1, 1, 1, 0, 2900 doc: /* Return NUMBER minus one. NUMBER may be a number or a marker. 2901Markers are converted to integers. */) 2902 (number) 2903 register Lisp_Object number; 2904{ 2905 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number); 2906 2907 if (FLOATP (number)) 2908 return (make_float (-1.0 + XFLOAT_DATA (number))); 2909 2910 XSETINT (number, XINT (number) - 1); 2911 return number; 2912} 2913 2914DEFUN ("lognot", Flognot, Slognot, 1, 1, 0, 2915 doc: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */) 2916 (number) 2917 register Lisp_Object number; 2918{ 2919 CHECK_NUMBER (number); 2920 XSETINT (number, ~XINT (number)); 2921 return number; 2922} 2923 2924DEFUN ("byteorder", Fbyteorder, Sbyteorder, 0, 0, 0, 2925 doc: /* Return the byteorder for the machine. 2926Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII 2927lowercase l) for small endian machines. */) 2928 () 2929{ 2930 unsigned i = 0x04030201; 2931 int order = *(char *)&i == 1 ? 108 : 66; 2932 2933 return make_number (order); 2934} 2935 2936 2937 2938void 2939syms_of_data () 2940{ 2941 Lisp_Object error_tail, arith_tail; 2942 2943 Qquote = intern ("quote"); 2944 Qlambda = intern ("lambda"); 2945 Qsubr = intern ("subr"); 2946 Qerror_conditions = intern ("error-conditions"); 2947 Qerror_message = intern ("error-message"); 2948 Qtop_level = intern ("top-level"); 2949 2950 Qerror = intern ("error"); 2951 Qquit = intern ("quit"); 2952 Qwrong_type_argument = intern ("wrong-type-argument"); 2953 Qargs_out_of_range = intern ("args-out-of-range"); 2954 Qvoid_function = intern ("void-function"); 2955 Qcyclic_function_indirection = intern ("cyclic-function-indirection"); 2956 Qcyclic_variable_indirection = intern ("cyclic-variable-indirection"); 2957 Qvoid_variable = intern ("void-variable"); 2958 Qsetting_constant = intern ("setting-constant"); 2959 Qinvalid_read_syntax = intern ("invalid-read-syntax"); 2960 2961 Qinvalid_function = intern ("invalid-function"); 2962 Qwrong_number_of_arguments = intern ("wrong-number-of-arguments"); 2963 Qno_catch = intern ("no-catch"); 2964 Qend_of_file = intern ("end-of-file"); 2965 Qarith_error = intern ("arith-error"); 2966 Qbeginning_of_buffer = intern ("beginning-of-buffer"); 2967 Qend_of_buffer = intern ("end-of-buffer"); 2968 Qbuffer_read_only = intern ("buffer-read-only"); 2969 Qtext_read_only = intern ("text-read-only"); 2970 Qmark_inactive = intern ("mark-inactive"); 2971 2972 Qlistp = intern ("listp"); 2973 Qconsp = intern ("consp"); 2974 Qsymbolp = intern ("symbolp"); 2975 Qkeywordp = intern ("keywordp"); 2976 Qintegerp = intern ("integerp"); 2977 Qnatnump = intern ("natnump"); 2978 Qwholenump = intern ("wholenump"); 2979 Qstringp = intern ("stringp"); 2980 Qarrayp = intern ("arrayp"); 2981 Qsequencep = intern ("sequencep"); 2982 Qbufferp = intern ("bufferp"); 2983 Qvectorp = intern ("vectorp"); 2984 Qchar_or_string_p = intern ("char-or-string-p"); 2985 Qmarkerp = intern ("markerp"); 2986 Qbuffer_or_string_p = intern ("buffer-or-string-p"); 2987 Qinteger_or_marker_p = intern ("integer-or-marker-p"); 2988 Qboundp = intern ("boundp"); 2989 Qfboundp = intern ("fboundp"); 2990 2991 Qfloatp = intern ("floatp"); 2992 Qnumberp = intern ("numberp"); 2993 Qnumber_or_marker_p = intern ("number-or-marker-p"); 2994 2995 Qchar_table_p = intern ("char-table-p"); 2996 Qvector_or_char_table_p = intern ("vector-or-char-table-p"); 2997 2998 Qsubrp = intern ("subrp"); 2999 Qunevalled = intern ("unevalled"); 3000 Qmany = intern ("many"); 3001 3002 Qcdr = intern ("cdr"); 3003 3004 /* Handle automatic advice activation */ 3005 Qad_advice_info = intern ("ad-advice-info"); 3006 Qad_activate_internal = intern ("ad-activate-internal"); 3007 3008 error_tail = Fcons (Qerror, Qnil); 3009 3010 /* ERROR is used as a signaler for random errors for which nothing else is right */ 3011 3012 Fput (Qerror, Qerror_conditions, 3013 error_tail); 3014 Fput (Qerror, Qerror_message, 3015 build_string ("error")); 3016 3017 Fput (Qquit, Qerror_conditions, 3018 Fcons (Qquit, Qnil)); 3019 Fput (Qquit, Qerror_message, 3020 build_string ("Quit")); 3021 3022 Fput (Qwrong_type_argument, Qerror_conditions, 3023 Fcons (Qwrong_type_argument, error_tail)); 3024 Fput (Qwrong_type_argument, Qerror_message, 3025 build_string ("Wrong type argument")); 3026 3027 Fput (Qargs_out_of_range, Qerror_conditions, 3028 Fcons (Qargs_out_of_range, error_tail)); 3029 Fput (Qargs_out_of_range, Qerror_message, 3030 build_string ("Args out of range")); 3031 3032 Fput (Qvoid_function, Qerror_conditions, 3033 Fcons (Qvoid_function, error_tail)); 3034 Fput (Qvoid_function, Qerror_message, 3035 build_string ("Symbol's function definition is void")); 3036 3037 Fput (Qcyclic_function_indirection, Qerror_conditions, 3038 Fcons (Qcyclic_function_indirection, error_tail)); 3039 Fput (Qcyclic_function_indirection, Qerror_message, 3040 build_string ("Symbol's chain of function indirections contains a loop")); 3041 3042 Fput (Qcyclic_variable_indirection, Qerror_conditions, 3043 Fcons (Qcyclic_variable_indirection, error_tail)); 3044 Fput (Qcyclic_variable_indirection, Qerror_message, 3045 build_string ("Symbol's chain of variable indirections contains a loop")); 3046 3047 Qcircular_list = intern ("circular-list"); 3048 staticpro (&Qcircular_list); 3049 Fput (Qcircular_list, Qerror_conditions, 3050 Fcons (Qcircular_list, error_tail)); 3051 Fput (Qcircular_list, Qerror_message, 3052 build_string ("List contains a loop")); 3053 3054 Fput (Qvoid_variable, Qerror_conditions, 3055 Fcons (Qvoid_variable, error_tail)); 3056 Fput (Qvoid_variable, Qerror_message, 3057 build_string ("Symbol's value as variable is void")); 3058 3059 Fput (Qsetting_constant, Qerror_conditions, 3060 Fcons (Qsetting_constant, error_tail)); 3061 Fput (Qsetting_constant, Qerror_message, 3062 build_string ("Attempt to set a constant symbol")); 3063 3064 Fput (Qinvalid_read_syntax, Qerror_conditions, 3065 Fcons (Qinvalid_read_syntax, error_tail)); 3066 Fput (Qinvalid_read_syntax, Qerror_message, 3067 build_string ("Invalid read syntax")); 3068 3069 Fput (Qinvalid_function, Qerror_conditions, 3070 Fcons (Qinvalid_function, error_tail)); 3071 Fput (Qinvalid_function, Qerror_message, 3072 build_string ("Invalid function")); 3073 3074 Fput (Qwrong_number_of_arguments, Qerror_conditions, 3075 Fcons (Qwrong_number_of_arguments, error_tail)); 3076 Fput (Qwrong_number_of_arguments, Qerror_message, 3077 build_string ("Wrong number of arguments")); 3078 3079 Fput (Qno_catch, Qerror_conditions, 3080 Fcons (Qno_catch, error_tail)); 3081 Fput (Qno_catch, Qerror_message, 3082 build_string ("No catch for tag")); 3083 3084 Fput (Qend_of_file, Qerror_conditions, 3085 Fcons (Qend_of_file, error_tail)); 3086 Fput (Qend_of_file, Qerror_message, 3087 build_string ("End of file during parsing")); 3088 3089 arith_tail = Fcons (Qarith_error, error_tail); 3090 Fput (Qarith_error, Qerror_conditions, 3091 arith_tail); 3092 Fput (Qarith_error, Qerror_message, 3093 build_string ("Arithmetic error")); 3094 3095 Fput (Qbeginning_of_buffer, Qerror_conditions, 3096 Fcons (Qbeginning_of_buffer, error_tail)); 3097 Fput (Qbeginning_of_buffer, Qerror_message, 3098 build_string ("Beginning of buffer")); 3099 3100 Fput (Qend_of_buffer, Qerror_conditions, 3101 Fcons (Qend_of_buffer, error_tail)); 3102 Fput (Qend_of_buffer, Qerror_message, 3103 build_string ("End of buffer")); 3104 3105 Fput (Qbuffer_read_only, Qerror_conditions, 3106 Fcons (Qbuffer_read_only, error_tail)); 3107 Fput (Qbuffer_read_only, Qerror_message, 3108 build_string ("Buffer is read-only")); 3109 3110 Fput (Qtext_read_only, Qerror_conditions, 3111 Fcons (Qtext_read_only, error_tail)); 3112 Fput (Qtext_read_only, Qerror_message, 3113 build_string ("Text is read-only")); 3114 3115 Qrange_error = intern ("range-error"); 3116 Qdomain_error = intern ("domain-error"); 3117 Qsingularity_error = intern ("singularity-error"); 3118 Qoverflow_error = intern ("overflow-error"); 3119 Qunderflow_error = intern ("underflow-error"); 3120 3121 Fput (Qdomain_error, Qerror_conditions, 3122 Fcons (Qdomain_error, arith_tail)); 3123 Fput (Qdomain_error, Qerror_message, 3124 build_string ("Arithmetic domain error")); 3125 3126 Fput (Qrange_error, Qerror_conditions, 3127 Fcons (Qrange_error, arith_tail)); 3128 Fput (Qrange_error, Qerror_message, 3129 build_string ("Arithmetic range error")); 3130 3131 Fput (Qsingularity_error, Qerror_conditions, 3132 Fcons (Qsingularity_error, Fcons (Qdomain_error, arith_tail))); 3133 Fput (Qsingularity_error, Qerror_message, 3134 build_string ("Arithmetic singularity error")); 3135 3136 Fput (Qoverflow_error, Qerror_conditions, 3137 Fcons (Qoverflow_error, Fcons (Qdomain_error, arith_tail))); 3138 Fput (Qoverflow_error, Qerror_message, 3139 build_string ("Arithmetic overflow error")); 3140 3141 Fput (Qunderflow_error, Qerror_conditions, 3142 Fcons (Qunderflow_error, Fcons (Qdomain_error, arith_tail))); 3143 Fput (Qunderflow_error, Qerror_message, 3144 build_string ("Arithmetic underflow error")); 3145 3146 staticpro (&Qrange_error); 3147 staticpro (&Qdomain_error); 3148 staticpro (&Qsingularity_error); 3149 staticpro (&Qoverflow_error); 3150 staticpro (&Qunderflow_error); 3151 3152 staticpro (&Qnil); 3153 staticpro (&Qt); 3154 staticpro (&Qquote); 3155 staticpro (&Qlambda); 3156 staticpro (&Qsubr); 3157 staticpro (&Qunbound); 3158 staticpro (&Qerror_conditions); 3159 staticpro (&Qerror_message); 3160 staticpro (&Qtop_level); 3161 3162 staticpro (&Qerror); 3163 staticpro (&Qquit); 3164 staticpro (&Qwrong_type_argument); 3165 staticpro (&Qargs_out_of_range); 3166 staticpro (&Qvoid_function); 3167 staticpro (&Qcyclic_function_indirection); 3168 staticpro (&Qcyclic_variable_indirection); 3169 staticpro (&Qvoid_variable); 3170 staticpro (&Qsetting_constant); 3171 staticpro (&Qinvalid_read_syntax); 3172 staticpro (&Qwrong_number_of_arguments); 3173 staticpro (&Qinvalid_function); 3174 staticpro (&Qno_catch); 3175 staticpro (&Qend_of_file); 3176 staticpro (&Qarith_error); 3177 staticpro (&Qbeginning_of_buffer); 3178 staticpro (&Qend_of_buffer); 3179 staticpro (&Qbuffer_read_only); 3180 staticpro (&Qtext_read_only); 3181 staticpro (&Qmark_inactive); 3182 3183 staticpro (&Qlistp); 3184 staticpro (&Qconsp); 3185 staticpro (&Qsymbolp); 3186 staticpro (&Qkeywordp); 3187 staticpro (&Qintegerp); 3188 staticpro (&Qnatnump); 3189 staticpro (&Qwholenump); 3190 staticpro (&Qstringp); 3191 staticpro (&Qarrayp); 3192 staticpro (&Qsequencep); 3193 staticpro (&Qbufferp); 3194 staticpro (&Qvectorp); 3195 staticpro (&Qchar_or_string_p); 3196 staticpro (&Qmarkerp); 3197 staticpro (&Qbuffer_or_string_p); 3198 staticpro (&Qinteger_or_marker_p); 3199 staticpro (&Qfloatp); 3200 staticpro (&Qnumberp); 3201 staticpro (&Qnumber_or_marker_p); 3202 staticpro (&Qchar_table_p); 3203 staticpro (&Qvector_or_char_table_p); 3204 staticpro (&Qsubrp); 3205 staticpro (&Qmany); 3206 staticpro (&Qunevalled); 3207 3208 staticpro (&Qboundp); 3209 staticpro (&Qfboundp); 3210 staticpro (&Qcdr); 3211 staticpro (&Qad_advice_info); 3212 staticpro (&Qad_activate_internal); 3213 3214 /* Types that type-of returns. */ 3215 Qinteger = intern ("integer"); 3216 Qsymbol = intern ("symbol"); 3217 Qstring = intern ("string"); 3218 Qcons = intern ("cons"); 3219 Qmarker = intern ("marker"); 3220 Qoverlay = intern ("overlay"); 3221 Qfloat = intern ("float"); 3222 Qwindow_configuration = intern ("window-configuration"); 3223 Qprocess = intern ("process"); 3224 Qwindow = intern ("window"); 3225 /* Qsubr = intern ("subr"); */ 3226 Qcompiled_function = intern ("compiled-function"); 3227 Qbuffer = intern ("buffer"); 3228 Qframe = intern ("frame"); 3229 Qvector = intern ("vector"); 3230 Qchar_table = intern ("char-table"); 3231 Qbool_vector = intern ("bool-vector"); 3232 Qhash_table = intern ("hash-table"); 3233 3234 staticpro (&Qinteger); 3235 staticpro (&Qsymbol); 3236 staticpro (&Qstring); 3237 staticpro (&Qcons); 3238 staticpro (&Qmarker); 3239 staticpro (&Qoverlay); 3240 staticpro (&Qfloat); 3241 staticpro (&Qwindow_configuration); 3242 staticpro (&Qprocess); 3243 staticpro (&Qwindow); 3244 /* staticpro (&Qsubr); */ 3245 staticpro (&Qcompiled_function); 3246 staticpro (&Qbuffer); 3247 staticpro (&Qframe); 3248 staticpro (&Qvector); 3249 staticpro (&Qchar_table); 3250 staticpro (&Qbool_vector); 3251 staticpro (&Qhash_table); 3252 3253 defsubr (&Sindirect_variable); 3254 defsubr (&Sinteractive_form); 3255 defsubr (&Seq); 3256 defsubr (&Snull); 3257 defsubr (&Stype_of); 3258 defsubr (&Slistp); 3259 defsubr (&Snlistp); 3260 defsubr (&Sconsp); 3261 defsubr (&Satom); 3262 defsubr (&Sintegerp); 3263 defsubr (&Sinteger_or_marker_p); 3264 defsubr (&Snumberp); 3265 defsubr (&Snumber_or_marker_p); 3266 defsubr (&Sfloatp); 3267 defsubr (&Snatnump); 3268 defsubr (&Ssymbolp); 3269 defsubr (&Skeywordp); 3270 defsubr (&Sstringp); 3271 defsubr (&Smultibyte_string_p); 3272 defsubr (&Svectorp); 3273 defsubr (&Schar_table_p); 3274 defsubr (&Svector_or_char_table_p); 3275 defsubr (&Sbool_vector_p); 3276 defsubr (&Sarrayp); 3277 defsubr (&Ssequencep); 3278 defsubr (&Sbufferp); 3279 defsubr (&Smarkerp); 3280 defsubr (&Ssubrp); 3281 defsubr (&Sbyte_code_function_p); 3282 defsubr (&Schar_or_string_p); 3283 defsubr (&Scar); 3284 defsubr (&Scdr); 3285 defsubr (&Scar_safe); 3286 defsubr (&Scdr_safe); 3287 defsubr (&Ssetcar); 3288 defsubr (&Ssetcdr); 3289 defsubr (&Ssymbol_function); 3290 defsubr (&Sindirect_function); 3291 defsubr (&Ssymbol_plist); 3292 defsubr (&Ssymbol_name); 3293 defsubr (&Smakunbound); 3294 defsubr (&Sfmakunbound); 3295 defsubr (&Sboundp); 3296 defsubr (&Sfboundp); 3297 defsubr (&Sfset); 3298 defsubr (&Sdefalias); 3299 defsubr (&Ssetplist); 3300 defsubr (&Ssymbol_value); 3301 defsubr (&Sset); 3302 defsubr (&Sdefault_boundp); 3303 defsubr (&Sdefault_value); 3304 defsubr (&Sset_default); 3305 defsubr (&Ssetq_default); 3306 defsubr (&Smake_variable_buffer_local); 3307 defsubr (&Smake_local_variable); 3308 defsubr (&Skill_local_variable); 3309 defsubr (&Smake_variable_frame_local); 3310 defsubr (&Slocal_variable_p); 3311 defsubr (&Slocal_variable_if_set_p); 3312 defsubr (&Svariable_binding_locus); 3313 defsubr (&Saref); 3314 defsubr (&Saset); 3315 defsubr (&Snumber_to_string); 3316 defsubr (&Sstring_to_number); 3317 defsubr (&Seqlsign); 3318 defsubr (&Slss); 3319 defsubr (&Sgtr); 3320 defsubr (&Sleq); 3321 defsubr (&Sgeq); 3322 defsubr (&Sneq); 3323 defsubr (&Szerop); 3324 defsubr (&Splus); 3325 defsubr (&Sminus); 3326 defsubr (&Stimes); 3327 defsubr (&Squo); 3328 defsubr (&Srem); 3329 defsubr (&Smod); 3330 defsubr (&Smax); 3331 defsubr (&Smin); 3332 defsubr (&Slogand); 3333 defsubr (&Slogior); 3334 defsubr (&Slogxor); 3335 defsubr (&Slsh); 3336 defsubr (&Sash); 3337 defsubr (&Sadd1); 3338 defsubr (&Ssub1); 3339 defsubr (&Slognot); 3340 defsubr (&Sbyteorder); 3341 defsubr (&Ssubr_arity); 3342 defsubr (&Ssubr_name); 3343 3344 XSYMBOL (Qwholenump)->function = XSYMBOL (Qnatnump)->function; 3345 3346 DEFVAR_LISP ("most-positive-fixnum", &Vmost_positive_fixnum, 3347 doc: /* The largest value that is representable in a Lisp integer. */); 3348 Vmost_positive_fixnum = make_number (MOST_POSITIVE_FIXNUM); 3349 3350 DEFVAR_LISP ("most-negative-fixnum", &Vmost_negative_fixnum, 3351 doc: /* The smallest value that is representable in a Lisp integer. */); 3352 Vmost_negative_fixnum = make_number (MOST_NEGATIVE_FIXNUM); 3353} 3354 3355SIGTYPE 3356arith_error (signo) 3357 int signo; 3358{ 3359#if defined(USG) && !defined(POSIX_SIGNALS) 3360 /* USG systems forget handlers when they are used; 3361 must reestablish each time */ 3362 signal (signo, arith_error); 3363#endif /* USG */ 3364#ifdef VMS 3365 /* VMS systems are like USG. */ 3366 signal (signo, arith_error); 3367#endif /* VMS */ 3368#ifdef BSD4_1 3369 sigrelse (SIGFPE); 3370#else /* not BSD4_1 */ 3371 sigsetmask (SIGEMPTYMASK); 3372#endif /* not BSD4_1 */ 3373 3374 SIGNAL_THREAD_CHECK (signo); 3375 xsignal0 (Qarith_error); 3376} 3377 3378void 3379init_data () 3380{ 3381 /* Don't do this if just dumping out. 3382 We don't want to call `signal' in this case 3383 so that we don't have trouble with dumping 3384 signal-delivering routines in an inconsistent state. */ 3385#ifndef CANNOT_DUMP 3386 if (!initialized) 3387 return; 3388#endif /* CANNOT_DUMP */ 3389 signal (SIGFPE, arith_error); 3390 3391#ifdef uts 3392 signal (SIGEMT, arith_error); 3393#endif /* uts */ 3394} 3395 3396/* arch-tag: 25879798-b84d-479a-9c89-7d148e2109f7 3397 (do not change this comment) */ 3398