home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / gnu / lucid / lemacs-19.6 / src / doc.c < prev    next >
Encoding:
C/C++ Source or Header  |  1993-02-14  |  14.3 KB  |  540 lines
  1. /* Record indices of function doc strings stored in a file.
  2.    Copyright (C) 1985-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.  
  21. #include "config.h"
  22.  
  23. #include <stdio.h>
  24. #include <sys/types.h>
  25. #include <sys/file.h>    /* Must be after sys/types.h for USG and BSD4_1*/
  26.  
  27. #ifdef USG5
  28. #include <fcntl.h>
  29. #endif
  30.  
  31. #ifndef O_RDONLY
  32. #define O_RDONLY 0
  33. #endif
  34.  
  35. #include "lisp.h"
  36. #include "buffer.h"
  37. #include "insdel.h"
  38.  
  39. Lisp_Object Vdoc_file_name;
  40.  
  41. static Lisp_Object
  42. get_doc_string (filepos)
  43.      long filepos;
  44. {
  45.   char buf[512 * 32 + 1];
  46.   register int fd;
  47.   register char *name;
  48.   register char *p, *p1;
  49.   register int count;
  50.  
  51.   if (!STRINGP (Vexec_directory)
  52.       || !STRINGP (Vdoc_file_name))
  53.     return Qnil;
  54.  
  55.   name = (char *) alloca (XSTRING (Vexec_directory)->size
  56.               + XSTRING (Vdoc_file_name)->size + 8);
  57.   strcpy (name, (char *) XSTRING (Vexec_directory)->data);
  58.   strcat (name, (char *) XSTRING (Vdoc_file_name)->data);
  59. #ifdef VMS
  60. #ifndef VMS4_4
  61.   /* For VMS versions with limited file name syntax,
  62.      convert the name to something VMS will allow.  */
  63.   p = name;
  64.   while (*p)
  65.     {
  66.       if (*p == '-')
  67.     *p = '_';
  68.       p++;
  69.     }
  70. #endif /* not VMS4_4 */
  71. #ifdef VMS4_4
  72.   strcpy (name, sys_translate_unix (name));
  73. #endif /* VMS4_4 */
  74. #endif /* VMS */
  75.  
  76.   fd = open (name, O_RDONLY, 0);
  77.   if (fd < 0)
  78.     error ("Cannot open doc string file \"%s\"", name);
  79.   if (0 > lseek (fd, filepos, 0))
  80.     {
  81.       close (fd);
  82.       error ("Position %ld out of range in doc string file \"%s\"",
  83.          filepos, name);
  84.     }
  85.   p = buf;
  86.   while (p != buf + sizeof buf - 1)
  87.     {
  88.       count = read (fd, p, 512);
  89.       p[count] = 0;
  90.       if (!count)
  91.     break;
  92.       p1 = strchr (p, '\037');
  93.       if (p1)
  94.     {
  95.       *p1 = 0;
  96.       p = p1;
  97.       break;
  98.     }
  99.       p += count;
  100.     }
  101.   close (fd);
  102.   return make_string (buf, p - buf);
  103. }
  104.  
  105. DEFUN ("documentation", Fdocumentation, Sdocumentation, 1, 1, 0,
  106.   "Return the documentation string of FUNCTION.")
  107.   (fun1)
  108.      Lisp_Object fun1;
  109. {
  110.   Lisp_Object fun;
  111.   Lisp_Object funcar;
  112.   Lisp_Object tem;
  113.  
  114.   fun = fun1;
  115.   while (SYMBOLP (fun))
  116.     fun = Fsymbol_function (fun);
  117.   if (SUBRP (fun))
  118.     {
  119.       if (XSUBR (fun)->doc == 0) return Qnil;
  120.       if ((int) XSUBR (fun)->doc >= 0)
  121.     return Fsubstitute_command_keys (build_string (XSUBR (fun)->doc));
  122.       return Fsubstitute_command_keys (get_doc_string (- (int) XSUBR (fun)->doc));
  123.     }
  124.   if (COMPILEDP (fun))
  125.     {
  126.       if (XVECTOR (fun)->size <= COMPILED_DOC_STRING)
  127.     return Qnil;
  128.       tem = XVECTOR (fun)->contents[COMPILED_DOC_STRING];
  129.       if (STRINGP (tem))
  130.     return Fsubstitute_command_keys (tem);
  131.       if (FIXNUMP (tem) && XINT (tem) >= 0)
  132.     return Fsubstitute_command_keys (get_doc_string (XFASTINT (tem)));
  133.       return Qnil;
  134.     }
  135.   if (KEYMAPP (fun))
  136.     return build_string ("Prefix command (definition is a keymap of subcommands).");
  137.   if (STRINGP (fun))
  138.     return build_string ("Keyboard macro.");
  139.   if (!CONSP (fun))
  140.     return Fsignal (Qinvalid_function, Fcons (fun, Qnil));
  141.   funcar = Fcar (fun);
  142.   if (!SYMBOLP (funcar))
  143.     return Fsignal (Qinvalid_function, Fcons (fun, Qnil));
  144.   if (XSYMBOL (funcar) == XSYMBOL (Qlambda)
  145.       || XSYMBOL (funcar) == XSYMBOL (Qautoload))
  146.     {
  147.       tem = Fcar (Fcdr (Fcdr (fun)));
  148.       if (STRINGP (tem))
  149.     return Fsubstitute_command_keys (tem);
  150.       if (FIXNUMP (tem) && XINT (tem) >= 0)
  151.     return Fsubstitute_command_keys (get_doc_string (XFASTINT (tem)));
  152.       return Qnil;
  153.     }
  154.   if (XSYMBOL (funcar) == XSYMBOL (Qmocklisp))
  155.     return Qnil;
  156.   if (XSYMBOL (funcar) == XSYMBOL (Qmacro))
  157.     return Fdocumentation (Fcdr (fun));
  158.   else
  159.     return Fsignal (Qinvalid_function, Fcons (fun, Qnil));
  160. }
  161.  
  162. DEFUN ("documentation-property", Fdocumentation_property, 
  163.        Sdocumentation_property, 2, 2, 0,
  164.   "Return the documentation string that is SYMBOL's PROP property.\n\
  165. This differs from using `get' only in that it can refer to strings\n\
  166. stored in the `etc/DOC' file.")
  167.   (sym, prop)
  168.      Lisp_Object sym, prop;
  169. {
  170.   register Lisp_Object tem;
  171.  
  172.   tem = Fget (sym, prop);
  173.   if (FIXNUMP (tem))
  174.     tem = get_doc_string (XINT (tem) > 0 ? XINT (tem) : - XINT (tem));
  175.   return Fsubstitute_command_keys (tem);
  176. }
  177.  
  178. DEFUN ("Snarf-documentation", Fsnarf_documentation, Ssnarf_documentation,
  179.   1, 1, 0,
  180.   "Used during Emacs initialization, before dumping runnable Emacs,\n\
  181. to find pointers to doc strings stored in `etc/DOC...' and\n\
  182. record them in function definitions.\n\
  183. One arg, FILENAME, a string which does not include a directory.\n\
  184. The file is found in `../etc' now; found in the `exec-directory'\n\
  185. when doc strings are referred to later in the dumped Emacs.")
  186.   (filename)
  187.      Lisp_Object filename;
  188. {
  189.   int fd;
  190.   char buf[1024 + 1];
  191.   register int filled;
  192.   register int pos;
  193.   register char *p, *end;
  194.   Lisp_Object sym, fun, tem;
  195.   char *name;
  196.  
  197.   CHECK_STRING (filename, 0);
  198.  
  199. #ifndef CANNOT_DUMP
  200.   name = (char *) alloca (XSTRING (filename)->size + 8);
  201.   strcpy (name, "../etc/");
  202. #else /* CANNOT_DUMP */
  203.   CHECK_STRING (Vexec_directory, 0);
  204.   name = (char *) alloca (XSTRING (filename)->size +
  205.               XSTRING (Vexec_directory)->size + 1);
  206.   strcpy (name, XSTRING (Vexec_directory)->data);
  207. #endif /* CANNOT_DUMP */
  208.   strcat (name, (char *) XSTRING (filename)->data);
  209. #ifdef VMS
  210. #ifndef VMS4_4
  211.   /* For VMS versions with limited file name syntax,
  212.      convert the name to something VMS will allow.  */
  213.   p = name;
  214.   while (*p)
  215.     {
  216.       if (*p == '-')
  217.     *p = '_';
  218.       p++;
  219.     }
  220. #endif /* not VMS4_4 */
  221. #ifdef VMS4_4
  222.   strcpy (name, sys_translate_unix (name));
  223. #endif /* VMS4_4 */
  224. #endif /* VMS */
  225.  
  226.   fd = open (name, O_RDONLY, 0);
  227.   if (fd < 0)
  228.     report_file_error ("Opening doc string file",
  229.                Fcons (build_string (name), Qnil));
  230.   Vdoc_file_name = filename;
  231.   filled = 0;
  232.   pos = 0;
  233.   while (1)
  234.     {
  235.       if (filled < 512)
  236.     filled += read (fd, &buf[filled], sizeof buf - 1 - filled);
  237.       if (!filled)
  238.     break;
  239.  
  240.       buf[filled] = 0;
  241.       p = buf;
  242.       end = buf + (filled < 512 ? filled : filled - 128);
  243.       while (p != end && *p != '\037') p++;
  244.       /* p points to ^_Ffunctionname\n or ^_Vvarname\n.  */
  245.       if (p != end)
  246.     {
  247.       end = strchr (p, '\n');
  248.       sym = oblookup (Vobarray, (unsigned char *) p + 2, end - p - 2);
  249.       if (SYMBOLP (sym))
  250.         {
  251.           if (p[1] == 'V')
  252.         {
  253.           /* Install file-position as variable-documentation property
  254.              and make it negative for a user-variable
  255.              (doc starts with a `*').  */
  256.           Fput (sym, Qvariable_documentation,
  257.             make_number ((pos + end + 1 - buf)
  258.                      * (end[1] == '*' ? -1 : 1)));
  259.         }
  260.           else if (p[1] == 'F')
  261.         {
  262.           fun = XSYMBOL (sym)->function;
  263.  
  264.           if (CONSP (fun) &&
  265.               EQ (XCONS (fun)->car, Qmacro))
  266.             fun = XCONS (fun)->cdr;
  267.  
  268.           if (SUBRP (fun))
  269.             XSUBR (fun)->doc = (char *) - (pos + end + 1 - buf);
  270.           else if (CONSP (fun))
  271.             {
  272.               tem = XCONS (fun)->car;
  273.               if (EQ (tem, Qlambda) || EQ (tem, Qautoload))
  274.             {
  275.               tem = Fcdr (Fcdr (fun));
  276.               if (CONSP (tem) &&
  277.                   FIXNUMP (XCONS (tem)->car))
  278.                 XFASTINT (XCONS (tem)->car) = (pos + end + 1 - buf);
  279.             }
  280.             }
  281.           else if (COMPILEDP (fun))
  282.             {
  283.               if (XVECTOR (fun)->size > COMPILED_DOC_STRING &&
  284.               FIXNUMP (XVECTOR (fun)->contents[COMPILED_DOC_STRING]))
  285.             XFASTINT (XVECTOR (fun)->contents[COMPILED_DOC_STRING])
  286.               = (pos + end + 1 - buf);
  287.             }
  288.         }
  289.           else error ("DOC file invalid at position %d", pos);
  290.         }
  291.     }
  292.       pos += end - buf;
  293.       filled -= end - buf;
  294.       memcpy (buf, end, filled);
  295.     }
  296.   close (fd);
  297.   return Qnil;
  298. }
  299.  
  300. static void
  301. verify_doc_mapper (Lisp_Object sym, Lisp_Object closure)
  302. {
  303.   if (!NILP (Ffboundp (sym)))
  304.     {
  305.       int doc = 0;
  306.       Lisp_Object fun = XSYMBOL (sym)->function;
  307.       if (CONSP (fun) &&
  308.       EQ (XCONS (fun)->car, Qmacro))
  309.     fun = XCONS (fun)->cdr;
  310.  
  311.       if (SUBRP (fun))
  312.     doc = (int) XSUBR (fun)->doc;
  313.       else if (SYMBOLP (fun))
  314.     doc = -1;
  315.       else if (KEYMAPP (fun))
  316.     doc = -1;
  317.       else if (CONSP (fun))
  318.     {
  319.       Lisp_Object tem = XCONS (fun)->car;
  320.       if (EQ (tem, Qlambda) || EQ (tem, Qautoload))
  321.         {
  322.           doc = -1;
  323.           tem = Fcdr (Fcdr (fun));
  324.           if (CONSP (tem) &&
  325.           FIXNUMP (XCONS (tem)->car))          
  326.         doc = XINT (XCONS (tem)->car);
  327.         }
  328.     }
  329.       else if (COMPILEDP (fun))
  330.     {
  331.       doc = -1;
  332.       if (XVECTOR (fun)->size > COMPILED_DOC_STRING &&
  333.           FIXNUMP (XVECTOR (fun)->contents[COMPILED_DOC_STRING]))
  334.         doc = XFASTINT (XVECTOR (fun)->contents[COMPILED_DOC_STRING]);
  335.     }
  336.  
  337.       if (doc == 0)
  338.     {
  339.       fprintf (stderr, "Warning: doc lost for function %s.\n",
  340.            (char *) XSYMBOL (sym)->name->data);
  341.       XCONS (closure)->cdr = Qt;
  342.     }
  343.     }
  344.   if (!NILP (Fboundp (sym)))
  345.     {
  346.       Lisp_Object doc = Fget (sym, Qvariable_documentation);
  347.       if (FIXNUMP (doc) && XFASTINT (doc) == 0)
  348.     {
  349.       fprintf (stderr, "Warning: doc lost for variable %s.\n",
  350.            (char *) XSYMBOL (sym)->name->data);
  351.       XCONS (closure)->cdr = Qt;
  352.     }
  353.     }
  354. }
  355.  
  356. DEFUN ("Verify-documentation", Fverify_documentation, Sverify_documentation,
  357.        0, 0, 0,
  358.        "Used to make sure everything went well with Snarf-documentation.\n\
  359. Writes to stderr if not.")
  360.      ()
  361. {
  362.   Lisp_Object closure = Fcons (Qnil, Qnil);
  363.   struct gcpro gcpro1;
  364.   GCPRO1 (closure);
  365.   map_obarray (Vobarray, verify_doc_mapper, closure);
  366.   if (!NILP (Fcdr (closure)))
  367.     fprintf (stderr, "\n\
  368. This is usually because some files were preloaded by loaddefs.el or\n\
  369. site-load.el, but were not passed to make-docfile by ymakefile.\n\n");
  370.   UNGCPRO;
  371.   return (NILP (Fcdr (closure)) ? Qt : Qnil);
  372. }
  373.  
  374.  
  375. DEFUN ("substitute-command-keys", Fsubstitute_command_keys,
  376.   Ssubstitute_command_keys, 1, 1, 0,
  377.   "Substitute key descriptions for command names in STRING.\n\
  378. Return a new string which is STRING with substrings of the form \\=\\[COMMAND]\n\
  379. replaced by either:  a keystroke sequence that will invoke COMMAND,\n\
  380. or \"M-x COMMAND\" if COMMAND is not on any keys.\n\
  381. Substrings of the form \\=\\{MAPVAR} are replaced by summaries\n\
  382. \(made by describe-bindings) of the value of MAPVAR, taken as a keymap.\n\
  383. Substrings of the form \\=\\<MAPVAR> specify to use the value of MAPVAR\n\
  384. as the keymap for future \\=\\[COMMAND] substrings.\n\
  385. \\=\\= quotes the following character and is discarded;\n\
  386. thus, \\=\\=\\=\\= puts \\=\\= into the output, and \\=\\=\\=\\[ puts \\=\\[ into the output.")
  387.   (str)
  388.      Lisp_Object str;
  389. {
  390.   unsigned char *buf;
  391.   int changed = 0;
  392.   register unsigned char *strp;
  393.   register unsigned char *bufp;
  394.   register unsigned char *send;
  395.   int bsize;
  396.   unsigned char *new;
  397.   Lisp_Object tem = Qnil;
  398.   Lisp_Object keymap;
  399.   unsigned char *start;
  400.   int length;
  401.   struct gcpro gcpro1;
  402.  
  403.   if (NILP (str))
  404.     return Qnil;
  405.  
  406.   GCPRO1 (tem);
  407.  
  408.   CHECK_STRING (str, 0);
  409.   strp = XSTRING(str)->data;
  410.   send = strp + XSTRING(str)->size;
  411.  
  412.   keymap = current_buffer->keymap;
  413.  
  414.   bsize = XSTRING (str)->size;
  415.   bufp = buf = (unsigned char *) xmalloc (bsize);
  416.  
  417.   while (strp < send)
  418.     {
  419.       if (strp[0] == '\\' && strp[1] == '=')
  420.     {
  421.       /* \= quotes the next character;
  422.          thus, to put in \[ without its special meaning, use \=\[.  */
  423.       changed = 1;
  424.       *bufp++ = strp[2];
  425.       strp += 3;
  426.     }
  427.       else if (strp[0] == '\\' && strp[1] == '[')
  428.     {
  429.       changed = 1;
  430.       strp += 2;        /* skip \[ */
  431.       start = strp;
  432.  
  433.       while (strp < send && *strp != ']')
  434.         strp++;
  435.       length = strp - start;
  436.       strp++;        /* skip ] */
  437.  
  438.       tem = Fintern (make_string ((char *) start, length), Qnil);
  439.       tem = Fwhere_is_internal (tem, keymap, Qt, Qnil, Qnil);
  440.  
  441.       if (NILP (tem))    /* but not on any keys */
  442.         {
  443.           new = (unsigned char *) xrealloc (buf, bsize += 4);
  444.           bufp += new - buf;
  445.           buf = new;
  446.           memcpy (bufp, "M-x ", 4);
  447.           bufp += 4;
  448.           goto subst;
  449.         }
  450.       else
  451.         {            /* function is on a key */
  452.           tem = Fkey_description (tem);
  453.           goto subst_string;
  454.         }
  455.     }
  456.       /* \{foo} is replaced with a summary of the keymap (symeval foo).
  457.      \<foo> just sets the keymap used for \[cmd].  */
  458.       else if (strp[0] == '\\' && (strp[1] == '{' || strp[1] == '<'))
  459.     {
  460.       struct buffer *oldbuf;
  461.       Lisp_Object name;
  462.  
  463.       changed = 1;
  464.       strp += 2;        /* skip \{ or \< */
  465.       start = strp;
  466.  
  467.       while (strp < send && *strp != '}' && *strp != '>')
  468.         strp++;
  469.       length = strp - start;
  470.       strp++;            /* skip } or > */
  471.  
  472.       /* Get the value of the keymap in TEM, or nil if undefined.
  473.          Do this while still in the user's current buffer
  474.          in case it is a local variable.  */
  475.       name = Fintern (make_string ((char *) start, length), Qnil);
  476.       tem = Fboundp (name);
  477.       if (! NILP (tem))
  478.         {
  479.           tem = Fsymbol_value (name);
  480.           if (! NILP (tem))
  481.         tem = get_keymap (tem, 0);
  482.         }
  483.  
  484.       /* Now switch to a temp buffer.  */
  485.       oldbuf = current_buffer;
  486.       internal_set_buffer (XBUFFER (Vprin1_to_string_buffer));
  487.  
  488.       if (NILP (tem))
  489.         {
  490.           name = Fsymbol_name (name);
  491.           insert_string ("\nUses keymap \"");
  492.           insert_from_string (name, 0, XSTRING (name)->size);
  493.           insert_string ("\", which is not currently defined.\n");
  494.           if (start[-1] == '<') keymap = Qnil;
  495.         }
  496.       else if (start[-1] == '<')
  497.         keymap = tem;
  498.       else
  499.         describe_map_tree (tem, 1, Qnil, Qnil, 0);
  500.       tem = Fbuffer_string ();
  501.       Ferase_buffer ();
  502.       internal_set_buffer (oldbuf);
  503.  
  504.     subst_string:
  505.       start = XSTRING (tem)->data;
  506.       length = XSTRING (tem)->size;
  507.     subst:
  508.       new = (unsigned char *) xrealloc (buf, bsize += length);
  509.       bufp += new - buf;
  510.       buf = new;
  511.       memcpy (bufp, start, length);
  512.       bufp += length;
  513.     }
  514.       else            /* just copy other chars */
  515.     *bufp++ = *strp++;
  516.     }
  517.  
  518.   if (changed)            /* don't bother if nothing substituted */
  519.     tem = make_string ((char *) buf, bufp - buf);
  520.   else
  521.     tem = str;
  522.   xfree (buf);
  523.   UNGCPRO;
  524.   return tem;
  525. }
  526.  
  527. void
  528. syms_of_doc ()
  529. {
  530.   DEFVAR_LISP ("internal-doc-file-name", &Vdoc_file_name,
  531.     "Name of file containing documentation strings of built-in symbols.");
  532.   Vdoc_file_name = Qnil;
  533.  
  534.   defsubr (&Sdocumentation);
  535.   defsubr (&Sdocumentation_property);
  536.   defsubr (&Ssnarf_documentation);
  537.   defsubr (&Sverify_documentation);
  538.   defsubr (&Ssubstitute_command_keys);
  539. }
  540.