|
|
1.1 ! root 1: /* Lisp parsing and input streams. ! 2: Copyright (C) 1985, 1986, 1987 Free Software Foundation, Inc. ! 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: /* non-zero if inside `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: { ! 118: register int c; ! 119: /* This used to be return of a conditional expression, ! 120: but that truncated -1 to a char on VMS. */ ! 121: if (read_from_string_index < read_from_string_limit) ! 122: c = XSTRING (readcharfun)->data[read_from_string_index++]; ! 123: else ! 124: c = -1; ! 125: return c; ! 126: } ! 127: ! 128: tem = call0 (readcharfun); ! 129: ! 130: if (NULL (tem)) ! 131: return -1; ! 132: return XINT (tem); ! 133: } ! 134: ! 135: #define READCHAR readchar(readcharfun) ! 136: #define UNREAD(c) (unrch = c) ! 137: ! 138: static Lisp_Object read0 (), read1 (), read_list (), read_vector (); ! 139: ! 140: /* get a character from the tty */ ! 141: ! 142: DEFUN ("read-char", Fread_char, Sread_char, 0, 0, 0, ! 143: "Read a character from the command input (keyboard or macro).\n\ ! 144: It is returned as a number.") ! 145: () ! 146: { ! 147: register Lisp_Object val; ! 148: ! 149: #ifndef standalone ! 150: XSET (val, Lisp_Int, get_char (0)); ! 151: #else ! 152: XSET (val, Lisp_Int, getchar ()); ! 153: #endif ! 154: ! 155: return val; ! 156: } ! 157: ! 158: DEFUN ("get-file-char", Fget_file_char, Sget_file_char, 0, 0, 0, ! 159: "Don't use this yourself.") ! 160: () ! 161: { ! 162: register Lisp_Object val; ! 163: XSET (val, Lisp_Int, getc (instream)); ! 164: return val; ! 165: } ! 166: ! 167: void readevalloop (); ! 168: static Lisp_Object load_unwind (); ! 169: ! 170: DEFUN ("load", Fload, Sload, 1, 4, 0, ! 171: "Execute a file of Lisp code named FILE.\n\ ! 172: First tries FILE with .elc appended, then tries with .el,\n\ ! 173: then tries FILE unmodified. Searches directories in load-path.\n\ ! 174: If optional second arg MISSING-OK is non-nil,\n\ ! 175: report no error if FILE doesn't exist.\n\ ! 176: Print messages at start and end of loading unless\n\ ! 177: optional third arg NOMESSAGE is non-nil.\n\ ! 178: If optional fourth arg NOSUFFIX is non-nil, don't try adding\n\ ! 179: suffixes .elc or .el to the specified name FILE.\n\ ! 180: Return t if file exists.") ! 181: (str, missing_ok, nomessage, nosuffix) ! 182: Lisp_Object str, missing_ok, nomessage, nosuffix; ! 183: { ! 184: register FILE *stream; ! 185: register int fd = -1; ! 186: register Lisp_Object lispstream; ! 187: register FILE **ptr; ! 188: int count = specpdl_ptr - specpdl; ! 189: struct gcpro gcpro1; ! 190: ! 191: CHECK_STRING (str, 0); ! 192: str = Fsubstitute_in_file_name (str); ! 193: ! 194: /* Avoid weird lossage with null string as arg, ! 195: since it would try to load a directory as a Lisp file */ ! 196: if (XSTRING (str)->size > 0) ! 197: { ! 198: fd = openp (Vload_path, str, !NULL (nosuffix) ? "" : ".elc:.el:", 0, 0); ! 199: } ! 200: ! 201: if (fd < 0) ! 202: if (NULL (missing_ok)) ! 203: while (1) ! 204: Fsignal (Qfile_error, Fcons (build_string ("Cannot open load file"), ! 205: Fcons (str, Qnil))); ! 206: else return Qnil; ! 207: ! 208: stream = fdopen (fd, "r"); ! 209: if (stream == 0) ! 210: { ! 211: close (fd); ! 212: error ("Failure to create stdio stream for %s", XSTRING (str)->data); ! 213: } ! 214: ! 215: if (NULL (nomessage)) ! 216: message ("Loading %s...", XSTRING (str)->data); ! 217: ! 218: GCPRO1 (str); ! 219: ptr = (FILE **) xmalloc (sizeof (FILE *)); ! 220: *ptr = stream; ! 221: XSET (lispstream, Lisp_Internal_Stream, (int) ptr); ! 222: record_unwind_protect (load_unwind, lispstream); ! 223: load_in_progress++; ! 224: readevalloop (Qget_file_char, stream, Feval, 0); ! 225: unbind_to (count); ! 226: UNGCPRO; ! 227: ! 228: if (!noninteractive && NULL (nomessage)) ! 229: message ("Loading %s...done", XSTRING (str)->data); ! 230: return Qt; ! 231: } ! 232: ! 233: static Lisp_Object ! 234: load_unwind (stream) /* used as unwind-protect function in load */ ! 235: Lisp_Object stream; ! 236: { ! 237: fclose (*(FILE **) XSTRING (stream)); ! 238: if (--load_in_progress < 0) load_in_progress = 0; ! 239: return Qnil; ! 240: } ! 241: ! 242: ! 243: static int ! 244: absolute_filename_p (pathname) ! 245: Lisp_Object pathname; ! 246: { ! 247: register unsigned char *s = XSTRING (pathname)->data; ! 248: return (*s == '~' || *s == '/' ! 249: #ifdef VMS ! 250: || index (s, ':') ! 251: #endif /* VMS */ ! 252: ); ! 253: } ! 254: ! 255: /* Search for a file whose name is STR, looking in directories ! 256: in the Lisp list PATH, and trying suffixes from SUFFIX. ! 257: SUFFIX is a string containing possible suffixes separated by colons. ! 258: On success, returns a file descriptor. On failure, returns -1. ! 259: ! 260: EXEC_ONLY nonzero means don't open the files, ! 261: just look for one that is executable. In this case, ! 262: returns 1 on success. ! 263: ! 264: If STOREPTR is nonzero, it points to a slot where the name of ! 265: the file actually found should be stored as a Lisp string. ! 266: Nil is stored there on failure. */ ! 267: ! 268: int ! 269: openp (path, str, suffix, storeptr, exec_only) ! 270: Lisp_Object path, str; ! 271: char *suffix; ! 272: Lisp_Object *storeptr; ! 273: int exec_only; ! 274: { ! 275: register int fd; ! 276: int fn_size = 100; ! 277: char buf[100]; ! 278: register char *fn = buf; ! 279: int absolute = 0; ! 280: int want_size; ! 281: register Lisp_Object filename; ! 282: struct stat st; ! 283: ! 284: if (storeptr) ! 285: *storeptr = Qnil; ! 286: ! 287: if (absolute_filename_p (str)) ! 288: absolute = 1; ! 289: ! 290: for (; !NULL (path); path = Fcdr (path)) ! 291: { ! 292: char *nsuffix; ! 293: ! 294: filename = Fexpand_file_name (str, Fcar (path)); ! 295: if (!absolute_filename_p (filename)) ! 296: /* If there are non-absolute elts in PATH (eg ".") */ ! 297: /* Of course, this could conceivably lose if luser sets ! 298: default-directory to be something non-absolute... */ ! 299: { ! 300: filename = Fexpand_file_name (filename, bf_cur->directory); ! 301: if (!absolute_filename_p (filename)) ! 302: /* Give up on this path element! */ ! 303: continue; ! 304: } ! 305: ! 306: /* Calculate maximum size of any filename made from ! 307: this path element/specified file name and any possible suffix. */ ! 308: want_size = strlen (suffix) + XSTRING (filename)->size + 1; ! 309: if (fn_size < want_size) ! 310: fn = (char *) alloca (fn_size = 100 + want_size); ! 311: ! 312: nsuffix = suffix; ! 313: ! 314: /* Loop over suffixes. */ ! 315: while (1) ! 316: { ! 317: char *esuffix = (char *) index (nsuffix, ':'); ! 318: int lsuffix = esuffix ? esuffix - nsuffix : strlen (nsuffix); ! 319: ! 320: /* Concatenate path element/specified name with the suffix. */ ! 321: strncpy (fn, XSTRING (filename)->data, XSTRING (filename)->size); ! 322: fn[XSTRING (filename)->size] = 0; ! 323: if (lsuffix != 0) /* Bug happens on CCI if lsuffix is 0. */ ! 324: strncat (fn, nsuffix, lsuffix); ! 325: ! 326: /* Ignore file if it's a directory. */ ! 327: if (stat (fn, &st) >= 0 ! 328: && (st.st_mode & S_IFMT) != S_IFDIR) ! 329: { ! 330: /* Check that we can access or open it. */ ! 331: if (exec_only) ! 332: fd = !access (fn, X_OK); ! 333: else ! 334: fd = open (fn, 0, 0); ! 335: ! 336: if (fd >= 0) ! 337: { ! 338: /* We succeeded; return this descriptor and filename. */ ! 339: if (storeptr) ! 340: *storeptr = build_string (fn); ! 341: return fd; ! 342: } ! 343: } ! 344: ! 345: /* Advance to next suffix. */ ! 346: if (esuffix == 0) ! 347: break; ! 348: nsuffix += lsuffix + 1; ! 349: } ! 350: if (absolute) return -1; ! 351: } ! 352: ! 353: return -1; ! 354: } ! 355: ! 356: ! 357: Lisp_Object ! 358: unreadpure () /* Used as unwind-protect function in readevalloop */ ! 359: { ! 360: read_pure = 0; ! 361: return Qnil; ! 362: } ! 363: ! 364: static void ! 365: readevalloop (readcharfun, stream, evalfun, printflag) ! 366: Lisp_Object readcharfun; ! 367: FILE *stream; ! 368: Lisp_Object (*evalfun) (); ! 369: int printflag; ! 370: { ! 371: register int c; ! 372: register Lisp_Object val; ! 373: register int xunrch; ! 374: int count = specpdl_ptr - specpdl; ! 375: ! 376: specbind (Qstandard_input, readcharfun); ! 377: ! 378: unrch = -1; ! 379: ! 380: while (1) ! 381: { ! 382: instream = stream; ! 383: c = READCHAR; ! 384: if (c == ';') ! 385: { ! 386: while ((c = READCHAR) != '\n' && c != -1); ! 387: continue; ! 388: } ! 389: if (c < 0) break; ! 390: if (c == ' ' || c == '\t' || c == '\n' || c == '\f') continue; ! 391: ! 392: if (!NULL (Vpurify_flag) && c == '(') ! 393: { ! 394: record_unwind_protect (unreadpure, Qnil); ! 395: val = read_list (-1, readcharfun); ! 396: unbind_to (count + 1); ! 397: } ! 398: else ! 399: { ! 400: UNREAD (c); ! 401: val = read0 (readcharfun); ! 402: } ! 403: ! 404: xunrch = unrch; ! 405: unrch = -1; ! 406: val = (*evalfun) (val); ! 407: if (printflag) ! 408: { ! 409: Vvalues = Fcons (val, Vvalues); ! 410: if (EQ (Vstandard_output, Qt)) ! 411: Fprin1 (val, Qnil); ! 412: else ! 413: Fprint (val, Qnil); ! 414: } ! 415: unrch = xunrch; ! 416: } ! 417: ! 418: unbind_to (count); ! 419: } ! 420: ! 421: #ifndef standalone ! 422: ! 423: DEFUN ("eval-current-buffer", Feval_current_buffer, Seval_current_buffer, 0, 1, "", ! 424: "Execute the current buffer as Lisp code.\n\ ! 425: Programs can pass argument PRINTFLAG which controls printing of output:\n\ ! 426: nil means discard it; anything else is stream for print.") ! 427: (printflag) ! 428: Lisp_Object printflag; ! 429: { ! 430: int count = specpdl_ptr - specpdl; ! 431: Lisp_Object tem; ! 432: if (NULL (printflag)) ! 433: tem = Qsymbolp; ! 434: else ! 435: tem = printflag; ! 436: specbind (Qstandard_output, tem); ! 437: record_unwind_protect (save_excursion_restore, save_excursion_save ()); ! 438: SetPoint (FirstCharacter); ! 439: readevalloop (Fcurrent_buffer (), 0, Feval, !NULL (printflag)); ! 440: unbind_to (count); ! 441: return Qnil; ! 442: } ! 443: ! 444: DEFUN ("eval-region", Feval_region, Seval_region, 2, 3, "r", ! 445: "Execute the region as Lisp code.\n\ ! 446: When called from programs, expects two arguments,\n\ ! 447: giving starting and ending indices in the current buffer\n\ ! 448: of the text to be executed.\n\ ! 449: Programs can pass third argument PRINTFLAG which controls printing of output:\n\ ! 450: nil means discard it; anything else is stream for print.") ! 451: (b, e, printflag) ! 452: Lisp_Object b, e, printflag; ! 453: { ! 454: int count = specpdl_ptr - specpdl; ! 455: Lisp_Object tem; ! 456: if (NULL (printflag)) ! 457: tem = Qsymbolp; ! 458: else ! 459: tem = printflag; ! 460: specbind (Qstandard_output, tem); ! 461: if (NULL (printflag)) ! 462: record_unwind_protect (save_excursion_restore, save_excursion_save ()); ! 463: record_unwind_protect (save_restriction_restore, save_restriction_save ()); ! 464: SetPoint (XINT (b)); ! 465: Fnarrow_to_region (make_number (FirstCharacter), e); ! 466: readevalloop (Fcurrent_buffer (), 0, Feval, !NULL (printflag)); ! 467: unbind_to (count); ! 468: return Qnil; ! 469: } ! 470: ! 471: #endif standalone ! 472: ! 473: DEFUN ("read", Fread, Sread, 0, 1, 0, ! 474: "Read one Lisp expression as text from STREAM, return as Lisp object.\n\ ! 475: If STREAM is nil, use the value of standard-input (which see).\n\ ! 476: STREAM or standard-input may be:\n\ ! 477: a buffer (read from point and advance it)\n\ ! 478: a marker (read from where it points and advance it)\n\ ! 479: a function (call it with no arguments for each character)\n\ ! 480: a string (takes text from string, starting at the beginning)\n\ ! 481: t (read text line using minibuffer and use it).") ! 482: (readcharfun) ! 483: Lisp_Object readcharfun; ! 484: { ! 485: extern Lisp_Object Fread_minibuffer (); ! 486: ! 487: unrch = -1; /* Allow buffering-back only within a read. */ ! 488: ! 489: if (NULL (readcharfun)) ! 490: readcharfun = Vstandard_input; ! 491: if (EQ (readcharfun, Qt)) ! 492: readcharfun = Qread_char; ! 493: ! 494: #ifndef standalone ! 495: if (EQ (readcharfun, Qread_char)) ! 496: return Fread_minibuffer (build_string ("Lisp expression: "), Qnil); ! 497: #endif ! 498: ! 499: if (XTYPE (readcharfun) == Lisp_String) ! 500: return Fcar (Fread_from_string (readcharfun, Qnil, Qnil)); ! 501: ! 502: return read0 (readcharfun); ! 503: } ! 504: ! 505: DEFUN ("read-from-string", Fread_from_string, Sread_from_string, 1, 3, 0, ! 506: "Read one Lisp expression which is represented as text by STRING.\n\ ! 507: Returns a cons: (OBJECT-READ . FINAL-STRING-INDEX).\n\ ! 508: START and END optionally delimit a substring of STRING from which to read;\n\ ! 509: they default to 0 and (length STRING) respectively.") ! 510: (string, start, end) ! 511: Lisp_Object string, start, end; ! 512: { ! 513: int startval, endval; ! 514: Lisp_Object tem; ! 515: ! 516: CHECK_STRING (string,0); ! 517: ! 518: if (NULL (end)) ! 519: endval = XSTRING (string)->size; ! 520: else ! 521: { CHECK_NUMBER (end,2); ! 522: endval = XINT (end); ! 523: if (endval < 0 || endval > XSTRING (string)->size) ! 524: args_out_of_range (string, end); ! 525: } ! 526: ! 527: if (NULL (start)) ! 528: startval = 0; ! 529: else ! 530: { CHECK_NUMBER (start,1); ! 531: startval = XINT (start); ! 532: if (startval < 0 || startval > endval) ! 533: args_out_of_range (string, start); ! 534: } ! 535: ! 536: read_from_string_index = startval; ! 537: read_from_string_limit = endval; ! 538: ! 539: unrch = -1; /* Allow buffering-back only within a read. */ ! 540: ! 541: tem = read0 (string); ! 542: return Fcons (tem, make_number (read_from_string_index)); ! 543: } ! 544: ! 545: /* Use this for recursive reads, in contexts where internal tokens are not allowed. */ ! 546: ! 547: static Lisp_Object ! 548: read0 (readcharfun) ! 549: Lisp_Object readcharfun; ! 550: { ! 551: register Lisp_Object val; ! 552: char c; ! 553: ! 554: val = read1 (readcharfun); ! 555: if (XTYPE (val) == Lisp_Internal) ! 556: { ! 557: c = XINT (val); ! 558: return Fsignal (Qinvalid_read_syntax, Fcons (make_string (&c, 1), Qnil)); ! 559: } ! 560: ! 561: return val; ! 562: } ! 563: ! 564: static int read_buffer_size; ! 565: static char *read_buffer; ! 566: ! 567: static Lisp_Object ! 568: read1 (readcharfun) ! 569: register Lisp_Object readcharfun; ! 570: { ! 571: register int c; ! 572: ! 573: retry: ! 574: ! 575: c = READCHAR; ! 576: if (c < 0) return Fsignal (Qend_of_file, Qnil); ! 577: ! 578: switch (c) ! 579: { ! 580: case '(': ! 581: return read_list (0, readcharfun); ! 582: ! 583: case '[': ! 584: return read_vector (readcharfun); ! 585: ! 586: case ')': ! 587: case ']': ! 588: case '.': ! 589: { ! 590: register Lisp_Object val; ! 591: XSET (val, Lisp_Internal, c); ! 592: return val; ! 593: } ! 594: ! 595: case '#': ! 596: return Fsignal (Qinvalid_read_syntax, Fcons (make_string ("#", 1), Qnil)); ! 597: ! 598: case ';': ! 599: while ((c = READCHAR) >= 0 && c != '\n'); ! 600: goto retry; ! 601: ! 602: case '\'': ! 603: { ! 604: return Fcons (Qquote, Fcons (read0 (readcharfun), Qnil)); ! 605: } ! 606: ! 607: case '?': ! 608: { ! 609: register Lisp_Object val; ! 610: ! 611: XSET (val, Lisp_Int, READCHAR); ! 612: if (XFASTINT (val) == '\\') ! 613: XSETINT (val, read_escape (readcharfun)); ! 614: ! 615: return val; ! 616: } ! 617: ! 618: case '\"': ! 619: { ! 620: register char *p = read_buffer; ! 621: register char *end = read_buffer + read_buffer_size; ! 622: register int c; ! 623: int cancel = 0; ! 624: ! 625: while ((c = READCHAR) >= 0 && ! 626: (c != '\"' || (c = READCHAR) == '\"')) ! 627: { ! 628: if (p == end) ! 629: { ! 630: char *new = (char *) xrealloc (read_buffer, read_buffer_size *= 2); ! 631: p += new - read_buffer; ! 632: read_buffer += new - read_buffer; ! 633: end = read_buffer + read_buffer_size; ! 634: } ! 635: if (c == '\\') ! 636: c = read_escape (readcharfun); ! 637: /* c is -1 if \ newline has just been seen */ ! 638: if (c < 0) ! 639: { ! 640: if (p == read_buffer) ! 641: cancel = 1; ! 642: } ! 643: else ! 644: *p++ = c; ! 645: } ! 646: ! 647: UNREAD (c); ! 648: /* If purifying, and string starts with \ newline, ! 649: return zero instead. This is for doc strings ! 650: that we are really going to find in etc/DOC.nn.nn */ ! 651: if (!NULL (Vpurify_flag) && NULL (Vdoc_file_name) && cancel) ! 652: return make_number (0); ! 653: ! 654: if (read_pure) ! 655: return make_pure_string (read_buffer, p - read_buffer); ! 656: else ! 657: return make_string (read_buffer, p - read_buffer); ! 658: } ! 659: ! 660: default: ! 661: if (c <= 040) goto retry; ! 662: { ! 663: register char *p = read_buffer; ! 664: ! 665: { ! 666: register char *end = read_buffer + read_buffer_size; ! 667: ! 668: while (c > 040 && ! 669: !(c == '\"' || c == '\'' || c == ';' || c == '?' ! 670: || c == '(' || c == ')' || c =='.' ! 671: || c == '[' || c == ']' || c == '#' ! 672: )) ! 673: { ! 674: if (p == end) ! 675: { ! 676: register char *new = (char *) xrealloc (read_buffer, read_buffer_size *= 2); ! 677: p += new - read_buffer; ! 678: read_buffer += new - read_buffer; ! 679: end = read_buffer + read_buffer_size; ! 680: } ! 681: if (c == '\\') ! 682: c = READCHAR; ! 683: *p++ = c; ! 684: c = READCHAR; ! 685: } ! 686: ! 687: if (p == end) ! 688: { ! 689: char *new = (char *) xrealloc (read_buffer, read_buffer_size *= 2); ! 690: p += new - read_buffer; ! 691: read_buffer += new - read_buffer; ! 692: /* end = read_buffer + read_buffer_size; */ ! 693: } ! 694: *p = 0; ! 695: UNREAD (c); ! 696: } ! 697: ! 698: /* Is it an integer? */ ! 699: { ! 700: register char *p1; ! 701: register Lisp_Object val; ! 702: p1 = read_buffer; ! 703: if (*p1 == '+' || *p1 == '-') p1++; ! 704: if (p1 != p) ! 705: { ! 706: while (p1 != p && (c = *p1) >= '0' && c <= '9') p1++; ! 707: if (p1 == p) ! 708: /* It is. */ ! 709: { ! 710: XSET (val, Lisp_Int, atoi (read_buffer)); ! 711: return val; ! 712: } ! 713: } ! 714: } ! 715: ! 716: return intern (read_buffer); ! 717: } ! 718: } ! 719: } ! 720: ! 721: static Lisp_Object ! 722: read_vector (readcharfun) ! 723: Lisp_Object readcharfun; ! 724: { ! 725: register int i; ! 726: register int size; ! 727: register Lisp_Object *ptr; ! 728: register Lisp_Object tem, vector; ! 729: register struct Lisp_Cons *otem; ! 730: Lisp_Object len; ! 731: ! 732: tem = read_list (1, readcharfun); ! 733: len = Flength (tem); ! 734: vector = (read_pure ? make_pure_vector (XINT (len)) : Fmake_vector (len, Qnil)); ! 735: ! 736: ! 737: size = XVECTOR (vector)->size; ! 738: ptr = XVECTOR (vector)->contents; ! 739: for (i = 0; i < size; i++) ! 740: { ! 741: ptr[i] = read_pure ? Fpurecopy (Fcar (tem)) : Fcar (tem); ! 742: otem = XCONS (tem); ! 743: tem = Fcdr (tem); ! 744: free_cons (otem); ! 745: } ! 746: return vector; ! 747: } ! 748: ! 749: /* flag = 1 means check for ] to terminate rather than ) and . ! 750: flag = -1 means check for starting with defun ! 751: and make structure pure. */ ! 752: ! 753: static Lisp_Object ! 754: read_list (flag, readcharfun) ! 755: int flag; ! 756: register Lisp_Object readcharfun; ! 757: { ! 758: /* -1 means check next element for defun, ! 759: 0 means don't check, ! 760: 1 means already checked and found defun. */ ! 761: int defunflag = flag < 0 ? -1 : 0; ! 762: Lisp_Object val, tail; ! 763: register Lisp_Object elt, tem; ! 764: struct gcpro gcpro1, gcpro2; ! 765: ! 766: val = Qnil; ! 767: tail = Qnil; ! 768: ! 769: while (1) ! 770: { ! 771: GCPRO2 (val, tail); ! 772: elt = read1 (readcharfun); ! 773: UNGCPRO; ! 774: if (XTYPE (elt) == Lisp_Internal) ! 775: { ! 776: if (flag > 0) ! 777: { ! 778: if (XINT (elt) == ']') ! 779: return val; ! 780: return Fsignal (Qinvalid_read_syntax, Fcons (make_string (") or . in a vector", 18), Qnil)); ! 781: } ! 782: if (XINT (elt) == ')') ! 783: return val; ! 784: if (XINT (elt) == '.') ! 785: { ! 786: GCPRO2 (val, tail); ! 787: if (!NULL (tail)) ! 788: XCONS (tail)->cdr = read0 (readcharfun); ! 789: else ! 790: val = read0 (readcharfun); ! 791: elt = read1 (readcharfun); ! 792: UNGCPRO; ! 793: if (XTYPE (elt) == Lisp_Internal && XINT (elt) == ')') ! 794: return val; ! 795: return Fsignal (Qinvalid_read_syntax, Fcons (make_string (". in wrong context", 18), Qnil)); ! 796: } ! 797: return Fsignal (Qinvalid_read_syntax, Fcons (make_string ("] in a list", 11), Qnil)); ! 798: } ! 799: tem = (read_pure && flag <= 0 ! 800: ? pure_cons (elt, Qnil) ! 801: : Fcons (elt, Qnil)); ! 802: if (!NULL (tail)) ! 803: XCONS (tail)->cdr = tem; ! 804: else ! 805: val = tem; ! 806: tail = tem; ! 807: if (defunflag < 0) ! 808: defunflag = EQ (elt, Qdefun); ! 809: else if (defunflag > 0) ! 810: read_pure = 1; ! 811: } ! 812: } ! 813: ! 814: static int ! 815: read_escape (readcharfun) ! 816: Lisp_Object readcharfun; ! 817: { ! 818: register int c = READCHAR; ! 819: switch (c) ! 820: { ! 821: case 'a': ! 822: return '\a'; ! 823: case 'b': ! 824: return '\b'; ! 825: case 'e': ! 826: return 033; ! 827: case 'f': ! 828: return '\f'; ! 829: case 'n': ! 830: return '\n'; ! 831: case 'r': ! 832: return '\r'; ! 833: case 't': ! 834: return '\t'; ! 835: case 'v': ! 836: return '\v'; ! 837: case '\n': ! 838: return -1; ! 839: ! 840: case 'M': ! 841: c = READCHAR; ! 842: if (c != '-') ! 843: error ("Invalid escape character syntax"); ! 844: c = READCHAR; ! 845: if (c == '\\') ! 846: c = read_escape (readcharfun); ! 847: return c | 0200; ! 848: ! 849: case 'C': ! 850: c = READCHAR; ! 851: if (c != '-') ! 852: error ("Invalid escape character syntax"); ! 853: case '^': ! 854: c = READCHAR; ! 855: if (c == '\\') ! 856: c = read_escape (readcharfun); ! 857: if (c == '?') ! 858: return 0177; ! 859: return (c & 0200) | (c & 037); ! 860: ! 861: case '0': ! 862: case '1': ! 863: case '2': ! 864: case '3': ! 865: case '4': ! 866: case '5': ! 867: case '6': ! 868: case '7': ! 869: { ! 870: register int i = c - '0'; ! 871: register int count = 0; ! 872: while (++count < 3) ! 873: { ! 874: if ((c = READCHAR) >= '0' && c <= '7') ! 875: { ! 876: i *= 8; ! 877: i += c - '0'; ! 878: } ! 879: else ! 880: { ! 881: UNREAD (c); ! 882: break; ! 883: } ! 884: } ! 885: return i; ! 886: } ! 887: default: ! 888: return c; ! 889: } ! 890: } ! 891: ! 892: Lisp_Object Vobarray; ! 893: Lisp_Object initial_obarray; ! 894: ! 895: Lisp_Object ! 896: check_obarray (obarray) ! 897: Lisp_Object obarray; ! 898: { ! 899: while (XTYPE (obarray) != Lisp_Vector || XVECTOR (obarray)->size == 0) ! 900: { ! 901: /* If Vobarray is now invalid, force it to be valid. */ ! 902: if (EQ (Vobarray, obarray)) Vobarray = initial_obarray; ! 903: ! 904: obarray = wrong_type_argument (Qvectorp, obarray); ! 905: } ! 906: return obarray; ! 907: } ! 908: ! 909: static int hash_string (); ! 910: Lisp_Object oblookup (); ! 911: ! 912: Lisp_Object ! 913: intern (str) ! 914: char *str; ! 915: { ! 916: Lisp_Object tem; ! 917: int len = strlen (str); ! 918: Lisp_Object obarray = Vobarray; ! 919: if (XTYPE (obarray) != Lisp_Vector || XVECTOR (obarray)->size == 0) ! 920: obarray = check_obarray (obarray); ! 921: tem = oblookup (obarray, str, len); ! 922: if (XTYPE (tem) == Lisp_Symbol) ! 923: return tem; ! 924: return Fintern ((!NULL (Vpurify_flag) ! 925: ? make_pure_string (str, len) ! 926: : make_string (str, len)), ! 927: obarray); ! 928: } ! 929: ! 930: DEFUN ("intern", Fintern, Sintern, 1, 2, 0, ! 931: "Return the symbol whose name is STRING.\n\ ! 932: A second optional argument specifies the obarray to use;\n\ ! 933: it defaults to the value of obarray.") ! 934: (str, obarray) ! 935: Lisp_Object str, obarray; ! 936: { ! 937: register Lisp_Object tem, sym, *ptr; ! 938: ! 939: if (NULL (obarray)) obarray = Vobarray; ! 940: obarray = check_obarray (obarray); ! 941: ! 942: CHECK_STRING (str, 0); ! 943: ! 944: tem = oblookup (obarray, XSTRING (str)->data, XSTRING (str)->size); ! 945: if (XTYPE (tem) != Lisp_Int) ! 946: return tem; ! 947: ! 948: if (!NULL (Vpurify_flag)) ! 949: str = Fpurecopy (str); ! 950: sym = Fmake_symbol (str); ! 951: ! 952: ptr = &XVECTOR (obarray)->contents[XINT (tem)]; ! 953: if (XTYPE (*ptr) == Lisp_Symbol) ! 954: XSYMBOL (sym)->next = XSYMBOL (*ptr); ! 955: else ! 956: XSYMBOL (sym)->next = 0; ! 957: *ptr = sym; ! 958: return sym; ! 959: } ! 960: ! 961: DEFUN ("intern-soft", Fintern_soft, Sintern_soft, 1, 2, 0, ! 962: "Return the symbol whose name is STRING, or nil if none exists yet.\n\ ! 963: A second optional argument specifies the obarray to use;\n\ ! 964: it defaults to the value of obarray.") ! 965: (str, obarray) ! 966: Lisp_Object str, obarray; ! 967: { ! 968: register Lisp_Object tem; ! 969: ! 970: if (NULL (obarray)) obarray = Vobarray; ! 971: obarray = check_obarray (obarray); ! 972: ! 973: CHECK_STRING (str, 0); ! 974: ! 975: tem = oblookup (obarray, XSTRING (str)->data, XSTRING (str)->size); ! 976: if (XTYPE (tem) != Lisp_Int) ! 977: return tem; ! 978: return Qnil; ! 979: } ! 980: ! 981: Lisp_Object ! 982: oblookup (obarray, ptr, size) ! 983: Lisp_Object obarray; ! 984: register char *ptr; ! 985: register int size; ! 986: { ! 987: int hash, obsize; ! 988: register Lisp_Object tail; ! 989: Lisp_Object bucket, tem; ! 990: ! 991: if (XTYPE (obarray) != Lisp_Vector || ! 992: (obsize = XVECTOR (obarray)->size) == 0) ! 993: { ! 994: obarray = check_obarray (obarray); ! 995: obsize = XVECTOR (obarray)->size; ! 996: } ! 997: /* Combining next two lines breaks VMS C 2.3. */ ! 998: hash = hash_string (ptr, size); ! 999: hash %= obsize; ! 1000: bucket = XVECTOR (obarray)->contents[hash]; ! 1001: if (XFASTINT (bucket) == 0) ! 1002: ; ! 1003: else if (XTYPE (bucket) != Lisp_Symbol) ! 1004: error ("Bad data in guts of obarray"); /* Like CADR error message */ ! 1005: else for (tail = bucket; ; XSET (tail, Lisp_Symbol, XSYMBOL (tail)->next)) ! 1006: { ! 1007: if (XSYMBOL (tail)->name->size == size && ! 1008: !bcmp (XSYMBOL (tail)->name->data, ptr, size)) ! 1009: return tail; ! 1010: else if (XSYMBOL (tail)->next == 0) ! 1011: break; ! 1012: } ! 1013: XSET (tem, Lisp_Int, hash); ! 1014: return tem; ! 1015: } ! 1016: ! 1017: static int ! 1018: hash_string (ptr, len) ! 1019: unsigned char *ptr; ! 1020: int len; ! 1021: { ! 1022: register unsigned char *p = ptr; ! 1023: register unsigned char *end = p + len; ! 1024: register unsigned char c; ! 1025: register int hash = 0; ! 1026: ! 1027: while (p != end) ! 1028: { ! 1029: c = *p++; ! 1030: if (c >= 0140) c -= 40; ! 1031: hash = ((hash<<3) + (hash>>28) + c); ! 1032: } ! 1033: return hash & 07777777777; ! 1034: } ! 1035: ! 1036: void ! 1037: map_obarray (obarray, fn, arg) ! 1038: Lisp_Object obarray; ! 1039: int (*fn) (); ! 1040: Lisp_Object arg; ! 1041: { ! 1042: register int i; ! 1043: register Lisp_Object tail; ! 1044: CHECK_VECTOR (obarray, 1); ! 1045: for (i = XVECTOR (obarray)->size - 1; i >= 0; i--) ! 1046: { ! 1047: tail = XVECTOR (obarray)->contents[i]; ! 1048: if (XFASTINT (tail) != 0) ! 1049: while (1) ! 1050: { ! 1051: (*fn) (tail, arg); ! 1052: if (XSYMBOL (tail)->next == 0) ! 1053: break; ! 1054: XSET (tail, Lisp_Symbol, XSYMBOL (tail)->next); ! 1055: } ! 1056: } ! 1057: } ! 1058: ! 1059: mapatoms_1 (sym, function) ! 1060: Lisp_Object sym, function; ! 1061: { ! 1062: call1 (function, sym); ! 1063: } ! 1064: ! 1065: DEFUN ("mapatoms", Fmapatoms, Smapatoms, 1, 2, 0, ! 1066: "Call FUNCTION on every symbol in OBARRAY.\n\ ! 1067: OBARRAY defaults to the value of obarray.") ! 1068: (function, obarray) ! 1069: Lisp_Object function, obarray; ! 1070: { ! 1071: Lisp_Object tem; ! 1072: ! 1073: if (NULL (obarray)) obarray = Vobarray; ! 1074: obarray = check_obarray (obarray); ! 1075: ! 1076: map_obarray (obarray, mapatoms_1, function); ! 1077: return Qnil; ! 1078: } ! 1079: ! 1080: #define OBARRAY_SIZE 511 ! 1081: ! 1082: void ! 1083: init_obarray () ! 1084: { ! 1085: Lisp_Object oblength; ! 1086: int hash; ! 1087: Lisp_Object *tem; ! 1088: ! 1089: XFASTINT (oblength) = OBARRAY_SIZE; ! 1090: ! 1091: Qnil = Fmake_symbol (make_pure_string ("nil", 3)); ! 1092: Vobarray = Fmake_vector (oblength, make_number (0)); ! 1093: initial_obarray = Vobarray; ! 1094: staticpro (&Vobarray); ! 1095: staticpro (&initial_obarray); ! 1096: /* Intern nil in the obarray */ ! 1097: /* These locals are to kludge around a pyramid compiler bug. */ ! 1098: hash = hash_string ("nil", 3); ! 1099: /* Separate statement here to avoid VAXC bug. */ ! 1100: hash %= OBARRAY_SIZE; ! 1101: tem = &XVECTOR (Vobarray)->contents[hash]; ! 1102: *tem = Qnil; ! 1103: ! 1104: Qunbound = Fmake_symbol (make_pure_string ("unbound", 7)); ! 1105: XSYMBOL (Qnil)->function = Qunbound; ! 1106: XSYMBOL (Qunbound)->value = Qunbound; ! 1107: XSYMBOL (Qunbound)->function = Qunbound; ! 1108: ! 1109: Qt = intern ("t"); ! 1110: XSYMBOL (Qnil)->value = Qnil; ! 1111: XSYMBOL (Qnil)->plist = Qnil; ! 1112: XSYMBOL (Qt)->value = Qt; ! 1113: ! 1114: /* Qt is correct even if CANNOT_DUMP. loadup.el will set to nil at end. */ ! 1115: Vpurify_flag = Qt; ! 1116: ! 1117: Qvariable_documentation = intern ("variable-documentation"); ! 1118: ! 1119: read_buffer_size = 100; ! 1120: read_buffer = (char *) malloc (read_buffer_size); ! 1121: } ! 1122: ! 1123: void ! 1124: defsubr (sname) ! 1125: struct Lisp_Subr *sname; ! 1126: { ! 1127: Lisp_Object sym; ! 1128: sym = intern (sname->symbol_name); ! 1129: XSET (XSYMBOL (sym)->function, Lisp_Subr, sname); ! 1130: } ! 1131: ! 1132: #ifdef NOTDEF /* use fset in subr.el now */ ! 1133: void ! 1134: defalias (sname, string) ! 1135: struct Lisp_Subr *sname; ! 1136: char *string; ! 1137: { ! 1138: Lisp_Object sym; ! 1139: sym = intern (string); ! 1140: XSET (XSYMBOL (sym)->function, Lisp_Subr, sname); ! 1141: } ! 1142: #endif NOTDEF ! 1143: ! 1144: /* New replacement for DefIntVar; it ignores the doc string argument ! 1145: on the assumption that make-docfile will handle that. */ ! 1146: /* Define an "integer variable"; a symbol whose value is forwarded ! 1147: to a C variable of type int. Sample call: */ ! 1148: /* DEFVARINT ("indent-tabs-mode", &indent_tabs_mode, "Documentation"); */ ! 1149: ! 1150: void ! 1151: defvar_int (namestring, address, doc) ! 1152: char *namestring; ! 1153: int *address; ! 1154: char *doc; ! 1155: { ! 1156: Lisp_Object sym; ! 1157: sym = intern (namestring); ! 1158: XSET (XSYMBOL (sym)->value, Lisp_Intfwd, address); ! 1159: } ! 1160: ! 1161: /* Similar but define a variable whose value is T if address contains 1, ! 1162: NIL if address contains 0 */ ! 1163: ! 1164: void ! 1165: defvar_bool (namestring, address, doc) ! 1166: char *namestring; ! 1167: int *address; ! 1168: char *doc; ! 1169: { ! 1170: Lisp_Object sym; ! 1171: sym = intern (namestring); ! 1172: XSET (XSYMBOL (sym)->value, Lisp_Boolfwd, address); ! 1173: } ! 1174: ! 1175: /* Similar but define a variable whose value is the Lisp Object stored at address. */ ! 1176: ! 1177: void ! 1178: defvar_lisp (namestring, address, doc) ! 1179: char *namestring; ! 1180: Lisp_Object *address; ! 1181: char *doc; ! 1182: { ! 1183: Lisp_Object sym; ! 1184: sym = intern (namestring); ! 1185: XSET (XSYMBOL (sym)->value, Lisp_Objfwd, address); ! 1186: staticpro (address); ! 1187: } ! 1188: ! 1189: /* Similar but don't request gc-marking of the C variable. ! 1190: Used when that variable will be gc-marked for some other reason, ! 1191: since marking the same slot twice can cause trouble with strings. */ ! 1192: ! 1193: void ! 1194: defvar_lisp_nopro (namestring, address, doc) ! 1195: char *namestring; ! 1196: Lisp_Object *address; ! 1197: char *doc; ! 1198: { ! 1199: Lisp_Object sym; ! 1200: sym = intern (namestring); ! 1201: XSET (XSYMBOL (sym)->value, Lisp_Objfwd, address); ! 1202: } ! 1203: ! 1204: #ifndef standalone ! 1205: ! 1206: /* Similar but define a variable whose value is the Lisp Object stored in ! 1207: the current buffer. address is the address of the slot in the buffer that is current now. */ ! 1208: ! 1209: void ! 1210: defvar_per_buffer (namestring, address, doc) ! 1211: char *namestring; ! 1212: Lisp_Object *address; ! 1213: char *doc; ! 1214: { ! 1215: Lisp_Object sym; ! 1216: int offset; ! 1217: extern struct buffer buffer_local_symbols; ! 1218: ! 1219: sym = intern (namestring); ! 1220: offset = (char *)address - (char *)bf_cur; ! 1221: ! 1222: XSET (XSYMBOL (sym)->value, Lisp_Buffer_Objfwd, ! 1223: (Lisp_Object *) offset); ! 1224: *(Lisp_Object *)(offset + (char *)&buffer_local_symbols) = sym; ! 1225: if (*(int *)(offset + (char *)&buffer_local_flags) == 0) ! 1226: /* Did a DEFVAR_PER_BUFFER without initializing the corresponding ! 1227: slot of buffer_local_flags */ ! 1228: abort (); ! 1229: } ! 1230: ! 1231: #endif standalone ! 1232: ! 1233: init_read () ! 1234: { ! 1235: char *normal = PATH_LOADSEARCH; ! 1236: Lisp_Object normal_path; ! 1237: ! 1238: /* Warn if dirs in the *standard* path don't exist. */ ! 1239: normal_path = decode_env_path ("", normal); ! 1240: for (; !NULL (normal_path); normal_path = XCONS (normal_path)->cdr) ! 1241: { ! 1242: Lisp_Object dirfile; ! 1243: dirfile = Fcar (normal_path); ! 1244: if (!NULL (dirfile)) ! 1245: { ! 1246: dirfile = Fdirectory_file_name (dirfile); ! 1247: if (access (XSTRING (dirfile)->data, 0) < 0) ! 1248: printf ("Warning: lisp library (%s) does not exist.\n", ! 1249: XSTRING (Fcar (normal_path))->data); ! 1250: } ! 1251: } ! 1252: ! 1253: Vvalues = Qnil; ! 1254: ! 1255: Vload_path = decode_env_path ("EMACSLOADPATH", normal); ! 1256: #ifndef CANNOT_DUMP ! 1257: if (!NULL (Vpurify_flag)) ! 1258: Vload_path = Fcons (build_string ("../lisp"), Vload_path); ! 1259: #endif /* not CANNOT_DUMP */ ! 1260: load_in_progress = 0; ! 1261: } ! 1262: ! 1263: void ! 1264: syms_of_read () ! 1265: { ! 1266: defsubr (&Sread); ! 1267: defsubr (&Sread_from_string); ! 1268: defsubr (&Sintern); ! 1269: defsubr (&Sintern_soft); ! 1270: defsubr (&Sload); ! 1271: defsubr (&Seval_current_buffer); ! 1272: defsubr (&Seval_region); ! 1273: defsubr (&Sread_char); ! 1274: defsubr (&Sget_file_char); ! 1275: defsubr (&Smapatoms); ! 1276: ! 1277: DEFVAR_LISP ("obarray", &Vobarray, ! 1278: "Symbol table for use by intern and read.\n\ ! 1279: It is a vector whose length ought to be prime for best results.\n\ ! 1280: Each element is a list of all interned symbols whose names hash in that bucket."); ! 1281: ! 1282: DEFVAR_LISP ("values", &Vvalues, ! 1283: "List of values of all expressions which were read, evaluated and printed.\n\ ! 1284: Order is reverse chronological."); ! 1285: ! 1286: DEFVAR_LISP ("standard-input", &Vstandard_input, ! 1287: "Stream for read to get input from.\n\ ! 1288: See documentation of read for possible values."); ! 1289: Vstandard_input = Qt; ! 1290: ! 1291: DEFVAR_LISP ("load-path", &Vload_path, ! 1292: "*List of directories to search for files to load.\n\ ! 1293: Each element is a string (directory name) or nil (try default directory).\n\ ! 1294: Initialized based on EMACSLOADPATH environment variable, if any,\n\ ! 1295: otherwise to default specified in by file paths.h when emacs was built."); ! 1296: ! 1297: DEFVAR_BOOL ("load-in-progress", &load_in_progress, ! 1298: "Non-nil iff inside of load."); ! 1299: ! 1300: Qstandard_input = intern ("standard-input"); ! 1301: staticpro (&Qstandard_input); ! 1302: ! 1303: Qread_char = intern ("read-char"); ! 1304: staticpro (&Qread_char); ! 1305: ! 1306: Qget_file_char = intern ("get-file-char"); ! 1307: staticpro (&Qget_file_char); ! 1308: ! 1309: unrch = -1; ! 1310: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.