git.chise.org Git - chise/xemacs-chise.git.1/blob - src/doc.c

   1 /* Record indices of function doc strings stored in a file.
   2    Copyright (C) 1985, 1986, 1992, 1993, 1994, 1995
   3    Free Software Foundation, Inc.
   4
   5 This file is part of XEmacs.
   6
   7 XEmacs is free software; you can redistribute it and/or modify it
   8 under the terms of the GNU General Public License as published by the
   9 Free Software Foundation; either version 2, or (at your option) any
  10 later version.
  11
  12 XEmacs is distributed in the hope that it will be useful, but WITHOUT
  13 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  14 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  15 for more details.
  16
  17 You should have received a copy of the GNU General Public License
  18 along with XEmacs; see the file COPYING.  If not, write to
  19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  20 Boston, MA 02111-1307, USA.  */
  21
  22 /* Synched up with: FSF 19.30. */
  23
  24 /* This file has been Mule-ized except as noted. */
  25
  26 #include <config.h>
  27 #include "lisp.h"
  28
  29 #include "buffer.h"
  30 #include "bytecode.h"
  31 #include "insdel.h"
  32 #include "keymap.h"
  33 #include "sysfile.h"
  34
  35 Lisp_Object Vinternal_doc_file_name;
  36
  37 Lisp_Object QSsubstitute;
  38
  39 /* Read and return doc string from open file descriptor FD
  40    at position POSITION.  Does not close the file.  Returns
  41    string; or if error, returns a cons holding the error
  42    data to pass to Fsignal.  NAME_NONRELOC and NAME_RELOC
  43    are only used for the error messages. */
  44
  45 Lisp_Object
  46 unparesseuxify_doc_string (int fd, EMACS_INT position,
  47                            char *name_nonreloc, Lisp_Object name_reloc)
  48 {
  49   char buf[512 * 32 + 1];
  50   char *buffer = buf;
  51   int buffer_size = sizeof (buf);
  52   char *from, *to;
  53   REGISTER char *p = buffer;
  54   Lisp_Object return_me;
  55
  56   if (0 > lseek (fd, position, 0))
  57     {
  58       if (name_nonreloc)
  59         name_reloc = build_string (name_nonreloc);
  60       return_me = list3 (build_string
  61                          ("Position out of range in doc string file"),
  62                           name_reloc, make_int (position));
  63       goto done;
  64     }
  65
  66   /* Read the doc string into a buffer.
  67      Use the fixed buffer BUF if it is big enough; otherwise allocate one.
  68      We store the buffer in use in BUFFER and its size in BUFFER_SIZE.  */
  69
  70   while (1)
  71     {
  72       int space_left = buffer_size - (p - buffer);
  73       int nread;
  74
  75       /* Switch to a bigger buffer if we need one.  */
  76       if (space_left == 0)
  77         {
  78           char * old_buffer = buffer;
  79           if (buffer == buf) {
  80             buffer = (char *) xmalloc (buffer_size *= 2);
  81             memcpy (buffer, old_buffer, p - old_buffer);
  82           } else {
  83             buffer = (char *) xrealloc (buffer, buffer_size *= 2);
  84           }
  85           p += buffer - old_buffer;
  86           space_left = buffer_size - (p - buffer);
  87         }
  88
  89       /* Don't read too much at one go.  */
  90       if (space_left > 1024 * 8)
  91         space_left = 1024 * 8;
  92       nread = read (fd, p, space_left);
  93       if (nread < 0)
  94         {
  95           return_me = list1 (build_string
  96                              ("Read error on documentation file"));
  97           goto done;
  98         }
  99       p[nread] = 0;
 100       if (!nread)
 101         break;
 102       {
 103         char *p1 = strchr (p, '\037'); /* End of doc string marker */
 104         if (p1)
 105           {
 106             *p1 = 0;
 107             p = p1;
 108             break;
 109           }
 110       }
 111       p += nread;
 112     }
 113
 114   /* Scan the text and remove quoting with ^A (char code 1).
 115      ^A^A becomes ^A, ^A0 becomes a null char, and ^A_ becomes a ^_.  */
 116   from = to = buffer;
 117   while (from < p)
 118     {
 119       if (*from != 1 /*^A*/)
 120         *to++ = *from++;
 121       else
 122         {
 123           int c = *(++from);
 124
 125           from++;
 126           switch (c)
 127             {
 128             case 1:   *to++ =  c;     break;
 129             case '0': *to++ = '\0';   break;
 130             case '_': *to++ = '\037'; break;
 131             default:
 132               return_me = list2 (build_string
 133         ("Invalid data in documentation file -- ^A followed by weird code"),
 134                                  make_int (c));
 135               goto done;
 136             }
 137         }
 138     }
 139
 140   /* #### mrb: following STILL completely broken */
 141   return_me = make_ext_string ((Bufbyte *) buffer, to - buffer, Qbinary);
 142
 143  done:
 144   if (buffer != buf) /* We must have allocated buffer above */
 145     xfree (buffer);
 146   return return_me;
 147 }
 148
 149 #define string_join(dest, s1, s2) \
 150   memcpy ((void *) dest, (void *) XSTRING_DATA (s1), XSTRING_LENGTH (s1)); \
 151   memcpy ((void *) ((Bufbyte *) dest + XSTRING_LENGTH (s1)), \
 152           (void *) XSTRING_DATA (s2), XSTRING_LENGTH (s2));  \
 153           dest[XSTRING_LENGTH (s1) + XSTRING_LENGTH (s2)] = '\0'
 154
 155 /* Extract a doc string from a file.  FILEPOS says where to get it.
 156    (This could actually be byte code instructions/constants instead
 157    of a doc string.)
 158    If it is an integer, use that position in the standard DOC file.
 159    If it is (FILE . INTEGER), use FILE as the file name
 160    and INTEGER as the position in that file.
 161    But if INTEGER is negative, make it positive.
 162    (A negative integer is used for user variables, so we can distinguish
 163    them without actually fetching the doc string.)  */
 164
 165 static Lisp_Object
 166 get_doc_string (Lisp_Object filepos)
 167 {
 168   /* !!#### This function has not been Mule-ized */
 169   REGISTER int fd;
 170   REGISTER char *name_nonreloc = 0;
 171   int minsize;
 172   EMACS_INT position;
 173   Lisp_Object file, tem;
 174   Lisp_Object name_reloc = Qnil;
 175
 176   if (INTP (filepos))
 177     {
 178       file = Vinternal_doc_file_name;
 179       position = XINT (filepos);
 180     }
 181   else if (CONSP (filepos) && INTP (XCDR (filepos)))
 182     {
 183       file = XCAR (filepos);
 184       position = XINT (XCDR (filepos));
 185       if (position < 0)
 186         position = - position;
 187     }
 188   else
 189     return Qnil;
 190
 191   if (!STRINGP (file))
 192     return Qnil;
 193
 194   /* Put the file name in NAME as a C string.
 195      If it is relative, combine it with Vdoc_directory.  */
 196
 197   tem = Ffile_name_absolute_p (file);
 198   if (NILP (tem))
 199     {
 200       /* XEmacs: Move this check here.  OK if called during loadup to
 201          load byte code instructions. */
 202       if (!STRINGP (Vdoc_directory))
 203         return Qnil;
 204
 205       minsize = XSTRING_LENGTH (Vdoc_directory);
 206       /* sizeof ("../lib-src/") == 12 */
 207       if (minsize < 12)
 208         minsize = 12;
 209       name_nonreloc = (char *) alloca (minsize + XSTRING_LENGTH (file) + 8);
 210       string_join (name_nonreloc, Vdoc_directory, file);
 211     }
 212   else
 213     name_reloc = file;
 214
 215   fd = open (name_nonreloc ? name_nonreloc :
 216              (char *) XSTRING_DATA (name_reloc), O_RDONLY | OPEN_BINARY, 0);
 217   if (fd < 0)
 218     {
 219 #ifndef CANNOT_DUMP
 220       if (purify_flag)
 221         {
 222             /* sizeof ("../lib-src/") == 12 */
 223           name_nonreloc = (char *) alloca (12 + XSTRING_LENGTH (file) + 8);
 224           /* Preparing to dump; DOC file is probably not installed.
 225              So check in ../lib-src. */
 226           strcpy (name_nonreloc, "../lib-src/");
 227           strcat (name_nonreloc, (char *) XSTRING_DATA (file));
 228
 229           fd = open (name_nonreloc, O_RDONLY | OPEN_BINARY, 0);
 230         }
 231 #endif /* CANNOT_DUMP */
 232
 233       if (fd < 0)
 234         error ("Cannot open doc string file \"%s\"",
 235                name_nonreloc ? name_nonreloc :
 236                (char *) XSTRING_DATA (name_reloc));
 237     }
 238
 239   tem = unparesseuxify_doc_string (fd, position, name_nonreloc, name_reloc);
 240   close (fd);
 241
 242   if (!STRINGP (tem))
 243     signal_error (Qerror, tem);
 244
 245   return tem;
 246 }
 247
 248 /* Get a string from position FILEPOS and pass it through the Lisp reader.
 249    We use this for fetching the bytecode string and constants vector
 250    of a compiled function from the .elc file.  */
 251
 252 Lisp_Object
 253 read_doc_string (Lisp_Object filepos)
 254 {
 255   Lisp_Object string = get_doc_string (filepos);
 256
 257   if (!STRINGP (string))
 258     signal_simple_error ("loading bytecode failed to return string", string);
 259   return Fread (string);
 260 }
 261
 262 DEFUN ("documentation", Fdocumentation, 1, 2, 0, /*
 263 Return the documentation string of FUNCTION.
 264 Unless a non-nil second argument is given, the
 265 string is passed through `substitute-command-keys'.
 266 */
 267        (function, raw))
 268 {
 269   /* This function can GC */
 270   Lisp_Object fun;
 271   Lisp_Object doc;
 272
 273   fun = Findirect_function (function);
 274
 275   if (SUBRP (fun))
 276     {
 277       if (XSUBR (fun)->doc == 0)
 278         return Qnil;
 279       if ((EMACS_INT) XSUBR (fun)->doc >= 0)
 280         doc = build_string (XSUBR (fun)->doc);
 281       else
 282         doc = get_doc_string (make_int (- (EMACS_INT) XSUBR (fun)->doc));
 283     }
 284   else if (COMPILED_FUNCTIONP (fun))
 285     {
 286       Lisp_Object tem;
 287       Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (fun);
 288       if (! (f->flags.documentationp))
 289         return Qnil;
 290       tem = compiled_function_documentation (f);
 291       if (STRINGP (tem))
 292         doc = tem;
 293       else if (NATNUMP (tem) || CONSP (tem))
 294         doc = get_doc_string (tem);
 295       else
 296         return Qnil;
 297     }
 298   else if (KEYMAPP (fun))
 299     return build_translated_string ("Prefix command (definition is a keymap of subcommands).");
 300   else if (STRINGP (fun) || VECTORP (fun))
 301     return build_translated_string ("Keyboard macro.");
 302   else if (CONSP (fun))
 303     {
 304       Lisp_Object funcar = Fcar (fun);
 305
 306       if (!SYMBOLP (funcar))
 307         return Fsignal (Qinvalid_function, list1 (fun));
 308       else if (EQ (funcar, Qlambda)
 309              || EQ (funcar, Qautoload))
 310         {
 311           Lisp_Object tem, tem1;
 312           tem1 = Fcdr (Fcdr (fun));
 313           tem = Fcar (tem1);
 314           if (STRINGP (tem))
 315             doc = tem;
 316           /* Handle a doc reference--but these never come last
 317              in the function body, so reject them if they are last.  */
 318           else if ((NATNUMP (tem) || CONSP (tem))
 319                    && ! NILP (XCDR (tem1)))
 320             doc = get_doc_string (tem);
 321           else
 322             return Qnil;
 323         }
 324       else if (EQ (funcar, Qmacro))
 325         return Fdocumentation (Fcdr (fun), raw);
 326       else
 327         goto oops;
 328     }
 329   else
 330     {
 331     oops:
 332       return Fsignal (Qinvalid_function, list1 (fun));
 333     }
 334
 335   if (NILP (raw))
 336     {
 337       struct gcpro gcpro1;
 338 #ifdef I18N3
 339       Lisp_Object domain = Qnil;
 340       if (COMPILED_FUNCTIONP (fun))
 341         domain = compiled_function_domain (XCOMPILED_FUNCTION (fun));
 342       if (NILP (domain))
 343         doc = Fgettext (doc);
 344       else
 345         doc = Fdgettext (domain, doc);
 346 #endif
 347
 348       GCPRO1 (doc);
 349       doc = Fsubstitute_command_keys (doc);
 350       UNGCPRO;
 351     }
 352   return doc;
 353 }
 354
 355 DEFUN ("documentation-property", Fdocumentation_property, 2, 3, 0, /*
 356 Return the documentation string that is SYMBOL's PROP property.
 357 This is like `get', but it can refer to strings stored in the
 358 `doc-directory/DOC' file; and if the value is a string, it is passed
 359 through `substitute-command-keys'.  A non-nil third argument avoids this
 360 translation.
 361 */
 362        (sym, prop, raw))
 363 {
 364   /* This function can GC */
 365   REGISTER Lisp_Object doc = Qnil;
 366 #ifdef I18N3
 367   REGISTER Lisp_Object domain;
 368 #endif
 369   struct gcpro gcpro1;
 370
 371   GCPRO1 (doc);
 372
 373   doc = Fget (sym, prop, Qnil);
 374   if (INTP (doc))
 375     doc = get_doc_string (XINT (doc) > 0 ? doc : make_int (- XINT (doc)));
 376   else if (CONSP (doc))
 377     doc = get_doc_string (doc);
 378 #ifdef I18N3
 379   if (!NILP (doc))
 380     {
 381       domain = Fget (sym, Qvariable_domain, Qnil);
 382       if (NILP (domain))
 383         doc = Fgettext (doc);
 384       else
 385         doc = Fdgettext (domain, doc);
 386     }
 387 #endif
 388   if (NILP (raw) && STRINGP (doc))
 389     doc = Fsubstitute_command_keys (doc);
 390   UNGCPRO;
 391   return doc;
 392 }
 393 \f
 394 static void
 395 weird_doc (Lisp_Object sym, CONST char *weirdness, CONST char *type, int pos)
 396 {
 397   if (!strcmp (weirdness, GETTEXT ("duplicate"))) return;
 398   message ("Note: Strange doc (%s) for %s %s @ %d",
 399            weirdness, type, string_data (XSYMBOL (sym)->name), pos);
 400 }
 401
 402
 403 DEFUN ("Snarf-documentation", Fsnarf_documentation, 1, 1, 0, /*
 404 Used during Emacs initialization, before dumping runnable Emacs,
 405 to find pointers to doc strings stored in `.../lib-src/DOC' and
 406 record them in function definitions.
 407 One arg, FILENAME, a string which does not include a directory.
 408 The file is written to `../lib-src', and later found in `exec-directory'
 409 when doc strings are referred to in the dumped Emacs.
 410 */
 411        (filename))
 412 {
 413   /* !!#### This function has not been Mule-ized */
 414   int fd;
 415   char buf[1024 + 1];
 416   REGISTER int filled;
 417   REGISTER int pos;
 418   REGISTER char *p, *end;
 419   Lisp_Object sym, fun, tem;
 420   char *name;
 421
 422 #ifndef CANNOT_DUMP
 423   if (!purify_flag)
 424     error ("Snarf-documentation can only be called in an undumped Emacs");
 425 #endif
 426
 427   CHECK_STRING (filename);
 428
 429 #ifdef CANNOT_DUMP
 430   if (!NILP(Vdoc_directory))
 431     {
 432       CHECK_STRING (Vdoc_directory);
 433       name = (char *) alloca (XSTRING_LENGTH (filename)
 434                               + XSTRING_LENGTH (Vdoc_directory)
 435                               + 1);
 436       strcpy (name, (char *) XSTRING_DATA (Vdoc_directory));
 437     }
 438   else
 439 #endif /* CANNOT_DUMP */
 440     {
 441       name = (char *) alloca (XSTRING_LENGTH (filename) + 14);
 442       strcpy (name, "../lib-src/");
 443     }
 444
 445   strcat (name, (char *) XSTRING_DATA (filename));
 446
 447   fd = open (name, O_RDONLY | OPEN_BINARY, 0);
 448   if (fd < 0)
 449     report_file_error ("Opening doc string file",
 450                        Fcons (build_string (name), Qnil));
 451   Vinternal_doc_file_name = filename;
 452   filled = 0;
 453   pos = 0;
 454   while (1)
 455     {
 456       if (filled < 512)
 457         filled += read (fd, &buf[filled], sizeof buf - 1 - filled);
 458       if (!filled)
 459         break;
 460
 461       buf[filled] = 0;
 462       p = buf;
 463       end = buf + (filled < 512 ? filled : filled - 128);
 464       while (p != end && *p != '\037') p++;
 465       /* p points to ^_Ffunctionname\n or ^_Vvarname\n.  */
 466       if (p != end)
 467         {
 468           end = strchr (p, '\n');
 469           sym = oblookup (Vobarray, (Bufbyte *) p + 2, end - p - 2);
 470           if (SYMBOLP (sym))
 471             {
 472               Lisp_Object offset = make_int (pos + end + 1 - buf);
 473               /* Attach a docstring to a variable */
 474               if (p[1] == 'V')
 475                 {
 476                   /* Install file-position as variable-documentation property
 477                      and make it negative for a user-variable
 478                      (doc starts with a `*').  */
 479                   Lisp_Object old = Fget (sym, Qvariable_documentation, Qzero);
 480                   if (!ZEROP (old))
 481                     {
 482                       weird_doc (sym, GETTEXT ("duplicate"),
 483                                  GETTEXT ("variable"), pos);
 484                       /* In the case of duplicate doc file entries, always
 485                          take the later one.  But if the doc is not an int
 486                          (a string, say) leave it alone. */
 487                       if (!INTP (old))
 488                         goto weird;
 489                     }
 490                   Fput (sym, Qvariable_documentation,
 491                         ((end[1] == '*')
 492                          ? make_int (- XINT (offset))
 493                          : offset));
 494                 }
 495               /* Attach a docstring to a function.
 496                  The type determines where the docstring is stored.  */
 497               else if (p[1] == 'F')
 498                 {
 499                   fun = indirect_function (sym,0);
 500
 501                   if (CONSP (fun) && EQ (XCAR (fun), Qmacro))
 502                     fun = XCDR (fun);
 503
 504                   if (UNBOUNDP (fun))
 505                     {
 506                       /* May have been #if'ed out or something */
 507                       weird_doc (sym, GETTEXT ("not fboundp"),
 508                                  GETTEXT ("function"), pos);
 509                       goto weird;
 510                     }
 511                   else if (SUBRP (fun))
 512                     {
 513                       /* Lisp_Subrs have a slot for it.  */
 514                       if (XSUBR (fun)->doc)
 515                         {
 516                           weird_doc (sym, GETTEXT ("duplicate"),
 517                                      GETTEXT ("subr"), pos);
 518                           goto weird;
 519                         }
 520                       XSUBR (fun)->doc = (char *) (- XINT (offset));
 521                     }
 522                   else if (CONSP (fun))
 523                     {
 524                       /* If it's a lisp form, stick it in the form.  */
 525                       tem = XCAR (fun);
 526                       if (EQ (tem, Qlambda) || EQ (tem, Qautoload))
 527                         {
 528                           tem = Fcdr (Fcdr (fun));
 529                           if (CONSP (tem) &&
 530                               INTP (XCAR (tem)))
 531                             {
 532                               Lisp_Object old = XCAR (tem);
 533                               if (!ZEROP (old))
 534                                 {
 535                                   weird_doc (sym, GETTEXT ("duplicate"),
 536                                              (EQ (tem, Qlambda)
 537                                               ? GETTEXT ("lambda")
 538                                               : GETTEXT ("autoload")),
 539                                              pos);
 540                                   /* In the case of duplicate doc file entries,
 541                                      always take the later one.  But if the doc
 542                                      is not an int (a string, say) leave it
 543                                      alone. */
 544                                   if (!INTP (old))
 545                                     goto weird;
 546                                 }
 547                               XCAR (tem) = offset;
 548                             }
 549                           else if (!CONSP (tem))
 550                             {
 551                               weird_doc (sym, GETTEXT ("!CONSP(tem)"),
 552                                          GETTEXT ("function"), pos);
 553                               goto cont;
 554                             }
 555                           else
 556                             {
 557                               /* DOC string is a string not integer 0 */
 558 #if 0
 559                               weird_doc (sym, GETTEXT ("!INTP(XCAR(tem))"),
 560                                          GETTEXT ("function"), pos);
 561 #endif
 562                               goto cont;
 563                             }
 564                         }
 565                       else
 566                         {
 567                           weird_doc (sym, GETTEXT ("not lambda or autoload"),
 568                                      GETTEXT ("function"), pos);
 569                           goto cont;
 570                         }
 571                     }
 572                   else if (COMPILED_FUNCTIONP (fun))
 573                     {
 574                       /* Compiled-Function objects sometimes have
 575                          slots for it.  */
 576                       Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (fun);
 577
 578                       /* This compiled-function object must have a
 579                          slot for the docstring, since we've found a
 580                          docstring for it.  Unless there were multiple
 581                          definitions of it, and the latter one didn't
 582                          have any doc, which is a legal if slightly
 583                          bogus situation, so don't blow up. */
 584
 585                       if (! (f->flags.documentationp))
 586                         {
 587                           weird_doc (sym, GETTEXT ("no doc slot"),
 588                                      GETTEXT ("bytecode"), pos);
 589                           goto weird;
 590                         }
 591                       else
 592                         {
 593                           Lisp_Object old =
 594                             compiled_function_documentation (f);
 595                           if (!ZEROP (old))
 596                             {
 597                               weird_doc (sym, GETTEXT ("duplicate"),
 598                                          GETTEXT ("bytecode"), pos);
 599                               /* In the case of duplicate doc file entries,
 600                                  always take the later one.  But if the doc is
 601                                  not an int (a string, say) leave it alone. */
 602                               if (!INTP (old))
 603                                 goto weird;
 604                             }
 605                           set_compiled_function_documentation (f, offset);
 606                         }
 607                     }
 608                   else
 609                     {
 610                       /* Otherwise the function is undefined or
 611                          otherwise weird.   Ignore it. */
 612                       weird_doc (sym, GETTEXT ("weird function"),
 613                                  GETTEXT ("function"), pos);
 614                       goto weird;
 615                     }
 616                 }
 617               else
 618                 {
 619                 /* lose: */
 620                   error ("DOC file invalid at position %d", pos);
 621                 weird:
 622                   /* goto lose */;
 623                 }
 624             }
 625         }
 626     cont:
 627       pos += end - buf;
 628       filled -= end - buf;
 629       memmove (buf, end, filled);
 630     }
 631   close (fd);
 632   return Qnil;
 633 }
 634
 635
 636 #if 1   /* Don't warn about functions whose doc was lost because they were
 637            wrapped by advice-freeze.el... */
 638 static int
 639 kludgily_ignore_lost_doc_p (Lisp_Object sym)
 640 {
 641 # define kludge_prefix "ad-Orig-"
 642   Lisp_String *name = XSYMBOL (sym)->name;
 643   return (string_length (name) > (Bytecount) (sizeof (kludge_prefix)) &&
 644           !strncmp ((char *) string_data (name), kludge_prefix,
 645                     sizeof (kludge_prefix) - 1));
 646 # undef kludge_prefix
 647 }
 648 #else
 649 # define kludgily_ignore_lost_doc_p(sym) 0
 650 #endif
 651
 652
 653 static int
 654 verify_doc_mapper (Lisp_Object sym, void *arg)
 655 {
 656   Lisp_Object closure = *(Lisp_Object *)arg;
 657
 658   if (!NILP (Ffboundp (sym)))
 659     {
 660       int doc = 0;
 661       Lisp_Object fun = XSYMBOL (sym)->function;
 662       if (CONSP (fun) &&
 663           EQ (XCAR (fun), Qmacro))
 664         fun = XCDR (fun);
 665
 666       if (SUBRP (fun))
 667         doc = (EMACS_INT) XSUBR (fun)->doc;
 668       else if (SYMBOLP (fun))
 669         doc = -1;
 670       else if (KEYMAPP (fun))
 671         doc = -1;
 672       else if (CONSP (fun))
 673         {
 674           Lisp_Object tem = XCAR (fun);
 675           if (EQ (tem, Qlambda) || EQ (tem, Qautoload))
 676             {
 677               doc = -1;
 678               tem = Fcdr (Fcdr (fun));
 679               if (CONSP (tem) &&
 680                   INTP (XCAR (tem)))
 681                 doc = XINT (XCAR (tem));
 682             }
 683         }
 684       else if (COMPILED_FUNCTIONP (fun))
 685         {
 686           Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (fun);
 687           if (! (f->flags.documentationp))
 688             doc = -1;
 689           else
 690             {
 691               Lisp_Object tem = compiled_function_documentation (f);
 692               if (INTP (tem))
 693                 doc = XINT (tem);
 694             }
 695         }
 696
 697       if (doc == 0 && !kludgily_ignore_lost_doc_p (sym))
 698         {
 699           message ("Warning: doc lost for function %s.",
 700                    string_data (XSYMBOL (sym)->name));
 701           XCDR (closure) = Qt;
 702         }
 703     }
 704   if (!NILP (Fboundp (sym)))
 705     {
 706       Lisp_Object doc = Fget (sym, Qvariable_documentation, Qnil);
 707       if (ZEROP (doc))
 708         {
 709           message ("Warning: doc lost for variable %s.",
 710                    string_data (XSYMBOL (sym)->name));
 711           XCDR (closure) = Qt;
 712         }
 713     }
 714   return 0; /* Never stop */
 715 }
 716
 717 DEFUN ("Verify-documentation", Fverify_documentation, 0, 0, 0, /*
 718 Used to make sure everything went well with Snarf-documentation.
 719 Writes to stderr if not.
 720 */
 721        ())
 722 {
 723   Lisp_Object closure = Fcons (Qnil, Qnil);
 724   struct gcpro gcpro1;
 725   GCPRO1 (closure);
 726   map_obarray (Vobarray, verify_doc_mapper, &closure);
 727   if (!NILP (Fcdr (closure)))
 728     message ("\n"
 729 "This is usually because some files were preloaded by loaddefs.el or\n"
 730 "site-load.el, but were not passed to make-docfile by Makefile.\n");
 731   UNGCPRO;
 732   return NILP (Fcdr (closure)) ? Qt : Qnil;
 733 }
 734
 735 \f
 736 DEFUN ("substitute-command-keys", Fsubstitute_command_keys, 1, 1, 0, /*
 737 Substitute key descriptions for command names in STRING.
 738 Return a new string which is STRING with substrings of the form \\=\\[COMMAND]
 739 replaced by either:  a keystroke sequence that will invoke COMMAND,
 740 or "M-x COMMAND" if COMMAND is not on any keys.
 741 Substrings of the form \\=\\{MAPVAR} are replaced by summaries
 742 \(made by describe-bindings) of the value of MAPVAR, taken as a keymap.
 743 Substrings of the form \\=\\<MAPVAR> specify to use the value of MAPVAR
 744 as the keymap for future \\=\\[COMMAND] substrings.
 745 \\=\\= quotes the following character and is discarded;
 746 thus, \\=\\=\\=\\= puts \\=\\= into the output, and \\=\\=\\=\\[ puts \\=\\[ into the output.
 747 */
 748        (str))
 749 {
 750   /* This function can GC */
 751   Bufbyte *buf;
 752   int changed = 0;
 753   REGISTER Bufbyte *strdata;
 754   REGISTER Bufbyte *bufp;
 755   Bytecount strlength;
 756   Bytecount idx;
 757   Bytecount bsize;
 758   Bufbyte *new;
 759   Lisp_Object tem;
 760   Lisp_Object keymap;
 761   Bufbyte *start;
 762   Bytecount length;
 763   Lisp_Object name;
 764   struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
 765
 766   if (NILP (str))
 767     return Qnil;
 768
 769   CHECK_STRING (str);
 770   tem = Qnil;
 771   keymap = Qnil;
 772   name = Qnil;
 773   GCPRO4 (str, tem, keymap, name);
 774
 775   /* There is the possibility that the string is not destined for a
 776      translating stream, and it could be argued that we should do the
 777      same thing here as in Fformat(), but there are very few times
 778      when this will be the case and many calls to this function
 779      would have to have `gettext' calls added. (I18N3) */
 780   str = LISP_GETTEXT (str);
 781
 782   /* KEYMAP is either nil (which means search all the active keymaps)
 783      or a specified local map (which means search just that and the
 784      global map).  If non-nil, it might come from Voverriding_local_map,
 785      or from a \\<mapname> construct in STR itself..  */
 786 #if 0 /* FSFmacs */
 787   /* This is really weird and garbagey.  If keymap is nil and there's
 788      an overriding-local-map, `where-is-internal' will correctly note
 789      this, so there's no reason to do it here.  Maybe FSFmacs
 790      `where-is-internal' is broken. */
 791   /*
 792   keymap = current_kboard->Voverriding_terminal_local_map;
 793   if (NILP (keymap))
 794     keymap = Voverriding_local_map;
 795   */
 796 #endif
 797
 798   strlength = XSTRING_LENGTH (str);
 799   bsize = 1 + strlength;
 800   buf = (Bufbyte *) xmalloc (bsize);
 801   bufp = buf;
 802
 803   /* Have to reset strdata every time GC might be called */
 804   strdata = XSTRING_DATA (str);
 805   for (idx = 0; idx < strlength; )
 806     {
 807       Bufbyte *strp = strdata + idx;
 808
 809       if (strp[0] != '\\')
 810         {
 811           /* just copy other chars */
 812           /* As it happens, this will work with Mule even if the
 813              character quoted is multi-byte; the remaining multi-byte
 814              characters will just be copied by this loop. */
 815           *bufp++ = *strp;
 816           idx++;
 817         }
 818       else switch (strp[1])
 819         {
 820         default:
 821           {
 822             /* just copy unknown escape sequences */
 823             *bufp++ = *strp;
 824             idx++;
 825             break;
 826           }
 827         case '=':
 828           {
 829             /* \= quotes the next character;
 830                thus, to put in \[ without its special meaning, use \=\[.  */
 831             /* As it happens, this will work with Mule even if the
 832                character quoted is multi-byte; the remaining multi-byte
 833                characters will just be copied by this loop. */
 834             changed = 1;
 835             *bufp++ = strp[2];
 836             idx += 3;
 837             break;
 838           }
 839         case '[':
 840           {
 841             changed = 1;
 842             idx += 2;           /* skip \[ */
 843             strp += 2;
 844             start = strp;
 845
 846             while ((idx < strlength)
 847                    && *strp != ']')
 848               {
 849                 strp++;
 850                 idx++;
 851               }
 852             length = strp - start;
 853             idx++;              /* skip ] */
 854
 855             tem = Fintern (make_string (start, length), Qnil);
 856             tem = Fwhere_is_internal (tem, keymap, Qt, Qnil, Qnil);
 857
 858 #if 0 /* FSFmacs */
 859           /* Disregard menu bar bindings; it is positively annoying to
 860              mention them when there's no menu bar, and it isn't terribly
 861              useful even when there is a menu bar.  */
 862           if (!NILP (tem))
 863             {
 864               firstkey = Faref (tem, Qzero);
 865               if (EQ (firstkey, Qmenu_bar))
 866                 tem = Qnil;
 867             }
 868 #endif
 869
 870             if (NILP (tem))     /* but not on any keys */
 871               {
 872                 new = (Bufbyte *) xrealloc (buf, bsize += 4);
 873                 bufp += new - buf;
 874                 buf = new;
 875                 memcpy (bufp, "M-x ", 4);
 876                 bufp += 4;
 877                 goto subst;
 878               }
 879             else
 880               {                 /* function is on a key */
 881                 tem = Fkey_description (tem);
 882                 goto subst_string;
 883               }
 884           }
 885         case '{':
 886         case '<':
 887           {
 888             /* #### jump to label `subst_string|subst' crosses
 889                initialization of `buffer|_buf' */
 890             Lisp_Object buffer;
 891             struct buffer *buf_;
 892
 893             buffer = Fget_buffer_create (QSsubstitute);
 894             buf_ = XBUFFER (buffer);
 895
 896             Fbuffer_disable_undo (buffer);
 897             Ferase_buffer (buffer);
 898
 899             /* \{foo} is replaced with a summary of keymap (symbol-value foo).
 900                \<foo> just sets the keymap used for \[cmd].  */
 901             changed = 1;
 902             idx += 2;           /* skip \{ or \< */
 903             strp += 2;
 904             start = strp;
 905
 906             while ((idx < strlength)
 907                    && *strp != '}' && *strp != '>')
 908               {
 909                 strp++;
 910                 idx++;
 911               }
 912             length = strp - start;
 913             idx++;              /* skip } or > */
 914
 915             /* Get the value of the keymap in TEM, or nil if undefined.
 916                Do this while still in the user's current buffer
 917                in case it is a local variable.  */
 918             name = Fintern (make_string (start, length), Qnil);
 919             tem = Fboundp (name);
 920             if (! NILP (tem))
 921               {
 922                 tem = Fsymbol_value (name);
 923                 if (! NILP (tem))
 924                   tem = get_keymap (tem, 0, 1);
 925               }
 926
 927             if (NILP (tem))
 928               {
 929                 char boof[255], *b = boof;
 930                 *b++ = '\n';
 931                 /* #### This sprintf() is potentially dangerous!  */
 932                 sprintf (b, GETTEXT (
 933                 "Uses keymap \"%s\", which is not currently defined."),
 934                          (char *) XSTRING_DATA (Fsymbol_name (name)));
 935                 b += strlen (b);
 936                 *b++ = '\n';
 937                 *b++ = 0;
 938                 buffer_insert_c_string (buf_, boof);
 939
 940                 if (start[-1] == '<') keymap = Qnil;
 941               }
 942             else if (start[-1] == '<')
 943               keymap = tem;
 944             else
 945               describe_map_tree (tem, 1, Qnil, Qnil, 0, buffer);
 946
 947             tem = make_string_from_buffer (buf_, BUF_BEG (buf_),
 948                                            BUF_Z (buf_) - BUF_BEG (buf_));
 949             Ferase_buffer (buffer);
 950             goto subst_string;
 951
 952           subst_string:
 953             start = XSTRING_DATA (tem);
 954             length = XSTRING_LENGTH (tem);
 955           subst:
 956             bsize += length;
 957             new = (Bufbyte *) xrealloc (buf, bsize);
 958             bufp += new - buf;
 959             buf = new;
 960             memcpy (bufp, start, length);
 961             bufp += length;
 962
 963             /* Reset STRDATA in case gc relocated it.  */
 964             strdata = XSTRING_DATA (str);
 965
 966             break;
 967           }
 968         }
 969     }
 970
 971   if (changed)                  /* don't bother if nothing substituted */
 972     tem = make_string (buf, bufp - buf);
 973   else
 974     tem = str;
 975   xfree (buf);
 976   UNGCPRO;
 977   return tem;
 978 }
 979
 980 \f
 981 /************************************************************************/
 982 /*                            initialization                            */
 983 /************************************************************************/
 984
 985 void
 986 syms_of_doc (void)
 987 {
 988   DEFSUBR (Fdocumentation);
 989   DEFSUBR (Fdocumentation_property);
 990   DEFSUBR (Fsnarf_documentation);
 991   DEFSUBR (Fverify_documentation);
 992   DEFSUBR (Fsubstitute_command_keys);
 993 }
 994
 995 void
 996 vars_of_doc (void)
 997 {
 998   DEFVAR_LISP ("internal-doc-file-name", &Vinternal_doc_file_name /*
 999 Name of file containing documentation strings of built-in symbols.
1000 */ );
1001   Vinternal_doc_file_name = Qnil;
1002
1003   QSsubstitute = build_string (" *substitute*");
1004   staticpro (&QSsubstitute);
1005 }