home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / gnu / lucid / lemacs-19.6 / src / lread.c < prev    next >
Encoding:
C/C++ Source or Header  |  1993-02-14  |  40.7 KB  |  1,622 lines
  1. /* Lisp parsing and input streams.
  2.    Copyright (C) 1992, 1993 Free Software Foundation, Inc.
  3.  
  4. This file is part of GNU Emacs.
  5.  
  6. GNU Emacs is free software; you can redistribute it and/or modify
  7. it under the terms of the GNU General Public License as published by
  8. the Free Software Foundation; either version 2, or (at your option)
  9. any later version.
  10.  
  11. GNU Emacs is distributed in the hope that it will be useful,
  12. but WITHOUT ANY WARRANTY; without even the implied warranty of
  13. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14. GNU General Public License for more details.
  15.  
  16. You should have received a copy of the GNU General Public License
  17. along with GNU Emacs; see the file COPYING.  If not, write to
  18. the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.  */
  19.  
  20. #include "config.h"
  21. #include "lisp.h"
  22.  
  23. #include <stdio.h>
  24. #include <string.h>
  25. #include <sys/types.h>
  26. #include <sys/stat.h>
  27. #include <sys/file.h>
  28.  
  29. #ifdef BSD
  30. #include <strings.h>    /* to get proto for index()... */
  31. #endif
  32.  
  33. #ifdef USG5_4
  34. #include <unistd.h>
  35. #endif
  36.  
  37. #ifndef standalone
  38. #include "buffer.h"
  39. #include "paths.h"
  40. #include "commands.h"
  41. #endif
  42.  
  43. #ifdef lint
  44. #include <sys/inode.h>
  45. #endif /* lint */
  46.  
  47. #ifndef X_OK
  48. #define X_OK 01
  49. #endif
  50.  
  51. #ifdef LISP_FLOAT_TYPE
  52. #include <math.h>
  53. #endif /* LISP_FLOAT_TYPE */
  54.  
  55. Lisp_Object Qread_char, Qget_file_char, Qstandard_input;
  56. Lisp_Object Qvariable_documentation, Vvalues, Vstandard_input, Vafter_load_alist;
  57.  
  58. /* Whether Fload() should check whether the .el is newer when loading .elc */
  59. int load_warn_when_source_newer;
  60. /* Whether Fload() should check whether the .elc doesn't exist */
  61. int load_warn_when_source_only;
  62.  
  63. /* non-zero if inside `load' */
  64. int load_in_progress;
  65.  
  66. /* Search path for files to be loaded. */
  67. Lisp_Object Vload_path;
  68.  
  69. /* File for get_file_char to read from.  Use by load */
  70. static FILE *instream;
  71.  
  72. /* When nonzero, read conses in pure space */
  73. static int read_pure;
  74.  
  75. /* For use within read-from-string (this reader is non-reentrant!!) */
  76. static int read_from_string_index;
  77. static int read_from_string_limit;
  78.  
  79. /* Handle unreading and rereading of characters.
  80.    Write READCHAR to read a character,
  81.    UNREAD(c) to unread c to be read again. */
  82.  
  83. #define READCHAR readchar (readcharfun)
  84. #define UNREAD(c) unreadchar (readcharfun, c)
  85.  
  86. static int
  87. readchar (readcharfun)
  88.      Lisp_Object readcharfun;
  89. {
  90.   Lisp_Object tem;
  91.   register struct buffer *inbuffer;
  92.   register int c, mpos;
  93.  
  94.   if (BUFFERP (readcharfun))
  95.     {
  96.       inbuffer = XBUFFER (readcharfun);
  97.  
  98.       if (BUF_PT (inbuffer) >= BUF_ZV (inbuffer))
  99.     return -1;
  100.       c = *(unsigned char *) BUF_CHAR_ADDRESS (inbuffer, BUF_PT (inbuffer));
  101.       SET_BUF_PT (inbuffer, BUF_PT (inbuffer) + 1);
  102.  
  103.       return c;
  104.     }
  105.   if (MARKERP (readcharfun))
  106.     {
  107.       inbuffer = XMARKER (readcharfun)->buffer;
  108.  
  109.       mpos = marker_position (readcharfun);
  110.  
  111.       if (mpos > BUF_ZV (inbuffer) - 1)
  112.     return -1;
  113.       c = *(unsigned char *) BUF_CHAR_ADDRESS (inbuffer, mpos);
  114.       if (mpos != BUF_GPT (inbuffer))
  115.     XMARKER (readcharfun)->bufpos++;
  116.       else
  117.     Fset_marker (readcharfun, make_number (mpos + 1),
  118.              Fmarker_buffer (readcharfun));
  119.       return c;
  120.     }
  121.   if (EQ (readcharfun, Qget_file_char))
  122.     return getc (instream);
  123.  
  124.   if (STRINGP (readcharfun))
  125.     {
  126.       register int c;
  127.       /* This used to be return of a conditional expression,
  128.      but that truncated -1 to a char on VMS.  */
  129.       if (read_from_string_index < read_from_string_limit)
  130.     c = XSTRING (readcharfun)->data[read_from_string_index++];
  131.       else
  132.     c = -1;
  133.       return c;
  134.     }
  135.  
  136.   tem = call0 (readcharfun);
  137.  
  138.   if (NILP (tem))
  139.     return -1;
  140.   return XINT (tem);
  141. }
  142.  
  143. /* Unread the character C in the way appropriate for the stream READCHARFUN.
  144.    If the stream is a user function, call it with the char as argument.  */
  145.  
  146. static void
  147. unreadchar (readcharfun, c)
  148.      Lisp_Object readcharfun;
  149.      int c;
  150. {
  151.   if (BUFFERP (readcharfun))
  152.     {
  153.       if (XBUFFER (readcharfun) == current_buffer)
  154.     SET_PT (point - 1);
  155.       else
  156.     SET_BUF_PT (XBUFFER (readcharfun), BUF_PT (XBUFFER (readcharfun)) - 1);
  157.     }
  158.   else if (MARKERP (readcharfun))
  159.     XMARKER (readcharfun)->bufpos--;
  160.   else if (STRINGP (readcharfun))
  161.     read_from_string_index--;
  162.   else if (EQ (readcharfun, Qget_file_char))
  163.     ungetc (c, instream);
  164.   else
  165.     call1 (readcharfun, make_number (c));
  166. }
  167.  
  168. static Lisp_Object read0 (), read1 (), read_list (), read_vector ();
  169.  
  170. /* get a character from the tty */
  171.  
  172. #ifdef standalone     /* This is normally defined in event-stream.c */
  173.  
  174. DEFUN ("read-char", Fread_char, Sread_char, 0, 0, 0, "") ()
  175. {
  176.   return getchar ();
  177. }
  178.  
  179. #endif
  180.  
  181.  
  182. DEFUN ("get-file-char", Fget_file_char, Sget_file_char, 0, 0, 0,
  183.   "Don't use this yourself.")
  184.   ()
  185. {
  186.   register Lisp_Object val;
  187.   XSET (val, Lisp_Int, getc (instream));
  188.   return val;
  189. }
  190.  
  191. static void readevalloop ();
  192. static Lisp_Object load_unwind ();
  193.  
  194. DEFUN ("load", Fload, Sload, 1, 4, 0,
  195.   "Execute a file of Lisp code named FILE.\n\
  196. First try FILE with `.elc' appended, then try with `.el',\n\
  197.  then try FILE unmodified.\n\
  198. This function searches the directories in `load-path'.\n\
  199. If optional second arg MISSING-OK is non-nil,\n\
  200.  report no error if FILE doesn't exist.\n\
  201. Print messages at start and end of loading unless\n\
  202.  optional third arg NOMESSAGE is non-nil.\n\
  203. If optional fourth arg NOSUFFIX is non-nil, don't try adding\n\
  204.  suffixes `.elc' or `.el' to the specified name FILE.\n\
  205. Return t if file exists.")
  206.   (str, missing_ok, nomessage, nosuffix)
  207.      Lisp_Object str, missing_ok, nomessage, nosuffix;
  208. {
  209.   register FILE *stream;
  210.   register int fd = -1;
  211.   register Lisp_Object lispstream;
  212.   register FILE **ptr;
  213.   int count = specpdl_depth;
  214.   Lisp_Object temp;
  215.   Lisp_Object newer = Qnil;
  216.   struct gcpro gcpro1, gcpro2;
  217.   int source_only = 0;
  218.  
  219.   CHECK_STRING (str, 0);
  220.   str = Fsubstitute_in_file_name (str);
  221.  
  222.   /* Avoid weird lossage with null string as arg,
  223.      since it would try to load a directory as a Lisp file.
  224.      Unix truly sucks */
  225.   if (XSTRING (str)->size > 0) 
  226.     {
  227.       Lisp_Object found;
  228.  
  229.       fd = locate_file (Vload_path, str, 
  230.                         ((!NILP (nosuffix)) ? "" : ".elc:.el:"),
  231.                         &found,
  232.                         -1);
  233.  
  234.       if (fd < 0)
  235.     {
  236.       if (NILP (missing_ok))
  237.         signal_error (Qfile_error,
  238.               list2 (build_string ("Cannot open load file"), str));
  239.       else
  240.         return Qnil;
  241.     }
  242.       else if (load_warn_when_source_newer &&
  243.            !memcmp ((char *) &(XSTRING (found)->data
  244.                    [XSTRING (found)->size - 4]),
  245.             ".elc", 4))
  246.     {
  247.       struct stat s1, s2;
  248.       if (! fstat (fd, &s1))    /* can't fail, right? */
  249.         {
  250.           int result;
  251.           /* temporarily hack the 'c' off the end of the filename */
  252.           XSTRING (found)->data[XSTRING (found)->size - 1] = 0;
  253.           result = stat ((char *) XSTRING (found)->data, &s2);
  254.           if (result >= 0 &&
  255.           (unsigned) s1.st_mtime < (unsigned) s2.st_mtime)
  256.         newer = Ffile_name_nondirectory (found);
  257.           /* put the 'c' back on (kludge-o-rama) */
  258.           XSTRING (found)->data[XSTRING (found)->size - 1] = 'c';
  259.         }
  260.     }
  261.       else if (load_warn_when_source_only &&
  262.            /* `found' ends in ".el" */
  263.            !memcmp ((char *) &(XSTRING (found)->data
  264.                    [XSTRING (found)->size - 3]),
  265.             ".el", 3) &&
  266.            /* `str' does not end in ".el" */
  267.            memcmp ((char *) &(XSTRING (str)->data
  268.                   [XSTRING (str)->size - 3]),
  269.                ".el", 3))
  270.     {
  271.       source_only = 1;
  272.     }
  273.     }
  274.  
  275.   stream = fdopen (fd, "r");
  276.   if (stream == 0)
  277.     {
  278.       close (fd);
  279.       error ("Failure to create stdio stream for %s", XSTRING (str)->data);
  280.     }
  281.  
  282.   if (!NILP (newer))
  283.     {
  284.       message ("Loading %s...  (file %s is newer)",
  285.            XSTRING (str)->data, XSTRING (newer)->data);
  286.       nomessage = Qnil; /* we printed the first one, so print "done" too */
  287.     }
  288.   else if (source_only)
  289.     {
  290.       message ("Loading %s...  (file %s.elc does not exist)",
  291.            XSTRING (str)->data,
  292.            XSTRING (Ffile_name_nondirectory (str))->data);
  293.       nomessage = Qnil;
  294.     }
  295.   else if (NILP (nomessage))
  296.     message ("Loading %s...", XSTRING (str)->data);
  297.  
  298.   GCPRO2 (str, newer);
  299.   /* We may not be able to store STREAM itself as a Lisp_Object pointer
  300.      since that is guaranteed to work only for data that has been malloc'd.
  301.      So malloc a full-size pointer, and record the address of that pointer.  */
  302.   ptr = (FILE **) xmalloc (sizeof (FILE *));
  303.   *ptr = stream;
  304.   XSET (lispstream, Lisp_Internal_Stream, (int) ptr);
  305.   record_unwind_protect (load_unwind, lispstream);
  306.   load_in_progress++;
  307.   readevalloop (Qget_file_char, stream, Feval, 0);
  308.   unbind_to (count, Qnil);
  309.  
  310.   /* Run any load-hooks for this file.  */
  311.   temp = Fassoc (str, Vafter_load_alist);
  312.   if (!NILP (temp))
  313.     Fprogn (Fcdr (temp));
  314.  
  315.   if (noninteractive || !NILP (nomessage))
  316.     ;
  317.   else if (!NILP (newer))
  318.     message ("Loading %s...done  (file %s is newer)",
  319.          XSTRING (str)->data, XSTRING (newer)->data);
  320.   else
  321.     message ("Loading %s...done", XSTRING (str)->data);
  322.  
  323.   UNGCPRO;
  324.   return Qt;
  325. }
  326.  
  327. static Lisp_Object
  328. load_unwind (stream)  /* used as unwind-protect function in load */
  329.      Lisp_Object stream;
  330. {
  331.   fclose (*(FILE **) XSTRING (stream));
  332.   xfree ((char *)XPNTR (stream));
  333.   if (--load_in_progress < 0) load_in_progress = 0;
  334.   return Qnil;
  335. }
  336.  
  337.  
  338. static int
  339. complete_filename_p (pathname)
  340.      Lisp_Object pathname;
  341. {
  342.   register unsigned char *s = XSTRING (pathname)->data;
  343.   return (*s == '/'
  344. #ifdef ALTOS
  345.       || *s == '@'
  346. #endif
  347. #ifdef VMS
  348.       || index (s, ':')
  349. #endif /* VMS */
  350.       );
  351. }
  352.  
  353. DEFUN ("locate-file", Flocate_file, Slocate_file, 2, 4, 0,
  354.   "Search for FILENAME through PATH-LIST, expanded by one of the optional\n\
  355. SUFFIXES (string of suffixes separated by \":\"s), checking for access\n\
  356. MODE (0|1|2|4 = exists|executable|writeable|readable), default readable.")
  357.   (file, path, suff, mode)
  358.      Lisp_Object file, path, suff, mode;
  359. {
  360.   Lisp_Object tp;
  361.   char *sstr = "";
  362.   CHECK_STRING (file, 0);
  363.   if (!NILP (suff))
  364.     {
  365.       CHECK_STRING (suff, 0);
  366.       sstr = (char *)(XSTRING (suff)->data);
  367.     }
  368.   if (!(NILP (mode) || (FIXNUMP (mode) && XINT (mode) >= 0)))
  369.     mode = wrong_type_argument (Qnatnump, mode);
  370.   locate_file (path, file, sstr, &tp, (NILP (mode) ? R_OK : XFASTINT (mode)));
  371.   return tp;
  372. }
  373.  
  374.  
  375. /* Search for a file whose name is STR, looking in directories
  376.    in the Lisp list PATH, and trying suffixes from SUFFIX.
  377.    SUFFIX is a string containing possible suffixes separated by colons.
  378.    On success, returns a file descriptor.  On failure, returns -1.
  379.  
  380.    MODE nonnegative means don't open the files,
  381.    just look for one for which access(file,MODE) succeeds.  In this case,
  382.    returns 1 on success.
  383.  
  384.    If STOREPTR is nonzero, it points to a slot where the name of
  385.    the file actually found should be stored as a Lisp string.
  386.    Nil is stored there on failure.  */
  387.  
  388. int
  389. locate_file (path, str, suffix, storeptr, mode)
  390.      Lisp_Object path, str;
  391.      const char *suffix;
  392.      Lisp_Object *storeptr;
  393.      int mode;
  394. {
  395.   register int fd;
  396.   int fn_size = 100;
  397.   char buf[100];
  398.   register char *fn = buf;
  399.   int absolute = 0;
  400.   int want_size;
  401.   register Lisp_Object filename;
  402.   struct stat st;
  403.  
  404.   if (storeptr)
  405.     *storeptr = Qnil;
  406.  
  407.   if (complete_filename_p (str))
  408.     absolute = 1;
  409.  
  410.   for (; !NILP (path); path = Fcdr (path))
  411.     {
  412.       const char *nsuffix;
  413.  
  414.       filename = Fexpand_file_name (str, Fcar (path));
  415.       if (!complete_filename_p (filename))
  416.     /* If there are non-absolute elts in PATH (eg ".") */
  417.     /* Of course, this could conceivably lose if luser sets
  418.        default-directory to be something non-absolute... */
  419.     {
  420.       filename = Fexpand_file_name (filename, current_buffer->directory);
  421.       if (!complete_filename_p (filename))
  422.         /* Give up on this path element! */
  423.         continue;
  424.     }
  425.  
  426.       /* Calculate maximum size of any filename made from
  427.      this path element/specified file name and any possible suffix.  */
  428.       want_size = strlen (suffix) + XSTRING (filename)->size + 1;
  429.       if (fn_size < want_size)
  430.     fn = (char *) alloca (fn_size = 100 + want_size);
  431.  
  432.       nsuffix = suffix;
  433.  
  434.       /* Loop over suffixes.  */
  435.       while (1)
  436.     {
  437.       char *esuffix = (char *) strchr (nsuffix, ':');
  438.       int lsuffix = esuffix ? esuffix - nsuffix : strlen (nsuffix);
  439.  
  440.       /* Concatenate path element/specified name with the suffix.  */
  441.       strncpy (fn, (char *) XSTRING (filename)->data,
  442.            XSTRING (filename)->size);
  443.       fn[XSTRING (filename)->size] = 0;
  444.       if (lsuffix != 0)  /* Bug happens on CCI if lsuffix is 0.  */
  445.         strncat (fn, nsuffix, lsuffix);
  446.  
  447.       /* Ignore file if it's a directory.  */
  448.       if (stat (fn, &st) >= 0
  449.           && (st.st_mode & S_IFMT) != S_IFDIR)
  450.         {
  451.           /* Check that we can access or open it.  */
  452.           if (mode>=0)
  453.         fd = access (fn, mode);
  454.           else
  455.         fd = open (fn, 0, 0);
  456.  
  457.           if (fd >= 0)
  458.         {
  459.           /* We succeeded; return this descriptor and filename.  */
  460.           if (storeptr)
  461.             *storeptr = build_string (fn);
  462.           return fd;
  463.         }
  464.         }
  465.  
  466.       /* Advance to next suffix.  */
  467.       if (esuffix == 0)
  468.         break;
  469.       nsuffix += lsuffix + 1;
  470.     }
  471.       if (absolute) return -1;
  472.     }
  473.  
  474.   return -1;
  475. }
  476.  
  477.  
  478. static Lisp_Object
  479. unreadpure (dummy)    /* Used as unwind-protect function in readevalloop */
  480.      Lisp_Object dummy;
  481. {
  482.   read_pure = 0;
  483.   return Qnil;
  484. }
  485.  
  486. static void
  487. readevalloop (readcharfun, stream, evalfun, printflag)
  488.      Lisp_Object readcharfun;
  489.      FILE *stream;     
  490.      Lisp_Object (*evalfun) ();
  491.      int printflag;
  492. {
  493.   register int c;
  494.   register Lisp_Object val;
  495.   int count = specpdl_depth;
  496.  
  497.   specbind (Qstandard_input, readcharfun);
  498.  
  499.   while (1)
  500.     {
  501.       instream = stream;
  502.       c = READCHAR;
  503.       if (c == ';')
  504.     {
  505.       while ((c = READCHAR) != '\n' && c != -1);
  506.       continue;
  507.     }
  508.       if (c < 0) break;
  509.       if (c == ' ' || c == '\t' || c == '\n' || c == '\f') continue;
  510.  
  511.       if (!NILP (Vpurify_flag) && c == '(')
  512.     {
  513.       record_unwind_protect (unreadpure, Qnil);
  514.       val = read_list (-1, readcharfun);
  515.       unbind_to (count + 1, Qnil);
  516.     }
  517.       else
  518.     {
  519.       UNREAD (c);
  520.       val = read0 (readcharfun);
  521.     }
  522.  
  523.       val = (*evalfun) (val);
  524.       if (printflag)
  525.     {
  526.       Vvalues = Fcons (val, Vvalues);
  527.       if (EQ (Vstandard_output, Qt))
  528.         Fprin1 (val, Qnil);
  529.       else
  530.         Fprint (val, Qnil);
  531.     }
  532.     }
  533.  
  534.   unbind_to (count, Qnil);
  535. }
  536.  
  537. #ifndef standalone
  538.  
  539. DEFUN ("eval-buffer", Feval_buffer, Seval_buffer, 1, 2, "bBuffer: ",
  540.   "Execute BUFFER as Lisp code.\n\
  541. Programs can pass argument PRINTFLAG which controls printing of output:\n\
  542. nil means discard it; anything else is stream for print.")
  543.   (bufname, printflag)
  544.      Lisp_Object bufname, printflag;
  545. {
  546.   int count = specpdl_depth;
  547.   Lisp_Object tem, buf;
  548.  
  549.   buf = Fget_buffer (bufname);
  550.   if (NILP (buf))
  551.     error ("No such buffer.");
  552.  
  553.   if (NILP (printflag))
  554.     tem = Qsymbolp;
  555.   else
  556.     tem = printflag;
  557.   specbind (Qstandard_output, tem);
  558.   record_unwind_protect (save_excursion_restore, save_excursion_save ());
  559.   SET_BUF_PT (XBUFFER (buf), BUF_BEGV (XBUFFER (buf)));
  560.   readevalloop (buf, 0, Feval, !NILP (printflag));
  561.   return unbind_to (count, Qnil);
  562. }
  563.  
  564. DEFUN ("eval-region", Feval_region, Seval_region, 2, 3, "r",
  565.   "Execute the region as Lisp code.\n\
  566. When called from programs, expects two arguments,\n\
  567. giving starting and ending indices in the current buffer\n\
  568. of the text to be executed.\n\
  569. Programs can pass third argument PRINTFLAG which controls output:\n\
  570. nil means discard it; anything else is stream for printing it.\n\
  571. \n\
  572. If there is no error, point does not move.  If there is an error,\n\
  573. point remains at the end of the last character read from the buffer.")
  574.   (b, e, printflag)
  575.      Lisp_Object b, e, printflag;
  576. {
  577.   int count = specpdl_depth;
  578.   Lisp_Object tem;
  579.  
  580.   if (NILP (printflag))
  581.     tem = Qsymbolp;
  582.   else
  583.     tem = printflag;
  584.   specbind (Qstandard_output, tem);
  585.   if (NILP (printflag))
  586.     record_unwind_protect (save_excursion_restore, save_excursion_save ());
  587.   record_unwind_protect (save_restriction_restore, save_restriction_save ());
  588.   SET_PT (XINT (b));
  589.   Fnarrow_to_region (make_number (BEGV), e);
  590.   readevalloop (Fcurrent_buffer (), 0, Feval, !NILP (printflag));
  591.   return unbind_to (count, Qnil);
  592. }
  593.  
  594. #endif /* standalone */
  595.  
  596. DEFUN ("read", Fread, Sread, 0, 1, 0,
  597.   "Read one Lisp expression as text from STREAM, return as Lisp object.\n\
  598. If STREAM is nil, use the value of `standard-input' (which see).\n\
  599. STREAM or the value of `standard-input' may be:\n\
  600.  a buffer (read from point and advance it)\n\
  601.  a marker (read from where it points and advance it)\n\
  602.  a function (call it with no arguments for each character,\n\
  603.      call it with a char as argument to push a char back)\n\
  604.  a string (takes text from string, starting at the beginning)\n\
  605.  t (read text line using minibuffer and use it).")
  606.   (readcharfun)
  607.      Lisp_Object readcharfun;
  608. {
  609.   extern Lisp_Object Fread_minibuffer ();
  610.  
  611.   if (NILP (readcharfun))
  612.     readcharfun = Vstandard_input;
  613.   if (EQ (readcharfun, Qt))
  614.     readcharfun = Qread_char;
  615.  
  616. #ifndef standalone
  617.   if (EQ (readcharfun, Qread_char))
  618.   {
  619.     Lisp_Object val = call1 (Qread_from_minibuffer, 
  620.                              build_string ("Lisp expression: "));
  621.     return (Fcar (Fread_from_string (val, Qnil, Qnil)));
  622.   }
  623. #endif
  624.  
  625.   if (STRINGP (readcharfun))
  626.     return Fcar (Fread_from_string (readcharfun, Qnil, Qnil));
  627.  
  628.   return read0 (readcharfun);
  629. }
  630.  
  631. DEFUN ("read-from-string", Fread_from_string, Sread_from_string, 1, 3, 0,
  632.   "Read one Lisp expression which is represented as text by STRING.\n\
  633. Returns a cons: (OBJECT-READ . FINAL-STRING-INDEX).\n\
  634. START and END optionally delimit a substring of STRING from which to read;\n\
  635.  they default to 0 and (length STRING) respectively.")
  636.   (string, start, end)
  637.      Lisp_Object string, start, end;
  638. {
  639.   int startval, endval;
  640.   Lisp_Object tem;
  641.  
  642.   CHECK_STRING (string,0);
  643.  
  644.   if (NILP (end))
  645.     endval = XSTRING (string)->size;
  646.   else
  647.     { CHECK_FIXNUM (end,2);
  648.       endval = XINT (end);
  649.       if (endval < 0 || endval > XSTRING (string)->size)
  650.     args_out_of_range (string, end);
  651.     }
  652.  
  653.   if (NILP (start))
  654.     startval = 0;
  655.   else
  656.     { CHECK_FIXNUM (start,1);
  657.       startval = XINT (start);
  658.       if (startval < 0 || startval > endval)
  659.     args_out_of_range (string, start);
  660.     }
  661.  
  662.   read_from_string_index = startval;
  663.   read_from_string_limit = endval;
  664.  
  665.   tem = read0 (string);
  666.   return Fcons (tem, make_number (read_from_string_index));
  667. }
  668.  
  669. /* Use this for recursive reads, in contexts where internal tokens are not allowed. */
  670.  
  671. static Lisp_Object
  672. read0 (readcharfun)
  673.      Lisp_Object readcharfun;
  674. {
  675.   register Lisp_Object val;
  676.   char c;
  677.  
  678.   val = read1 (readcharfun);
  679.   if (XTYPE (val) == Lisp_Internal)
  680.     {
  681.       c = XINT (val);
  682.       return Fsignal (Qinvalid_read_syntax, Fcons (make_string (&c, 1), Qnil));
  683.     }
  684.  
  685.   return val;
  686. }
  687.  
  688. static int read_buffer_size;
  689. static char *read_buffer;
  690.  
  691. static int
  692. read_escape (readcharfun)
  693.      Lisp_Object readcharfun;
  694. {
  695.   register int c = READCHAR;
  696.   switch (c)
  697.     {
  698.     case 'a':
  699.       return 7;     /* some systems don't know '\a' */
  700.     case 'b':
  701.       return '\b';
  702.     case 'e':
  703.       return 033;
  704.     case 'f':
  705.       return '\f';
  706.     case 'n':
  707.       return '\n';
  708.     case 'r':
  709.       return '\r';
  710.     case 't':
  711.       return '\t';
  712.     case 'v':
  713.       return '\v';
  714.     case '\n':
  715.       return -1;
  716.  
  717.     case 'M':
  718.       c = READCHAR;
  719.       if (c != '-')
  720.     error ("Invalid escape character syntax");
  721.       c = READCHAR;
  722.       if (c == '\\')
  723.     c = read_escape (readcharfun);
  724.       return c | 0200;
  725.  
  726.     case 'C':
  727.       c = READCHAR;
  728.       if (c != '-')
  729.     error ("Invalid escape character syntax");
  730.     case '^':
  731.       c = READCHAR;
  732.       if (c == '\\')
  733.     c = read_escape (readcharfun);
  734.       if (c == '?')
  735.     return 0177;
  736.       return (c & 0200) | (c & 037);
  737.       
  738.     case '0':
  739.     case '1':
  740.     case '2':
  741.     case '3':
  742.     case '4':
  743.     case '5':
  744.     case '6':
  745.     case '7':
  746.       /* An octal escape, as in ANSI C.  */
  747.       {
  748.     register int i = c - '0';
  749.     register int count = 0;
  750.     while (++count < 3)
  751.       {
  752.         if ((c = READCHAR) >= '0' && c <= '7')
  753.           {
  754.         i *= 8;
  755.         i += c - '0';
  756.           }
  757.         else
  758.           {
  759.         UNREAD (c);
  760.         break;
  761.           }
  762.       }
  763.     return i;
  764.       }
  765.  
  766.     case 'x':
  767.       /* A hex escape, as in ANSI C.  */
  768.       {
  769.     int i = 0;
  770.     while (1)
  771.       {
  772.         c = READCHAR;
  773.         if (c >= '0' && c <= '9')
  774.           {
  775.         i *= 16;
  776.         i += c - '0';
  777.           }
  778.         else if ((c >= 'a' && c <= 'f')
  779.              || (c >= 'A' && c <= 'F'))
  780.           {
  781.         i *= 16;
  782.         if (c >= 'a' && c <= 'f')
  783.           i += c - 'a' + 10;
  784.         else
  785.           i += c - 'A' + 10;
  786.           }
  787.         else
  788.           {
  789.         UNREAD (c);
  790.         break;
  791.           }
  792.       }
  793.     return i;
  794.       }
  795.  
  796.     default:
  797.       return c;
  798.     }
  799. }
  800.  
  801.  
  802. extern Lisp_Object make_pure_symbol_name (const char *, int);
  803.  
  804. static Lisp_Object
  805. read1 (readcharfun)
  806.      register Lisp_Object readcharfun;
  807. {
  808.   register int c;
  809.   int uninterned_symbol = 0;
  810.  
  811.  retry:
  812.  
  813.   c = READCHAR;
  814.   if (c < 0) return Fsignal (Qend_of_file, Qnil);
  815.  
  816.   switch (c)
  817.     {
  818.     case '(':
  819.       return read_list (0, readcharfun);
  820.  
  821.     case '[':
  822.       return read_vector (readcharfun, Lisp_Vector);
  823.  
  824.     case ')':
  825.     case ']':
  826.     case '.':
  827.       {
  828.     register Lisp_Object val;
  829.     XSET (val, Lisp_Internal, c);
  830.     return val;
  831.       }
  832.  
  833.     case '#':
  834.       c = READCHAR;
  835.       if (c == '[')
  836.     {
  837.       /* accept compiled functions at read-time so that we don't have to
  838.          build them at load-time. */
  839.       Lisp_Object vec = read_vector (readcharfun, Lisp_Compiled);
  840.       if (XVECTOR (vec)->size < 4 || XVECTOR (vec)->size > 6)
  841.         return Fsignal (Qinvalid_read_syntax,
  842.                 Fcons (build_string
  843.                  ("#[...] used with wrong number of elements"),
  844.                    Qnil));
  845.       return (NILP (Vpurify_flag) ? vec : Fpurecopy (vec));
  846.     }
  847.       else if (c == ':')
  848.     {
  849.       uninterned_symbol = 1;
  850.       c = READCHAR;
  851.       goto UNINTERNED_SYMBOL;
  852.     }
  853.       
  854.       UNREAD (c);
  855.       return Fsignal (Qinvalid_read_syntax, Fcons (make_string ("#", 1), Qnil));
  856.  
  857.     case ';':
  858.       while ((c = READCHAR) >= 0 && c != '\n');
  859.       goto retry;
  860.  
  861.     case '\'':
  862.       {
  863.     return Fcons (Qquote, Fcons (read0 (readcharfun), Qnil));
  864.       }
  865.  
  866.     case '?':
  867.       {
  868.     register Lisp_Object val;
  869.  
  870.     c = READCHAR;
  871.     if (c < 0) return Fsignal (Qend_of_file, Qnil);
  872.  
  873.     if (c == '\\')
  874.       XSET (val, Lisp_Int, read_escape (readcharfun));
  875.     else
  876.       XSET (val, Lisp_Int, c);
  877.  
  878.     return val;
  879.       }
  880.  
  881.     case '\"':
  882.       {
  883.     register char *p = read_buffer;
  884.     register char *end = read_buffer + read_buffer_size;
  885.     register int c;
  886.     int cancel = 0;
  887.  
  888.     while ((c = READCHAR) >= 0
  889.            && c != '\"')
  890.       {
  891.         if (p == end)
  892.           {
  893.         char *new = (char *) xrealloc (read_buffer, read_buffer_size *= 2);
  894.         p = new + (p - read_buffer);
  895.         read_buffer = new;
  896.         end = read_buffer + read_buffer_size;
  897.           }
  898.         if (c == '\\')
  899.           c = read_escape (readcharfun);
  900.         /* c is -1 if \ newline has just been seen */
  901.         if (c < 0)
  902.           {
  903.         if (p == read_buffer)
  904.           cancel = 1;
  905.           }
  906.         else
  907.           *p++ = c;
  908.       }
  909.     if (c < 0) return Fsignal (Qend_of_file, Qnil);
  910.  
  911.     /* If purifying, and string starts with \ newline,
  912.        return zero instead.  This is for doc strings
  913.        that we are really going to find in etc/DOC.nn.nn  */
  914.     if (!NILP (Vpurify_flag) && NILP (Vdoc_file_name) && cancel)
  915.       return make_number (0);
  916.  
  917.     if (read_pure)
  918.       return make_pure_string (read_buffer, p - read_buffer);
  919.     else
  920.       return make_string (read_buffer, p - read_buffer);
  921.       }
  922.  
  923.     default:
  924.       uninterned_symbol = 0;
  925.       if (c <= 040) goto retry;
  926.     UNINTERNED_SYMBOL:
  927.       {
  928.     register char *p = read_buffer;
  929.     int saw_a_backslash = 0; /* whether there were backslashes in token */
  930.  
  931.     {
  932.       register char *end = read_buffer + read_buffer_size;
  933.  
  934.       while (c > 040 && 
  935.          !(c == '\"' || c == '\'' || c == ';' || c == '?'
  936.            || c == '(' || c == ')'
  937. #ifndef LISP_FLOAT_TYPE        /* we need to see <number><dot><number> */
  938.            || c =='.'
  939. #endif /* not LISP_FLOAT_TYPE */
  940.            || c == '[' || c == ']' || c == '#'
  941.            ))
  942.         {
  943.           if (p == end)
  944.         {
  945.           register char *new = (char *) xrealloc (read_buffer, read_buffer_size *= 2);
  946.           p += new - read_buffer;
  947.           read_buffer += new - read_buffer;
  948.           end = read_buffer + read_buffer_size;
  949.         }
  950.           if (c == '\\')
  951.         {
  952.           c = READCHAR;
  953.           saw_a_backslash = 1;
  954.         }
  955.           *p++ = c;
  956.           c = READCHAR;
  957.         }
  958.  
  959.       if (p == end)
  960.         {
  961.           char *new = (char *) xrealloc (read_buffer, read_buffer_size *= 2);
  962.           p += new - read_buffer;
  963.           read_buffer += new - read_buffer;
  964. /*          end = read_buffer + read_buffer_size;  */
  965.         }
  966.       *p = 0;
  967.       if (c >= 0)
  968.         UNREAD (c);
  969.     }
  970.  
  971.     /* Is it an integer? */
  972.     if (! (saw_a_backslash || uninterned_symbol))
  973.       /* If a token had any backslashes in it, it is disqualified from
  974.          being an integer or a float.  This means that 123\456 is a
  975.          symbol, as is \123 (which is the way (intern "123") prints.)
  976.          Also, if token was preceeded by #:, it's always a symbol.
  977.        */
  978.     {
  979.       register char *p1;
  980.       register Lisp_Object val;
  981.       p1 = read_buffer;
  982.       if (*p1 == '+' || *p1 == '-') p1++;
  983.       if (p1 != p)
  984.         {
  985.           while (p1 != p && (c = *p1) >= '0' && c <= '9') p1++;
  986.           if (p1 == p)
  987.         /* It is. */
  988.         {
  989.           int number = 0;
  990.  
  991. #if 0
  992.           /* This change breaks many elisp applications. */
  993.           if (read_buffer[0] == '0')
  994.             {
  995.               p = read_buffer;
  996.               /* Lucid fix */
  997.               while (p1 != p) {
  998.             
  999.             if (*p < '0' || *p > '7')
  1000.               return Fsignal
  1001.                 (Qinvalid_read_syntax,
  1002.                  Fcons (make_string ("non-octal digit", 15),
  1003.                     Qnil));
  1004.             
  1005.             number = (number << 3) + *p++ - '0';
  1006.               }
  1007.             }
  1008.           else
  1009. #endif
  1010.             number = atoi (read_buffer);
  1011.  
  1012.           XSET (val, Lisp_Int, number);
  1013.           return val;
  1014.         }
  1015.         }
  1016. #ifdef LISP_FLOAT_TYPE
  1017.       if (isfloat_string (read_buffer))
  1018.         return make_float (atof (read_buffer));
  1019. #endif
  1020.     }
  1021.  
  1022.     if (uninterned_symbol)
  1023.       {
  1024.         if (read_pure)
  1025.           return Fmake_symbol (make_pure_symbol_name
  1026.                    (read_buffer, strlen (read_buffer)));
  1027.         else
  1028.           return Fmake_symbol (make_string (read_buffer,
  1029.                         strlen (read_buffer)));
  1030.       }
  1031.     else
  1032.       return intern (read_buffer);
  1033.       }
  1034.     }
  1035. }
  1036.  
  1037. #ifdef LISP_FLOAT_TYPE
  1038.  
  1039. #include <ctype.h>
  1040. #define LEAD_INT 1
  1041. #define DOT_CHAR 2
  1042. #define TRAIL_INT 4
  1043. #define E_CHAR 8
  1044. #define EXP_INT 16
  1045.  
  1046. int
  1047. isfloat_string (cp)
  1048.      register const char *cp;
  1049. {
  1050.   register state;
  1051.   
  1052.   state = 0;
  1053.   if (*cp == '+' || *cp == '-')
  1054.     cp++;
  1055.  
  1056.   if (isdigit(*cp))
  1057.     {
  1058.       state |= LEAD_INT;
  1059.       while (isdigit (*cp))
  1060.     cp ++;
  1061.     }
  1062.   if (*cp == '.')
  1063.     {
  1064.       state |= DOT_CHAR;
  1065.       cp++;
  1066.     }
  1067.   if (isdigit(*cp))
  1068.     {
  1069.       state |= TRAIL_INT;
  1070.       while (isdigit (*cp))
  1071.     cp++;
  1072.     }
  1073.   if (*cp == 'e')
  1074.     {
  1075.       state |= E_CHAR;
  1076.       cp++;
  1077.     }
  1078.   if ((*cp == '+') || (*cp == '-'))
  1079.     cp++;
  1080.  
  1081.   if (isdigit (*cp))
  1082.     {
  1083.       state |= EXP_INT;
  1084.       while (isdigit (*cp))
  1085.     cp++;
  1086.     }
  1087.   return (*cp == 0
  1088.       && (state == (LEAD_INT|DOT_CHAR|TRAIL_INT)
  1089.           || state == (LEAD_INT|E_CHAR|EXP_INT)
  1090.           || state == (LEAD_INT|DOT_CHAR|TRAIL_INT|E_CHAR|EXP_INT)));
  1091. }
  1092. #endif /* LISP_FLOAT_TYPE */
  1093.  
  1094. static Lisp_Object
  1095. read_vector (readcharfun, vector_type)
  1096.      Lisp_Object readcharfun;
  1097.      enum Lisp_Type vector_type;
  1098. {
  1099.   register int i;
  1100.   register int size;
  1101.   register Lisp_Object *ptr;
  1102.   register Lisp_Object tem, vector;
  1103.   register struct Lisp_Cons *otem;
  1104.   Lisp_Object len;
  1105.  
  1106.   tem = read_list (1, readcharfun);
  1107.   len = Flength (tem);
  1108.   vector = (read_pure
  1109.         ? make_pure_vector (XINT (len), vector_type)
  1110.         : Fmake_vector (len, Qnil));
  1111.   XSETTYPE (vector, vector_type);
  1112.  
  1113.   size = XVECTOR (vector)->size;
  1114.   ptr = XVECTOR (vector)->contents;
  1115.   for (i = 0; i < size; i++)
  1116.     {
  1117.       ptr[i] = read_pure ? Fpurecopy (Fcar (tem)) : Fcar (tem);
  1118.       otem = XCONS (tem);
  1119.       tem = Fcdr (tem);
  1120.       free_cons (otem);
  1121.     }
  1122.   return vector;
  1123. }
  1124.   
  1125. /* flag = 1 means check for ] to terminate rather than ) and .
  1126.    flag = -1 means check for starting with defun
  1127.     and make structure pure.  */
  1128.  
  1129. static Lisp_Object
  1130. read_list (flag, readcharfun)
  1131.      int flag;
  1132.      register Lisp_Object readcharfun;
  1133. {
  1134.   /* -1 means check next element for defun,
  1135.      0 means don't check,
  1136.      1 means already checked and found defun. */
  1137.   int defunflag = flag < 0 ? -1 : 0;
  1138.   Lisp_Object val, tail;
  1139.   register Lisp_Object elt, tem;
  1140.   struct gcpro gcpro1, gcpro2;
  1141.  
  1142.   val = Qnil;
  1143.   tail = Qnil;
  1144.  
  1145.   while (1)
  1146.     {
  1147.       GCPRO2 (val, tail);
  1148.       elt = read1 (readcharfun);
  1149.       UNGCPRO;
  1150.       if (XTYPE (elt) == Lisp_Internal)
  1151.     {
  1152.       if (flag > 0)
  1153.         {
  1154.           if (XINT (elt) == ']')
  1155.         return val;
  1156.           return Fsignal (Qinvalid_read_syntax, Fcons (make_string (") or . in a vector", 18), Qnil));
  1157.         }
  1158.       if (XINT (elt) == ')')
  1159.         return val;
  1160.       if (XINT (elt) == '.')
  1161.         {
  1162.           GCPRO2 (val, tail);
  1163.           if (!NILP (tail))
  1164.         XCONS (tail)->cdr = read0 (readcharfun);
  1165.           else
  1166.         val = read0 (readcharfun);
  1167.           elt = read1 (readcharfun);
  1168.           UNGCPRO;
  1169.           if (XTYPE (elt) == Lisp_Internal && XINT (elt) == ')')
  1170.         return val;
  1171.           return Fsignal (Qinvalid_read_syntax, Fcons (make_string (". in wrong context", 18), Qnil));
  1172.         }
  1173.       return Fsignal (Qinvalid_read_syntax, Fcons (make_string ("] in a list", 11), Qnil));
  1174.     }
  1175.       tem = (read_pure && flag <= 0
  1176.          ? pure_cons (elt, Qnil)
  1177.          : Fcons (elt, Qnil));
  1178.       if (!NILP (tail))
  1179.     XCONS (tail)->cdr = tem;
  1180.       else
  1181.     val = tem;
  1182.       tail = tem;
  1183.       if (defunflag < 0)
  1184.     defunflag = EQ (elt, Qdefun);
  1185.       else if (defunflag > 0)
  1186.     read_pure = 1;
  1187.     }
  1188. }
  1189.  
  1190. Lisp_Object Vobarray;
  1191. static Lisp_Object initial_obarray;
  1192.  
  1193. static Lisp_Object
  1194. check_obarray (obarray)
  1195.      Lisp_Object obarray;
  1196. {
  1197.   while (!VECTORP (obarray) || XVECTOR (obarray)->size == 0)
  1198.     {
  1199.       /* If Vobarray is now invalid, force it to be valid.  */
  1200.       if (EQ (Vobarray, obarray)) Vobarray = initial_obarray;
  1201.  
  1202.       obarray = wrong_type_argument (Qvectorp, obarray);
  1203.     }
  1204.   return obarray;
  1205. }
  1206.  
  1207. static int hash_string (const unsigned char *ptr, int len);
  1208.  
  1209. Lisp_Object
  1210. intern (str)
  1211.      const char *str;
  1212. {
  1213.   Lisp_Object tem;
  1214.   int len = strlen (str);
  1215.   Lisp_Object obarray = Vobarray;
  1216.   if (!VECTORP (obarray) || XVECTOR (obarray)->size == 0)
  1217.     obarray = check_obarray (obarray);
  1218.   tem = oblookup (obarray, (unsigned char *) str, len);
  1219.   if (SYMBOLP (tem))
  1220.     return tem;
  1221.   return Fintern ((!NILP (Vpurify_flag)
  1222.            ? make_pure_symbol_name (str, len)
  1223.            : make_string (str, len)),
  1224.           obarray);
  1225. }
  1226.  
  1227. DEFUN ("intern", Fintern, Sintern, 1, 2, 0,
  1228.   "Return the canonical symbol whose name is STRING.\n\
  1229. If there is none, one is created by this function and returned.\n\
  1230. A second optional argument specifies the obarray to use;\n\
  1231. it defaults to the value of `obarray'.")
  1232.   (str, obarray)
  1233.      Lisp_Object str, obarray;
  1234. {
  1235.   register Lisp_Object tem, sym, *ptr;
  1236.  
  1237.   if (NILP (obarray)) obarray = Vobarray;
  1238.   obarray = check_obarray (obarray);
  1239.  
  1240.   CHECK_STRING (str, 0);
  1241.  
  1242.   tem = oblookup (obarray, XSTRING (str)->data, XSTRING (str)->size);
  1243.   if (!FIXNUMP (tem))
  1244.     return tem;
  1245.  
  1246.   if (!NILP (Vpurify_flag))
  1247.     str = Fpurecopy (str);
  1248.   sym = Fmake_symbol (str);
  1249.  
  1250.   ptr = &XVECTOR (obarray)->contents[XINT (tem)];
  1251.   if (SYMBOLP (*ptr))
  1252.     XSYMBOL (sym)->next = XSYMBOL (*ptr);
  1253.   else
  1254.     XSYMBOL (sym)->next = 0;
  1255.   *ptr = sym;
  1256.   return sym;
  1257. }
  1258.  
  1259. DEFUN ("intern-soft", Fintern_soft, Sintern_soft, 1, 2, 0,
  1260.   "Return the canonical symbol whose name is STRING, or nil if none exists.\n\
  1261. A second optional argument specifies the obarray to use;\n\
  1262. it defaults to the value of `obarray'.")
  1263.   (str, obarray)
  1264.      Lisp_Object str, obarray;
  1265. {
  1266.   register Lisp_Object tem;
  1267.  
  1268.   if (NILP (obarray)) obarray = Vobarray;
  1269.   obarray = check_obarray (obarray);
  1270.  
  1271.   CHECK_STRING (str, 0);
  1272.  
  1273.   tem = oblookup (obarray, XSTRING (str)->data, XSTRING (str)->size);
  1274.   if (!FIXNUMP (tem))
  1275.     return tem;
  1276.   return Qnil;
  1277. }
  1278.  
  1279. Lisp_Object
  1280. oblookup (obarray, ptr, size)
  1281.      Lisp_Object obarray;
  1282.      register const unsigned char *ptr;
  1283.      register int size;
  1284. {
  1285.   int hash, obsize;
  1286.   register Lisp_Object tail;
  1287.   Lisp_Object bucket, tem;
  1288.  
  1289.   if (!VECTORP (obarray) ||
  1290.       (obsize = XVECTOR (obarray)->size) == 0)
  1291.     {
  1292.       obarray = check_obarray (obarray);
  1293.       obsize = XVECTOR (obarray)->size;
  1294.     }
  1295.   /* Combining next two lines breaks VMS C 2.3.  */
  1296.   hash = hash_string ((unsigned char *) ptr, size);
  1297.   hash %= obsize;
  1298.   bucket = XVECTOR (obarray)->contents[hash];
  1299.   if (XFASTINT (bucket) == 0)
  1300.     ;
  1301.   else if (!SYMBOLP (bucket))
  1302.     error ("Bad data in guts of obarray"); /* Like CADR error message */
  1303.   else for (tail = bucket; ; XSET (tail, Lisp_Symbol, XSYMBOL (tail)->next))
  1304.       {
  1305.     if (XSYMBOL (tail)->name->size == size &&
  1306.         !memcmp (XSYMBOL (tail)->name->data, ptr, size))
  1307.       return tail;
  1308.     else if (XSYMBOL (tail)->next == 0)
  1309.       break;
  1310.       }
  1311.   XSET (tem, Lisp_Int, hash);
  1312.   return tem;
  1313. }
  1314.  
  1315. static int
  1316. hash_string (ptr, len)
  1317.      const unsigned char *ptr;
  1318.      int len;
  1319. {
  1320.   register const unsigned char *p = ptr;
  1321.   register const unsigned char *end = p + len;
  1322.   register unsigned char c;
  1323.   register int hash = 0;
  1324.  
  1325.   while (p != end)
  1326.     {
  1327.       c = *p++;
  1328.       if (c >= 0140) c -= 40;
  1329.       hash = ((hash<<3) + (hash>>28) + c);
  1330.     }
  1331.   return hash & 07777777777;
  1332. }
  1333.  
  1334. void
  1335. map_obarray (obarray, fn, arg)
  1336.      Lisp_Object obarray;
  1337.      void (*fn) (Lisp_Object sym, Lisp_Object arg);
  1338.      Lisp_Object arg;
  1339. {
  1340.   register int i;
  1341.   register Lisp_Object tail;
  1342.   CHECK_VECTOR (obarray, 1);
  1343.   for (i = XVECTOR (obarray)->size - 1; i >= 0; i--)
  1344.     {
  1345.       tail = XVECTOR (obarray)->contents[i];
  1346.       if (XFASTINT (tail) != 0)
  1347.     while (1)
  1348.       {
  1349.         (*fn) (tail, arg);
  1350.         if (XSYMBOL (tail)->next == 0)
  1351.           break;
  1352.         XSET (tail, Lisp_Symbol, XSYMBOL (tail)->next);
  1353.       }
  1354.     }
  1355. }
  1356.  
  1357. static void
  1358. mapatoms_1 (sym, function)
  1359.      Lisp_Object sym, function;
  1360. {
  1361.   call1 (function, sym);
  1362. }
  1363.  
  1364. DEFUN ("mapatoms", Fmapatoms, Smapatoms, 1, 2, 0,
  1365.   "Call FUNCTION on every symbol in OBARRAY.\n\
  1366. OBARRAY defaults to the value of `obarray'.")
  1367.   (function, obarray)
  1368.      Lisp_Object function, obarray;
  1369. {
  1370.   if (NILP (obarray))
  1371.     obarray = Vobarray;
  1372.   obarray = check_obarray (obarray);
  1373.  
  1374.   map_obarray (obarray, mapatoms_1, function);
  1375.   return Qnil;
  1376. }
  1377.  
  1378. #define OBARRAY_SIZE 509
  1379.  
  1380. void
  1381. init_obarray ()
  1382. {
  1383.   int hash;
  1384.   Lisp_Object *tem;
  1385.  
  1386.   Qnil = Fmake_symbol (make_pure_symbol_name ("nil", 3));
  1387.   /* Bootstrapping problem: Qnil isn't set when make_pure_string is
  1388.      called the first time. */
  1389.   XSYMBOL (Qnil)->name->dup_list = Qnil;
  1390.   XSYMBOL (Qnil)->value = Qnil;
  1391.   XSYMBOL (Qnil)->plist = Qnil;
  1392.  
  1393.   Vobarray = Fmake_vector (make_number (OBARRAY_SIZE), make_number (0));
  1394.   initial_obarray = Vobarray;
  1395.   staticpro (&initial_obarray);
  1396.   /* Intern nil in the obarray */
  1397.   /* These locals are to kludge around a pyramid compiler bug. */
  1398.   hash = hash_string ((const unsigned char *) "nil", 3);
  1399.   /* Separate statement here to avoid VAXC bug. */
  1400.   hash %= OBARRAY_SIZE;
  1401.   tem = &XVECTOR (Vobarray)->contents[hash];
  1402.   *tem = Qnil;
  1403.  
  1404.   Qunbound = Fmake_symbol (make_pure_symbol_name ("??unbound-marker??", 18));
  1405.   XSYMBOL (Qnil)->function = Qunbound;
  1406.   XSYMBOL (Qunbound)->value = Qunbound;
  1407.   XSYMBOL (Qunbound)->function = Qunbound;
  1408.  
  1409.   Qt = intern ("t");
  1410.   XSYMBOL (Qt)->value = Qt;
  1411.  
  1412.   /* Qt is correct even if CANNOT_DUMP.  loadup.el will set to nil at end.  */
  1413.   Vpurify_flag = Qt;
  1414.  
  1415.   Qvariable_documentation = intern ("variable-documentation");
  1416.  
  1417.   read_buffer_size = 100;
  1418.   read_buffer = (char *) xmalloc (read_buffer_size);
  1419. }
  1420.  
  1421. void
  1422. defsubr (struct Lisp_Subr *subr)
  1423. {
  1424.   Lisp_Object sym;
  1425.  
  1426.   /* Check that nobody spazzed */
  1427.   if (subr->max_args != MANY && subr->max_args != UNEVALLED)
  1428.   {
  1429.     if (subr->max_args > SUBR_MAX_ARGS /* Need to fix eval.c if so */
  1430.         || subr->max_args < subr->min_args)
  1431.       abort ();
  1432.   }
  1433.   if (subr->min_args < 0 || subr->min_args > SUBR_MAX_ARGS)
  1434.     abort ();
  1435.  
  1436.   sym = intern (subr_name (subr));
  1437.   XSET (XSYMBOL (sym)->function, Lisp_Subr, subr);
  1438. }
  1439.  
  1440. void
  1441. defsymbol (Lisp_Object *location, const char *name)
  1442. {
  1443.   *location = intern (name);
  1444.   staticpro (location);
  1445. }
  1446.  
  1447.  
  1448. /* New replacement for DefIntVar; it ignores the doc string argument
  1449.    on the assumption that make-docfile will handle that.  */
  1450. /* Define an "integer variable"; a symbol whose value is forwarded
  1451.  to a C variable of type int.  Sample call: */
  1452.   /* DEFVARINT ("indent-tabs-mode", &indent_tabs_mode, "Documentation");  */
  1453.  
  1454. void
  1455. defvar_int (namestring, address, doc)
  1456.      const char *namestring;
  1457.      int *address;
  1458.      const char *doc;
  1459. {
  1460.   Lisp_Object sym;
  1461.   sym = intern (namestring);
  1462.   XSET (XSYMBOL (sym)->value, Lisp_Intfwd, address);
  1463. }
  1464.  
  1465. /* Similar but define a variable whose value is T if address contains 1,
  1466.  NIL if address contains 0 */
  1467.  
  1468. void
  1469. defvar_bool (namestring, address, doc)
  1470.      const char *namestring;
  1471.      int *address;
  1472.      const char *doc;
  1473. {
  1474.   Lisp_Object sym;
  1475.   sym = intern (namestring);
  1476.   XSET (XSYMBOL (sym)->value, Lisp_Boolfwd, address);
  1477. }
  1478.  
  1479. /* Similar but define a variable whose value is the Lisp Object stored at address. */
  1480.  
  1481. void
  1482. defvar_lisp (namestring, address, doc)
  1483.      const char *namestring;
  1484.      Lisp_Object *address;
  1485.      const char *doc;
  1486. {
  1487.   Lisp_Object sym;
  1488.   sym = intern (namestring);
  1489.   XSET (XSYMBOL (sym)->value, Lisp_Objfwd, address);
  1490.   staticpro (address);
  1491. }
  1492.  
  1493. /* Similar but don't request gc-marking of the C variable.
  1494.    Used when that variable will be gc-marked for some other reason,
  1495.    since marking the same slot twice can cause trouble with strings.  */
  1496.  
  1497. void
  1498. defvar_lisp_nopro (namestring, address, doc)
  1499.      const char *namestring;
  1500.      Lisp_Object *address;
  1501.      const char *doc;
  1502. {
  1503.   Lisp_Object sym;
  1504.   sym = intern (namestring);
  1505.   XSET (XSYMBOL (sym)->value, Lisp_Objfwd, address);
  1506. }
  1507.  
  1508. void
  1509. init_lread ()
  1510. {
  1511. #ifdef PATH_LOADSEARCH
  1512.   char *normal = PATH_LOADSEARCH;
  1513.   Lisp_Object normal_path;
  1514.  
  1515.   /* Warn if dirs in the *standard* path don't exist.  */
  1516.   normal_path = decode_env_path ("", normal);
  1517.   for (; !NILP (normal_path); normal_path = XCONS (normal_path)->cdr)
  1518.     {
  1519.       Lisp_Object dirfile;
  1520.       dirfile = Fcar (normal_path);
  1521.       if (!NILP (dirfile))
  1522.     {
  1523.       dirfile = Fdirectory_file_name (dirfile);
  1524.       if (access (XSTRING (dirfile)->data, 0) < 0)
  1525.         printf ("Warning: lisp library (%s) does not exist.\n",
  1526.             XSTRING (Fcar (normal_path))->data);
  1527.     }
  1528.     }
  1529. #else
  1530.   char *normal = 0;
  1531. #endif
  1532.   Vvalues = Qnil;
  1533.  
  1534.   if (egetenv ("EMACSLOADPATH") || normal)
  1535.     Vload_path = decode_env_path ("EMACSLOADPATH", normal);
  1536.   else
  1537.     Vload_path = Qnil; /* further frobbed by startup.el */
  1538.  
  1539. #ifndef CANNOT_DUMP
  1540.   if (!NILP (Vpurify_flag))
  1541.     /* loadup.el will frob this some more */
  1542.     Vload_path = Fcons (build_string ("../lisp/prim"), Vload_path);
  1543. #endif /* not CANNOT_DUMP */
  1544.   load_in_progress = 0;
  1545. }
  1546.  
  1547. void
  1548. syms_of_lread ()
  1549. {
  1550.   defsubr (&Sread);
  1551.   defsubr (&Sread_from_string);
  1552.   defsubr (&Sintern);
  1553.   defsubr (&Sintern_soft);
  1554.   defsubr (&Sload);
  1555.   defsubr (&Slocate_file);
  1556.   defsubr (&Seval_buffer);
  1557.   defsubr (&Seval_region);
  1558. #ifdef standalone
  1559.   defsubr (&Sread_char);
  1560. #endif
  1561.   defsubr (&Sget_file_char);
  1562.   defsubr (&Smapatoms);
  1563.  
  1564.   DEFVAR_LISP ("obarray", &Vobarray,
  1565.     "Symbol table for use by `intern' and `read'.\n\
  1566. It is a vector whose length ought to be prime for best results.\n\
  1567. The vector's contents don't make sense if examined from Lisp programs;\n\
  1568. to find all the symbols in an obarray, use `mapatoms'.");
  1569.  
  1570.   DEFVAR_LISP ("values", &Vvalues,
  1571.     "List of values of all expressions which were read, evaluated and printed.\n\
  1572. Order is reverse chronological.");
  1573.  
  1574.   DEFVAR_LISP ("standard-input", &Vstandard_input,
  1575.     "Stream for read to get input from.\n\
  1576. See documentation of `read' for possible values.");
  1577.   Vstandard_input = Qt;
  1578.  
  1579.   DEFVAR_LISP ("load-path", &Vload_path,
  1580.     "*List of directories to search for files to load.\n\
  1581. Each element is a string (directory name) or nil (try default directory).\n\n\
  1582. Note that the elements of this list *may not* begin with \"~\", so you must\n\
  1583. call `expand-file-name' on them before adding them to this list.\n\n\
  1584. Initialized based on EMACSLOADPATH environment variable, if any,\n\
  1585. otherwise to default specified in by file `paths.h' when Emacs was built.\n\
  1586. If there were no paths specified in `paths.h', then emacs chooses a default\n\
  1587. value for this variable by looking around in the file-system near the\n\
  1588. directory in which the emacs executable resides.");
  1589.  
  1590.   DEFVAR_BOOL ("load-in-progress", &load_in_progress,
  1591.     "Non-nil iff inside of `load'.");
  1592.  
  1593.   DEFVAR_LISP ("after-load-alist", &Vafter_load_alist,
  1594.     "An alist of expressions to be evalled when particular files are loaded.\n\
  1595. Each element looks like (FILENAME FORMS...).\n\
  1596. When `load' is run and the file-name argument is FILENAME,\n\
  1597. the FORMS in the corresponding element are executed at the end of loading.\n\n\
  1598. FILENAME must match exactly!  Normally FILENAME is the name of a library,\n\
  1599. with no directory specified, since that is how `load' is normally called.\n\
  1600. An error in FORMS does not undo the load,\n\
  1601. but does prevent execution of the rest of the FORMS.");
  1602.   Vafter_load_alist = Qnil;
  1603.  
  1604.   DEFVAR_BOOL ("load-warn-when-source-newer", &load_warn_when_source_newer,
  1605.   "*Whether `load' should check whether the source is newer than the binary;\n\
  1606. If this variable is true, then when a `.elc' file is being loaded and the\n\
  1607. corresponding `.el' is newer, a warning message will be printed.");
  1608.   load_warn_when_source_newer = 0;
  1609.  
  1610.   DEFVAR_BOOL ("load-warn-when-source-only", &load_warn_when_source_only,
  1611.   "*Whether `load' should warn when loading a .el file instead of an .elc.\n\
  1612. If this variable is true, then when load is called with a filename without\n\
  1613. an extension, and the .elc version doesn't exist but the .el version does,\n\
  1614. then a message will be printed.  If an explicit extension is passed to load,\n\
  1615. no warning will be printed.");
  1616.   load_warn_when_source_only = 0;
  1617.  
  1618.   defsymbol (&Qstandard_input, "standard-input");
  1619.   defsymbol (&Qread_char, "read-char");
  1620.   defsymbol (&Qget_file_char, "get-file-char");
  1621. }
  1622.