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 (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   EMACS_INT position;
 172   Lisp_Object file, tem;
 173   Lisp_Object name_reloc = Qnil;
 174
 175   if (INTP (filepos))
 176     {
 177       file = Vinternal_doc_file_name;
 178       position = XINT (filepos);
 179     }
 180   else if (CONSP (filepos) && INTP (XCDR (filepos)))
 181     {
 182       file = XCAR (filepos);
 183       position = XINT (XCDR (filepos));
 184       if (position < 0)
 185         position = - position;
 186     }
 187   else
 188     return Qnil;
 189
 190   if (!STRINGP (file))
 191     return Qnil;
 192
 193   /* Put the file name in NAME as a C string.
 194      If it is relative, combine it with Vdoc_directory.  */
 195
 196   tem = Ffile_name_absolute_p (file);
 197   if (NILP (tem))
 198     {
 199       size_t minsize;
 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 RAW 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        (symbol, 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 (symbol, 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 (symbol, 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        (string))
 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 = Qnil;
 760   Lisp_Object keymap = Qnil;
 761   Lisp_Object name = Qnil;
 762   Bufbyte *start;
 763   Bytecount length;
 764   struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
 765
 766   if (NILP (string))
 767     return Qnil;
 768
 769   CHECK_STRING (string);
 770   GCPRO4 (string, tem, keymap, name);
 771
 772   /* There is the possibility that the string is not destined for a
 773      translating stream, and it could be argued that we should do the
 774      same thing here as in Fformat(), but there are very few times
 775      when this will be the case and many calls to this function
 776      would have to have `gettext' calls added. (I18N3) */
 777   string = LISP_GETTEXT (string);
 778
 779   /* KEYMAP is either nil (which means search all the active keymaps)
 780      or a specified local map (which means search just that and the
 781      global map).  If non-nil, it might come from Voverriding_local_map,
 782      or from a \\<mapname> construct in STRING itself..  */
 783 #if 0 /* FSFmacs */
 784   /* This is really weird and garbagey.  If keymap is nil and there's
 785      an overriding-local-map, `where-is-internal' will correctly note
 786      this, so there's no reason to do it here.  Maybe FSFmacs
 787      `where-is-internal' is broken. */
 788   /*
 789   keymap = current_kboard->Voverriding_terminal_local_map;
 790   if (NILP (keymap))
 791     keymap = Voverriding_local_map;
 792   */
 793 #endif
 794
 795   strlength = XSTRING_LENGTH (string);
 796   bsize = 1 + strlength;
 797   buf = (Bufbyte *) xmalloc (bsize);
 798   bufp = buf;
 799
 800   /* Have to reset strdata every time GC might be called */
 801   strdata = XSTRING_DATA (string);
 802   for (idx = 0; idx < strlength; )
 803     {
 804       Bufbyte *strp = strdata + idx;
 805
 806       if (strp[0] != '\\')
 807         {
 808           /* just copy other chars */
 809           /* As it happens, this will work with Mule even if the
 810              character quoted is multi-byte; the remaining multi-byte
 811              characters will just be copied by this loop. */
 812           *bufp++ = *strp;
 813           idx++;
 814         }
 815       else switch (strp[1])
 816         {
 817         default:
 818           {
 819             /* just copy unknown escape sequences */
 820             *bufp++ = *strp;
 821             idx++;
 822             break;
 823           }
 824         case '=':
 825           {
 826             /* \= quotes the next character;
 827                thus, to put in \[ without its special meaning, use \=\[.  */
 828             /* As it happens, this will work with Mule even if the
 829                character quoted is multi-byte; the remaining multi-byte
 830                characters will just be copied by this loop. */
 831             changed = 1;
 832             *bufp++ = strp[2];
 833             idx += 3;
 834             break;
 835           }
 836         case '[':
 837           {
 838             changed = 1;
 839             idx += 2;           /* skip \[ */
 840             strp += 2;
 841             start = strp;
 842
 843             while ((idx < strlength)
 844                    && *strp != ']')
 845               {
 846                 strp++;
 847                 idx++;
 848               }
 849             length = strp - start;
 850             idx++;              /* skip ] */
 851
 852             tem = Fintern (make_string (start, length), Qnil);
 853             tem = Fwhere_is_internal (tem, keymap, Qt, Qnil, Qnil);
 854
 855 #if 0 /* FSFmacs */
 856             /* Disregard menu bar bindings; it is positively annoying to
 857                mention them when there's no menu bar, and it isn't terribly
 858                useful even when there is a menu bar.  */
 859             if (!NILP (tem))
 860               {
 861                 firstkey = Faref (tem, Qzero);
 862                 if (EQ (firstkey, Qmenu_bar))
 863                   tem = Qnil;
 864               }
 865 #endif
 866
 867             if (NILP (tem))     /* but not on any keys */
 868               {
 869                 new = (Bufbyte *) xrealloc (buf, bsize += 4);
 870                 bufp += new - buf;
 871                 buf = new;
 872                 memcpy (bufp, "M-x ", 4);
 873                 bufp += 4;
 874                 goto subst;
 875               }
 876             else
 877               {                 /* function is on a key */
 878                 tem = Fkey_description (tem);
 879                 goto subst_string;
 880               }
 881           }
 882         case '{':
 883         case '<':
 884           {
 885             Lisp_Object buffer = Fget_buffer_create (QSsubstitute);
 886             struct buffer *buf_ = XBUFFER (buffer);
 887
 888             Fbuffer_disable_undo (buffer);
 889             Ferase_buffer (buffer);
 890
 891             /* \{foo} is replaced with a summary of keymap (symbol-value foo).
 892                \<foo> just sets the keymap used for \[cmd].  */
 893             changed = 1;
 894             idx += 2;           /* skip \{ or \< */
 895             strp += 2;
 896             start = strp;
 897
 898             while ((idx < strlength)
 899                    && *strp != '}' && *strp != '>')
 900               {
 901                 strp++;
 902                 idx++;
 903               }
 904             length = strp - start;
 905             idx++;              /* skip } or > */
 906
 907             /* Get the value of the keymap in TEM, or nil if undefined.
 908                Do this while still in the user's current buffer
 909                in case it is a local variable.  */
 910             name = Fintern (make_string (start, length), Qnil);
 911             tem = Fboundp (name);
 912             if (! NILP (tem))
 913               {
 914                 tem = Fsymbol_value (name);
 915                 if (! NILP (tem))
 916                   tem = get_keymap (tem, 0, 1);
 917               }
 918
 919             if (NILP (tem))
 920               {
 921                 buffer_insert_c_string (buf_, "(uses keymap \"");
 922                 buffer_insert_lisp_string (buf_, Fsymbol_name (name));
 923                 buffer_insert_c_string (buf_, "\", which is not currently defined) ");
 924
 925                 if (start[-1] == '<') keymap = Qnil;
 926               }
 927             else if (start[-1] == '<')
 928               keymap = tem;
 929             else
 930               describe_map_tree (tem, 1, Qnil, Qnil, 0, buffer);
 931
 932             tem = make_string_from_buffer (buf_, BUF_BEG (buf_),
 933                                            BUF_Z (buf_) - BUF_BEG (buf_));
 934             Ferase_buffer (buffer);
 935           }
 936           goto subst_string;
 937
 938         subst_string:
 939           start = XSTRING_DATA (tem);
 940           length = XSTRING_LENGTH (tem);
 941         subst:
 942           bsize += length;
 943           new = (Bufbyte *) xrealloc (buf, bsize);
 944           bufp += new - buf;
 945           buf = new;
 946           memcpy (bufp, start, length);
 947           bufp += length;
 948
 949           /* Reset STRDATA in case gc relocated it.  */
 950           strdata = XSTRING_DATA (string);
 951
 952           break;
 953         }
 954     }
 955
 956   if (changed)                  /* don't bother if nothing substituted */
 957     tem = make_string (buf, bufp - buf);
 958   else
 959     tem = string;
 960   xfree (buf);
 961   UNGCPRO;
 962   return tem;
 963 }
 964
 965 \f
 966 /************************************************************************/
 967 /*                            initialization                            */
 968 /************************************************************************/
 969
 970 void
 971 syms_of_doc (void)
 972 {
 973   DEFSUBR (Fdocumentation);
 974   DEFSUBR (Fdocumentation_property);
 975   DEFSUBR (Fsnarf_documentation);
 976   DEFSUBR (Fverify_documentation);
 977   DEFSUBR (Fsubstitute_command_keys);
 978 }
 979
 980 void
 981 vars_of_doc (void)
 982 {
 983   DEFVAR_LISP ("internal-doc-file-name", &Vinternal_doc_file_name /*
 984 Name of file containing documentation strings of built-in symbols.
 985 */ );
 986   Vinternal_doc_file_name = Qnil;
 987
 988   QSsubstitute = build_string (" *substitute*");
 989   staticpro (&QSsubstitute);
 990 }