1: /* Lisp parsing and input streams. 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 <stdio.h> 23: #include <sys/types.h> 24: #include <sys/stat.h> 25: #include <sys/file.h> 26: #undef NULL 27: #include "config.h" 28: #include "lisp.h" 29: 30: #ifndef standalone 31: #include "buffer.h" 32: #include "paths.h" 33: #endif 34: 35: #ifdef lint 36: #include <sys/inode.h> 37: #endif /* lint */ 38: 39: #ifndef X_OK 40: #define X_OK 01 41: #endif 42: 43: Lisp_Object Qread_char, Qget_file_char, Qstandard_input; 44: Lisp_Object Qvariable_documentation, Vvalues, Vstandard_input; 45: 46: /* 1 iff inside of load */ 47: int load_in_progress; 48: 49: /* Search path for files to be loaded. */ 50: Lisp_Object Vload_path; 51: 52: /* File for get_file_char to read from. Use by load */ 53: static FILE *instream; 54: 55: /* When nonzero, read conses in pure space */ 56: static int read_pure; 57: 58: /* For use within read-from-string (this reader is non-reentrant!!) */ 59: static int read_from_string_index; 60: static int read_from_string_limit; 61: 62: /* Handle unreading and rereading of characters. 63: Write READCHAR to read a character, UNREAD(c) to unread c to be read again. */ 64: 65: static int unrch; 66: 67: static int readchar (readcharfun) 68: Lisp_Object readcharfun; 69: { 70: Lisp_Object tem; 71: register struct buffer_text *inbuffer; 72: register int c, mpos; 73: 74: if (unrch >= 0) 75: { 76: c = unrch; 77: unrch = -1; 78: return c; 79: } 80: if (XTYPE (readcharfun) == Lisp_Buffer) 81: { 82: if (XBUFFER (readcharfun) == bf_cur) 83: inbuffer = &bf_text; 84: else 85: inbuffer = &XBUFFER (readcharfun)->text; 86: 87: if (inbuffer->pointloc > 88: inbuffer->size1 + inbuffer->size2 - inbuffer->tail_clip) 89: return -1; 90: c = *(unsigned char *) &(inbuffer->pointloc > inbuffer->size1 ? inbuffer->p2 : inbuffer->p1)[inbuffer->pointloc]; 91: inbuffer->pointloc++; 92: return c; 93: } 94: if (XTYPE (readcharfun) == Lisp_Marker) 95: { 96: if (XMARKER (readcharfun)->buffer == bf_cur) 97: inbuffer = &bf_text; 98: else 99: inbuffer = &XMARKER (readcharfun)->buffer->text; 100: mpos = marker_position (readcharfun); 101: 102: if (mpos > 103: inbuffer->size1 + inbuffer->size2 - inbuffer->tail_clip) 104: return -1; 105: c = *(unsigned char *) &(mpos > inbuffer->size1 ? inbuffer->p2 : inbuffer->p1)[mpos]; 106: if (mpos != inbuffer->size1 + 1) 107: XMARKER (readcharfun)->bufpos++; 108: else 109: Fset_marker (readcharfun, make_number (mpos + 1), 110: Fmarker_buffer (readcharfun)); 111: return c; 112: } 113: if (EQ (readcharfun, Qget_file_char)) 114: return getc (instream); 115: 116: if (XTYPE (readcharfun) == Lisp_String) 117: return (read_from_string_index < read_from_string_limit) ? 118: XSTRING (readcharfun)->data[read_from_string_index++] : -1; 119: 120: tem = Fapply (readcharfun, Qnil); 121: 122: if (NULL (tem)) 123: return -1; 124: return XINT (tem); 125: } 126: 127: #define READCHAR readchar(readcharfun) 128: #define UNREAD(c) (unrch = c) 129: 130: static Lisp_Object read0 (), read1 (), read_list (), read_vector (); 131: 132: /* get a character from the tty */ 133: 134: DEFUN ("read-char", Fread_char, Sread_char, 0, 0, 0, 135: "Read a character from the command input (keyboard or macro).\n\ 136: It is returned as a number.") 137: () 138: { 139: register Lisp_Object val; 140: 141: #ifndef standalone 142: XSET (val, Lisp_Int, get_char (0)); 143: #else 144: XSET (val, Lisp_Int, getchar ()); 145: #endif 146: 147: return val; 148: } 149: 150: DEFUN ("get-file-char", Fget_file_char, Sget_file_char, 0, 0, 0, 151: "Don't use this yourself.") 152: () 153: { 154: register Lisp_Object val; 155: XSET (val, Lisp_Int, getc (instream)); 156: return val; 157: } 158: 159: void readevalloop (); 160: Lisp_Object load_unwind (); 161: 162: DEFUN ("load", Fload, Sload, 1, 3, "sLoad file: ", 163: "Execute a file of Lisp code named FILE.\n\ 164: First tries FILE with .elc appended, then tries with .el,\n\ 165: then tries FILE unmodified. Searches directories in load-path.\n\ 166: If optional second arg MISSING-OK is non-nil,\n\ 167: report no error if FILE doesn't exist.\n\ 168: Print messages at start and end of loading unless\n\ 169: optional third arg NOMESSAGE is non-nil.\n\ 170: Return t if file exists.") 171: (str, missing_ok, nomessage) 172: Lisp_Object str, missing_ok, nomessage; 173: { 174: register FILE *stream; 175: register int fd = -1; 176: register Lisp_Object lispstream; 177: int count = specpdl_ptr - specpdl; 178: struct gcpro gcpro1; 179: 180: CHECK_STRING (str, 0); 181: str = Fsubstitute_in_file_name (str); 182: 183: /* Avoid weird lossage with null string as arg, 184: since it would try to load a directory as a Lisp file */ 185: if (XSTRING (str)->size > 0) 186: { 187: fd = openp (Vload_path, str, ".elc", 0, 0); 188: if (fd < 0) 189: fd = openp (Vload_path, str, ".el", 0, 0); 190: if (fd < 0) 191: fd = openp (Vload_path, str, "", 0, 0); 192: } 193: 194: if (fd < 0) 195: if (NULL (missing_ok)) 196: while (1) 197: Fsignal (Qfile_error, Fcons (build_string ("Cannot open load file"), 198: Fcons (str, Qnil))); 199: else return Qnil; 200: 201: stream = fdopen (fd, "r"); 202: if (stream == 0) 203: { 204: close (fd); 205: error ("Failure to create stdio stream for %s", XSTRING (str)->data); 206: } 207: XSET (lispstream, Lisp_Internal_Stream, (int) stream); 208: 209: if (NULL (nomessage)) 210: message ("Loading %s...", XSTRING (str)->data); 211: 212: GCPRO1 (str); 213: record_unwind_protect (load_unwind, lispstream); 214: load_in_progress = 1; 215: readevalloop (Qget_file_char, stream, Feval, 0); 216: unbind_to (count); 217: UNGCPRO; 218: 219: if (!noninteractive && NULL (nomessage)) 220: message ("Loading %s...done", XSTRING (str)->data); 221: return Qt; 222: } 223: 224: /* exec_only nonzero means don't open the files, 225: just look for one that is executable; 226: returns 1 on success, having stored a string into *storeptr */ 227: 228: int 229: openp (path, str, suffix, storeptr, exec_only) 230: Lisp_Object path, str; 231: char *suffix; 232: Lisp_Object *storeptr; 233: int exec_only; 234: { 235: register int fd; 236: int fn_size = 100; 237: char buf[100]; 238: register char *fn = buf; 239: int absolute = 0; 240: int want_size; 241: register Lisp_Object filename; 242: struct stat st; 243: 244: if (storeptr) 245: *storeptr = Qnil; 246: 247: if (*XSTRING (str)->data == '~' || *XSTRING (str)->data == '/') 248: absolute = 1; 249: 250: for (; !NULL (path); path = Fcdr (path)) 251: { 252: filename = Fexpand_file_name (str, Fcar (path)); 253: 254: want_size = strlen (suffix) + XSTRING (filename)->size + 1; 255: if (fn_size < want_size) 256: fn = (char *) alloca (fn_size = 100 + want_size); 257: 258: strncpy (fn, XSTRING (filename)->data, XSTRING (filename)->size); 259: fn[XSTRING (filename)->size] = 0; 260: strcat (fn, suffix); 261: if (exec_only) 262: { 263: if (!access (fn, X_OK) && stat (fn, &st) >= 0 264: && (st.st_mode & S_IFMT) != S_IFDIR) 265: { 266: if (storeptr) 267: *storeptr = build_string (fn); 268: return 1; 269: } 270: } 271: else 272: { 273: fd = open (fn, 0, 0); 274: if (fd >= 0) 275: { 276: if (storeptr) 277: *storeptr = build_string (fn); 278: return fd; 279: } 280: } 281: if (absolute) return -1; 282: } 283: 284: return -1; 285: } 286: 287: Lisp_Object 288: load_unwind (stream) /* used as unwind-protect function in load */ 289: Lisp_Object stream; 290: { 291: fclose ((FILE *) XSTRING (stream)); 292: load_in_progress = 0; 293: return Qnil; 294: } 295: 296: Lisp_Object 297: unreadpure () /* Used as unwind-protect function in readevalloop */ 298: { 299: read_pure = 0; 300: return Qnil; 301: } 302: 303: void 304: readevalloop (readcharfun, stream, evalfun, printflag) 305: Lisp_Object readcharfun; 306: FILE *stream; 307: Lisp_Object (*evalfun) (); 308: int printflag; 309: { 310: register int c; 311: register Lisp_Object val; 312: register int xunrch; 313: int count = specpdl_ptr - specpdl; 314: 315: specbind (Qstandard_input, readcharfun); 316: 317: unrch = -1; 318: 319: while (1) 320: { 321: instream = stream; 322: c = READCHAR; 323: if (c == ';') 324: { 325: while ((c = READCHAR) != '\n' && c != -1); 326: continue; 327: } 328: if (c < 0) break; 329: if (c == ' ' || c == '\t' || c == '\n' || c == '\f') continue; 330: 331: if (!NULL (Vpurify_flag) && c == '(') 332: { 333: record_unwind_protect (unreadpure, Qnil); 334: val = read_list (-1, readcharfun); 335: unbind_to (count + 1); 336: } 337: else 338: { 339: UNREAD (c); 340: val = read0 (readcharfun); 341: } 342: 343: xunrch = unrch; 344: unrch = -1; 345: val = (*evalfun) (val); 346: if (printflag) 347: { 348: Vvalues = Fcons (val, Vvalues); 349: if (EQ (Vstandard_output, Qt)) 350: Fprin1 (val, Qnil); 351: else 352: Fprint (val, Qnil); 353: } 354: unrch = xunrch; 355: } 356: 357: unbind_to (count); 358: } 359: 360: #ifndef standalone 361: 362: DEFUN ("eval-current-buffer", Feval_current_buffer, Seval_current_buffer, 0, 1, "", 363: "Execute the current buffer as Lisp code.\n\ 364: Programs can pass argument PRINTFLAG which controls printing of output:\n\ 365: nil means discard it; anything else is stream for print.") 366: (printflag) 367: Lisp_Object printflag; 368: { 369: int count = specpdl_ptr - specpdl; 370: Lisp_Object tem; 371: if (NULL (printflag)) 372: tem = Qsymbolp; 373: else 374: tem = printflag; 375: specbind (Qstandard_output, tem); 376: record_unwind_protect (save_excursion_restore, save_excursion_save ()); 377: SetPoint (FirstCharacter); 378: readevalloop (Fcurrent_buffer (), 0, Feval, !NULL (printflag)); 379: unbind_to (count); 380: return Qnil; 381: } 382: 383: DEFUN ("eval-region", Feval_region, Seval_region, 2, 3, "r", 384: "Execute the region as Lisp code.\n\ 385: When called from programs, expects two arguments,\n\ 386: giving starting and ending indices in the current buffer\n\ 387: of the text to be executed.\n\ 388: Programs can pass third argument PRINTFLAG which controls printing of output:\n\ 389: nil means discard it; anything else is stream for print.") 390: (b, e, printflag) 391: Lisp_Object b, e, printflag; 392: { 393: int count = specpdl_ptr - specpdl; 394: Lisp_Object tem; 395: if (NULL (printflag)) 396: tem = Qsymbolp; 397: else 398: tem = printflag; 399: specbind (Qstandard_output, tem); 400: if (NULL (printflag)) 401: record_unwind_protect (save_excursion_restore, save_excursion_save ()); 402: record_unwind_protect (save_restriction_restore, save_restriction_save ()); 403: SetPoint (XINT (b)); 404: Fnarrow_to_region (make_number (FirstCharacter), e); 405: readevalloop (Fcurrent_buffer (), 0, Feval, !NULL (printflag)); 406: unbind_to (count); 407: return Qnil; 408: } 409: 410: #endif standalone 411: 412: DEFUN ("read", Fread, Sread, 0, 1, 0, 413: "Read one Lisp expression as text from STREAM, return as Lisp object.\n\ 414: If STREAM is nil, use the value of standard-input (which see).\n\ 415: STREAM or standard-input may be:\n\ 416: a buffer (read from point and advance it)\n\ 417: a marker (read from where it points and advance it)\n\ 418: a function (call it with no arguments for each character)\n\ 419: a string (takes text from string, starting at the beginning)\n\ 420: t (read text line using minibuffer and use it).") 421: (readcharfun) 422: Lisp_Object readcharfun; 423: { 424: extern Lisp_Object Fread_minibuffer (); 425: 426: unrch = -1; /* Allow buffering-back only within a read. */ 427: 428: if (NULL (readcharfun)) 429: readcharfun = Vstandard_input; 430: if (EQ (readcharfun, Qt)) 431: readcharfun = Qread_char; 432: 433: #ifndef standalone 434: if (EQ (readcharfun, Qread_char)) 435: return Fread_minibuffer (build_string ("Lisp expression: "), Qnil); 436: #endif 437: 438: if (XTYPE (readcharfun) == Lisp_String) 439: return Fcar (Fread_from_string (readcharfun, Qnil, Qnil)); 440: 441: return read0 (readcharfun); 442: } 443: 444: DEFUN ("read-from-string", Fread_from_string, Sread_from_string, 1, 3, 0, 445: "Read one Lisp expression which is represented as text by STRING.\n\ 446: Returns a cons: (OBJECT-READ . FINAL-STRING-INDEX).\n\ 447: START and END optionally delimit a substring of STRING from which to read;\n\ 448: they default to 0 and (length STRING) respectively.") 449: (string, start, end) 450: Lisp_Object string, start, end; 451: { 452: int startval, endval; 453: Lisp_Object tem; 454: 455: CHECK_STRING (string,0); 456: 457: if (NULL (end)) 458: endval = XSTRING (string)->size; 459: else 460: { CHECK_NUMBER (end,2); 461: endval = XINT (end); 462: if (endval < 0 || endval > XSTRING (string)->size) 463: args_out_of_range (string, end); 464: } 465: 466: if (NULL (start)) 467: startval = 0; 468: else 469: { CHECK_NUMBER (start,1); 470: startval = XINT (start); 471: if (startval < 0 || startval > endval) 472: args_out_of_range (string, start); 473: } 474: 475: read_from_string_index = startval; 476: read_from_string_limit = endval; 477: 478: unrch = -1; /* Allow buffering-back only within a read. */ 479: 480: tem = read0 (string); 481: return Fcons (tem, make_number (read_from_string_index)); 482: } 483: 484: /* Use this for recursive reads, in contexts where internal tokens are not allowed. */ 485: 486: static Lisp_Object 487: read0 (readcharfun) 488: Lisp_Object readcharfun; 489: { 490: register Lisp_Object val; 491: char c; 492: 493: val = read1 (readcharfun); 494: if (XTYPE (val) == Lisp_Internal) 495: { 496: c = XINT (val); 497: return Fsignal (Qinvalid_read_syntax, Fcons (make_string (&c, 1), Qnil)); 498: } 499: 500: return val; 501: } 502: 503: static int read_buffer_size; 504: static char *read_buffer; 505: 506: static Lisp_Object 507: read1 (readcharfun) 508: register Lisp_Object readcharfun; 509: { 510: register int c; 511: 512: retry: 513: 514: c = READCHAR; 515: if (c < 0) return Fsignal (Qend_of_file, Qnil); 516: 517: switch (c) 518: { 519: case '(': 520: return read_list (0, readcharfun); 521: 522: case '[': 523: return read_vector (readcharfun); 524: 525: case ')': 526: case ']': 527: case '.': 528: { 529: register Lisp_Object val; 530: XSET (val, Lisp_Internal, c); 531: return val; 532: } 533: 534: case '#': 535: return Fsignal (Qinvalid_read_syntax, Fcons (make_string ("#", 1), Qnil)); 536: 537: case ';': 538: while ((c = READCHAR) >= 0 && c != '\n'); 539: goto retry; 540: 541: case '\'': 542: { 543: return Fcons (Qquote, Fcons (read0 (readcharfun), Qnil)); 544: } 545: 546: case '?': 547: { 548: register Lisp_Object val; 549: 550: XSET (val, Lisp_Int, READCHAR); 551: if (XFASTINT (val) == '\\') 552: XSETINT (val, read_escape (readcharfun)); 553: 554: return val; 555: } 556: 557: case '\"': 558: { 559: register char *p = read_buffer; 560: register char *end = read_buffer + read_buffer_size; 561: register int c; 562: int cancel = 0; 563: 564: while ((c = READCHAR) >= 0 && 565: (c != '\"' || (c = READCHAR) == '\"')) 566: { 567: if (p == end) 568: { 569: char *new = (char *) xrealloc (read_buffer, read_buffer_size *= 2); 570: p += new - read_buffer; 571: read_buffer += new - read_buffer; 572: end = read_buffer + read_buffer_size; 573: } 574: if (c == '\\') 575: c = read_escape (readcharfun); 576: /* c is -1 if \ newline has just been seen */ 577: if (c < 0) 578: { 579: if (p == read_buffer) 580: cancel = 1; 581: } 582: else 583: *p++ = c; 584: } 585: 586: UNREAD (c); 587: /* If purifying, and string starts with \ newline, 588: return zero instead. This is for doc strings 589: that we are really going to find in etc/DOC.nn.nn */ 590: if (!NULL (Vpurify_flag) && NULL (Vdoc_file_name) && cancel) 591: return make_number (0); 592: 593: if (read_pure) 594: return make_pure_string (read_buffer, p - read_buffer); 595: else 596: return make_string (read_buffer, p - read_buffer); 597: } 598: 599: default: 600: if (c <= 040) goto retry; 601: { 602: register char *p = read_buffer; 603: 604: { 605: register char *end = read_buffer + read_buffer_size; 606: 607: while (c > 040 && 608: !(c == '\"' || c == '\'' || c == ';' || c == '?' 609: || c == '(' || c == ')' || c =='.' 610: || c == '[' || c == ']' || c == '#' 611: )) 612: { 613: if (p == end) 614: { 615: register char *new = (char *) xrealloc (read_buffer, read_buffer_size *= 2); 616: p += new - read_buffer; 617: read_buffer += new - read_buffer; 618: end = read_buffer + read_buffer_size; 619: } 620: if (c == '\\') 621: c = READCHAR; 622: *p++ = c; 623: c = READCHAR; 624: } 625: 626: if (p == end) 627: { 628: char *new = (char *) xrealloc (read_buffer, read_buffer_size *= 2); 629: p += new - read_buffer; 630: read_buffer += new - read_buffer; 631: end = read_buffer + read_buffer_size; 632: } 633: *p = 0; 634: UNREAD (c); 635: } 636: 637: /* Is it an integer? */ 638: { 639: register char *p1; 640: register Lisp_Object val; 641: p1 = read_buffer; 642: if (*p1 == '+' || *p1 == '-') p1++; 643: if (p1 != p) 644: { 645: while (p1 != p && (c = *p1) >= '0' && c <= '9') p1++; 646: if (p1 == p) 647: /* It is. */ 648: { 649: XSET (val, Lisp_Int, atoi (read_buffer)); 650: return val; 651: } 652: } 653: } 654: 655: return intern (read_buffer); 656: } 657: } 658: } 659: 660: static Lisp_Object 661: read_vector (readcharfun) 662: Lisp_Object readcharfun; 663: { 664: register int i; 665: register int size; 666: register Lisp_Object *ptr; 667: register Lisp_Object tem, vector; 668: register struct Lisp_Cons *otem; 669: Lisp_Object len; 670: 671: tem = read_list (1, readcharfun); 672: len = Flength (tem); 673: vector = (read_pure ? make_pure_vector (XINT (len)) : Fmake_vector (len, Qnil)); 674: 675: 676: size = XVECTOR (vector)->size; 677: ptr = XVECTOR (vector)->contents; 678: for (i = 0; i < size; i++) 679: { 680: ptr[i] = read_pure ? Fpurecopy (Fcar (tem)) : Fcar (tem); 681: otem = XCONS (tem); 682: tem = Fcdr (tem); 683: free_cons (otem); 684: } 685: return vector; 686: } 687: 688: /* flag = 1 means check for ] to terminate rather than ) and . 689: flag = -1 means check for starting with defun 690: and make structure pure. */ 691: 692: static Lisp_Object 693: read_list (flag, readcharfun) 694: int flag; 695: register Lisp_Object readcharfun; 696: { 697: /* -1 means check next element for defun, 698: 0 means don't check, 699: 1 means already checked and found defun. */ 700: int defunflag = flag < 0 ? -1 : 0; 701: register Lisp_Object elt, val, tail, tem; 702: 703: val = Qnil; 704: tail = Qnil; 705: 706: while (1) 707: { 708: elt = read1 (readcharfun); 709: if (XTYPE (elt) == Lisp_Internal) 710: { 711: if (flag > 0) 712: { 713: if (XINT (elt) == ']') 714: return val; 715: return Fsignal (Qinvalid_read_syntax, Fcons (make_string (") or . in a vector", 18), Qnil)); 716: } 717: if (XINT (elt) == ')') 718: return val; 719: if (XINT (elt) == '.') 720: { 721: if (!NULL (tail)) 722: tail = XCONS (tail)->cdr = read0 (readcharfun); 723: else 724: val = read0 (readcharfun); 725: elt = read1 (readcharfun); 726: if (XTYPE (elt) == Lisp_Internal && XINT (elt) == ')') 727: return val; 728: return Fsignal (Qinvalid_read_syntax, Fcons (make_string (". in wrong context", 18), Qnil)); 729: } 730: return Fsignal (Qinvalid_read_syntax, Fcons (make_string ("] in a vector", 13), Qnil)); 731: } 732: tem = (read_pure && flag <= 0 733: ? pure_cons (elt, Qnil) 734: : Fcons (elt, Qnil)); 735: if (!NULL (tail)) 736: XCONS (tail)->cdr = tem; 737: else 738: val = tem; 739: tail = tem; 740: if (defunflag < 0) 741: defunflag = EQ (elt, Qdefun); 742: else if (defunflag > 0) 743: read_pure = 1; 744: } 745: } 746: 747: static int 748: read_escape (readcharfun) 749: Lisp_Object readcharfun; 750: { 751: register int c = READCHAR; 752: switch (c) 753: { 754: case 'a': 755: return '\a'; 756: case 'b': 757: return '\b'; 758: case 'e': 759: return 033; 760: case 'f': 761: return '\f'; 762: case 'n': 763: return '\n'; 764: case 'r': 765: return '\r'; 766: case 't': 767: return '\t'; 768: case 'v': 769: return '\v'; 770: case '\n': 771: return -1; 772: 773: case 'M': 774: c = READCHAR; 775: if (c != '-') 776: error ("Invalid escape character syntax"); 777: c = READCHAR; 778: if (c == '\\') 779: c = read_escape (readcharfun); 780: return c | 0200; 781: 782: case 'C': 783: c = READCHAR; 784: if (c != '-') 785: error ("Invalid escape character syntax"); 786: case '^': 787: c = READCHAR; 788: if (c == '\\') 789: c = read_escape (readcharfun); 790: if (c == '?') 791: return 0177; 792: return (c & 0200) | (c & 037); 793: 794: case '0': 795: case '1': 796: case '2': 797: case '3': 798: case '4': 799: case '5': 800: case '6': 801: case '7': 802: { 803: register int i = c - '0'; 804: register int count = 0; 805: while (++count < 3) 806: { 807: if ((c = READCHAR) >= '0' && c <= '7') 808: { 809: i *= 8; 810: i += c - '0'; 811: } 812: else 813: { 814: UNREAD (c); 815: break; 816: } 817: } 818: return i; 819: } 820: default: 821: return c; 822: } 823: } 824: 825: Lisp_Object Vobarray; 826: Lisp_Object initial_obarray; 827: 828: /* CHECK_OBARRAY assumes the variable `tem' is available */ 829: #define CHECK_OBARRAY(obarray) \ 830: if (XTYPE (obarray) != Lisp_Vector) \ 831: { tem = obarray; obarray = initial_obarray; \ 832: wrong_type_argument (Qvectorp, tem); } 833: 834: static int hash_string (); 835: Lisp_Object oblookup (); 836: 837: Lisp_Object 838: intern (str) 839: char *str; 840: { 841: Lisp_Object tem; 842: int len = strlen (str); 843: CHECK_OBARRAY (Vobarray); 844: tem = oblookup (Vobarray, str, len); 845: if (XTYPE (tem) == Lisp_Symbol) 846: return tem; 847: return Fintern ((!NULL (Vpurify_flag) 848: ? make_pure_string (str, len) 849: : make_string (str, len)), 850: Vobarray); 851: } 852: 853: DEFUN ("intern", Fintern, Sintern, 1, 2, 0, 854: "Return the symbol whose name is STRING.\n\ 855: A second optional argument specifies the obarray to use;\n\ 856: it defaults to the value of obarray.") 857: (str, obarray) 858: Lisp_Object str, obarray; 859: { 860: register Lisp_Object tem, sym, *ptr; 861: 862: if (NULL (obarray)) 863: { 864: CHECK_OBARRAY (Vobarray); 865: obarray = Vobarray; 866: } 867: else 868: CHECK_VECTOR (obarray, 1); 869: 870: CHECK_STRING (str, 0); 871: 872: tem = oblookup (obarray, XSTRING (str)->data, XSTRING (str)->size); 873: if (XTYPE (tem) != Lisp_Int) 874: return tem; 875: 876: if (!NULL (Vpurify_flag)) 877: str = Fpurecopy (str); 878: sym = Fmake_symbol (str); 879: 880: ptr = &XVECTOR (obarray)->contents[XINT (tem)]; 881: if (XTYPE (*ptr) == Lisp_Symbol) 882: XSYMBOL (sym)->next = XSYMBOL (*ptr); 883: else 884: XSYMBOL (sym)->next = 0; 885: *ptr = sym; 886: return sym; 887: } 888: 889: DEFUN ("intern-soft", Fintern_soft, Sintern_soft, 1, 2, 0, 890: "Return the symbol whose name is STRING, or nil if none exists yet.\n\ 891: A second optional argument specifies the obarray to use;\n\ 892: it defaults to the value of obarray.") 893: (str, obarray) 894: Lisp_Object str, obarray; 895: { 896: register Lisp_Object tem; 897: 898: if (NULL (obarray)) 899: { 900: CHECK_OBARRAY (Vobarray); 901: obarray = Vobarray; 902: } 903: else 904: CHECK_VECTOR (obarray, 1); 905: 906: CHECK_STRING (str, 0); 907: 908: tem = oblookup (obarray, XSTRING (str)->data, XSTRING (str)->size); 909: if (XTYPE (tem) != Lisp_Int) 910: return tem; 911: return Qnil; 912: } 913: 914: Lisp_Object 915: oblookup (obarray, ptr, size) 916: Lisp_Object obarray; 917: register char *ptr; 918: register int size; 919: { 920: int hash, obsize; 921: register Lisp_Object tail; 922: Lisp_Object bucket, tem; 923: 924: if (XTYPE (obarray) != Lisp_Vector || !(obsize = XVECTOR (obarray)->size)) 925: error ("Invalid obarray"); 926: hash = hash_string (ptr, size) % obsize; 927: bucket = XVECTOR (obarray)->contents[hash]; 928: for (tail = bucket; XSYMBOL (tail); XSETSYMBOL (tail, XSYMBOL (tail)->next)) 929: { 930: if (XSYMBOL (tail)->name->size != size) continue; 931: if (bcmp (XSYMBOL (tail)->name->data, ptr, size)) continue; 932: return tail; 933: } 934: 935: XSET (tem, Lisp_Int, hash); 936: return tem; 937: } 938: 939: static int 940: hash_string (ptr, len) 941: unsigned char *ptr; 942: int len; 943: { 944: register unsigned char *p = ptr; 945: register unsigned char *end = p + len; 946: register unsigned char c; 947: register int hash = 0; 948: 949: while (p != end) 950: { 951: c = *p++; 952: if (c >= 0140) c -= 40; 953: hash = ((hash<<3) + (hash>>28) + c); 954: } 955: return hash & 07777777777; 956: } 957: 958: void 959: map_obarray (obarray, fn, arg) 960: Lisp_Object obarray; 961: int (*fn) (); 962: Lisp_Object arg; 963: { 964: register int i; 965: register Lisp_Object tail; 966: CHECK_VECTOR (obarray, 1); 967: for (i = XVECTOR (obarray)->size - 1; i >= 0; i--) 968: for (tail = XVECTOR (obarray)->contents[i]; 969: XTYPE (tail) == Lisp_Symbol && XSYMBOL (tail); 970: XSETSYMBOL (tail, XSYMBOL (tail)->next)) 971: (*fn) (tail, arg); 972: } 973: 974: mapatoms_1 (sym, function) 975: Lisp_Object sym, function; 976: { 977: call1 (function, sym); 978: } 979: 980: DEFUN ("mapatoms", Fmapatoms, Smapatoms, 1, 2, 0, 981: "Call FUNCTION on every symbol in OBARRAY.\n\ 982: OBARRAY defaults to the value of obarray.") 983: (function, obarray) 984: Lisp_Object function, obarray; 985: { 986: Lisp_Object tem; 987: 988: if (NULL (obarray)) 989: { 990: CHECK_OBARRAY (Vobarray); 991: obarray = Vobarray; 992: } 993: else 994: CHECK_VECTOR (obarray, 1); 995: 996: map_obarray (obarray, mapatoms_1, function); 997: return Qnil; 998: } 999: 1000: #define OBARRAY_SIZE 511 1001: 1002: void 1003: init_obarray () 1004: { 1005: Lisp_Object oblength; 1006: int hash; 1007: Lisp_Object *tem; 1008: 1009: XFASTINT (oblength) = OBARRAY_SIZE; 1010: 1011: Qnil = Fmake_symbol (make_pure_string ("nil", 3)); 1012: Vobarray = Fmake_vector (oblength, make_number (0)); 1013: initial_obarray = Vobarray; 1014: staticpro (&Vobarray); 1015: staticpro (&initial_obarray); 1016: /* Intern nil in the obarray */ 1017: /* These locals are to kludge around a pyramid compiler bug. */ 1018: hash = hash_string ("nil", 3) % OBARRAY_SIZE; 1019: tem = &XVECTOR (Vobarray)->contents[hash]; 1020: *tem = Qnil; 1021: 1022: Qunbound = Fmake_symbol (make_pure_string ("unbound", 7)); 1023: XSYMBOL (Qnil)->function = Qunbound; 1024: XSYMBOL (Qunbound)->value = Qunbound; 1025: XSYMBOL (Qunbound)->function = Qunbound; 1026: 1027: Qt = intern ("t"); 1028: XSYMBOL (Qnil)->value = Qnil; 1029: XSYMBOL (Qnil)->plist = Qnil; 1030: XSYMBOL (Qt)->value = Qt; 1031: 1032: Qvariable_documentation = intern ("variable-documentation"); 1033: 1034: read_buffer_size = 100; 1035: read_buffer = (char *) malloc (read_buffer_size); 1036: } 1037: 1038: void 1039: defsubr (sname) 1040: struct Lisp_Subr *sname; 1041: { 1042: Lisp_Object sym; 1043: sym = intern (sname->symbol_name); 1044: XSET (XSYMBOL (sym)->function, Lisp_Subr, sname); 1045: } 1046: 1047: void 1048: defalias (sname, string) 1049: struct Lisp_Subr *sname; 1050: char *string; 1051: { 1052: Lisp_Object sym; 1053: sym = intern (string); 1054: XSET (XSYMBOL (sym)->function, Lisp_Subr, sname); 1055: } 1056: 1057: /* Define an "integer variable"; a symbol whose value is forwarded 1058: to a C variable of type int. Sample call is 1059: DefIntVar ("indent-tabs-mode", &indent_tabs_mode, "Documentation"); */ 1060: 1061: void 1062: DefIntVar (namestring, address, doc) 1063: char *namestring; 1064: int *address; 1065: char *doc; 1066: { 1067: Lisp_Object sym; 1068: sym = intern (namestring); 1069: XSET (XSYMBOL (sym)->value, Lisp_Intfwd, address); 1070: Fput (sym, Qvariable_documentation, 1071: make_pure_string (doc, strlen (doc))); 1072: } 1073: 1074: /* Similar but define a variable whose value is T if address contains 1, 1075: NIL if address contains 0 */ 1076: 1077: void 1078: DefBoolVar (namestring, address, doc) 1079: char *namestring; 1080: int *address; 1081: char *doc; 1082: { 1083: Lisp_Object sym; 1084: sym = intern (namestring); 1085: XSET (XSYMBOL (sym)->value, Lisp_Boolfwd, address); 1086: Fput (sym, Qvariable_documentation, 1087: make_pure_string (doc, strlen (doc))); 1088: } 1089: 1090: /* Similar but define a variable whose value is the Lisp Object stored at address. */ 1091: 1092: void 1093: DefLispVar (namestring, address, doc) 1094: char *namestring; 1095: Lisp_Object *address; 1096: char *doc; 1097: { 1098: Lisp_Object sym; 1099: sym = intern (namestring); 1100: XSET (XSYMBOL (sym)->value, Lisp_Objfwd, address); 1101: Fput (sym, Qvariable_documentation, 1102: make_pure_string (doc, strlen (doc))); 1103: } 1104: 1105: #ifndef standalone 1106: 1107: /* Similar but define a variable whose value is the Lisp Object stored in 1108: the current buffer. address is the address of the slot in the buffer that is current now. */ 1109: 1110: void 1111: DefBufferLispVar (namestring, address, doc) 1112: char *namestring; 1113: Lisp_Object *address; 1114: char *doc; 1115: { 1116: Lisp_Object sym; 1117: sym = intern (namestring); 1118: XSET (XSYMBOL (sym)->value, Lisp_Buffer_Objfwd, 1119: (Lisp_Object *)((char *)address - (char *)bf_cur)); 1120: Fput (sym, Qvariable_documentation, 1121: make_pure_string (doc, strlen (doc))); 1122: } 1123: 1124: #endif standalone 1125: 1126: init_read () 1127: { 1128: Vvalues = Qnil; 1129: 1130: Vload_path = decode_env_path ("EMACSLOADPATH", PATH_LOADSEARCH); 1131: #ifndef CANNOT_DUMP 1132: if (!NULL (Vpurify_flag)) 1133: Vload_path = Fcons (build_string ("../lisp"), Vload_path); 1134: #endif /* not CANNOT_DUMP */ 1135: } 1136: 1137: void 1138: syms_of_read () 1139: { 1140: defsubr (&Sread); 1141: defsubr (&Sread_from_string); 1142: defsubr (&Sintern); 1143: defsubr (&Sintern_soft); 1144: defsubr (&Sload); 1145: defsubr (&Seval_current_buffer); 1146: defsubr (&Seval_region); 1147: defsubr (&Sread_char); 1148: defsubr (&Sget_file_char); 1149: defsubr (&Smapatoms); 1150: 1151: DefLispVar ("obarray", &Vobarray, 1152: "Symbol table for use by intern and read.\n\ 1153: It is a vector whose length ought to be prime for best results.\n\ 1154: Each element is a list of all interned symbols whose names hash in that bucket."); 1155: 1156: DefLispVar ("values", &Vvalues, 1157: "List of values of all expressions which were read, evaluated and printed.\n\ 1158: Order is reverse chronological."); 1159: 1160: DefLispVar ("standard-input", &Vstandard_input, 1161: "Stream for read to get input from.\n\ 1162: See documentation of read for possible values."); 1163: Vstandard_input = Qt; 1164: 1165: DefLispVar ("load-path", &Vload_path, 1166: "*List of directories to search for files to load.\n\ 1167: Each element is a string (directory name) or nil (try default directory).\n\ 1168: Initialized based on EMACSLOADPATH environment variable, if any,\n\ 1169: otherwise to default specified in by file paths.h when emacs was built."); 1170: 1171: DefBoolVar ("load-in-progress", &load_in_progress, 1172: "Non-nil iff inside of load."); 1173: 1174: Qstandard_input = intern ("standard-input"); 1175: staticpro (&Qstandard_input); 1176: 1177: Qread_char = intern ("read-char"); 1178: staticpro (&Qread_char); 1179: 1180: Qget_file_char = intern ("get-file-char"); 1181: staticpro (&Qget_file_char); 1182: 1183: unrch = -1; 1184: }