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