src/doc.c

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