![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to lread.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 lread.c CVS log | Up to [CSRG BSD Unix] / 43BSD / contrib / emacs / src |
1.1 ! root 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: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.