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