4.3BSD - /usr/src/new/emacs/src/lread.c

   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: }

Defined functions

Defined variables

Defined macros