src/doc.c

   1 /* Record indices of function doc strings stored in a file.
   2
   3 Copyright (C) 1985-1986, 1993-1995, 1997-2012 Free Software Foundation, Inc.
   4
   5 This file is part of GNU Emacs.
   6
   7 GNU Emacs is free software: you can redistribute it and/or modify
   8 it under the terms of the GNU General Public License as published by
   9 the Free Software Foundation, either version 3 of the License, or
  10 (at your option) any later version.
  11
  12 GNU Emacs is distributed in the hope that it will be useful,
  13 but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 GNU General Public License for more details.
  16
  17 You should have received a copy of the GNU General Public License
  18 along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.  */
  19
  20
  21 #include <config.h>
  22
  23 #include <sys/types.h>
  24 #include <sys/file.h>   /* Must be after sys/types.h for USG*/
  25 #include <setjmp.h>
  26 #include <fcntl.h>
  27 #include <unistd.h>
  28
  29 #include <c-ctype.h>
  30
  31 #include "lisp.h"
  32 #include "character.h"
  33 #include "buffer.h"
  34 #include "keyboard.h"
  35 #include "keymap.h"
  36 #include "buildobj.h"
  37
  38 Lisp_Object Qfunction_documentation;
  39
  40 extern Lisp_Object Qclosure;
  41 /* Buffer used for reading from documentation file.  */
  42 static char *get_doc_string_buffer;
  43 static ptrdiff_t get_doc_string_buffer_size;
  44
  45 static unsigned char *read_bytecode_pointer;
  46
  47 /* readchar in lread.c calls back here to fetch the next byte.
  48    If UNREADFLAG is 1, we unread a byte.  */
  49
  50 int
  51 read_bytecode_char (int unreadflag)
  52 {
  53   if (unreadflag)
  54     {
  55       read_bytecode_pointer--;
  56       return 0;
  57     }
  58   return *read_bytecode_pointer++;
  59 }
  60
  61 /* Extract a doc string from a file.  FILEPOS says where to get it.
  62    If it is an integer, use that position in the standard DOC-... file.
  63    If it is (FILE . INTEGER), use FILE as the file name
  64    and INTEGER as the position in that file.
  65    But if INTEGER is negative, make it positive.
  66    (A negative integer is used for user variables, so we can distinguish
  67    them without actually fetching the doc string.)
  68
  69    If the location does not point to the beginning of a docstring
  70    (e.g. because the file has been modified and the location is stale),
  71    return nil.
  72
  73    If UNIBYTE is nonzero, always make a unibyte string.
  74
  75    If DEFINITION is nonzero, assume this is for reading
  76    a dynamic function definition; convert the bytestring
  77    and the constants vector with appropriate byte handling,
  78    and return a cons cell.  */
  79
  80 Lisp_Object
  81 get_doc_string (Lisp_Object filepos, int unibyte, int definition)
  82 {
  83   char *from, *to;
  84   register int fd;
  85   register char *name;
  86   register char *p, *p1;
  87   ptrdiff_t minsize;
  88   int offset;
  89   EMACS_INT position;
  90   Lisp_Object file, tem;
  91   USE_SAFE_ALLOCA;
  92
  93   if (INTEGERP (filepos))
  94     {
  95       file = Vdoc_file_name;
  96       position = XINT (filepos);
  97     }
  98   else if (CONSP (filepos))
  99     {
 100       file = XCAR (filepos);
 101       position = XINT (XCDR (filepos));
 102     }
 103   else
 104     return Qnil;
 105
 106   if (position < 0)
 107     position = - position;
 108
 109   if (!STRINGP (Vdoc_directory))
 110     return Qnil;
 111
 112   if (!STRINGP (file))
 113     return Qnil;
 114
 115   /* Put the file name in NAME as a C string.
 116      If it is relative, combine it with Vdoc_directory.  */
 117
 118   tem = Ffile_name_absolute_p (file);
 119   file = ENCODE_FILE (file);
 120   if (NILP (tem))
 121     {
 122       Lisp_Object docdir = ENCODE_FILE (Vdoc_directory);
 123       minsize = SCHARS (docdir);
 124       /* sizeof ("../etc/") == 8 */
 125       if (minsize < 8)
 126         minsize = 8;
 127       name = SAFE_ALLOCA (minsize + SCHARS (file) + 8);
 128       strcpy (name, SSDATA (docdir));
 129       strcat (name, SSDATA (file));
 130     }
 131   else
 132     {
 133       name = SSDATA (file);
 134     }
 135
 136   fd = emacs_open (name, O_RDONLY, 0);
 137   if (fd < 0)
 138     {
 139 #ifndef CANNOT_DUMP
 140       if (!NILP (Vpurify_flag))
 141         {
 142           /* Preparing to dump; DOC file is probably not installed.
 143              So check in ../etc.  */
 144           strcpy (name, "../etc/");
 145           strcat (name, SSDATA (file));
 146
 147           fd = emacs_open (name, O_RDONLY, 0);
 148         }
 149 #endif
 150       if (fd < 0)
 151         error ("Cannot open doc string file \"%s\"", name);
 152     }
 153
 154   /* Seek only to beginning of disk block.  */
 155   /* Make sure we read at least 1024 bytes before `position'
 156      so we can check the leading text for consistency.  */
 157   offset = min (position, max (1024, position % (8 * 1024)));
 158   if (TYPE_MAXIMUM (off_t) < position
 159       || lseek (fd, position - offset, 0) < 0)
 160     {
 161       emacs_close (fd);
 162       error ("Position %"pI"d out of range in doc string file \"%s\"",
 163              position, name);
 164     }
 165
 166   SAFE_FREE ();
 167
 168   /* Read the doc string into get_doc_string_buffer.
 169      P points beyond the data just read.  */
 170
 171   p = get_doc_string_buffer;
 172   while (1)
 173     {
 174       ptrdiff_t space_left = (get_doc_string_buffer_size - 1
 175                               - (p - get_doc_string_buffer));
 176       int nread;
 177
 178       /* Allocate or grow the buffer if we need to.  */
 179       if (space_left <= 0)
 180         {
 181           ptrdiff_t in_buffer = p - get_doc_string_buffer;
 182           get_doc_string_buffer =
 183             xpalloc (get_doc_string_buffer, &get_doc_string_buffer_size,
 184                      16 * 1024, -1, 1);
 185           p = get_doc_string_buffer + in_buffer;
 186           space_left = (get_doc_string_buffer_size - 1
 187                         - (p - get_doc_string_buffer));
 188         }
 189
 190       /* Read a disk block at a time.
 191          If we read the same block last time, maybe skip this?  */
 192       if (space_left > 1024 * 8)
 193         space_left = 1024 * 8;
 194       nread = emacs_read (fd, p, space_left);
 195       if (nread < 0)
 196         {
 197           emacs_close (fd);
 198           error ("Read error on documentation file");
 199         }
 200       p[nread] = 0;
 201       if (!nread)
 202         break;
 203       if (p == get_doc_string_buffer)
 204         p1 = strchr (p + offset, '\037');
 205       else
 206         p1 = strchr (p, '\037');
 207       if (p1)
 208         {
 209           *p1 = 0;
 210           p = p1;
 211           break;
 212         }
 213       p += nread;
 214     }
 215   emacs_close (fd);
 216
 217   /* Sanity checking.  */
 218   if (CONSP (filepos))
 219     {
 220       int test = 1;
 221       if (get_doc_string_buffer[offset - test++] != ' ')
 222         return Qnil;
 223       while (get_doc_string_buffer[offset - test] >= '0'
 224              && get_doc_string_buffer[offset - test] <= '9')
 225         test++;
 226       if (get_doc_string_buffer[offset - test++] != '@'
 227           || get_doc_string_buffer[offset - test] != '#')
 228         return Qnil;
 229     }
 230   else
 231     {
 232       int test = 1;
 233       if (get_doc_string_buffer[offset - test++] != '\n')
 234         return Qnil;
 235       while (get_doc_string_buffer[offset - test] > ' ')
 236         test++;
 237       if (get_doc_string_buffer[offset - test] != '\037')
 238         return Qnil;
 239     }
 240
 241   /* Scan the text and perform quoting with ^A (char code 1).
 242      ^A^A becomes ^A, ^A0 becomes a null char, and ^A_ becomes a ^_.  */
 243   from = get_doc_string_buffer + offset;
 244   to = get_doc_string_buffer + offset;
 245   while (from != p)
 246     {
 247       if (*from == 1)
 248         {
 249           int c;
 250
 251           from++;
 252           c = *from++;
 253           if (c == 1)
 254             *to++ = c;
 255           else if (c == '0')
 256             *to++ = 0;
 257           else if (c == '_')
 258             *to++ = 037;
 259           else
 260             {
 261               unsigned char uc = c;
 262               error ("\
 263 Invalid data in documentation file -- %c followed by code %03o",
 264                      1, uc);
 265             }
 266         }
 267       else
 268         *to++ = *from++;
 269     }
 270
 271   /* If DEFINITION, read from this buffer
 272      the same way we would read bytes from a file.  */
 273   if (definition)
 274     {
 275       read_bytecode_pointer = (unsigned char *) get_doc_string_buffer + offset;
 276       return Fread (Qlambda);
 277     }
 278
 279   if (unibyte)
 280     return make_unibyte_string (get_doc_string_buffer + offset,
 281                                 to - (get_doc_string_buffer + offset));
 282   else
 283     {
 284       /* The data determines whether the string is multibyte.  */
 285       ptrdiff_t nchars =
 286         multibyte_chars_in_text (((unsigned char *) get_doc_string_buffer
 287                                   + offset),
 288                                  to - (get_doc_string_buffer + offset));
 289       return make_string_from_bytes (get_doc_string_buffer + offset,
 290                                      nchars,
 291                                      to - (get_doc_string_buffer + offset));
 292     }
 293 }
 294
 295 /* Get a string from position FILEPOS and pass it through the Lisp reader.
 296    We use this for fetching the bytecode string and constants vector
 297    of a compiled function from the .elc file.  */
 298
 299 Lisp_Object
 300 read_doc_string (Lisp_Object filepos)
 301 {
 302   return get_doc_string (filepos, 0, 1);
 303 }
 304
 305 static int
 306 reread_doc_file (Lisp_Object file)
 307 {
 308 #if 0
 309   Lisp_Object reply, prompt[3];
 310   struct gcpro gcpro1;
 311   GCPRO1 (file);
 312   prompt[0] = build_string ("File ");
 313   prompt[1] = NILP (file) ? Vdoc_file_name : file;
 314   prompt[2] = build_string (" is out of sync.  Reload? ");
 315   reply = Fy_or_n_p (Fconcat (3, prompt));
 316   UNGCPRO;
 317   if (NILP (reply))
 318     return 0;
 319 #endif
 320
 321   if (NILP (file))
 322     Fsnarf_documentation (Vdoc_file_name);
 323   else
 324     Fload (file, Qt, Qt, Qt, Qnil);
 325
 326   return 1;
 327 }
 328
 329 DEFUN ("documentation", Fdocumentation, Sdocumentation, 1, 2, 0,
 330        doc: /* Return the documentation string of FUNCTION.
 331 Unless a non-nil second argument RAW is given, the
 332 string is passed through `substitute-command-keys'.  */)
 333   (Lisp_Object function, Lisp_Object raw)
 334 {
 335   Lisp_Object fun;
 336   Lisp_Object funcar;
 337   Lisp_Object doc;
 338   int try_reload = 1;
 339
 340  documentation:
 341
 342   doc = Qnil;
 343
 344   if (SYMBOLP (function))
 345     {
 346       Lisp_Object tem = Fget (function, Qfunction_documentation);
 347       if (!NILP (tem))
 348         return Fdocumentation_property (function, Qfunction_documentation,
 349                                         raw);
 350     }
 351
 352   fun = Findirect_function (function, Qnil);
 353   if (SUBRP (fun))
 354     {
 355       if (XSUBR (fun)->doc == 0)
 356         return Qnil;
 357       /* FIXME: This is not portable, as it assumes that string
 358          pointers have the top bit clear.  */
 359       else if ((intptr_t) XSUBR (fun)->doc >= 0)
 360         doc = build_string (XSUBR (fun)->doc);
 361       else
 362         doc = make_number ((intptr_t) XSUBR (fun)->doc);
 363     }
 364   else if (COMPILEDP (fun))
 365     {
 366       if ((ASIZE (fun) & PSEUDOVECTOR_SIZE_MASK) <= COMPILED_DOC_STRING)
 367         return Qnil;
 368       else
 369         {
 370           Lisp_Object tem = AREF (fun, COMPILED_DOC_STRING);
 371           if (STRINGP (tem))
 372             doc = tem;
 373           else if (NATNUMP (tem) || CONSP (tem))
 374             doc = tem;
 375           else
 376             return Qnil;
 377         }
 378     }
 379   else if (STRINGP (fun) || VECTORP (fun))
 380     {
 381       return build_string ("Keyboard macro.");
 382     }
 383   else if (CONSP (fun))
 384     {
 385       funcar = XCAR (fun);
 386       if (!SYMBOLP (funcar))
 387         xsignal1 (Qinvalid_function, fun);
 388       else if (EQ (funcar, Qkeymap))
 389         return build_string ("Prefix command (definition is a keymap associating keystrokes with commands).");
 390       else if (EQ (funcar, Qlambda)
 391                || (EQ (funcar, Qclosure) && (fun = XCDR (fun), 1))
 392                || EQ (funcar, Qautoload))
 393         {
 394           Lisp_Object tem1 = Fcdr (Fcdr (fun));
 395           Lisp_Object tem = Fcar (tem1);
 396           if (STRINGP (tem))
 397             doc = tem;
 398           /* Handle a doc reference--but these never come last
 399              in the function body, so reject them if they are last.  */
 400           else if ((NATNUMP (tem) || (CONSP (tem) && INTEGERP (XCDR (tem))))
 401                    && !NILP (XCDR (tem1)))
 402             doc = tem;
 403           else
 404             return Qnil;
 405         }
 406       else if (EQ (funcar, Qmacro))
 407         return Fdocumentation (Fcdr (fun), raw);
 408       else
 409         goto oops;
 410     }
 411   else
 412     {
 413     oops:
 414       xsignal1 (Qinvalid_function, fun);
 415     }
 416
 417   /* Check for an advised function.  Its doc string
 418      has an `ad-advice-info' text property.  */
 419   if (STRINGP (doc))
 420     {
 421       Lisp_Object innerfunc;
 422       innerfunc = Fget_text_property (make_number (0),
 423                                       intern ("ad-advice-info"),
 424                                       doc);
 425       if (! NILP (innerfunc))
 426         doc = call1 (intern ("ad-make-advised-docstring"), innerfunc);
 427     }
 428
 429   /* If DOC is 0, it's typically because of a dumped file missing
 430      from the DOC file (bug in src/Makefile.in).  */
 431   if (EQ (doc, make_number (0)))
 432     doc = Qnil;
 433   if (INTEGERP (doc) || CONSP (doc))
 434     {
 435       Lisp_Object tem;
 436       tem = get_doc_string (doc, 0, 0);
 437       if (NILP (tem) && try_reload)
 438         {
 439           /* The file is newer, we need to reset the pointers.  */
 440           struct gcpro gcpro1, gcpro2;
 441           GCPRO2 (function, raw);
 442           try_reload = reread_doc_file (Fcar_safe (doc));
 443           UNGCPRO;
 444           if (try_reload)
 445             {
 446               try_reload = 0;
 447               goto documentation;
 448             }
 449         }
 450       else
 451         doc = tem;
 452     }
 453
 454   if (NILP (raw))
 455     doc = Fsubstitute_command_keys (doc);
 456   return doc;
 457 }
 458
 459 DEFUN ("documentation-property", Fdocumentation_property,
 460        Sdocumentation_property, 2, 3, 0,
 461        doc: /* Return the documentation string that is SYMBOL's PROP property.
 462 Third argument RAW omitted or nil means pass the result through
 463 `substitute-command-keys' if it is a string.
 464
 465 This differs from `get' in that it can refer to strings stored in the
 466 `etc/DOC' file; and that it evaluates documentation properties that
 467 aren't strings.  */)
 468   (Lisp_Object symbol, Lisp_Object prop, Lisp_Object raw)
 469 {
 470   int try_reload = 1;
 471   Lisp_Object tem;
 472
 473  documentation_property:
 474
 475   tem = Fget (symbol, prop);
 476   if (EQ (tem, make_number (0)))
 477     tem = Qnil;
 478   if (INTEGERP (tem) || (CONSP (tem) && INTEGERP (XCDR (tem))))
 479     {
 480       Lisp_Object doc = tem;
 481       tem = get_doc_string (tem, 0, 0);
 482       if (NILP (tem) && try_reload)
 483         {
 484           /* The file is newer, we need to reset the pointers.  */
 485           struct gcpro gcpro1, gcpro2, gcpro3;
 486           GCPRO3 (symbol, prop, raw);
 487           try_reload = reread_doc_file (Fcar_safe (doc));
 488           UNGCPRO;
 489           if (try_reload)
 490             {
 491               try_reload = 0;
 492               goto documentation_property;
 493             }
 494         }
 495     }
 496   else if (!STRINGP (tem))
 497     /* Feval protects its argument.  */
 498     tem = Feval (tem, Qnil);
 499
 500   if (NILP (raw) && STRINGP (tem))
 501     tem = Fsubstitute_command_keys (tem);
 502   return tem;
 503 }
 504 \f
 505 /* Scanning the DOC files and placing docstring offsets into functions.  */
 506
 507 static void
 508 store_function_docstring (Lisp_Object obj, ptrdiff_t offset)
 509 {
 510   /* Don't use indirect_function here, or defaliases will apply their
 511      docstrings to the base functions (Bug#2603).  */
 512   Lisp_Object fun = SYMBOLP (obj) ? XSYMBOL (obj)->function : obj;
 513
 514   /* The type determines where the docstring is stored.  */
 515
 516   /* Lisp_Subrs have a slot for it.  */
 517   if (SUBRP (fun))
 518     {
 519       intptr_t negative_offset = - offset;
 520       XSUBR (fun)->doc = (char *) negative_offset;
 521     }
 522
 523   /* If it's a lisp form, stick it in the form.  */
 524   else if (CONSP (fun))
 525     {
 526       Lisp_Object tem;
 527
 528       tem = XCAR (fun);
 529       if (EQ (tem, Qlambda) || EQ (tem, Qautoload)
 530           || (EQ (tem, Qclosure) && (fun = XCDR (fun), 1)))
 531         {
 532           tem = Fcdr (Fcdr (fun));
 533           if (CONSP (tem) && INTEGERP (XCAR (tem)))
 534             XSETCAR (tem, make_number (offset));
 535         }
 536       else if (EQ (tem, Qmacro))
 537         store_function_docstring (XCDR (fun), offset);
 538     }
 539
 540   /* Bytecode objects sometimes have slots for it.  */
 541   else if (COMPILEDP (fun))
 542     {
 543       /* This bytecode object must have a slot for the
 544          docstring, since we've found a docstring for it.  */
 545       if ((ASIZE (fun) & PSEUDOVECTOR_SIZE_MASK) > COMPILED_DOC_STRING)
 546         ASET (fun, COMPILED_DOC_STRING, make_number (offset));
 547     }
 548 }
 549
 550 static const char buildobj[] = BUILDOBJ;
 551
 552 DEFUN ("Snarf-documentation", Fsnarf_documentation, Ssnarf_documentation,
 553        1, 1, 0,
 554        doc: /* Used during Emacs initialization to scan the `etc/DOC...' file.
 555 This searches the `etc/DOC...' file for doc strings and
 556 records them in function and variable definitions.
 557 The function takes one argument, FILENAME, a string;
 558 it specifies the file name (without a directory) of the DOC file.
 559 That file is found in `../etc' now; later, when the dumped Emacs is run,
 560 the same file name is found in the `doc-directory'.  */)
 561   (Lisp_Object filename)
 562 {
 563   int fd;
 564   char buf[1024 + 1];
 565   register int filled;
 566   register EMACS_INT pos;
 567   register char *p;
 568   Lisp_Object sym;
 569   char *name;
 570   int skip_file = 0;
 571
 572   CHECK_STRING (filename);
 573
 574   if
 575 #ifndef CANNOT_DUMP
 576     (!NILP (Vpurify_flag))
 577 #else /* CANNOT_DUMP */
 578       (0)
 579 #endif /* CANNOT_DUMP */
 580     {
 581       name = alloca (SCHARS (filename) + 14);
 582       strcpy (name, "../etc/");
 583     }
 584   else
 585     {
 586       CHECK_STRING (Vdoc_directory);
 587       name = alloca (SCHARS (filename) + SCHARS (Vdoc_directory) + 1);
 588       strcpy (name, SSDATA (Vdoc_directory));
 589     }
 590   strcat (name, SSDATA (filename));     /*** Add this line ***/
 591
 592   /* Vbuild_files is nil when temacs is run, and non-nil after that.  */
 593   if (NILP (Vbuild_files))
 594   {
 595     const char *beg, *end;
 596
 597     for (beg = buildobj; *beg; beg = end)
 598       {
 599         ptrdiff_t len;
 600
 601         while (*beg && c_isspace (*beg)) ++beg;
 602
 603         for (end = beg; *end && ! c_isspace (*end); ++end)
 604           if (*end == '/') beg = end+1;  /* skip directory part  */
 605
 606         len = end - beg;
 607         if (len > 4 && end[-4] == '.' && end[-3] == 'o')
 608           len -= 2;  /* Just take .o if it ends in .obj  */
 609
 610         if (len > 0)
 611           Vbuild_files = Fcons (make_string (beg, len), Vbuild_files);
 612       }
 613     Vbuild_files = Fpurecopy (Vbuild_files);
 614   }
 615
 616   fd = emacs_open (name, O_RDONLY, 0);
 617   if (fd < 0)
 618     report_file_error ("Opening doc string file",
 619                        Fcons (build_string (name), Qnil));
 620   Vdoc_file_name = filename;
 621   filled = 0;
 622   pos = 0;
 623   while (1)
 624     {
 625       register char *end;
 626       if (filled < 512)
 627         filled += emacs_read (fd, &buf[filled], sizeof buf - 1 - filled);
 628       if (!filled)
 629         break;
 630
 631       buf[filled] = 0;
 632       p = buf;
 633       end = buf + (filled < 512 ? filled : filled - 128);
 634       while (p != end && *p != '\037') p++;
 635       /* p points to ^_Ffunctionname\n or ^_Vvarname\n or ^_Sfilename\n.  */
 636       if (p != end)
 637         {
 638           end = strchr (p, '\n');
 639
 640           /* See if this is a file name, and if it is a file in build-files.  */
 641           if (p[1] == 'S')
 642             {
 643               skip_file = 0;
 644               if (end - p > 4 && end[-2] == '.'
 645                   && (end[-1] == 'o' || end[-1] == 'c'))
 646                 {
 647                   ptrdiff_t len = end - p - 2;
 648                   char *fromfile = alloca (len + 1);
 649                   memcpy (fromfile, &p[2], len);
 650                   fromfile[len] = 0;
 651                   if (fromfile[len-1] == 'c')
 652                     fromfile[len-1] = 'o';
 653
 654                   skip_file = NILP (Fmember (build_string (fromfile),
 655                                              Vbuild_files));
 656                 }
 657             }
 658
 659           sym = oblookup (Vobarray, p + 2,
 660                           multibyte_chars_in_text ((unsigned char *) p + 2,
 661                                                    end - p - 2),
 662                           end - p - 2);
 663           /* Check skip_file so that when a function is defined several
 664              times in different files (typically, once in xterm, once in
 665              w32term, ...), we only pay attention to the one that
 666              matters.  */
 667           if (! skip_file && SYMBOLP (sym))
 668             {
 669               /* Attach a docstring to a variable?  */
 670               if (p[1] == 'V')
 671                 {
 672                   /* Install file-position as variable-documentation property
 673                      and make it negative for a user-variable
 674                      (doc starts with a `*').  */
 675                   if (!NILP (Fboundp (sym)))
 676                     Fput (sym, Qvariable_documentation,
 677                           make_number ((pos + end + 1 - buf)
 678                                        * (end[1] == '*' ? -1 : 1)));
 679                 }
 680
 681               /* Attach a docstring to a function?  */
 682               else if (p[1] == 'F')
 683                 {
 684                   if (!NILP (Ffboundp (sym)))
 685                     store_function_docstring (sym, pos + end + 1 - buf);
 686                 }
 687               else if (p[1] == 'S')
 688                 ; /* Just a source file name boundary marker.  Ignore it.  */
 689
 690               else
 691                 error ("DOC file invalid at position %"pI"d", pos);
 692             }
 693         }
 694       pos += end - buf;
 695       filled -= end - buf;
 696       memmove (buf, end, filled);
 697     }
 698   emacs_close (fd);
 699   return Qnil;
 700 }
 701 \f
 702 DEFUN ("substitute-command-keys", Fsubstitute_command_keys,
 703        Ssubstitute_command_keys, 1, 1, 0,
 704        doc: /* Substitute key descriptions for command names in STRING.
 705 Each substring of the form \\=\\[COMMAND] is replaced by either a
 706 keystroke sequence that invokes COMMAND, or "M-x COMMAND" if COMMAND
 707 is not on any keys.
 708
 709 Each substring of the form \\=\\{MAPVAR} is replaced by a summary of
 710 the value of MAPVAR as a keymap.  This summary is similar to the one
 711 produced by `describe-bindings'.  The summary ends in two newlines
 712 \(used by the helper function `help-make-xrefs' to find the end of the
 713 summary).
 714
 715 Each substring of the form \\=\\<MAPVAR> specifies the use of MAPVAR
 716 as the keymap for future \\=\\[COMMAND] substrings.
 717 \\=\\= quotes the following character and is discarded;
 718 thus, \\=\\=\\=\\= puts \\=\\= into the output, and \\=\\=\\=\\[ puts \\=\\[ into the output.
 719
 720 Return the original STRING if no substitutions are made.
 721 Otherwise, return a new string, without any text properties.  */)
 722   (Lisp_Object string)
 723 {
 724   char *buf;
 725   int changed = 0;
 726   register unsigned char *strp;
 727   register char *bufp;
 728   ptrdiff_t idx;
 729   ptrdiff_t bsize;
 730   Lisp_Object tem;
 731   Lisp_Object keymap;
 732   unsigned char *start;
 733   ptrdiff_t length, length_byte;
 734   Lisp_Object name;
 735   struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
 736   int multibyte;
 737   ptrdiff_t nchars;
 738
 739   if (NILP (string))
 740     return Qnil;
 741
 742   CHECK_STRING (string);
 743   tem = Qnil;
 744   keymap = Qnil;
 745   name = Qnil;
 746   GCPRO4 (string, tem, keymap, name);
 747
 748   multibyte = STRING_MULTIBYTE (string);
 749   nchars = 0;
 750
 751   /* KEYMAP is either nil (which means search all the active keymaps)
 752      or a specified local map (which means search just that and the
 753      global map).  If non-nil, it might come from Voverriding_local_map,
 754      or from a \\<mapname> construct in STRING itself..  */
 755   keymap = KVAR (current_kboard, Voverriding_terminal_local_map);
 756   if (NILP (keymap))
 757     keymap = Voverriding_local_map;
 758
 759   bsize = SBYTES (string);
 760   bufp = buf = xmalloc (bsize);
 761
 762   strp = SDATA (string);
 763   while (strp < SDATA (string) + SBYTES (string))
 764     {
 765       if (strp[0] == '\\' && strp[1] == '=')
 766         {
 767           /* \= quotes the next character;
 768              thus, to put in \[ without its special meaning, use \=\[.  */
 769           changed = 1;
 770           strp += 2;
 771           if (multibyte)
 772             {
 773               int len;
 774
 775               STRING_CHAR_AND_LENGTH (strp, len);
 776               if (len == 1)
 777                 *bufp = *strp;
 778               else
 779                 memcpy (bufp, strp, len);
 780               strp += len;
 781               bufp += len;
 782               nchars++;
 783             }
 784           else
 785             *bufp++ = *strp++, nchars++;
 786         }
 787       else if (strp[0] == '\\' && strp[1] == '[')
 788         {
 789           ptrdiff_t start_idx;
 790           int follow_remap = 1;
 791
 792           changed = 1;
 793           strp += 2;            /* skip \[ */
 794           start = strp;
 795           start_idx = start - SDATA (string);
 796
 797           while ((strp - SDATA (string)
 798                   < SBYTES (string))
 799                  && *strp != ']')
 800             strp++;
 801           length_byte = strp - start;
 802
 803           strp++;               /* skip ] */
 804
 805           /* Save STRP in IDX.  */
 806           idx = strp - SDATA (string);
 807           name = Fintern (make_string ((char *) start, length_byte), Qnil);
 808
 809         do_remap:
 810           tem = Fwhere_is_internal (name, keymap, Qt, Qnil, Qnil);
 811
 812           if (VECTORP (tem) && ASIZE (tem) > 1
 813               && EQ (AREF (tem, 0), Qremap) && SYMBOLP (AREF (tem, 1))
 814               && follow_remap)
 815             {
 816               name = AREF (tem, 1);
 817               follow_remap = 0;
 818               goto do_remap;
 819             }
 820
 821           /* Note the Fwhere_is_internal can GC, so we have to take
 822              relocation of string contents into account.  */
 823           strp = SDATA (string) + idx;
 824           start = SDATA (string) + start_idx;
 825
 826           if (NILP (tem))       /* but not on any keys */
 827             {
 828               ptrdiff_t offset = bufp - buf;
 829               if (STRING_BYTES_BOUND - 4 < bsize)
 830                 string_overflow ();
 831               buf = xrealloc (buf, bsize += 4);
 832               bufp = buf + offset;
 833               memcpy (bufp, "M-x ", 4);
 834               bufp += 4;
 835               nchars += 4;
 836               if (multibyte)
 837                 length = multibyte_chars_in_text (start, length_byte);
 838               else
 839                 length = length_byte;
 840               goto subst;
 841             }
 842           else
 843             {                   /* function is on a key */
 844               tem = Fkey_description (tem, Qnil);
 845               goto subst_string;
 846             }
 847         }
 848       /* \{foo} is replaced with a summary of the keymap (symbol-value foo).
 849          \<foo> just sets the keymap used for \[cmd].  */
 850       else if (strp[0] == '\\' && (strp[1] == '{' || strp[1] == '<'))
 851         {
 852           struct buffer *oldbuf;
 853           ptrdiff_t start_idx;
 854           /* This is for computing the SHADOWS arg for describe_map_tree.  */
 855           Lisp_Object active_maps = Fcurrent_active_maps (Qnil, Qnil);
 856           Lisp_Object earlier_maps;
 857
 858           changed = 1;
 859           strp += 2;            /* skip \{ or \< */
 860           start = strp;
 861           start_idx = start - SDATA (string);
 862
 863           while ((strp - SDATA (string) < SBYTES (string))
 864                  && *strp != '}' && *strp != '>')
 865             strp++;
 866
 867           length_byte = strp - start;
 868           strp++;                       /* skip } or > */
 869
 870           /* Save STRP in IDX.  */
 871           idx = strp - SDATA (string);
 872
 873           /* Get the value of the keymap in TEM, or nil if undefined.
 874              Do this while still in the user's current buffer
 875              in case it is a local variable.  */
 876           name = Fintern (make_string ((char *) start, length_byte), Qnil);
 877           tem = Fboundp (name);
 878           if (! NILP (tem))
 879             {
 880               tem = Fsymbol_value (name);
 881               if (! NILP (tem))
 882                 {
 883                   tem = get_keymap (tem, 0, 1);
 884                   /* Note that get_keymap can GC.  */
 885                   strp = SDATA (string) + idx;
 886                   start = SDATA (string) + start_idx;
 887                 }
 888             }
 889
 890           /* Now switch to a temp buffer.  */
 891           oldbuf = current_buffer;
 892           set_buffer_internal (XBUFFER (Vprin1_to_string_buffer));
 893
 894           if (NILP (tem))
 895             {
 896               name = Fsymbol_name (name);
 897               insert_string ("\nUses keymap `");
 898               insert_from_string (name, 0, 0,
 899                                   SCHARS (name),
 900                                   SBYTES (name), 1);
 901               insert_string ("', which is not currently defined.\n");
 902               if (start[-1] == '<') keymap = Qnil;
 903             }
 904           else if (start[-1] == '<')
 905             keymap = tem;
 906           else
 907             {
 908               /* Get the list of active keymaps that precede this one.
 909                  If this one's not active, get nil.  */
 910               earlier_maps = Fcdr (Fmemq (tem, Freverse (active_maps)));
 911               describe_map_tree (tem, 1, Fnreverse (earlier_maps),
 912                                  Qnil, (char *)0, 1, 0, 0, 1);
 913             }
 914           tem = Fbuffer_string ();
 915           Ferase_buffer ();
 916           set_buffer_internal (oldbuf);
 917
 918         subst_string:
 919           start = SDATA (tem);
 920           length = SCHARS (tem);
 921           length_byte = SBYTES (tem);
 922         subst:
 923           {
 924             ptrdiff_t offset = bufp - buf;
 925             if (STRING_BYTES_BOUND - length_byte < bsize)
 926               string_overflow ();
 927             buf = xrealloc (buf, bsize += length_byte);
 928             bufp = buf + offset;
 929             memcpy (bufp, start, length_byte);
 930             bufp += length_byte;
 931             nchars += length;
 932             /* Check STRING again in case gc relocated it.  */
 933             strp = SDATA (string) + idx;
 934           }
 935         }
 936       else if (! multibyte)             /* just copy other chars */
 937         *bufp++ = *strp++, nchars++;
 938       else
 939         {
 940           int len;
 941
 942           STRING_CHAR_AND_LENGTH (strp, len);
 943           if (len == 1)
 944             *bufp = *strp;
 945           else
 946             memcpy (bufp, strp, len);
 947           strp += len;
 948           bufp += len;
 949           nchars++;
 950         }
 951     }
 952
 953   if (changed)                  /* don't bother if nothing substituted */
 954     tem = make_string_from_bytes (buf, nchars, bufp - buf);
 955   else
 956     tem = string;
 957   xfree (buf);
 958   RETURN_UNGCPRO (tem);
 959 }
 960 \f
 961 void
 962 syms_of_doc (void)
 963 {
 964   DEFSYM (Qfunction_documentation, "function-documentation");
 965
 966   DEFVAR_LISP ("internal-doc-file-name", Vdoc_file_name,
 967                doc: /* Name of file containing documentation strings of built-in symbols.  */);
 968   Vdoc_file_name = Qnil;
 969
 970   DEFVAR_LISP ("build-files", Vbuild_files,
 971                doc: /* A list of files used to build this Emacs binary.  */);
 972   Vbuild_files = Qnil;
 973
 974   defsubr (&Sdocumentation);
 975   defsubr (&Sdocumentation_property);
 976   defsubr (&Ssnarf_documentation);
 977   defsubr (&Ssubstitute_command_keys);
 978 }