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, FORMAT_BINARY);
 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       struct Lisp_Compiled_Function *b = XCOMPILED_FUNCTION (fun);
 288       if (! (b->flags.documentationp))
 289         return Qnil;
 290       tem = compiled_function_documentation (b);
 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 = Fcompiled_function_domain (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                       struct Lisp_Compiled_Function *b =
 577                         XCOMPILED_FUNCTION (fun);
 578
 579                       /* This compiled-function object must have a
 580                          slot for the docstring, since we've found a
 581                          docstring for it.  Unless there were multiple
 582                          definitions of it, and the latter one didn't
 583                          have any doc, which is a legal if slightly
 584                          bogus situation, so don't blow up. */
 585
 586                       if (! (b->flags.documentationp))
 587                         {
 588                           weird_doc (sym, GETTEXT ("no doc slot"),
 589                                      GETTEXT ("bytecode"), pos);
 590                           goto weird;
 591                         }
 592                       else
 593                         {
 594                           Lisp_Object old =
 595                             compiled_function_documentation (b);
 596                           if (!ZEROP (old))
 597                             {
 598                               weird_doc (sym, GETTEXT ("duplicate"),
 599                                          GETTEXT ("bytecode"), pos);
 600                               /* In the case of duplicate doc file entries,
 601                                  always take the later one.  But if the doc is
 602                                  not an int (a string, say) leave it alone. */
 603                               if (!INTP (old))
 604                                 goto weird;
 605                             }
 606                           set_compiled_function_documentation (b, offset);
 607                         }
 608                     }
 609                   else
 610                     {
 611                       /* Otherwise the function is undefined or
 612                          otherwise weird.   Ignore it. */
 613                       weird_doc (sym, GETTEXT ("weird function"),
 614                                  GETTEXT ("function"), pos);
 615                       goto weird;
 616                     }
 617                 }
 618               else
 619                 {
 620                 /* lose: */
 621                   error ("DOC file invalid at position %d", pos);
 622                 weird:
 623                   /* goto lose */;
 624                 }
 625             }
 626         }
 627     cont:
 628       pos += end - buf;
 629       filled -= end - buf;
 630       memmove (buf, end, filled);
 631     }
 632   close (fd);
 633   return Qnil;
 634 }
 635
 636
 637 #if 1   /* Don't warn about functions whose doc was lost because they were
 638            wrapped by advice-freeze.el... */
 639 static int
 640 kludgily_ignore_lost_doc_p (Lisp_Object sym)
 641 {
 642 # define kludge_prefix "ad-Orig-"
 643   struct Lisp_String *name = XSYMBOL (sym)->name;
 644   return (string_length (name) > (Bytecount) (sizeof (kludge_prefix)) &&
 645           !strncmp ((char *) string_data (name), kludge_prefix,
 646                     sizeof (kludge_prefix) - 1));
 647 # undef kludge_prefix
 648 }
 649 #else
 650 # define kludgily_ignore_lost_doc_p(sym) 0
 651 #endif
 652
 653
 654 static int
 655 verify_doc_mapper (Lisp_Object sym, void *arg)
 656 {
 657   Lisp_Object closure = *(Lisp_Object *)arg;
 658
 659   if (!NILP (Ffboundp (sym)))
 660     {
 661       int doc = 0;
 662       Lisp_Object fun = XSYMBOL (sym)->function;
 663       if (CONSP (fun) &&
 664           EQ (XCAR (fun), Qmacro))
 665         fun = XCDR (fun);
 666
 667       if (SUBRP (fun))
 668         doc = (EMACS_INT) XSUBR (fun)->doc;
 669       else if (SYMBOLP (fun))
 670         doc = -1;
 671       else if (KEYMAPP (fun))
 672         doc = -1;
 673       else if (CONSP (fun))
 674         {
 675           Lisp_Object tem = XCAR (fun);
 676           if (EQ (tem, Qlambda) || EQ (tem, Qautoload))
 677             {
 678               doc = -1;
 679               tem = Fcdr (Fcdr (fun));
 680               if (CONSP (tem) &&
 681                   INTP (XCAR (tem)))
 682                 doc = XINT (XCAR (tem));
 683             }
 684         }
 685       else if (COMPILED_FUNCTIONP (fun))
 686         {
 687           struct Lisp_Compiled_Function *b = XCOMPILED_FUNCTION (fun);
 688           if (! (b->flags.documentationp))
 689             doc = -1;
 690           else
 691             {
 692               Lisp_Object tem = compiled_function_documentation (b);
 693               if (INTP (tem))
 694                 doc = XINT (tem);
 695             }
 696         }
 697
 698       if (doc == 0 && !kludgily_ignore_lost_doc_p (sym))
 699         {
 700           message ("Warning: doc lost for function %s.",
 701                    string_data (XSYMBOL (sym)->name));
 702           XCDR (closure) = Qt;
 703         }
 704     }
 705   if (!NILP (Fboundp (sym)))
 706     {
 707       Lisp_Object doc = Fget (sym, Qvariable_documentation, Qnil);
 708       if (ZEROP (doc))
 709         {
 710           message ("Warning: doc lost for variable %s.",
 711                    string_data (XSYMBOL (sym)->name));
 712           XCDR (closure) = Qt;
 713         }
 714     }
 715   return 0; /* Never stop */
 716 }
 717
 718 DEFUN ("Verify-documentation", Fverify_documentation, 0, 0, 0, /*
 719 Used to make sure everything went well with Snarf-documentation.
 720 Writes to stderr if not.
 721 */
 722        ())
 723 {
 724   Lisp_Object closure = Fcons (Qnil, Qnil);
 725   struct gcpro gcpro1;
 726   GCPRO1 (closure);
 727   map_obarray (Vobarray, verify_doc_mapper, &closure);
 728   if (!NILP (Fcdr (closure)))
 729     message ("\n"
 730 "This is usually because some files were preloaded by loaddefs.el or\n"
 731 "site-load.el, but were not passed to make-docfile by Makefile.\n");
 732   UNGCPRO;
 733   return NILP (Fcdr (closure)) ? Qt : Qnil;
 734 }
 735
 736 \f
 737 DEFUN ("substitute-command-keys", Fsubstitute_command_keys, 1, 1, 0, /*
 738 Substitute key descriptions for command names in STRING.
 739 Return a new string which is STRING with substrings of the form \\=\\[COMMAND]
 740 replaced by either:  a keystroke sequence that will invoke COMMAND,
 741 or "M-x COMMAND" if COMMAND is not on any keys.
 742 Substrings of the form \\=\\{MAPVAR} are replaced by summaries
 743 \(made by describe-bindings) of the value of MAPVAR, taken as a keymap.
 744 Substrings of the form \\=\\<MAPVAR> specify to use the value of MAPVAR
 745 as the keymap for future \\=\\[COMMAND] substrings.
 746 \\=\\= quotes the following character and is discarded;
 747 thus, \\=\\=\\=\\= puts \\=\\= into the output, and \\=\\=\\=\\[ puts \\=\\[ into the output.
 748 */
 749        (str))
 750 {
 751   /* This function can GC */
 752   Bufbyte *buf;
 753   int changed = 0;
 754   REGISTER Bufbyte *strdata;
 755   REGISTER Bufbyte *bufp;
 756   Bytecount strlength;
 757   Bytecount idx;
 758   Bytecount bsize;
 759   Bufbyte *new;
 760   Lisp_Object tem;
 761   Lisp_Object keymap;
 762   Bufbyte *start;
 763   Bytecount length;
 764   Lisp_Object name;
 765   struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
 766
 767   if (NILP (str))
 768     return Qnil;
 769
 770   CHECK_STRING (str);
 771   tem = Qnil;
 772   keymap = Qnil;
 773   name = Qnil;
 774   GCPRO4 (str, tem, keymap, name);
 775
 776   /* There is the possibility that the string is not destined for a
 777      translating stream, and it could be argued that we should do the
 778      same thing here as in Fformat(), but there are very few times
 779      when this will be the case and many calls to this function
 780      would have to have `gettext' calls added. (I18N3) */
 781   str = LISP_GETTEXT (str);
 782
 783   /* KEYMAP is either nil (which means search all the active keymaps)
 784      or a specified local map (which means search just that and the
 785      global map).  If non-nil, it might come from Voverriding_local_map,
 786      or from a \\<mapname> construct in STR itself..  */
 787 #if 0 /* FSFmacs */
 788   /* This is really weird and garbagey.  If keymap is nil and there's
 789      an overriding-local-map, `where-is-internal' will correctly note
 790      this, so there's no reason to do it here.  Maybe FSFmacs
 791      `where-is-internal' is broken. */
 792   /*
 793   keymap = current_kboard->Voverriding_terminal_local_map;
 794   if (NILP (keymap))
 795     keymap = Voverriding_local_map;
 796   */
 797 #endif
 798
 799   strlength = XSTRING_LENGTH (str);
 800   bsize = 1 + strlength;
 801   buf = (Bufbyte *) xmalloc (bsize);
 802   bufp = buf;
 803
 804   /* Have to reset strdata every time GC might be called */
 805   strdata = XSTRING_DATA (str);
 806   for (idx = 0; idx < strlength; )
 807     {
 808       Bufbyte *strp = strdata + idx;
 809
 810       if (strp[0] != '\\')
 811         {
 812           /* just copy other chars */
 813           /* As it happens, this will work with Mule even if the
 814              character quoted is multi-byte; the remaining multi-byte
 815              characters will just be copied by this loop. */
 816           *bufp++ = *strp;
 817           idx++;
 818         }
 819       else switch (strp[1])
 820         {
 821         default:
 822           {
 823             /* just copy unknown escape sequences */
 824             *bufp++ = *strp;
 825             idx++;
 826             break;
 827           }
 828         case '=':
 829           {
 830             /* \= quotes the next character;
 831                thus, to put in \[ without its special meaning, use \=\[.  */
 832             /* As it happens, this will work with Mule even if the
 833                character quoted is multi-byte; the remaining multi-byte
 834                characters will just be copied by this loop. */
 835             changed = 1;
 836             *bufp++ = strp[2];
 837             idx += 3;
 838             break;
 839           }
 840         case '[':
 841           {
 842             changed = 1;
 843             idx += 2;           /* skip \[ */
 844             strp += 2;
 845             start = strp;
 846
 847             while ((idx < strlength)
 848                    && *strp != ']')
 849               {
 850                 strp++;
 851                 idx++;
 852               }
 853             length = strp - start;
 854             idx++;              /* skip ] */
 855
 856             tem = Fintern (make_string (start, length), Qnil);
 857             tem = Fwhere_is_internal (tem, keymap, Qt, Qnil, Qnil);
 858
 859 #if 0 /* FSFmacs */
 860           /* Disregard menu bar bindings; it is positively annoying to
 861              mention them when there's no menu bar, and it isn't terribly
 862              useful even when there is a menu bar.  */
 863           if (!NILP (tem))
 864             {
 865               firstkey = Faref (tem, Qzero);
 866               if (EQ (firstkey, Qmenu_bar))
 867                 tem = Qnil;
 868             }
 869 #endif
 870
 871             if (NILP (tem))     /* but not on any keys */
 872               {
 873                 new = (Bufbyte *) xrealloc (buf, bsize += 4);
 874                 bufp += new - buf;
 875                 buf = new;
 876                 memcpy (bufp, "M-x ", 4);
 877                 bufp += 4;
 878                 goto subst;
 879               }
 880             else
 881               {                 /* function is on a key */
 882                 tem = Fkey_description (tem);
 883                 goto subst_string;
 884               }
 885           }
 886         case '{':
 887         case '<':
 888           {
 889             /* ### jump to label `subst_string|subst' crosses
 890                initialization of `buffer|_buf' */
 891             Lisp_Object buffer;
 892             struct buffer *buf_;
 893
 894             buffer = Fget_buffer_create (QSsubstitute);
 895             buf_ = XBUFFER (buffer);
 896
 897             Fbuffer_disable_undo (buffer);
 898             Ferase_buffer (buffer);
 899
 900             /* \{foo} is replaced with a summary of keymap (symbol-value foo).
 901                \<foo> just sets the keymap used for \[cmd].  */
 902             changed = 1;
 903             idx += 2;           /* skip \{ or \< */
 904             strp += 2;
 905             start = strp;
 906
 907             while ((idx < strlength)
 908                    && *strp != '}' && *strp != '>')
 909               {
 910                 strp++;
 911                 idx++;
 912               }
 913             length = strp - start;
 914             idx++;              /* skip } or > */
 915
 916             /* Get the value of the keymap in TEM, or nil if undefined.
 917                Do this while still in the user's current buffer
 918                in case it is a local variable.  */
 919             name = Fintern (make_string (start, length), Qnil);
 920             tem = Fboundp (name);
 921             if (! NILP (tem))
 922               {
 923                 tem = Fsymbol_value (name);
 924                 if (! NILP (tem))
 925                   tem = get_keymap (tem, 0, 1);
 926               }
 927
 928             if (NILP (tem))
 929               {
 930                 char boof[255], *b = boof;
 931                 *b++ = '\n';
 932                 /* #### This sprintf() is potentially dangerous!  */
 933                 sprintf (b, GETTEXT (
 934                 "Uses keymap \"%s\", which is not currently defined."),
 935                          (char *) XSTRING_DATA (Fsymbol_name (name)));
 936                 b += strlen (b);
 937                 *b++ = '\n';
 938                 *b++ = 0;
 939                 buffer_insert_c_string (buf_, boof);
 940
 941                 if (start[-1] == '<') keymap = Qnil;
 942               }
 943             else if (start[-1] == '<')
 944               keymap = tem;
 945             else
 946               describe_map_tree (tem, 1, Qnil, Qnil, 0, buffer);
 947
 948             tem = make_string_from_buffer (buf_, BUF_BEG (buf_),
 949                                            BUF_Z (buf_) - BUF_BEG (buf_));
 950             Ferase_buffer (buffer);
 951             goto subst_string;
 952
 953           subst_string:
 954             start = XSTRING_DATA (tem);
 955             length = XSTRING_LENGTH (tem);
 956           subst:
 957             bsize += length;
 958             new = (Bufbyte *) xrealloc (buf, bsize);
 959             bufp += new - buf;
 960             buf = new;
 961             memcpy (bufp, start, length);
 962             bufp += length;
 963
 964             /* Reset STRDATA in case gc relocated it.  */
 965             strdata = XSTRING_DATA (str);
 966
 967             break;
 968           }
 969         }
 970     }
 971
 972   if (changed)                  /* don't bother if nothing substituted */
 973     tem = make_string (buf, bufp - buf);
 974   else
 975     tem = str;
 976   xfree (buf);
 977   UNGCPRO;
 978   return tem;
 979 }
 980
 981 \f
 982 /************************************************************************/
 983 /*                            initialization                            */
 984 /************************************************************************/
 985
 986 void
 987 syms_of_doc (void)
 988 {
 989   DEFSUBR (Fdocumentation);
 990   DEFSUBR (Fdocumentation_property);
 991   DEFSUBR (Fsnarf_documentation);
 992   DEFSUBR (Fverify_documentation);
 993   DEFSUBR (Fsubstitute_command_keys);
 994 }
 995
 996 void
 997 vars_of_doc (void)
 998 {
 999   DEFVAR_LISP ("internal-doc-file-name", &Vinternal_doc_file_name /*
1000 Name of file containing documentation strings of built-in symbols.
1001 */ );
1002   Vinternal_doc_file_name = Qnil;
1003
1004   QSsubstitute = build_string (" *substitute*");
1005   staticpro (&QSsubstitute);
1006 }