Mercurial > hg > xemacs-beta

comparison src/doc.c @ 0:376386a54a3c r19-14

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