|
|
1.1 ! root 1: /* Primitive operations on Lisp data types for GNU Emacs Lisp interpreter. ! 2: Copyright (C) 1985, 1986 Free Software Foundation, Inc. ! 3: ! 4: This file is part of GNU Emacs. ! 5: ! 6: GNU Emacs is free software; you can redistribute it and/or modify ! 7: it under the terms of the GNU General Public License as published by ! 8: the Free Software Foundation; either version 1, or (at your option) ! 9: any later version. ! 10: ! 11: GNU Emacs is distributed in the hope that it will be useful, ! 12: but WITHOUT ANY WARRANTY; without even the implied warranty of ! 13: MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! 14: GNU General Public License for more details. ! 15: ! 16: You should have received a copy of the GNU General Public License ! 17: along with GNU Emacs; see the file COPYING. If not, write to ! 18: the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ ! 19: ! 20: ! 21: /* This must precede sys/signal.h on certain machines. */ ! 22: #include <sys/types.h> ! 23: #include <signal.h> ! 24: ! 25: #include "config.h" ! 26: #include "lisp.h" ! 27: ! 28: #ifndef standalone ! 29: #include "buffer.h" ! 30: #endif ! 31: ! 32: #include "emacssignal.h" ! 33: ! 34: Lisp_Object Qnil, Qt, Qquote, Qlambda, Qsubr, Qunbound; ! 35: Lisp_Object Qerror_conditions, Qerror_message, Qtop_level; ! 36: Lisp_Object Qerror, Qquit, Qwrong_type_argument, Qargs_out_of_range; ! 37: Lisp_Object Qvoid_variable, Qvoid_function; ! 38: Lisp_Object Qsetting_constant, Qinvalid_read_syntax; ! 39: Lisp_Object Qinvalid_function, Qwrong_number_of_arguments, Qno_catch; ! 40: Lisp_Object Qend_of_file, Qarith_error; ! 41: Lisp_Object Qbeginning_of_buffer, Qend_of_buffer, Qbuffer_read_only; ! 42: Lisp_Object Qintegerp, Qnatnump, Qsymbolp, Qlistp, Qconsp; ! 43: Lisp_Object Qstringp, Qarrayp, Qsequencep, Qbufferp; ! 44: Lisp_Object Qchar_or_string_p, Qmarkerp, Qinteger_or_marker_p, Qvectorp; ! 45: Lisp_Object Qboundp, Qfboundp; ! 46: Lisp_Object Qcdr; ! 47: ! 48: Lisp_Object ! 49: wrong_type_argument (predicate, value) ! 50: register Lisp_Object predicate, value; ! 51: { ! 52: register Lisp_Object tem; ! 53: do ! 54: { ! 55: if (!EQ (Vmocklisp_arguments, Qt)) ! 56: { ! 57: if (XTYPE (value) == Lisp_String && ! 58: (EQ (predicate, Qintegerp) || EQ (predicate, Qinteger_or_marker_p))) ! 59: return Fstring_to_int (value, Qt); ! 60: if (XTYPE (value) == Lisp_Int && EQ (predicate, Qstringp)) ! 61: return Fint_to_string (value); ! 62: } ! 63: value = Fsignal (Qwrong_type_argument, Fcons (predicate, Fcons (value, Qnil))); ! 64: tem = call1 (predicate, value); ! 65: } ! 66: while (NULL (tem)); ! 67: return value; ! 68: } ! 69: ! 70: pure_write_error () ! 71: { ! 72: error ("Attempt to modify read-only object"); ! 73: } ! 74: ! 75: void ! 76: args_out_of_range (a1, a2) ! 77: Lisp_Object a1, a2; ! 78: { ! 79: while (1) ! 80: Fsignal (Qargs_out_of_range, Fcons (a1, Fcons (a2, Qnil))); ! 81: } ! 82: ! 83: void ! 84: args_out_of_range_3 (a1, a2, a3) ! 85: Lisp_Object a1, a2, a3; ! 86: { ! 87: while (1) ! 88: Fsignal (Qargs_out_of_range, Fcons (a1, Fcons (a2, Fcons (a3, Qnil)))); ! 89: } ! 90: ! 91: Lisp_Object ! 92: make_number (num) ! 93: int num; ! 94: { ! 95: register Lisp_Object val; ! 96: XSET (val, Lisp_Int, num); ! 97: return val; ! 98: } ! 99: ! 100: /* On some machines, XINT needs a temporary location. ! 101: Here it is, in case it is needed. */ ! 102: ! 103: int sign_extend_temp; ! 104: ! 105: /* On a few machines, XINT can only be done by calling this. */ ! 106: ! 107: int ! 108: sign_extend_lisp_int (num) ! 109: int num; ! 110: { ! 111: if (num & (1 << (VALBITS - 1))) ! 112: return num | ((-1) << VALBITS); ! 113: else ! 114: return num & ((1 << VALBITS) - 1); ! 115: } ! 116: ! 117: /* Data type predicates */ ! 118: ! 119: DEFUN ("eq", Feq, Seq, 2, 2, 0, ! 120: "T if the two args are the same Lisp object.") ! 121: (obj1, obj2) ! 122: Lisp_Object obj1, obj2; ! 123: { ! 124: if (EQ (obj1, obj2)) ! 125: return Qt; ! 126: return Qnil; ! 127: } ! 128: ! 129: DEFUN ("null", Fnull, Snull, 1, 1, 0, "T if OBJECT is nil.") ! 130: (obj) ! 131: Lisp_Object obj; ! 132: { ! 133: if (NULL (obj)) ! 134: return Qt; ! 135: return Qnil; ! 136: } ! 137: ! 138: DEFUN ("consp", Fconsp, Sconsp, 1, 1, 0, "T if OBJECT is a cons cell.") ! 139: (obj) ! 140: Lisp_Object obj; ! 141: { ! 142: if (XTYPE (obj) == Lisp_Cons) ! 143: return Qt; ! 144: return Qnil; ! 145: } ! 146: ! 147: DEFUN ("atom", Fatom, Satom, 1, 1, 0, "T if OBJECT is not a cons cell. This includes nil.") ! 148: (obj) ! 149: Lisp_Object obj; ! 150: { ! 151: if (XTYPE (obj) == Lisp_Cons) ! 152: return Qnil; ! 153: return Qt; ! 154: } ! 155: ! 156: DEFUN ("listp", Flistp, Slistp, 1, 1, 0, "T if OBJECT is a list. This includes nil.") ! 157: (obj) ! 158: Lisp_Object obj; ! 159: { ! 160: if (XTYPE (obj) == Lisp_Cons || NULL (obj)) ! 161: return Qt; ! 162: return Qnil; ! 163: } ! 164: ! 165: DEFUN ("nlistp", Fnlistp, Snlistp, 1, 1, 0, "T if OBJECT is not a list. Lists include nil.") ! 166: (obj) ! 167: Lisp_Object obj; ! 168: { ! 169: if (XTYPE (obj) == Lisp_Cons || NULL (obj)) ! 170: return Qnil; ! 171: return Qt; ! 172: } ! 173: ! 174: DEFUN ("integerp", Fintegerp, Sintegerp, 1, 1, 0, "T if OBJECT is a number.") ! 175: (obj) ! 176: Lisp_Object obj; ! 177: { ! 178: if (XTYPE (obj) == Lisp_Int) ! 179: return Qt; ! 180: return Qnil; ! 181: } ! 182: ! 183: DEFUN ("natnump", Fnatnump, Snatnump, 1, 1, 0, "T if OBJECT is a nonnegative number.") ! 184: (obj) ! 185: Lisp_Object obj; ! 186: { ! 187: if (XTYPE (obj) == Lisp_Int && XINT (obj) >= 0) ! 188: return Qt; ! 189: return Qnil; ! 190: } ! 191: ! 192: DEFUN ("symbolp", Fsymbolp, Ssymbolp, 1, 1, 0, "T if OBJECT is a symbol.") ! 193: (obj) ! 194: Lisp_Object obj; ! 195: { ! 196: if (XTYPE (obj) == Lisp_Symbol) ! 197: return Qt; ! 198: return Qnil; ! 199: } ! 200: ! 201: DEFUN ("vectorp", Fvectorp, Svectorp, 1, 1, 0, "T if OBJECT is a vector.") ! 202: (obj) ! 203: Lisp_Object obj; ! 204: { ! 205: if (XTYPE (obj) == Lisp_Vector) ! 206: return Qt; ! 207: return Qnil; ! 208: } ! 209: ! 210: DEFUN ("stringp", Fstringp, Sstringp, 1, 1, 0, "T if OBJECT is a string.") ! 211: (obj) ! 212: Lisp_Object obj; ! 213: { ! 214: if (XTYPE (obj) == Lisp_String) ! 215: return Qt; ! 216: return Qnil; ! 217: } ! 218: ! 219: DEFUN ("arrayp", Farrayp, Sarrayp, 1, 1, 0, "T if OBJECT is an array (string or vector).") ! 220: (obj) ! 221: Lisp_Object obj; ! 222: { ! 223: if (XTYPE (obj) == Lisp_Vector || XTYPE (obj) == Lisp_String) ! 224: return Qt; ! 225: return Qnil; ! 226: } ! 227: ! 228: DEFUN ("sequencep", Fsequencep, Ssequencep, 1, 1, 0, ! 229: "T if OBJECT is a sequence (list or array).") ! 230: (obj) ! 231: register Lisp_Object obj; ! 232: { ! 233: if (CONSP (obj) || NULL (obj) || ! 234: XTYPE (obj) == Lisp_Vector || XTYPE (obj) == Lisp_String) ! 235: return Qt; ! 236: return Qnil; ! 237: } ! 238: ! 239: DEFUN ("bufferp", Fbufferp, Sbufferp, 1, 1, 0, "T if OBJECT is an editor buffer.") ! 240: (obj) ! 241: Lisp_Object obj; ! 242: { ! 243: if (XTYPE (obj) == Lisp_Buffer) ! 244: return Qt; ! 245: return Qnil; ! 246: } ! 247: ! 248: DEFUN ("markerp", Fmarkerp, Smarkerp, 1, 1, 0, "T if OBJECT is a marker (editor pointer).") ! 249: (obj) ! 250: Lisp_Object obj; ! 251: { ! 252: if (XTYPE (obj) == Lisp_Marker) ! 253: return Qt; ! 254: return Qnil; ! 255: } ! 256: ! 257: DEFUN ("integer-or-marker-p", Finteger_or_marker_p, Sinteger_or_marker_p, 1, 1, 0, ! 258: "T if OBJECT is an integer or a marker (editor pointer).") ! 259: (obj) ! 260: register Lisp_Object obj; ! 261: { ! 262: if (XTYPE (obj) == Lisp_Marker || XTYPE (obj) == Lisp_Int) ! 263: return Qt; ! 264: return Qnil; ! 265: } ! 266: ! 267: DEFUN ("subrp", Fsubrp, Ssubrp, 1, 1, 0, "T if OBJECT is a built-in function.") ! 268: (obj) ! 269: Lisp_Object obj; ! 270: { ! 271: if (XTYPE (obj) == Lisp_Subr) ! 272: return Qt; ! 273: return Qnil; ! 274: } ! 275: ! 276: DEFUN ("char-or-string-p", Fchar_or_string_p, Schar_or_string_p, 1, 1, 0, "T if OBJECT is a character (a number) or a string.") ! 277: (obj) ! 278: register Lisp_Object obj; ! 279: { ! 280: if (XTYPE (obj) == Lisp_Int || XTYPE (obj) == Lisp_String) ! 281: return Qt; ! 282: return Qnil; ! 283: } ! 284: ! 285: /* Extract and set components of lists */ ! 286: ! 287: DEFUN ("car", Fcar, Scar, 1, 1, 0, ! 288: "Return the car of CONSCELL. If arg is nil, return nil.") ! 289: (list) ! 290: register Lisp_Object list; ! 291: { ! 292: while (1) ! 293: { ! 294: if (XTYPE (list) == Lisp_Cons) ! 295: return XCONS (list)->car; ! 296: else if (EQ (list, Qnil)) ! 297: return Qnil; ! 298: else ! 299: list = wrong_type_argument (Qlistp, list); ! 300: } ! 301: } ! 302: ! 303: DEFUN ("car-safe", Fcar_safe, Scar_safe, 1, 1, 0, ! 304: "Return the car of OBJECT if it is a cons cell, or else nil.") ! 305: (object) ! 306: Lisp_Object object; ! 307: { ! 308: if (XTYPE (object) == Lisp_Cons) ! 309: return XCONS (object)->car; ! 310: else ! 311: return Qnil; ! 312: } ! 313: ! 314: DEFUN ("cdr", Fcdr, Scdr, 1, 1, 0, ! 315: "Return the cdr of CONSCELL. If arg is nil, return nil.") ! 316: (list) ! 317: register Lisp_Object list; ! 318: { ! 319: while (1) ! 320: { ! 321: if (XTYPE (list) == Lisp_Cons) ! 322: return XCONS (list)->cdr; ! 323: else if (EQ (list, Qnil)) ! 324: return Qnil; ! 325: else ! 326: list = wrong_type_argument (Qlistp, list); ! 327: } ! 328: } ! 329: ! 330: DEFUN ("cdr-safe", Fcdr_safe, Scdr_safe, 1, 1, 0, ! 331: "Return the cdr of OBJECT if it is a cons cell, or else nil.") ! 332: (object) ! 333: Lisp_Object object; ! 334: { ! 335: if (XTYPE (object) == Lisp_Cons) ! 336: return XCONS (object)->cdr; ! 337: else ! 338: return Qnil; ! 339: } ! 340: ! 341: DEFUN ("setcar", Fsetcar, Ssetcar, 2, 2, 0, ! 342: "Set the car of CONSCELL to be NEWCAR. Returns NEWCAR.") ! 343: (cell, newcar) ! 344: register Lisp_Object cell, newcar; ! 345: { ! 346: if (XTYPE (cell) != Lisp_Cons) ! 347: cell = wrong_type_argument (Qconsp, cell); ! 348: ! 349: CHECK_IMPURE (cell); ! 350: XCONS (cell)->car = newcar; ! 351: return newcar; ! 352: } ! 353: ! 354: DEFUN ("setcdr", Fsetcdr, Ssetcdr, 2, 2, 0, ! 355: "Set the cdr of CONSCELL to be NEWCDR. Returns NEWCDR.") ! 356: (cell, newcdr) ! 357: register Lisp_Object cell, newcdr; ! 358: { ! 359: if (XTYPE (cell) != Lisp_Cons) ! 360: cell = wrong_type_argument (Qconsp, cell); ! 361: ! 362: CHECK_IMPURE (cell); ! 363: XCONS (cell)->cdr = newcdr; ! 364: return newcdr; ! 365: } ! 366: ! 367: /* Extract and set components of symbols */ ! 368: ! 369: DEFUN ("boundp", Fboundp, Sboundp, 1, 1, 0, "T if SYMBOL's value is not void.") ! 370: (sym) ! 371: register Lisp_Object sym; ! 372: { ! 373: CHECK_SYMBOL (sym, 0); ! 374: return (XTYPE (XSYMBOL (sym)->value) == Lisp_Void ! 375: || EQ (XSYMBOL (sym)->value, Qunbound)) ! 376: ? Qnil : Qt; ! 377: } ! 378: ! 379: DEFUN ("fboundp", Ffboundp, Sfboundp, 1, 1, 0, "T if SYMBOL's function definition is not void.") ! 380: (sym) ! 381: register Lisp_Object sym; ! 382: { ! 383: CHECK_SYMBOL (sym, 0); ! 384: return (XTYPE (XSYMBOL (sym)->function) == Lisp_Void ! 385: || EQ (XSYMBOL (sym)->function, Qunbound)) ! 386: ? Qnil : Qt; ! 387: } ! 388: ! 389: DEFUN ("makunbound", Fmakunbound, Smakunbound, 1, 1, 0, "Make SYMBOL's value be void.") ! 390: (sym) ! 391: register Lisp_Object sym; ! 392: { ! 393: CHECK_SYMBOL (sym, 0); ! 394: XSYMBOL (sym)->value = Qunbound; ! 395: return sym; ! 396: } ! 397: ! 398: DEFUN ("fmakunbound", Ffmakunbound, Sfmakunbound, 1, 1, 0, "Make SYMBOL's function definition be void.") ! 399: (sym) ! 400: register Lisp_Object sym; ! 401: { ! 402: CHECK_SYMBOL (sym, 0); ! 403: XSYMBOL (sym)->function = Qunbound; ! 404: return sym; ! 405: } ! 406: ! 407: DEFUN ("symbol-function", Fsymbol_function, Ssymbol_function, 1, 1, 0, ! 408: "Return SYMBOL's function definition.") ! 409: (sym) ! 410: register Lisp_Object sym; ! 411: { ! 412: CHECK_SYMBOL (sym, 0); ! 413: if (EQ (XSYMBOL (sym)->function, Qunbound)) ! 414: return Fsignal (Qvoid_function, Fcons (sym, Qnil)); ! 415: return XSYMBOL (sym)->function; ! 416: } ! 417: ! 418: DEFUN ("symbol-plist", Fsymbol_plist, Ssymbol_plist, 1, 1, 0, "Return SYMBOL's property list.") ! 419: (sym) ! 420: register Lisp_Object sym; ! 421: { ! 422: CHECK_SYMBOL (sym, 0); ! 423: return XSYMBOL (sym)->plist; ! 424: } ! 425: ! 426: DEFUN ("symbol-name", Fsymbol_name, Ssymbol_name, 1, 1, 0, "Return SYMBOL's name, a string.") ! 427: (sym) ! 428: register Lisp_Object sym; ! 429: { ! 430: register Lisp_Object name; ! 431: ! 432: CHECK_SYMBOL (sym, 0); ! 433: XSET (name, Lisp_String, XSYMBOL (sym)->name); ! 434: return name; ! 435: } ! 436: ! 437: DEFUN ("fset", Ffset, Sfset, 2, 2, 0, ! 438: "Set SYMBOL's function definition to NEWVAL, and return NEWVAL.") ! 439: (sym, newdef) ! 440: register Lisp_Object sym, newdef; ! 441: { ! 442: CHECK_SYMBOL (sym, 0); ! 443: if (!NULL (Vautoload_queue) && !EQ (XSYMBOL (sym)->function, Qunbound)) ! 444: Vautoload_queue = Fcons (Fcons (sym, XSYMBOL (sym)->function), ! 445: Vautoload_queue); ! 446: XSYMBOL (sym)->function = newdef; ! 447: return newdef; ! 448: } ! 449: ! 450: DEFUN ("setplist", Fsetplist, Ssetplist, 2, 2, 0, ! 451: "Set SYMBOL's property list to NEWVAL, and return NEWVAL.") ! 452: (sym, newplist) ! 453: register Lisp_Object sym, newplist; ! 454: { ! 455: CHECK_SYMBOL (sym, 0); ! 456: XSYMBOL (sym)->plist = newplist; ! 457: return newplist; ! 458: } ! 459: ! 460: /* Getting and setting values of symbols */ ! 461: ! 462: /* Given the raw contents of a symbol value cell, ! 463: return the Lisp value of the symbol. */ ! 464: ! 465: Lisp_Object ! 466: do_symval_forwarding (valcontents) ! 467: register Lisp_Object valcontents; ! 468: { ! 469: register Lisp_Object val; ! 470: #ifdef SWITCH_ENUM_BUG ! 471: switch ((int) XTYPE (valcontents)) ! 472: #else ! 473: switch (XTYPE (valcontents)) ! 474: #endif ! 475: { ! 476: case Lisp_Intfwd: ! 477: XSET (val, Lisp_Int, *XINTPTR (valcontents)); ! 478: return val; ! 479: ! 480: case Lisp_Boolfwd: ! 481: if (*XINTPTR (valcontents)) ! 482: return Qt; ! 483: return Qnil; ! 484: ! 485: case Lisp_Objfwd: ! 486: return *XOBJFWD (valcontents); ! 487: ! 488: case Lisp_Buffer_Objfwd: ! 489: return *(Lisp_Object *)(XUINT (valcontents) + (char *)current_buffer); ! 490: } ! 491: return valcontents; ! 492: } ! 493: ! 494: void ! 495: store_symval_forwarding (sym, valcontents, newval) ! 496: Lisp_Object sym; ! 497: register Lisp_Object valcontents, newval; ! 498: { ! 499: #ifdef SWITCH_ENUM_BUG ! 500: switch ((int) XTYPE (valcontents)) ! 501: #else ! 502: switch (XTYPE (valcontents)) ! 503: #endif ! 504: { ! 505: case Lisp_Intfwd: ! 506: CHECK_NUMBER (newval, 1); ! 507: *XINTPTR (valcontents) = XINT (newval); ! 508: break; ! 509: ! 510: case Lisp_Boolfwd: ! 511: *XINTPTR (valcontents) = NULL(newval) ? 0 : 1; ! 512: break; ! 513: ! 514: case Lisp_Objfwd: ! 515: *XOBJFWD (valcontents) = newval; ! 516: break; ! 517: ! 518: case Lisp_Buffer_Objfwd: ! 519: *(Lisp_Object *)(XUINT (valcontents) + (char *)current_buffer) = newval; ! 520: break; ! 521: ! 522: default: ! 523: valcontents = XSYMBOL (sym)->value; ! 524: if (XTYPE (valcontents) == Lisp_Buffer_Local_Value || ! 525: XTYPE (valcontents) == Lisp_Some_Buffer_Local_Value) ! 526: XCONS (XSYMBOL (sym)->value)->car = newval; ! 527: else ! 528: XSYMBOL (sym)->value = newval; ! 529: } ! 530: } ! 531: ! 532: /* Note that it must not be possible to quit within this function. ! 533: Great care is required for this. */ ! 534: ! 535: DEFUN ("symbol-value", Fsymbol_value, Ssymbol_value, 1, 1, 0, "Return SYMBOL's value.") ! 536: (sym) ! 537: Lisp_Object sym; ! 538: { ! 539: register Lisp_Object valcontents, tem1; ! 540: register Lisp_Object val; ! 541: CHECK_SYMBOL (sym, 0); ! 542: valcontents = XSYMBOL (sym)->value; ! 543: ! 544: retry: ! 545: #ifdef SWITCH_ENUM_BUG ! 546: switch ((int) XTYPE (valcontents)) ! 547: #else ! 548: switch (XTYPE (valcontents)) ! 549: #endif ! 550: { ! 551: case Lisp_Buffer_Local_Value: ! 552: case Lisp_Some_Buffer_Local_Value: ! 553: /* valcontents is a list ! 554: (REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE)). ! 555: ! 556: CURRENT-ALIST-ELEMENT is a pointer to an element of BUFFER's ! 557: local_var_alist, that being the element whose car is this variable. ! 558: Or it can be a pointer to the (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE), if BUFFER ! 559: does not have an element in its alist for this variable. ! 560: ! 561: If the current buffer is not BUFFER, we store the current REALVALUE value into ! 562: CURRENT-ALIST-ELEMENT, then find the appropriate alist element for ! 563: the buffer now current and set up CURRENT-ALIST-ELEMENT. ! 564: Then we set REALVALUE out of that element, and store into BUFFER. ! 565: Note that REALVALUE can be a forwarding pointer. */ ! 566: ! 567: tem1 = XCONS (XCONS (valcontents)->cdr)->car; ! 568: if (NULL (tem1) || current_buffer != XBUFFER (tem1)) ! 569: { ! 570: tem1 = XCONS (XCONS (XCONS (valcontents)->cdr)->cdr)->car; ! 571: Fsetcdr (tem1, do_symval_forwarding (XCONS (valcontents)->car)); ! 572: tem1 = assq_no_quit (sym, current_buffer->local_var_alist); ! 573: if (NULL (tem1)) ! 574: tem1 = XCONS (XCONS (valcontents)->cdr)->cdr; ! 575: XCONS (XCONS (XCONS (valcontents)->cdr)->cdr)->car = tem1; ! 576: XSET (XCONS (XCONS (valcontents)->cdr)->car, Lisp_Buffer, current_buffer); ! 577: store_symval_forwarding (sym, XCONS (valcontents)->car, Fcdr (tem1)); ! 578: } ! 579: valcontents = XCONS (valcontents)->car; ! 580: goto retry; ! 581: ! 582: case Lisp_Intfwd: ! 583: XSET (val, Lisp_Int, *XINTPTR (valcontents)); ! 584: return val; ! 585: ! 586: case Lisp_Boolfwd: ! 587: if (*XINTPTR (valcontents)) ! 588: return Qt; ! 589: return Qnil; ! 590: ! 591: case Lisp_Objfwd: ! 592: return *XOBJFWD (valcontents); ! 593: ! 594: case Lisp_Buffer_Objfwd: ! 595: return *(Lisp_Object *)(XUINT (valcontents) + (char *)current_buffer); ! 596: ! 597: case Lisp_Symbol: ! 598: /* For a symbol, check whether it is 'unbound. */ ! 599: if (!EQ (valcontents, Qunbound)) ! 600: break; ! 601: /* drops through! */ ! 602: case Lisp_Void: ! 603: return Fsignal (Qvoid_variable, Fcons (sym, Qnil)); ! 604: } ! 605: return valcontents; ! 606: } ! 607: ! 608: DEFUN ("default-value", Fdefault_value, Sdefault_value, 1, 1, 0, ! 609: "Return SYMBOL's default value.\n\ ! 610: This is the value that is seen in buffers that do not have their own values\n\ ! 611: for this variable.") ! 612: (sym) ! 613: Lisp_Object sym; ! 614: { ! 615: register Lisp_Object valcontents; ! 616: ! 617: CHECK_SYMBOL (sym, 0); ! 618: valcontents = XSYMBOL (sym)->value; ! 619: if (XTYPE (valcontents) == Lisp_Buffer_Objfwd) ! 620: { ! 621: register int idx = XUINT (valcontents); ! 622: ! 623: if (*(int *) (idx + (char *) &buffer_local_flags) != 0) ! 624: return *(Lisp_Object *)(idx + (char *) &buffer_defaults); ! 625: } ! 626: ! 627: if (XTYPE (valcontents) == Lisp_Buffer_Local_Value || ! 628: XTYPE (valcontents) == Lisp_Some_Buffer_Local_Value) ! 629: return XCONS (XCONS (XCONS (valcontents)->cdr)->cdr)->cdr; ! 630: return Fsymbol_value (sym); ! 631: } ! 632: ! 633: DEFUN ("set", Fset, Sset, 2, 2, 0, ! 634: "Set SYMBOL's value to NEWVAL, and return NEWVAL.") ! 635: (sym, newval) ! 636: register Lisp_Object sym, newval; ! 637: { ! 638: #ifndef RTPC_REGISTER_BUG ! 639: register Lisp_Object valcontents, tem1, current_alist_element; ! 640: #else /* RTPC_REGISTER_BUG */ ! 641: register Lisp_Object tem1; ! 642: Lisp_Object valcontents, current_alist_element; ! 643: #endif /* RTPC_REGISTER_BUG */ ! 644: ! 645: CHECK_SYMBOL (sym, 0); ! 646: if (NULL (sym) || EQ (sym, Qt)) ! 647: return Fsignal (Qsetting_constant, Fcons (sym, Qnil)); ! 648: valcontents = XSYMBOL (sym)->value; ! 649: ! 650: if (XTYPE (valcontents) == Lisp_Buffer_Objfwd) ! 651: { ! 652: register int idx = XUINT (valcontents); ! 653: register int mask = *(int *)(idx + (char *) &buffer_local_flags); ! 654: if (mask > 0) ! 655: current_buffer->local_var_flags |= mask; ! 656: } ! 657: ! 658: if (XTYPE (valcontents) == Lisp_Buffer_Local_Value ! 659: || XTYPE (valcontents) == Lisp_Some_Buffer_Local_Value) ! 660: { ! 661: /* valcontents is a list ! 662: (REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE)). ! 663: ! 664: CURRENT-ALIST-ELEMENT is a pointer to an element of BUFFER's ! 665: local_var_alist, that being the element whose car is this variable. ! 666: Or it can be a pointer to the (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE), ! 667: if BUFFER does not have an element in its alist for this variable. ! 668: ! 669: If the current buffer is not BUFFER, we store the current REALVALUE value into ! 670: CURRENT-ALIST-ELEMENT, then find the appropriate alist element for ! 671: the buffer now current and set up CURRENT-ALIST-ELEMENT. ! 672: Then we set REALVALUE out of that element, and store into BUFFER. ! 673: Note that REALVALUE can be a forwarding pointer. */ ! 674: ! 675: current_alist_element = XCONS (XCONS (XCONS (valcontents)->cdr)->cdr)->car; ! 676: if (current_buffer ! 677: != ((XTYPE (valcontents) == Lisp_Some_Buffer_Local_Value) ! 678: /* If the current buffer is already cached, ! 679: we don't need to change that fact. */ ! 680: ? XBUFFER (XCONS (XCONS (valcontents)->cdr)->car) ! 681: /* If setting the variable should make it local, ! 682: it's not enough if the current buffer is already cached. ! 683: We need to make sure it has a local value for the var. */ ! 684: : XBUFFER (XCONS (current_alist_element)->car))) ! 685: { ! 686: /* "Swap out" the buffer that was previously cached. */ ! 687: Fsetcdr (current_alist_element, ! 688: do_symval_forwarding (XCONS (valcontents)->car)); ! 689: ! 690: /* Encache the current buffer. */ ! 691: tem1 = Fassq (sym, current_buffer->local_var_alist); ! 692: if (NULL (tem1)) ! 693: { ! 694: /* This buffer sees the default value still. ! 695: If type is Lisp_Some_Buffer_Local_Value, set the default value. ! 696: If type is Lisp_Buffer_Local_Value, give this buffer a local value ! 697: and set that. */ ! 698: if (XTYPE (valcontents) == Lisp_Some_Buffer_Local_Value) ! 699: tem1 = XCONS (XCONS (valcontents)->cdr)->cdr; ! 700: else ! 701: { ! 702: tem1 = Fcons (sym, Fcdr (current_alist_element)); ! 703: current_buffer->local_var_alist = Fcons (tem1, current_buffer->local_var_alist); ! 704: } ! 705: } ! 706: /* Set the CURRENT-ALIST-ELEMENT slot to fit this buffer. */ ! 707: current_alist_element = tem1; ! 708: XCONS (XCONS (XCONS (valcontents)->cdr)->cdr)->car = tem1; ! 709: /* Record this buffer in the BUFFER slot. */ ! 710: XSET (XCONS (XCONS (valcontents)->cdr)->car, ! 711: Lisp_Buffer, current_buffer); ! 712: /* Now the CURRENT-ALIST-ELEMENT slot in VALCONTENTS ! 713: is correct for the current buffer. */ ! 714: } ! 715: /* If the current buffer sees the default value, ! 716: set the default value in the CURRENT-ALIST-ELEMENT right now. ! 717: Don't wait till some other buffer gets cached. */ ! 718: if (XCONS (XCONS (valcontents)->cdr)->cdr == current_alist_element) ! 719: XCONS (current_alist_element)->cdr = newval; ! 720: valcontents = XCONS (valcontents)->car; ! 721: } ! 722: store_symval_forwarding (sym, valcontents, newval); ! 723: return newval; ! 724: } ! 725: ! 726: DEFUN ("set-default", Fset_default, Sset_default, 2, 2, 0, ! 727: "Set SYMBOL's default value to VAL. SYMBOL and VAL are evaluated.\n\ ! 728: The default value is seen in buffers that do not have their own values\n\ ! 729: for this variable.") ! 730: (sym, value) ! 731: Lisp_Object sym, value; ! 732: { ! 733: register Lisp_Object valcontents, current_alist_element, alist_element_buffer; ! 734: ! 735: CHECK_SYMBOL (sym, 0); ! 736: valcontents = XSYMBOL (sym)->value; ! 737: ! 738: /* Handle variables like case-fold-search that have special slots ! 739: in the buffer. Make them work apparently like Lisp_Buffer_Local_Value ! 740: variables. */ ! 741: if (XTYPE (valcontents) == Lisp_Buffer_Objfwd) ! 742: { ! 743: register int idx = XUINT (valcontents); ! 744: #ifndef RTPC_REGISTER_BUG ! 745: register struct buffer *b; ! 746: #else ! 747: struct buffer *b; ! 748: #endif ! 749: register int mask = *(int *) (idx + (char *) &buffer_local_flags); ! 750: ! 751: if (mask < 0) ! 752: /* -1 means the variable is always local in every buffer. ! 753: Set the default value, but not any of the local values. */ ! 754: *(Lisp_Object *)(idx + (char *) &buffer_defaults) = value; ! 755: ! 756: if (mask > 0) ! 757: { ! 758: /* Positive means a value that is local in some buffers. ! 759: Set the default value, and also the corresponding slot ! 760: in buffers where the variable is not local. */ ! 761: *(Lisp_Object *)(idx + (char *) &buffer_defaults) = value; ! 762: for (b = all_buffers; b; b = b->next) ! 763: if (!(b->local_var_flags & mask)) ! 764: *(Lisp_Object *)(idx + (char *) b) = value; ! 765: } ! 766: return value; ! 767: } ! 768: ! 769: if (XTYPE (valcontents) != Lisp_Buffer_Local_Value && ! 770: XTYPE (valcontents) != Lisp_Some_Buffer_Local_Value) ! 771: return Fset (sym, value); ! 772: ! 773: /* Store new value into the DEFAULT-VALUE slot */ ! 774: XCONS (XCONS (XCONS (valcontents)->cdr)->cdr)->cdr = value; ! 775: ! 776: /* If that slot is current, we must set the REALVALUE slot too */ ! 777: current_alist_element = XCONS (XCONS (XCONS (valcontents)->cdr)->cdr)->car; ! 778: alist_element_buffer = Fcar (current_alist_element); ! 779: if (EQ (alist_element_buffer, current_alist_element)) ! 780: store_symval_forwarding (sym, XCONS (valcontents)->car, value); ! 781: ! 782: return value; ! 783: } ! 784: ! 785: DEFUN ("setq-default", Fsetq_default, Ssetq_default, 2, UNEVALLED, 0, ! 786: "Set SYMBOL's default value to VAL. VAL is evaluated; SYMBOL is not.\n\ ! 787: The default value is seen in buffers that do not have their own values\n\ ! 788: for this variable.") ! 789: (args) ! 790: Lisp_Object args; ! 791: { ! 792: register Lisp_Object val; ! 793: struct gcpro gcpro1; ! 794: ! 795: GCPRO1 (args); ! 796: val = Feval (Fcar (Fcdr (args))); ! 797: UNGCPRO; ! 798: return Fset_default (Fcar (args), val); ! 799: } ! 800: ! 801: DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local, Smake_variable_buffer_local, ! 802: 1, 1, "vMake Variable Buffer Local: ", ! 803: "Make VARIABLE have a separate value for each buffer.\n\ ! 804: At any time, the value for the current buffer is in effect.\n\ ! 805: There is also a default value which is seen in any buffer which has not yet\n\ ! 806: set its own value.\n\ ! 807: The function `default-value' gets the default value and `set-default' sets it.\n\ ! 808: Using `set' or `setq' to set the variable causes it to have a separate value\n\ ! 809: for the current buffer if it was previously using the default value.") ! 810: (sym) ! 811: register Lisp_Object sym; ! 812: { ! 813: register Lisp_Object tem, valcontents; ! 814: ! 815: CHECK_SYMBOL (sym, 0); ! 816: ! 817: if (EQ (sym, Qnil) || EQ (sym, Qt)) ! 818: error ("Symbol %s may not be buffer-local", XSYMBOL (sym)->name->data); ! 819: ! 820: valcontents = XSYMBOL (sym)->value; ! 821: if ((XTYPE (valcontents) == Lisp_Buffer_Local_Value) || ! 822: (XTYPE (valcontents) == Lisp_Buffer_Objfwd)) ! 823: return sym; ! 824: if (XTYPE (valcontents) == Lisp_Some_Buffer_Local_Value) ! 825: { ! 826: XSETTYPE (XSYMBOL (sym)->value, Lisp_Buffer_Local_Value); ! 827: return sym; ! 828: } ! 829: if (EQ (valcontents, Qunbound)) ! 830: XSYMBOL (sym)->value = Qnil; ! 831: tem = Fcons (Qnil, Fsymbol_value (sym)); ! 832: XCONS (tem)->car = tem; ! 833: XSYMBOL (sym)->value = Fcons (XSYMBOL (sym)->value, Fcons (Fcurrent_buffer (), tem)); ! 834: XSETTYPE (XSYMBOL (sym)->value, Lisp_Buffer_Local_Value); ! 835: return sym; ! 836: } ! 837: ! 838: DEFUN ("make-local-variable", Fmake_local_variable, Smake_local_variable, ! 839: 1, 1, "vMake Local Variable: ", ! 840: "Make VARIABLE have a separate value in the current buffer.\n\ ! 841: Other buffers will continue to share a common default value.\n\ ! 842: See also `make-variable-buffer-local'.") ! 843: (sym) ! 844: register Lisp_Object sym; ! 845: { ! 846: register Lisp_Object tem, valcontents; ! 847: ! 848: CHECK_SYMBOL (sym, 0); ! 849: ! 850: if (EQ (sym, Qnil) || EQ (sym, Qt)) ! 851: error ("Symbol %s may not be buffer-local", XSYMBOL (sym)->name->data); ! 852: ! 853: valcontents = XSYMBOL (sym)->value; ! 854: if ((XTYPE (valcontents) == Lisp_Buffer_Local_Value) || ! 855: (XTYPE (valcontents) == Lisp_Buffer_Objfwd)) ! 856: return sym; ! 857: /* Make sure sym is set up to hold per-buffer values */ ! 858: if (XTYPE (valcontents) != Lisp_Some_Buffer_Local_Value) ! 859: { ! 860: if (EQ (valcontents, Qunbound)) ! 861: XSYMBOL (sym)->value = Qnil; ! 862: tem = Fcons (Qnil, Fsymbol_value (sym)); ! 863: XCONS (tem)->car = tem; ! 864: XSYMBOL (sym)->value = Fcons (XSYMBOL (sym)->value, Fcons (Qnil, tem)); ! 865: XSETTYPE (XSYMBOL (sym)->value, Lisp_Some_Buffer_Local_Value); ! 866: } ! 867: /* Make sure this buffer has its own value of sym */ ! 868: tem = Fassq (sym, current_buffer->local_var_alist); ! 869: if (NULL (tem)) ! 870: { ! 871: current_buffer->local_var_alist ! 872: = Fcons (Fcons (sym, XCONS (XCONS (XCONS (XSYMBOL (sym)->value)->cdr)->cdr)->cdr), ! 873: current_buffer->local_var_alist); ! 874: ! 875: /* Make sure symbol does not think it is set up for this buffer; ! 876: force it to look once again for this buffer's value */ ! 877: { ! 878: /* This local variable avoids "expression to complex" on IBM RT. */ ! 879: Lisp_Object xs; ! 880: ! 881: xs = XSYMBOL (sym)->value; ! 882: if (current_buffer == XBUFFER (XCONS (XCONS (xs)->cdr)->car)) ! 883: XCONS (XCONS (XSYMBOL (sym)->value)->cdr)->car = Qnil; ! 884: } ! 885: } ! 886: return sym; ! 887: } ! 888: ! 889: DEFUN ("kill-local-variable", Fkill_local_variable, Skill_local_variable, ! 890: 1, 1, "vKill Local Variable: ", ! 891: "Make VARIABLE no longer have a separate value in the current buffer.\n\ ! 892: From now on the default value will apply in this buffer.") ! 893: (sym) ! 894: register Lisp_Object sym; ! 895: { ! 896: register Lisp_Object tem, valcontents; ! 897: ! 898: CHECK_SYMBOL (sym, 0); ! 899: ! 900: valcontents = XSYMBOL (sym)->value; ! 901: ! 902: if (XTYPE (valcontents) == Lisp_Buffer_Objfwd) ! 903: { ! 904: register int idx = XUINT (valcontents); ! 905: register int mask = *(int *) (idx + (char *) &buffer_local_flags); ! 906: ! 907: if (mask > 0) ! 908: { ! 909: *(Lisp_Object *)(idx + (char *) current_buffer) ! 910: = *(Lisp_Object *)(idx + (char *) &buffer_defaults); ! 911: current_buffer->local_var_flags &= ~mask; ! 912: } ! 913: return sym; ! 914: } ! 915: ! 916: if (XTYPE (valcontents) != Lisp_Buffer_Local_Value && ! 917: XTYPE (valcontents) != Lisp_Some_Buffer_Local_Value) ! 918: return sym; ! 919: ! 920: /* Get rid of this buffer's alist element, if any */ ! 921: ! 922: tem = Fassq (sym, current_buffer->local_var_alist); ! 923: if (!NULL (tem)) ! 924: current_buffer->local_var_alist = Fdelq (tem, current_buffer->local_var_alist); ! 925: ! 926: /* Make sure symbol does not think it is set up for this buffer; ! 927: force it to look once again for this buffer's value */ ! 928: { ! 929: Lisp_Object sv; ! 930: sv = XSYMBOL (sym)->value; ! 931: if (current_buffer == XBUFFER (XCONS (XCONS (sv)->cdr)->car)) ! 932: XCONS (XCONS (sv)->cdr)->car = Qnil; ! 933: } ! 934: ! 935: return sym; ! 936: } ! 937: ! 938: /* Extract and set vector and string elements */ ! 939: ! 940: DEFUN ("aref", Faref, Saref, 2, 2, 0, ! 941: "Return the element of ARRAY at index INDEX.\n\ ! 942: ARRAY may be a vector or a string. INDEX starts at 0.") ! 943: (vector, idx) ! 944: register Lisp_Object vector; ! 945: Lisp_Object idx; ! 946: { ! 947: register int idxval; ! 948: ! 949: CHECK_NUMBER (idx, 1); ! 950: idxval = XINT (idx); ! 951: if (XTYPE (vector) != Lisp_Vector && XTYPE (vector) != Lisp_String) ! 952: vector = wrong_type_argument (Qarrayp, vector); ! 953: if (idxval < 0 || idxval >= XVECTOR (vector)->size) ! 954: args_out_of_range (vector, idx); ! 955: if (XTYPE (vector) == Lisp_Vector) ! 956: return XVECTOR (vector)->contents[idxval]; ! 957: else ! 958: { ! 959: Lisp_Object val; ! 960: XFASTINT (val) = (unsigned char) XSTRING (vector)->data[idxval]; ! 961: return val; ! 962: } ! 963: } ! 964: ! 965: DEFUN ("aset", Faset, Saset, 3, 3, 0, ! 966: "Store into the element of ARRAY at index INDEX the value NEWVAL.\n\ ! 967: ARRAY may be a vector or a string. INDEX starts at 0.") ! 968: (vector, idx, newelt) ! 969: register Lisp_Object vector; ! 970: Lisp_Object idx, newelt; ! 971: { ! 972: register int idxval; ! 973: ! 974: CHECK_NUMBER (idx, 1); ! 975: idxval = XINT (idx); ! 976: if (XTYPE (vector) != Lisp_Vector && XTYPE (vector) != Lisp_String) ! 977: vector = wrong_type_argument (Qarrayp, vector); ! 978: if (idxval < 0 || idxval >= XVECTOR (vector)->size) ! 979: args_out_of_range (vector, idx); ! 980: CHECK_IMPURE (vector); ! 981: ! 982: if (XTYPE (vector) == Lisp_Vector) ! 983: XVECTOR (vector)->contents[idxval] = newelt; ! 984: else ! 985: XSTRING (vector)->data[idxval] = XINT (newelt); ! 986: ! 987: return newelt; ! 988: } ! 989: ! 990: Lisp_Object ! 991: Farray_length (vector) ! 992: register Lisp_Object vector; ! 993: { ! 994: register Lisp_Object size; ! 995: if (XTYPE (vector) != Lisp_Vector && XTYPE (vector) != Lisp_String) ! 996: vector = wrong_type_argument (Qarrayp, vector); ! 997: XFASTINT (size) = XVECTOR (vector)->size; ! 998: return size; ! 999: } ! 1000: ! 1001: /* Arithmetic functions */ ! 1002: ! 1003: DEFUN ("=", Feqlsign, Seqlsign, 2, 2, 0, ! 1004: "T if two args, both numbers, are equal.") ! 1005: (num1, num2) ! 1006: register Lisp_Object num1, num2; ! 1007: { ! 1008: CHECK_NUMBER_COERCE_MARKER (num1, 0); ! 1009: CHECK_NUMBER_COERCE_MARKER (num2, 0); ! 1010: ! 1011: if (XINT (num1) == XINT (num2)) ! 1012: return Qt; ! 1013: return Qnil; ! 1014: } ! 1015: ! 1016: DEFUN ("<", Flss, Slss, 2, 2, 0, ! 1017: "T if first arg is less than second arg. Both must be numbers.") ! 1018: (num1, num2) ! 1019: register Lisp_Object num1, num2; ! 1020: { ! 1021: CHECK_NUMBER_COERCE_MARKER (num1, 0); ! 1022: CHECK_NUMBER_COERCE_MARKER (num2, 0); ! 1023: ! 1024: if (XINT (num1) < XINT (num2)) ! 1025: return Qt; ! 1026: return Qnil; ! 1027: } ! 1028: ! 1029: DEFUN (">", Fgtr, Sgtr, 2, 2, 0, ! 1030: "T if first arg is greater than second arg. Both must be numbers.") ! 1031: (num1, num2) ! 1032: register Lisp_Object num1, num2; ! 1033: { ! 1034: CHECK_NUMBER_COERCE_MARKER (num1, 0); ! 1035: CHECK_NUMBER_COERCE_MARKER (num2, 0); ! 1036: ! 1037: if (XINT (num1) > XINT (num2)) ! 1038: return Qt; ! 1039: return Qnil; ! 1040: } ! 1041: ! 1042: DEFUN ("<=", Fleq, Sleq, 2, 2, 0, ! 1043: "T if first arg is less than or equal to second arg. Both must be numbers.") ! 1044: (num1, num2) ! 1045: register Lisp_Object num1, num2; ! 1046: { ! 1047: CHECK_NUMBER_COERCE_MARKER (num1, 0); ! 1048: CHECK_NUMBER_COERCE_MARKER (num2, 0); ! 1049: ! 1050: if (XINT (num1) <= XINT (num2)) ! 1051: return Qt; ! 1052: return Qnil; ! 1053: } ! 1054: ! 1055: DEFUN (">=", Fgeq, Sgeq, 2, 2, 0, ! 1056: "T if first arg is greater than or equal to second arg. Both must be numbers.") ! 1057: (num1, num2) ! 1058: register Lisp_Object num1, num2; ! 1059: { ! 1060: CHECK_NUMBER_COERCE_MARKER (num1, 0); ! 1061: CHECK_NUMBER_COERCE_MARKER (num2, 0); ! 1062: ! 1063: if (XINT (num1) >= XINT (num2)) ! 1064: return Qt; ! 1065: return Qnil; ! 1066: } ! 1067: ! 1068: DEFUN ("/=", Fneq, Sneq, 2, 2, 0, ! 1069: "T if first arg is not equal to second arg. Both must be numbers.") ! 1070: (num1, num2) ! 1071: register Lisp_Object num1, num2; ! 1072: { ! 1073: CHECK_NUMBER_COERCE_MARKER (num1, 0); ! 1074: CHECK_NUMBER_COERCE_MARKER (num2, 0); ! 1075: ! 1076: if (XINT (num1) != XINT (num2)) ! 1077: return Qt; ! 1078: return Qnil; ! 1079: } ! 1080: ! 1081: DEFUN ("zerop", Fzerop, Szerop, 1, 1, 0, "T if NUMBER is zero.") ! 1082: (num) ! 1083: register Lisp_Object num; ! 1084: { ! 1085: CHECK_NUMBER (num, 0); ! 1086: ! 1087: if (!XINT (num)) ! 1088: return Qt; ! 1089: return Qnil; ! 1090: } ! 1091: ! 1092: DEFUN ("int-to-string", Fint_to_string, Sint_to_string, 1, 1, 0, ! 1093: "Convert INT to a string by printing it in decimal, with minus sign if negative.") ! 1094: (num) ! 1095: Lisp_Object num; ! 1096: { ! 1097: char buffer[20]; ! 1098: ! 1099: CHECK_NUMBER (num, 0); ! 1100: sprintf (buffer, "%d", XINT (num)); ! 1101: return build_string (buffer); ! 1102: } ! 1103: ! 1104: DEFUN ("string-to-int", Fstring_to_int, Sstring_to_int, 1, 1, 0, ! 1105: "Convert STRING to an integer by parsing it as a decimal number.") ! 1106: (str) ! 1107: register Lisp_Object str; ! 1108: { ! 1109: CHECK_STRING (str, 0); ! 1110: return make_number (atoi (XSTRING (str)->data)); ! 1111: } ! 1112: ! 1113: enum arithop ! 1114: { Aadd, Asub, Amult, Adiv, Alogand, Alogior, Alogxor, Amax, Amin }; ! 1115: ! 1116: Lisp_Object ! 1117: arith_driver ! 1118: (code, nargs, args) ! 1119: enum arithop code; ! 1120: int nargs; ! 1121: register Lisp_Object *args; ! 1122: { ! 1123: register Lisp_Object val; ! 1124: register int argnum; ! 1125: register int accum; ! 1126: register int next; ! 1127: ! 1128: #ifdef SWITCH_ENUM_BUG ! 1129: switch ((int) code) ! 1130: #else ! 1131: switch (code) ! 1132: #endif ! 1133: { ! 1134: case Alogior: ! 1135: case Alogxor: ! 1136: case Aadd: ! 1137: case Asub: ! 1138: accum = 0; break; ! 1139: case Amult: ! 1140: accum = 1; break; ! 1141: case Alogand: ! 1142: accum = -1; break; ! 1143: } ! 1144: ! 1145: for (argnum = 0; argnum < nargs; argnum++) ! 1146: { ! 1147: val = args[argnum]; /* using args[argnum] as argument to CHECK_NUMBER_... */ ! 1148: CHECK_NUMBER_COERCE_MARKER (val, argnum); ! 1149: args[argnum] = val; /* runs into a compiler bug. */ ! 1150: next = XINT (args[argnum]); ! 1151: #ifdef SWITCH_ENUM_BUG ! 1152: switch ((int) code) ! 1153: #else ! 1154: switch (code) ! 1155: #endif ! 1156: { ! 1157: case Aadd: accum += next; break; ! 1158: case Asub: ! 1159: if (!argnum && nargs != 1) ! 1160: next = - next; ! 1161: accum -= next; ! 1162: break; ! 1163: case Amult: accum *= next; break; ! 1164: case Adiv: ! 1165: if (!argnum) accum = next; ! 1166: else ! 1167: { ! 1168: /* Some systems fail to trap this right. */ ! 1169: if (!XINT (next)) ! 1170: while (1) ! 1171: Fsignal (Qarith_error, Qnil); ! 1172: ! 1173: accum /= next; ! 1174: } ! 1175: break; ! 1176: case Alogand: accum &= next; break; ! 1177: case Alogior: accum |= next; break; ! 1178: case Alogxor: accum ^= next; break; ! 1179: case Amax: if (!argnum || next > accum) accum = next; break; ! 1180: case Amin: if (!argnum || next < accum) accum = next; break; ! 1181: } ! 1182: } ! 1183: ! 1184: XSET (val, Lisp_Int, accum); ! 1185: return val; ! 1186: } ! 1187: ! 1188: DEFUN ("+", Fplus, Splus, 0, MANY, 0, ! 1189: "Return sum of any number of numbers.") ! 1190: (nargs, args) ! 1191: int nargs; ! 1192: Lisp_Object *args; ! 1193: { ! 1194: return arith_driver (Aadd, nargs, args); ! 1195: } ! 1196: ! 1197: DEFUN ("-", Fminus, Sminus, 0, MANY, 0, ! 1198: "Negate number or subtract numbers.\n\ ! 1199: With one arg, negates it. With more than one arg,\n\ ! 1200: subtracts all but the first from the first.") ! 1201: (nargs, args) ! 1202: int nargs; ! 1203: Lisp_Object *args; ! 1204: { ! 1205: return arith_driver (Asub, nargs, args); ! 1206: } ! 1207: ! 1208: DEFUN ("*", Ftimes, Stimes, 0, MANY, 0, ! 1209: "Returns product of any number of numbers.") ! 1210: (nargs, args) ! 1211: int nargs; ! 1212: Lisp_Object *args; ! 1213: { ! 1214: return arith_driver (Amult, nargs, args); ! 1215: } ! 1216: ! 1217: DEFUN ("/", Fquo, Squo, 2, MANY, 0, ! 1218: "Returns first argument divided by rest of arguments.") ! 1219: (nargs, args) ! 1220: int nargs; ! 1221: Lisp_Object *args; ! 1222: { ! 1223: return arith_driver (Adiv, nargs, args); ! 1224: } ! 1225: ! 1226: DEFUN ("%", Frem, Srem, 2, 2, 0, ! 1227: "Returns remainder of first arg divided by second.") ! 1228: (num1, num2) ! 1229: register Lisp_Object num1, num2; ! 1230: { ! 1231: Lisp_Object val; ! 1232: ! 1233: CHECK_NUMBER (num1, 0); ! 1234: CHECK_NUMBER (num2, 1); ! 1235: ! 1236: /* Some systems fail to trap this right. */ ! 1237: if (!XINT (num2)) ! 1238: while (1) ! 1239: Fsignal (Qarith_error, Qnil); ! 1240: ! 1241: XSET (val, Lisp_Int, XINT (num1) % XINT (num2)); ! 1242: return val; ! 1243: } ! 1244: ! 1245: DEFUN ("max", Fmax, Smax, 1, MANY, 0, ! 1246: "Return largest of all the arguments (which must be numbers.)") ! 1247: (nargs, args) ! 1248: int nargs; ! 1249: Lisp_Object *args; ! 1250: { ! 1251: return arith_driver (Amax, nargs, args); ! 1252: } ! 1253: ! 1254: DEFUN ("min", Fmin, Smin, 1, MANY, 0, ! 1255: "Return smallest of all the arguments (which must be numbers.)") ! 1256: (nargs, args) ! 1257: int nargs; ! 1258: Lisp_Object *args; ! 1259: { ! 1260: return arith_driver (Amin, nargs, args); ! 1261: } ! 1262: ! 1263: DEFUN ("logand", Flogand, Slogand, 0, MANY, 0, ! 1264: "Return bitwise and of all the arguments (numbers).") ! 1265: (nargs, args) ! 1266: int nargs; ! 1267: Lisp_Object *args; ! 1268: { ! 1269: return arith_driver (Alogand, nargs, args); ! 1270: } ! 1271: ! 1272: DEFUN ("logior", Flogior, Slogior, 0, MANY, 0, ! 1273: "Return bitwise or of all the arguments (numbers).") ! 1274: (nargs, args) ! 1275: int nargs; ! 1276: Lisp_Object *args; ! 1277: { ! 1278: return arith_driver (Alogior, nargs, args); ! 1279: } ! 1280: ! 1281: DEFUN ("logxor", Flogxor, Slogxor, 0, MANY, 0, ! 1282: "Return bitwise exclusive-or of all the arguments (numbers).") ! 1283: (nargs, args) ! 1284: int nargs; ! 1285: Lisp_Object *args; ! 1286: { ! 1287: return arith_driver (Alogxor, nargs, args); ! 1288: } ! 1289: ! 1290: DEFUN ("ash", Fash, Sash, 2, 2, 0, ! 1291: "Return VALUE with its bits shifted left by COUNT.\n\ ! 1292: If COUNT is negative, shifting is actually to the right.\n\ ! 1293: In this case, the sign bit is duplicated.") ! 1294: (num1, num2) ! 1295: register Lisp_Object num1, num2; ! 1296: { ! 1297: register Lisp_Object val; ! 1298: ! 1299: CHECK_NUMBER (num1, 0); ! 1300: CHECK_NUMBER (num2, 1); ! 1301: ! 1302: if (XINT (num2) > 0) ! 1303: XSET (val, Lisp_Int, XINT (num1) << XFASTINT (num2)); ! 1304: else ! 1305: XSET (val, Lisp_Int, XINT (num1) >> -XINT (num2)); ! 1306: return val; ! 1307: } ! 1308: ! 1309: DEFUN ("lsh", Flsh, Slsh, 2, 2, 0, ! 1310: "Return VALUE with its bits shifted left by COUNT.\n\ ! 1311: If COUNT is negative, shifting is actually to the right.\n\ ! 1312: In this case, zeros are shifted in on the left.") ! 1313: (num1, num2) ! 1314: register Lisp_Object num1, num2; ! 1315: { ! 1316: register Lisp_Object val; ! 1317: ! 1318: CHECK_NUMBER (num1, 0); ! 1319: CHECK_NUMBER (num2, 1); ! 1320: ! 1321: if (XINT (num2) > 0) ! 1322: XSET (val, Lisp_Int, (unsigned) XFASTINT (num1) << XFASTINT (num2)); ! 1323: else ! 1324: XSET (val, Lisp_Int, (unsigned) XFASTINT (num1) >> -XINT (num2)); ! 1325: return val; ! 1326: } ! 1327: ! 1328: DEFUN ("1+", Fadd1, Sadd1, 1, 1, 0, ! 1329: "Return NUMBER plus one.") ! 1330: (num) ! 1331: register Lisp_Object num; ! 1332: { ! 1333: CHECK_NUMBER_COERCE_MARKER (num, 0); ! 1334: XSETINT (num, XFASTINT (num) + 1); ! 1335: return num; ! 1336: } ! 1337: ! 1338: DEFUN ("1-", Fsub1, Ssub1, 1, 1, 0, ! 1339: "Return NUMBER minus one.") ! 1340: (num) ! 1341: register Lisp_Object num; ! 1342: { ! 1343: CHECK_NUMBER_COERCE_MARKER (num, 0); ! 1344: XSETINT (num, XFASTINT (num) - 1); ! 1345: return num; ! 1346: } ! 1347: ! 1348: DEFUN ("lognot", Flognot, Slognot, 1, 1, 0, ! 1349: "Return the bitwise complement of ARG.") ! 1350: (num) ! 1351: register Lisp_Object num; ! 1352: { ! 1353: CHECK_NUMBER (num, 0); ! 1354: XSETINT (num, ~XFASTINT (num)); ! 1355: return num; ! 1356: } ! 1357: ! 1358: void ! 1359: syms_of_data () ! 1360: { ! 1361: Qquote = intern ("quote"); ! 1362: Qlambda = intern ("lambda"); ! 1363: Qsubr = intern ("subr"); ! 1364: Qerror_conditions = intern ("error-conditions"); ! 1365: Qerror_message = intern ("error-message"); ! 1366: Qtop_level = intern ("top-level"); ! 1367: ! 1368: Qerror = intern ("error"); ! 1369: Qquit = intern ("quit"); ! 1370: Qwrong_type_argument = intern ("wrong-type-argument"); ! 1371: Qargs_out_of_range = intern ("args-out-of-range"); ! 1372: Qvoid_function = intern ("void-function"); ! 1373: Qvoid_variable = intern ("void-variable"); ! 1374: Qsetting_constant = intern ("setting-constant"); ! 1375: Qinvalid_read_syntax = intern ("invalid-read-syntax"); ! 1376: ! 1377: Qinvalid_function = intern ("invalid-function"); ! 1378: Qwrong_number_of_arguments = intern ("wrong-number-of-arguments"); ! 1379: Qno_catch = intern ("no-catch"); ! 1380: Qend_of_file = intern ("end-of-file"); ! 1381: Qarith_error = intern ("arith-error"); ! 1382: Qbeginning_of_buffer = intern ("beginning-of-buffer"); ! 1383: Qend_of_buffer = intern ("end-of-buffer"); ! 1384: Qbuffer_read_only = intern ("buffer-read-only"); ! 1385: ! 1386: Qlistp = intern ("listp"); ! 1387: Qconsp = intern ("consp"); ! 1388: Qsymbolp = intern ("symbolp"); ! 1389: Qintegerp = intern ("integerp"); ! 1390: Qnatnump = intern ("natnump"); ! 1391: Qstringp = intern ("stringp"); ! 1392: Qarrayp = intern ("arrayp"); ! 1393: Qsequencep = intern ("sequencep"); ! 1394: Qbufferp = intern ("bufferp"); ! 1395: Qvectorp = intern ("vectorp"); ! 1396: Qchar_or_string_p = intern ("char-or-string-p"); ! 1397: Qmarkerp = intern ("markerp"); ! 1398: Qinteger_or_marker_p = intern ("integer-or-marker-p"); ! 1399: Qboundp = intern ("boundp"); ! 1400: Qfboundp = intern ("fboundp"); ! 1401: ! 1402: Qcdr = intern ("cdr"); ! 1403: ! 1404: /* ERROR is used as a signaler for random errors for which nothing else is right */ ! 1405: ! 1406: Fput (Qerror, Qerror_conditions, ! 1407: Fcons (Qerror, Qnil)); ! 1408: Fput (Qerror, Qerror_message, ! 1409: build_string ("error")); ! 1410: ! 1411: Fput (Qquit, Qerror_conditions, ! 1412: Fcons (Qquit, Qnil)); ! 1413: Fput (Qquit, Qerror_message, ! 1414: build_string ("Quit")); ! 1415: ! 1416: Fput (Qwrong_type_argument, Qerror_conditions, ! 1417: Fcons (Qwrong_type_argument, Fcons (Qerror, Qnil))); ! 1418: Fput (Qwrong_type_argument, Qerror_message, ! 1419: build_string ("Wrong type argument")); ! 1420: ! 1421: Fput (Qargs_out_of_range, Qerror_conditions, ! 1422: Fcons (Qargs_out_of_range, Fcons (Qerror, Qnil))); ! 1423: Fput (Qargs_out_of_range, Qerror_message, ! 1424: build_string ("Args out of range")); ! 1425: ! 1426: Fput (Qvoid_function, Qerror_conditions, ! 1427: Fcons (Qvoid_function, Fcons (Qerror, Qnil))); ! 1428: Fput (Qvoid_function, Qerror_message, ! 1429: build_string ("Symbol's function definition is void")); ! 1430: ! 1431: Fput (Qvoid_variable, Qerror_conditions, ! 1432: Fcons (Qvoid_variable, Fcons (Qerror, Qnil))); ! 1433: Fput (Qvoid_variable, Qerror_message, ! 1434: build_string ("Symbol's value as variable is void")); ! 1435: ! 1436: Fput (Qsetting_constant, Qerror_conditions, ! 1437: Fcons (Qsetting_constant, Fcons (Qerror, Qnil))); ! 1438: Fput (Qsetting_constant, Qerror_message, ! 1439: build_string ("Attempt to set a constant symbol")); ! 1440: ! 1441: Fput (Qinvalid_read_syntax, Qerror_conditions, ! 1442: Fcons (Qinvalid_read_syntax, Fcons (Qerror, Qnil))); ! 1443: Fput (Qinvalid_read_syntax, Qerror_message, ! 1444: build_string ("Invalid read syntax")); ! 1445: ! 1446: Fput (Qinvalid_function, Qerror_conditions, ! 1447: Fcons (Qinvalid_function, Fcons (Qerror, Qnil))); ! 1448: Fput (Qinvalid_function, Qerror_message, ! 1449: build_string ("Invalid function")); ! 1450: ! 1451: Fput (Qwrong_number_of_arguments, Qerror_conditions, ! 1452: Fcons (Qwrong_number_of_arguments, Fcons (Qerror, Qnil))); ! 1453: Fput (Qwrong_number_of_arguments, Qerror_message, ! 1454: build_string ("Wrong number of arguments")); ! 1455: ! 1456: Fput (Qno_catch, Qerror_conditions, ! 1457: Fcons (Qno_catch, Fcons (Qerror, Qnil))); ! 1458: Fput (Qno_catch, Qerror_message, ! 1459: build_string ("No catch for tag")); ! 1460: ! 1461: Fput (Qend_of_file, Qerror_conditions, ! 1462: Fcons (Qend_of_file, Fcons (Qerror, Qnil))); ! 1463: Fput (Qend_of_file, Qerror_message, ! 1464: build_string ("End of file during parsing")); ! 1465: ! 1466: Fput (Qarith_error, Qerror_conditions, ! 1467: Fcons (Qarith_error, Fcons (Qerror, Qnil))); ! 1468: Fput (Qarith_error, Qerror_message, ! 1469: build_string ("Arithmetic error")); ! 1470: ! 1471: Fput (Qbeginning_of_buffer, Qerror_conditions, ! 1472: Fcons (Qbeginning_of_buffer, Fcons (Qerror, Qnil))); ! 1473: Fput (Qbeginning_of_buffer, Qerror_message, ! 1474: build_string ("Beginning of buffer")); ! 1475: ! 1476: Fput (Qend_of_buffer, Qerror_conditions, ! 1477: Fcons (Qend_of_buffer, Fcons (Qerror, Qnil))); ! 1478: Fput (Qend_of_buffer, Qerror_message, ! 1479: build_string ("End of buffer")); ! 1480: ! 1481: Fput (Qbuffer_read_only, Qerror_conditions, ! 1482: Fcons (Qbuffer_read_only, Fcons (Qerror, Qnil))); ! 1483: Fput (Qbuffer_read_only, Qerror_message, ! 1484: build_string ("Buffer is read-only")); ! 1485: ! 1486: staticpro (&Qnil); ! 1487: staticpro (&Qt); ! 1488: staticpro (&Qquote); ! 1489: staticpro (&Qlambda); ! 1490: staticpro (&Qsubr); ! 1491: staticpro (&Qunbound); ! 1492: staticpro (&Qerror_conditions); ! 1493: staticpro (&Qerror_message); ! 1494: staticpro (&Qtop_level); ! 1495: ! 1496: staticpro (&Qerror); ! 1497: staticpro (&Qquit); ! 1498: staticpro (&Qwrong_type_argument); ! 1499: staticpro (&Qargs_out_of_range); ! 1500: staticpro (&Qvoid_function); ! 1501: staticpro (&Qvoid_variable); ! 1502: staticpro (&Qsetting_constant); ! 1503: staticpro (&Qinvalid_read_syntax); ! 1504: staticpro (&Qwrong_number_of_arguments); ! 1505: staticpro (&Qinvalid_function); ! 1506: staticpro (&Qno_catch); ! 1507: staticpro (&Qend_of_file); ! 1508: staticpro (&Qarith_error); ! 1509: staticpro (&Qbeginning_of_buffer); ! 1510: staticpro (&Qend_of_buffer); ! 1511: staticpro (&Qbuffer_read_only); ! 1512: ! 1513: staticpro (&Qlistp); ! 1514: staticpro (&Qconsp); ! 1515: staticpro (&Qsymbolp); ! 1516: staticpro (&Qintegerp); ! 1517: staticpro (&Qnatnump); ! 1518: staticpro (&Qstringp); ! 1519: staticpro (&Qarrayp); ! 1520: staticpro (&Qsequencep); ! 1521: staticpro (&Qbufferp); ! 1522: staticpro (&Qvectorp); ! 1523: staticpro (&Qchar_or_string_p); ! 1524: staticpro (&Qmarkerp); ! 1525: staticpro (&Qinteger_or_marker_p); ! 1526: staticpro (&Qboundp); ! 1527: staticpro (&Qfboundp); ! 1528: staticpro (&Qcdr); ! 1529: ! 1530: defsubr (&Seq); ! 1531: defsubr (&Snull); ! 1532: defsubr (&Slistp); ! 1533: defsubr (&Snlistp); ! 1534: defsubr (&Sconsp); ! 1535: defsubr (&Satom); ! 1536: defsubr (&Sintegerp); ! 1537: defsubr (&Snatnump); ! 1538: defsubr (&Ssymbolp); ! 1539: defsubr (&Sstringp); ! 1540: defsubr (&Svectorp); ! 1541: defsubr (&Sarrayp); ! 1542: defsubr (&Ssequencep); ! 1543: defsubr (&Sbufferp); ! 1544: defsubr (&Smarkerp); ! 1545: defsubr (&Sinteger_or_marker_p); ! 1546: defsubr (&Ssubrp); ! 1547: defsubr (&Schar_or_string_p); ! 1548: defsubr (&Scar); ! 1549: defsubr (&Scdr); ! 1550: defsubr (&Scar_safe); ! 1551: defsubr (&Scdr_safe); ! 1552: defsubr (&Ssetcar); ! 1553: defsubr (&Ssetcdr); ! 1554: defsubr (&Ssymbol_function); ! 1555: defsubr (&Ssymbol_plist); ! 1556: defsubr (&Ssymbol_name); ! 1557: defsubr (&Smakunbound); ! 1558: defsubr (&Sfmakunbound); ! 1559: defsubr (&Sboundp); ! 1560: defsubr (&Sfboundp); ! 1561: defsubr (&Sfset); ! 1562: defsubr (&Ssetplist); ! 1563: defsubr (&Ssymbol_value); ! 1564: defsubr (&Sset); ! 1565: defsubr (&Sdefault_value); ! 1566: defsubr (&Sset_default); ! 1567: defsubr (&Ssetq_default); ! 1568: defsubr (&Smake_variable_buffer_local); ! 1569: defsubr (&Smake_local_variable); ! 1570: defsubr (&Skill_local_variable); ! 1571: defsubr (&Saref); ! 1572: defsubr (&Saset); ! 1573: defsubr (&Sint_to_string); ! 1574: defsubr (&Sstring_to_int); ! 1575: defsubr (&Seqlsign); ! 1576: defsubr (&Slss); ! 1577: defsubr (&Sgtr); ! 1578: defsubr (&Sleq); ! 1579: defsubr (&Sgeq); ! 1580: defsubr (&Sneq); ! 1581: defsubr (&Szerop); ! 1582: defsubr (&Splus); ! 1583: defsubr (&Sminus); ! 1584: defsubr (&Stimes); ! 1585: defsubr (&Squo); ! 1586: defsubr (&Srem); ! 1587: defsubr (&Smax); ! 1588: defsubr (&Smin); ! 1589: defsubr (&Slogand); ! 1590: defsubr (&Slogior); ! 1591: defsubr (&Slogxor); ! 1592: defsubr (&Slsh); ! 1593: defsubr (&Sash); ! 1594: defsubr (&Sadd1); ! 1595: defsubr (&Ssub1); ! 1596: defsubr (&Slognot); ! 1597: } ! 1598: ! 1599: arith_error (signo) ! 1600: int signo; ! 1601: { ! 1602: #ifdef USG ! 1603: /* USG systems forget handlers when they are used; ! 1604: must reestablish each time */ ! 1605: signal (signo, arith_error); ! 1606: #endif /* USG */ ! 1607: #ifdef VMS ! 1608: /* VMS systems are like USG. */ ! 1609: signal (signo, arith_error); ! 1610: #endif /* VMS */ ! 1611: #ifdef BSD4_1 ! 1612: sigrelse (SIGFPE); ! 1613: #else /* not BSD4_1 */ ! 1614: sigsetmask (SIGEMPTYMASK); ! 1615: #endif /* not BSD4_1 */ ! 1616: ! 1617: while (1) ! 1618: Fsignal (Qarith_error, Qnil); ! 1619: } ! 1620: ! 1621: init_data () ! 1622: { ! 1623: /* Don't do this if just dumping out. ! 1624: We don't want to call `signal' in this case ! 1625: so that we don't have trouble with dumping ! 1626: signal-delivering routines in an inconsistent state. */ ! 1627: #ifndef CANNOT_DUMP ! 1628: if (!initialized) ! 1629: return; ! 1630: #endif /* CANNOT_DUMP */ ! 1631: signal (SIGFPE, arith_error); ! 1632: #ifdef uts ! 1633: signal (SIGEMT, arith_error); ! 1634: #endif /* uts */ ! 1635: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.