1: /* Lisp parsing and input streams.
    2:    Copyright (C) 1985, 1986, 1987, 1988, 1989, 1993, 1994, 1995,
    3:                  1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
    4:                  2005, 2006, 2007 Free Software Foundation, Inc.
    5: 
    6: This file is part of GNU Emacs.
    7: 
    8: GNU Emacs is free software; you can redistribute it and/or modify
    9: it under the terms of the GNU General Public License as published by
   10: the Free Software Foundation; either version 2, or (at your option)
   11: any later version.
   12: 
   13: GNU Emacs is distributed in the hope that it will be useful,
   14: but WITHOUT ANY WARRANTY; without even the implied warranty of
   15: MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   16: GNU General Public License for more details.
   17: 
   18: You should have received a copy of the GNU General Public License
   19: along with GNU Emacs; see the file COPYING.  If not, write to
   20: the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
   21: Boston, MA 02110-1301, USA.  */
   22: 
   23: 
   24: #include <config.h>
   25: #include <stdio.h>
   26: #include <sys/types.h>
   27: #include <sys/stat.h>
   28: #include <sys/file.h>
   29: #include <errno.h>
   30: #include "lisp.h"
   31: #include "intervals.h"
   32: #include "buffer.h"
   33: #include "charset.h"
   34: #include <epaths.h>
   35: #include "commands.h"
   36: #include "keyboard.h"
   37: #include "termhooks.h"
   38: #include "coding.h"
   39: #include "blockinput.h"
   40: 
   41: #ifdef lint
   42: #include <sys/inode.h>
   43: #endif /* lint */
   44: 
   45: #ifdef MSDOS
   46: #if __DJGPP__ < 2
   47: #include <unistd.h>     /* to get X_OK */
   48: #endif
   49: #include "msdos.h"
   50: #endif
   51: 
   52: #ifdef HAVE_UNISTD_H
   53: #include <unistd.h>
   54: #endif
   55: 
   56: #ifndef X_OK
   57: #define X_OK 01
   58: #endif
   59: 
   60: #include <math.h>
   61: 
   62: #ifdef HAVE_SETLOCALE
   63: #include <locale.h>
   64: #endif /* HAVE_SETLOCALE */
   65: 
   66: #ifdef HAVE_FCNTL_H
   67: #include <fcntl.h>
   68: #endif
   69: #ifndef O_RDONLY
   70: #define O_RDONLY 0
   71: #endif
   72: 
   73: #ifdef HAVE_FSEEKO
   74: #define file_offset off_t
   75: #define file_tell ftello
   76: #else
   77: #define file_offset long
   78: #define file_tell ftell
   79: #endif
   80: 
   81: #ifndef USE_CRT_DLL
   82: extern int errno;
   83: #endif
   84: 
   85: Lisp_Object Qread_char, Qget_file_char, Qstandard_input, Qcurrent_load_list;
   86: Lisp_Object Qvariable_documentation, Vvalues, Vstandard_input, Vafter_load_alist;
   87: Lisp_Object Qascii_character, Qload, Qload_file_name;
   88: Lisp_Object Qbackquote, Qcomma, Qcomma_at, Qcomma_dot, Qfunction;
   89: Lisp_Object Qinhibit_file_name_operation;
   90: Lisp_Object Qeval_buffer_list, Veval_buffer_list;
   91: Lisp_Object Qfile_truename, Qdo_after_load_evaluation; /* ACM 2006/5/16 */
   92: 
   93: extern Lisp_Object Qevent_symbol_element_mask;
   94: extern Lisp_Object Qfile_exists_p;
   95: 
   96: /* non-zero iff inside `load' */
   97: int load_in_progress;
   98: 
   99: /* Directory in which the sources were found.  */
  100: Lisp_Object Vsource_directory;
  101: 
  102: /* Search path and suffixes for files to be loaded. */
  103: Lisp_Object Vload_path, Vload_suffixes, Vload_file_rep_suffixes;
  104: 
  105: /* File name of user's init file.  */
  106: Lisp_Object Vuser_init_file;
  107: 
  108: /* This is the user-visible association list that maps features to
  109:    lists of defs in their load files. */
  110: Lisp_Object Vload_history;
  111: 
  112: /* This is used to build the load history. */
  113: Lisp_Object Vcurrent_load_list;
  114: 
  115: /* List of files that were preloaded.  */
  116: Lisp_Object Vpreloaded_file_list;
  117: 
  118: /* Name of file actually being read by `load'.  */
  119: Lisp_Object Vload_file_name;
  120: 
  121: /* Function to use for reading, in `load' and friends.  */
  122: Lisp_Object Vload_read_function;
  123: 
  124: /* The association list of objects read with the #n=object form.
  125:    Each member of the list has the form (n . object), and is used to
  126:    look up the object for the corresponding #n# construct.
  127:    It must be set to nil before all top-level calls to read0.  */
  128: Lisp_Object read_objects;
  129: 
  130: /* Nonzero means load should forcibly load all dynamic doc strings.  */
  131: static int load_force_doc_strings;
  132: 
  133: /* Nonzero means read should convert strings to unibyte.  */
  134: static int load_convert_to_unibyte;
  135: 
  136: /* Function to use for loading an Emacs Lisp source file (not
  137:    compiled) instead of readevalloop.  */
  138: Lisp_Object Vload_source_file_function;
  139: 
  140: /* List of all DEFVAR_BOOL variables.  Used by the byte optimizer.  */
  141: Lisp_Object Vbyte_boolean_vars;
  142: 
  143: /* Whether or not to add a `read-positions' property to symbols
  144:    read. */
  145: Lisp_Object Vread_with_symbol_positions;
  146: 
  147: /* List of (SYMBOL . POSITION) accumulated so far. */
  148: Lisp_Object Vread_symbol_positions_list;
  149: 
  150: /* List of descriptors now open for Fload.  */
  151: static Lisp_Object load_descriptor_list;
  152: 
  153: /* File for get_file_char to read from.  Use by load.  */
  154: static FILE *instream;
  155: 
  156: /* When nonzero, read conses in pure space */
  157: static int read_pure;
  158: 
  159: /* For use within read-from-string (this reader is non-reentrant!!)  */
  160: static int read_from_string_index;
  161: static int read_from_string_index_byte;
  162: static int read_from_string_limit;
  163: 
  164: /* Number of bytes left to read in the buffer character
  165:    that `readchar' has already advanced over.  */
  166: static int readchar_backlog;
  167: /* Number of characters read in the current call to Fread or
  168:    Fread_from_string. */
  169: static int readchar_count;
  170: 
  171: /* This contains the last string skipped with #@.  */
  172: static char *saved_doc_string;
  173: /* Length of buffer allocated in saved_doc_string.  */
  174: static int saved_doc_string_size;
  175: /* Length of actual data in saved_doc_string.  */
  176: static int saved_doc_string_length;
  177: /* This is the file position that string came from.  */
  178: static file_offset saved_doc_string_position;
  179: 
  180: /* This contains the previous string skipped with #@.
  181:    We copy it from saved_doc_string when a new string
  182:    is put in saved_doc_string.  */
  183: static char *prev_saved_doc_string;
  184: /* Length of buffer allocated in prev_saved_doc_string.  */
  185: static int prev_saved_doc_string_size;
  186: /* Length of actual data in prev_saved_doc_string.  */
  187: static int prev_saved_doc_string_length;
  188: /* This is the file position that string came from.  */
  189: static file_offset prev_saved_doc_string_position;
  190: 
  191: /* Nonzero means inside a new-style backquote
  192:    with no surrounding parentheses.
  193:    Fread initializes this to zero, so we need not specbind it
  194:    or worry about what happens to it when there is an error.  */
  195: static int new_backquote_flag;
  196: 
  197: /* A list of file names for files being loaded in Fload.  Used to
  198:    check for recursive loads.  */
  199: 
  200: static Lisp_Object Vloads_in_progress;
  201: 
  202: /* Non-zero means load dangerous compiled Lisp files.  */
  203: 
  204: int load_dangerous_libraries;
  205: 
  206: /* A regular expression used to detect files compiled with Emacs.  */
  207: 
  208: static Lisp_Object Vbytecomp_version_regexp;
  209: 
  210: static void to_multibyte P_ ((char **, char **, int *));
  211: static void readevalloop P_ ((Lisp_Object, FILE*, Lisp_Object,
  212:                               Lisp_Object (*) (), int,
  213:                               Lisp_Object, Lisp_Object,
  214:                               Lisp_Object, Lisp_Object));
  215: static Lisp_Object load_unwind P_ ((Lisp_Object));
  216: static Lisp_Object load_descriptor_unwind P_ ((Lisp_Object));
  217: 
  218: static void invalid_syntax P_ ((const char *, int)) NO_RETURN;
  219: static void end_of_file_error P_ (()) NO_RETURN;
  220: 
  221: ^L
  222: /* Handle unreading and rereading of characters.
  223:    Write READCHAR to read a character,
  224:    UNREAD(c) to unread c to be read again.
  225: 
  226:    The READCHAR and UNREAD macros are meant for reading/unreading a
  227:    byte code; they do not handle multibyte characters.  The caller
  228:    should manage them if necessary.
  229: 
  230:    [ Actually that seems to be a lie; READCHAR will definitely read
  231:      multibyte characters from buffer sources, at least.  Is the
  232:      comment just out of date?
  233:      -- Colin Walters <walters@gnu.org>, 22 May 2002 16:36:50 -0400 ]
  234:  */
  235: 
  236: #define READCHAR readchar (readcharfun)
  237: #define UNREAD(c) unreadchar (readcharfun, c)
  238: 
  239: static int
  240: readchar (readcharfun)
  241:      Lisp_Object readcharfun;
  242: {
  243:   Lisp_Object tem;
  244:   register int c;
  245: 
  246:   readchar_count++;
  247: 
  248:   if (BUFFERP (readcharfun))
  249:     {
  250:       register struct buffer *inbuffer = XBUFFER (readcharfun);
  251: 
  252:       int pt_byte = BUF_PT_BYTE (inbuffer);
  253:       int orig_pt_byte = pt_byte;
  254: 
  255:       if (readchar_backlog > 0)
  256:         /* We get the address of the byte just passed,
  257:            which is the last byte of the character.
  258:            The other bytes in this character are consecutive with it,
  259:            because the gap can't be in the middle of a character.  */
  260:         return *(BUF_BYTE_ADDRESS (inbuffer, BUF_PT_BYTE (inbuffer) - 1)
  261:                  - --readchar_backlog);
  262: 
  263:       if (pt_byte >= BUF_ZV_BYTE (inbuffer))
  264:         return -1;
  265: 
  266:       readchar_backlog = -1;
  267: 
  268:       if (! NILP (inbuffer->enable_multibyte_characters))
  269:         {
  270:           /* Fetch the character code from the buffer.  */
  271:           unsigned char *p = BUF_BYTE_ADDRESS (inbuffer, pt_byte);
  272:           BUF_INC_POS (inbuffer, pt_byte);
  273:           c = STRING_CHAR (p, pt_byte - orig_pt_byte);
  274:         }
  275:       else
  276:         {
  277:           c = BUF_FETCH_BYTE (inbuffer, pt_byte);
  278:           pt_byte++;
  279:         }
  280:       SET_BUF_PT_BOTH (inbuffer, BUF_PT (inbuffer) + 1, pt_byte);
  281: 
  282:       return c;
  283:     }
  284:   if (MARKERP (readcharfun))
  285:     {
  286:       register struct buffer *inbuffer = XMARKER (readcharfun)->buffer;
  287: 
  288:       int bytepos = marker_byte_position (readcharfun);
  289:       int orig_bytepos = bytepos;
  290: 
  291:       if (readchar_backlog > 0)
  292:         /* We get the address of the byte just passed,
  293:            which is the last byte of the character.
  294:            The other bytes in this character are consecutive with it,
  295:            because the gap can't be in the middle of a character.  */
  296:         return *(BUF_BYTE_ADDRESS (inbuffer, XMARKER (readcharfun)->bytepos - 1)
  297:                  - --readchar_backlog);
  298: 
  299:       if (bytepos >= BUF_ZV_BYTE (inbuffer))
  300:         return -1;
  301: 
  302:       readchar_backlog = -1;
  303: 
  304:       if (! NILP (inbuffer->enable_multibyte_characters))
  305:         {
  306:           /* Fetch the character code from the buffer.  */
  307:           unsigned char *p = BUF_BYTE_ADDRESS (inbuffer, bytepos);
  308:           BUF_INC_POS (inbuffer, bytepos);
  309:           c = STRING_CHAR (p, bytepos - orig_bytepos);
  310:         }
  311:       else
  312:         {
  313:           c = BUF_FETCH_BYTE (inbuffer, bytepos);
  314:           bytepos++;
  315:         }
  316: 
  317:       XMARKER (readcharfun)->bytepos = bytepos;
  318:       XMARKER (readcharfun)->charpos++;
  319: 
  320:       return c;
  321:     }
  322: 
  323:   if (EQ (readcharfun, Qlambda))
  324:     return read_bytecode_char (0);
  325: 
  326:   if (EQ (readcharfun, Qget_file_char))
  327:     {
  328:       BLOCK_INPUT;
  329:       c = getc (instream);
  330: #ifdef EINTR
  331:       /* Interrupted reads have been observed while reading over the network */
  332:       while (c == EOF && ferror (instream) && errno == EINTR)
  333:         {
  334:           UNBLOCK_INPUT;
  335:           QUIT;
  336:           BLOCK_INPUT;
  337:           clearerr (instream);
  338:           c = getc (instream);
  339:         }
  340: #endif
  341:       UNBLOCK_INPUT;
  342:       return c;
  343:     }
  344: 
  345:   if (STRINGP (readcharfun))
  346:     {
  347:       if (read_from_string_index >= read_from_string_limit)
  348:         c = -1;
  349:       else
  350:         FETCH_STRING_CHAR_ADVANCE (c, readcharfun,
  351:                                    read_from_string_index,
  352:                                    read_from_string_index_byte);
  353: 
  354:       return c;
  355:     }
  356: 
  357:   tem = call0 (readcharfun);
  358: 
  359:   if (NILP (tem))
  360:     return -1;
  361:   return XINT (tem);
  362: }
  363: 
  364: /* Unread the character C in the way appropriate for the stream READCHARFUN.
  365:    If the stream is a user function, call it with the char as argument.  */
  366: 
  367: static void
  368: unreadchar (readcharfun, c)
  369:      Lisp_Object readcharfun;
  370:      int c;
  371: {
  372:   readchar_count--;
  373:   if (c == -1)
  374:     /* Don't back up the pointer if we're unreading the end-of-input mark,
  375:        since readchar didn't advance it when we read it.  */
  376:     ;
  377:   else if (BUFFERP (readcharfun))
  378:     {
  379:       struct buffer *b = XBUFFER (readcharfun);
  380:       int bytepos = BUF_PT_BYTE (b);
  381: 
  382:       if (readchar_backlog >= 0)
  383:         readchar_backlog++;
  384:       else
  385:         {
  386:           BUF_PT (b)--;
  387:           if (! NILP (b->enable_multibyte_characters))
  388:             BUF_DEC_POS (b, bytepos);
  389:           else
  390:             bytepos--;
  391: 
  392:           BUF_PT_BYTE (b) = bytepos;
  393:         }
  394:     }
  395:   else if (MARKERP (readcharfun))
  396:     {
  397:       struct buffer *b = XMARKER (readcharfun)->buffer;
  398:       int bytepos = XMARKER (readcharfun)->bytepos;
  399: 
  400:       if (readchar_backlog >= 0)
  401:         readchar_backlog++;
  402:       else
  403:         {
  404:           XMARKER (readcharfun)->charpos--;
  405:           if (! NILP (b->enable_multibyte_characters))
  406:             BUF_DEC_POS (b, bytepos);
  407:           else
  408:             bytepos--;
  409: 
  410:           XMARKER (readcharfun)->bytepos = bytepos;
  411:         }
  412:     }
  413:   else if (STRINGP (readcharfun))
  414:     {
  415:       read_from_string_index--;
  416:       read_from_string_index_byte
  417:         = string_char_to_byte (readcharfun, read_from_string_index);
  418:     }
  419:   else if (EQ (readcharfun, Qlambda))
  420:     read_bytecode_char (1);
  421:   else if (EQ (readcharfun, Qget_file_char))
  422:     {
  423:       BLOCK_INPUT;
  424:       ungetc (c, instream);
  425:       UNBLOCK_INPUT;
  426:     }
  427:   else
  428:     call1 (readcharfun, make_number (c));
  429: }
  430: 
  431: static Lisp_Object read_internal_start P_ ((Lisp_Object, Lisp_Object,
  432:                                             Lisp_Object));
  433: static Lisp_Object read0 P_ ((Lisp_Object));
  434: static Lisp_Object read1 P_ ((Lisp_Object, int *, int));
  435: 
  436: static Lisp_Object read_list P_ ((int, Lisp_Object));
  437: static Lisp_Object read_vector P_ ((Lisp_Object, int));
  438: static int read_multibyte P_ ((int, Lisp_Object));
  439: 
  440: static Lisp_Object substitute_object_recurse P_ ((Lisp_Object, Lisp_Object,
  441:                                                   Lisp_Object));
  442: static void substitute_object_in_subtree P_ ((Lisp_Object,
  443:                                               Lisp_Object));
  444: static void substitute_in_interval P_ ((INTERVAL, Lisp_Object));
  445: 
  446: ^L
  447: /* Get a character from the tty.  */
  448: 
  449: extern Lisp_Object read_char ();
  450: 
  451: /* Read input events until we get one that's acceptable for our purposes.
  452: 
  453:    If NO_SWITCH_FRAME is non-zero, switch-frame events are stashed
  454:    until we get a character we like, and then stuffed into
  455:    unread_switch_frame.
  456: 
  457:    If ASCII_REQUIRED is non-zero, we check function key events to see
  458:    if the unmodified version of the symbol has a Qascii_character
  459:    property, and use that character, if present.
  460: 
  461:    If ERROR_NONASCII is non-zero, we signal an error if the input we
  462:    get isn't an ASCII character with modifiers.  If it's zero but
  463:    ASCII_REQUIRED is non-zero, we just re-read until we get an ASCII
  464:    character.
  465: 
  466:    If INPUT_METHOD is nonzero, we invoke the current input method
  467:    if the character warrants that.
  468: 
  469:    If SECONDS is a number, we wait that many seconds for input, and
  470:    return Qnil if no input arrives within that time.  */
  471: 
  472: Lisp_Object
  473: read_filtered_event (no_switch_frame, ascii_required, error_nonascii,
  474:                      input_method, seconds)
  475:      int no_switch_frame, ascii_required, error_nonascii, input_method;
  476:      Lisp_Object seconds;
  477: {
  478:   Lisp_Object val, delayed_switch_frame;
  479:   EMACS_TIME end_time;
  480: 
  481: #ifdef HAVE_WINDOW_SYSTEM
  482:   if (display_hourglass_p)
  483:     cancel_hourglass ();
  484: #endif
  485: 
  486:   delayed_switch_frame = Qnil;
  487: 
  488:   /* Compute timeout.  */
  489:   if (NUMBERP (seconds))
  490:     {
  491:       EMACS_TIME wait_time;
  492:       int sec, usec;
  493:       double duration = extract_float (seconds);
  494: 
  495:       sec  = (int) duration;
  496:       usec = (duration - sec) * 1000000;
  497:       EMACS_GET_TIME (end_time);
  498:       EMACS_SET_SECS_USECS (wait_time, sec, usec);
  499:       EMACS_ADD_TIME (end_time, end_time, wait_time);
  500:     }
  501: 
  502:   /* Read until we get an acceptable event.  */
  503:  retry:
  504:   val = read_char (0, 0, 0, (input_method ? Qnil : Qt), 0,
  505:                    NUMBERP (seconds) ? &end_time : NULL);
  506: 
  507:   if (BUFFERP (val))
  508:     goto retry;
  509: 
  510:   /* switch-frame events are put off until after the next ASCII
  511:      character.  This is better than signaling an error just because
  512:      the last characters were typed to a separate minibuffer frame,
  513:      for example.  Eventually, some code which can deal with
  514:      switch-frame events will read it and process it.  */
  515:   if (no_switch_frame
  516:       && EVENT_HAS_PARAMETERS (val)
  517:       && EQ (EVENT_HEAD_KIND (EVENT_HEAD (val)), Qswitch_frame))
  518:     {
  519:       delayed_switch_frame = val;
  520:       goto retry;
  521:     }
  522: 
  523:   if (ascii_required && !(NUMBERP (seconds) && NILP (val)))
  524:     {
  525:       /* Convert certain symbols to their ASCII equivalents.  */
  526:       if (SYMBOLP (val))
  527:         {
  528:           Lisp_Object tem, tem1;
  529:           tem = Fget (val, Qevent_symbol_element_mask);
  530:           if (!NILP (tem))
  531:             {
  532:               tem1 = Fget (Fcar (tem), Qascii_character);
  533:               /* Merge this symbol's modifier bits
  534:                  with the ASCII equivalent of its basic code.  */
  535:               if (!NILP (tem1))
  536:                 XSETFASTINT (val, XINT (tem1) | XINT (Fcar (Fcdr (tem))));
  537:             }
  538:         }
  539: 
  540:       /* If we don't have a character now, deal with it appropriately.  */
  541:       if (!INTEGERP (val))
  542:         {
  543:           if (error_nonascii)
  544:             {
  545:               Vunread_command_events = Fcons (val, Qnil);
  546:               error ("Non-character input-event");
  547:             }
  548:           else
  549:             goto retry;
  550:         }
  551:     }
  552: 
  553:   if (! NILP (delayed_switch_frame))
  554:     unread_switch_frame = delayed_switch_frame;
  555: 
  556: #if 0
  557: 
  558: #ifdef HAVE_WINDOW_SYSTEM
  559:   if (display_hourglass_p)
  560:     start_hourglass ();
  561: #endif
  562: 
  563: #endif
  564: 
  565:   return val;
  566: }
  567: 
  568: DEFUN ("read-char", Fread_char, Sread_char, 0, 3, 0,
  569:        doc: /* Read a character from the command input (keyboard or macro).
  570: It is returned as a number.
  571: If the user generates an event which is not a character (i.e. a mouse
  572: click or function key event), `read-char' signals an error.  As an
  573: exception, switch-frame events are put off until non-ASCII events can
  574: be read.
  575: If you want to read non-character events, or ignore them, call
  576: `read-event' or `read-char-exclusive' instead.
  577: 
  578: If the optional argument PROMPT is non-nil, display that as a prompt.
  579: If the optional argument INHERIT-INPUT-METHOD is non-nil and some
  580: input method is turned on in the current buffer, that input method
  581: is used for reading a character.
  582: If the optional argument SECONDS is non-nil, it should be a number
  583: specifying the maximum number of seconds to wait for input.  If no
  584: input arrives in that time, return nil.  SECONDS may be a
  585: floating-point value.  */)
  586:      (prompt, inherit_input_method, seconds)
  587:      Lisp_Object prompt, inherit_input_method, seconds;
  588: {
  589:   if (! NILP (prompt))
  590:     message_with_string ("%s", prompt, 0);
  591:   return read_filtered_event (1, 1, 1, ! NILP (inherit_input_method), seconds);
  592: }
  593: 
  594: DEFUN ("read-event", Fread_event, Sread_event, 0, 3, 0,
  595:        doc: /* Read an event object from the input stream.
  596: If the optional argument PROMPT is non-nil, display that as a prompt.
  597: If the optional argument INHERIT-INPUT-METHOD is non-nil and some
  598: input method is turned on in the current buffer, that input method
  599: is used for reading a character.
  600: If the optional argument SECONDS is non-nil, it should be a number
  601: specifying the maximum number of seconds to wait for input.  If no
  602: input arrives in that time, return nil.  SECONDS may be a
  603: floating-point value.  */)
  604:      (prompt, inherit_input_method, seconds)
  605:      Lisp_Object prompt, inherit_input_method, seconds;
  606: {
  607:   if (! NILP (prompt))
  608:     message_with_string ("%s", prompt, 0);
  609:   return read_filter