merge trunk
[bpt/emacs.git] / src / doc.c
1 /* Record indices of function doc strings stored in a file.
2
3 Copyright (C) 1985-1986, 1993-1995, 1997-2012 Free Software Foundation, Inc.
4
5 This file is part of GNU Emacs.
6
7 GNU Emacs is free software: you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation, either version 3 of the License, or
10 (at your option) any later version.
11
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
16
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
19
20
21 #include <config.h>
22
23 #include <sys/types.h>
24 #include <sys/file.h> /* Must be after sys/types.h for USG*/
25 #include <ctype.h>
26 #include <setjmp.h>
27 #include <fcntl.h>
28 #include <unistd.h>
29
30 #include "lisp.h"
31 #include "buffer.h"
32 #include "keyboard.h"
33 #include "character.h"
34 #include "keymap.h"
35 #include "buildobj.h"
36
37 Lisp_Object Qfunction_documentation;
38
39 extern Lisp_Object Qclosure;
40 /* Buffer used for reading from documentation file. */
41 static char *get_doc_string_buffer;
42 static ptrdiff_t get_doc_string_buffer_size;
43
44 static unsigned char *read_bytecode_pointer;
45 static Lisp_Object Fdocumentation_property (Lisp_Object, Lisp_Object,
46 Lisp_Object);
47 static Lisp_Object Fsnarf_documentation (Lisp_Object);
48
49 /* readchar in lread.c calls back here to fetch the next byte.
50 If UNREADFLAG is 1, we unread a byte. */
51
52 int
53 read_bytecode_char (int unreadflag)
54 {
55 if (unreadflag)
56 {
57 read_bytecode_pointer--;
58 return 0;
59 }
60 return *read_bytecode_pointer++;
61 }
62
63 /* Extract a doc string from a file. FILEPOS says where to get it.
64 If it is an integer, use that position in the standard DOC-... file.
65 If it is (FILE . INTEGER), use FILE as the file name
66 and INTEGER as the position in that file.
67 But if INTEGER is negative, make it positive.
68 (A negative integer is used for user variables, so we can distinguish
69 them without actually fetching the doc string.)
70
71 If the location does not point to the beginning of a docstring
72 (e.g. because the file has been modified and the location is stale),
73 return nil.
74
75 If UNIBYTE is nonzero, always make a unibyte string.
76
77 If DEFINITION is nonzero, assume this is for reading
78 a dynamic function definition; convert the bytestring
79 and the constants vector with appropriate byte handling,
80 and return a cons cell. */
81
82 Lisp_Object
83 get_doc_string (Lisp_Object filepos, int unibyte, int definition)
84 {
85 char *from, *to;
86 register int fd;
87 register char *name;
88 register char *p, *p1;
89 ptrdiff_t minsize;
90 int offset;
91 EMACS_INT position;
92 Lisp_Object file, tem;
93 USE_SAFE_ALLOCA;
94
95 if (INTEGERP (filepos))
96 {
97 file = Vdoc_file_name;
98 position = XINT (filepos);
99 }
100 else if (CONSP (filepos))
101 {
102 file = XCAR (filepos);
103 position = XINT (XCDR (filepos));
104 }
105 else
106 return Qnil;
107
108 if (position < 0)
109 position = - position;
110
111 if (!STRINGP (Vdoc_directory))
112 return Qnil;
113
114 if (!STRINGP (file))
115 return Qnil;
116
117 /* Put the file name in NAME as a C string.
118 If it is relative, combine it with Vdoc_directory. */
119
120 tem = Ffile_name_absolute_p (file);
121 file = ENCODE_FILE (file);
122 if (NILP (tem))
123 {
124 Lisp_Object docdir = ENCODE_FILE (Vdoc_directory);
125 minsize = SCHARS (docdir);
126 /* sizeof ("../etc/") == 8 */
127 if (minsize < 8)
128 minsize = 8;
129 SAFE_ALLOCA (name, char *, minsize + SCHARS (file) + 8);
130 strcpy (name, SSDATA (docdir));
131 strcat (name, SSDATA (file));
132 }
133 else
134 {
135 name = SSDATA (file);
136 }
137
138 fd = emacs_open (name, O_RDONLY, 0);
139 if (fd < 0)
140 {
141 #ifndef CANNOT_DUMP
142 if (!NILP (Vpurify_flag))
143 {
144 /* Preparing to dump; DOC file is probably not installed.
145 So check in ../etc. */
146 strcpy (name, "../etc/");
147 strcat (name, SSDATA (file));
148
149 fd = emacs_open (name, O_RDONLY, 0);
150 }
151 #endif
152 if (fd < 0)
153 error ("Cannot open doc string file \"%s\"", name);
154 }
155
156 /* Seek only to beginning of disk block. */
157 /* Make sure we read at least 1024 bytes before `position'
158 so we can check the leading text for consistency. */
159 offset = min (position, max (1024, position % (8 * 1024)));
160 if (TYPE_MAXIMUM (off_t) < position
161 || lseek (fd, position - offset, 0) < 0)
162 {
163 emacs_close (fd);
164 error ("Position %"pI"d out of range in doc string file \"%s\"",
165 position, name);
166 }
167
168 SAFE_FREE ();
169
170 /* Read the doc string into get_doc_string_buffer.
171 P points beyond the data just read. */
172
173 p = get_doc_string_buffer;
174 while (1)
175 {
176 ptrdiff_t space_left = (get_doc_string_buffer_size - 1
177 - (p - get_doc_string_buffer));
178 int nread;
179
180 /* Allocate or grow the buffer if we need to. */
181 if (space_left <= 0)
182 {
183 ptrdiff_t in_buffer = p - get_doc_string_buffer;
184 get_doc_string_buffer =
185 xpalloc (get_doc_string_buffer, &get_doc_string_buffer_size,
186 16 * 1024, -1, 1);
187 p = get_doc_string_buffer + in_buffer;
188 space_left = (get_doc_string_buffer_size - 1
189 - (p - get_doc_string_buffer));
190 }
191
192 /* Read a disk block at a time.
193 If we read the same block last time, maybe skip this? */
194 if (space_left > 1024 * 8)
195 space_left = 1024 * 8;
196 nread = emacs_read (fd, p, space_left);
197 if (nread < 0)
198 {
199 emacs_close (fd);
200 error ("Read error on documentation file");
201 }
202 p[nread] = 0;
203 if (!nread)
204 break;
205 if (p == get_doc_string_buffer)
206 p1 = strchr (p + offset, '\037');
207 else
208 p1 = strchr (p, '\037');
209 if (p1)
210 {
211 *p1 = 0;
212 p = p1;
213 break;
214 }
215 p += nread;
216 }
217 emacs_close (fd);
218
219 /* Sanity checking. */
220 if (CONSP (filepos))
221 {
222 int test = 1;
223 if (get_doc_string_buffer[offset - test++] != ' ')
224 return Qnil;
225 while (get_doc_string_buffer[offset - test] >= '0'
226 && get_doc_string_buffer[offset - test] <= '9')
227 test++;
228 if (get_doc_string_buffer[offset - test++] != '@'
229 || get_doc_string_buffer[offset - test] != '#')
230 return Qnil;
231 }
232 else
233 {
234 int test = 1;
235 if (get_doc_string_buffer[offset - test++] != '\n')
236 return Qnil;
237 while (get_doc_string_buffer[offset - test] > ' ')
238 test++;
239 if (get_doc_string_buffer[offset - test] != '\037')
240 return Qnil;
241 }
242
243 /* Scan the text and perform quoting with ^A (char code 1).
244 ^A^A becomes ^A, ^A0 becomes a null char, and ^A_ becomes a ^_. */
245 from = get_doc_string_buffer + offset;
246 to = get_doc_string_buffer + offset;
247 while (from != p)
248 {
249 if (*from == 1)
250 {
251 int c;
252
253 from++;
254 c = *from++;
255 if (c == 1)
256 *to++ = c;
257 else if (c == '0')
258 *to++ = 0;
259 else if (c == '_')
260 *to++ = 037;
261 else
262 {
263 unsigned char uc = c;
264 error ("\
265 Invalid data in documentation file -- %c followed by code %03o",
266 1, uc);
267 }
268 }
269 else
270 *to++ = *from++;
271 }
272
273 /* If DEFINITION, read from this buffer
274 the same way we would read bytes from a file. */
275 if (definition)
276 {
277 read_bytecode_pointer = (unsigned char *) get_doc_string_buffer + offset;
278 return Fread (Qlambda);
279 }
280
281 if (unibyte)
282 return make_unibyte_string (get_doc_string_buffer + offset,
283 to - (get_doc_string_buffer + offset));
284 else
285 {
286 /* The data determines whether the string is multibyte. */
287 ptrdiff_t nchars =
288 multibyte_chars_in_text (((unsigned char *) get_doc_string_buffer
289 + offset),
290 to - (get_doc_string_buffer + offset));
291 return make_string_from_bytes (get_doc_string_buffer + offset,
292 nchars,
293 to - (get_doc_string_buffer + offset));
294 }
295 }
296
297 /* Get a string from position FILEPOS and pass it through the Lisp reader.
298 We use this for fetching the bytecode string and constants vector
299 of a compiled function from the .elc file. */
300
301 Lisp_Object
302 read_doc_string (Lisp_Object filepos)
303 {
304 return get_doc_string (filepos, 0, 1);
305 }
306
307 static int
308 reread_doc_file (Lisp_Object file)
309 {
310 #if 0
311 Lisp_Object reply, prompt[3];
312 struct gcpro gcpro1;
313 GCPRO1 (file);
314 prompt[0] = build_string ("File ");
315 prompt[1] = NILP (file) ? Vdoc_file_name : file;
316 prompt[2] = build_string (" is out of sync. Reload? ");
317 reply = Fy_or_n_p (Fconcat (3, prompt));
318 UNGCPRO;
319 if (NILP (reply))
320 return 0;
321 #endif
322
323 if (NILP (file))
324 Fsnarf_documentation (Vdoc_file_name);
325 else
326 Fload (file, Qt, Qt, Qt, Qnil);
327
328 return 1;
329 }
330
331 DEFUN ("documentation", Fdocumentation, Sdocumentation, 1, 2, 0,
332 doc: /* Return the documentation string of FUNCTION.
333 Unless a non-nil second argument RAW is given, the
334 string is passed through `substitute-command-keys'. */)
335 (Lisp_Object function, Lisp_Object raw)
336 {
337 Lisp_Object fun;
338 Lisp_Object funcar;
339 Lisp_Object doc;
340 int try_reload = 1;
341
342 documentation:
343
344 doc = Qnil;
345
346 if (SYMBOLP (function))
347 {
348 Lisp_Object tem = Fget (function, Qfunction_documentation);
349 if (!NILP (tem))
350 return Fdocumentation_property (function, Qfunction_documentation,
351 raw);
352 }
353
354 fun = Findirect_function (function, Qnil);
355 if (SUBRP (fun))
356 {
357 if (XSUBR (fun)->doc == 0)
358 return Qnil;
359 /* FIXME: This is not portable, as it assumes that string
360 pointers have the top bit clear. */
361 else if ((intptr_t) XSUBR (fun)->doc >= 0)
362 doc = build_string (XSUBR (fun)->doc);
363 else
364 doc = make_number ((intptr_t) XSUBR (fun)->doc);
365 }
366 else if (COMPILEDP (fun))
367 {
368 if ((ASIZE (fun) & PSEUDOVECTOR_SIZE_MASK) <= COMPILED_DOC_STRING)
369 return Qnil;
370 else
371 {
372 Lisp_Object tem = AREF (fun, COMPILED_DOC_STRING);
373 if (STRINGP (tem))
374 doc = tem;
375 else if (NATNUMP (tem) || CONSP (tem))
376 doc = tem;
377 else
378 return Qnil;
379 }
380 }
381 else if (STRINGP (fun) || VECTORP (fun))
382 {
383 return build_string ("Keyboard macro.");
384 }
385 else if (CONSP (fun))
386 {
387 funcar = Fcar (fun);
388 if (!SYMBOLP (funcar))
389 xsignal1 (Qinvalid_function, fun);
390 else if (EQ (funcar, Qkeymap))
391 return build_string ("Prefix command (definition is a keymap associating keystrokes with commands).");
392 else if (EQ (funcar, Qlambda)
393 || (EQ (funcar, Qclosure) && (fun = XCDR (fun), 1))
394 || EQ (funcar, Qautoload))
395 {
396 Lisp_Object tem1 = Fcdr (Fcdr (fun));
397 Lisp_Object tem = Fcar (tem1);
398 if (STRINGP (tem))
399 doc = tem;
400 /* Handle a doc reference--but these never come last
401 in the function body, so reject them if they are last. */
402 else if ((NATNUMP (tem) || (CONSP (tem) && INTEGERP (XCDR (tem))))
403 && !NILP (XCDR (tem1)))
404 doc = tem;
405 else
406 return Qnil;
407 }
408 else if (EQ (funcar, Qmacro))
409 return Fdocumentation (Fcdr (fun), raw);
410 else
411 goto oops;
412 }
413 else
414 {
415 oops:
416 xsignal1 (Qinvalid_function, fun);
417 }
418
419 /* Check for an advised function. Its doc string
420 has an `ad-advice-info' text property. */
421 if (STRINGP (doc))
422 {
423 Lisp_Object innerfunc;
424 innerfunc = Fget_text_property (make_number (0),
425 intern ("ad-advice-info"),
426 doc);
427 if (! NILP (innerfunc))
428 doc = call1 (intern ("ad-make-advised-docstring"), innerfunc);
429 }
430
431 /* If DOC is 0, it's typically because of a dumped file missing
432 from the DOC file (bug in src/Makefile.in). */
433 if (EQ (doc, make_number (0)))
434 doc = Qnil;
435 if (INTEGERP (doc) || CONSP (doc))
436 {
437 Lisp_Object tem;
438 tem = get_doc_string (doc, 0, 0);
439 if (NILP (tem) && try_reload)
440 {
441 /* The file is newer, we need to reset the pointers. */
442 struct gcpro gcpro1, gcpro2;
443 GCPRO2 (function, raw);
444 try_reload = reread_doc_file (Fcar_safe (doc));
445 UNGCPRO;
446 if (try_reload)
447 {
448 try_reload = 0;
449 goto documentation;
450 }
451 }
452 else
453 doc = tem;
454 }
455
456 if (NILP (raw))
457 doc = Fsubstitute_command_keys (doc);
458 return doc;
459 }
460
461 DEFUN ("documentation-property", Fdocumentation_property,
462 Sdocumentation_property, 2, 3, 0,
463 doc: /* Return the documentation string that is SYMBOL's PROP property.
464 Third argument RAW omitted or nil means pass the result through
465 `substitute-command-keys' if it is a string.
466
467 This differs from `get' in that it can refer to strings stored in the
468 `etc/DOC' file; and that it evaluates documentation properties that
469 aren't strings. */)
470 (Lisp_Object symbol, Lisp_Object prop, Lisp_Object raw)
471 {
472 int try_reload = 1;
473 Lisp_Object tem;
474
475 documentation_property:
476
477 tem = Fget (symbol, prop);
478 if (EQ (tem, make_number (0)))
479 tem = Qnil;
480 if (INTEGERP (tem) || (CONSP (tem) && INTEGERP (XCDR (tem))))
481 {
482 Lisp_Object doc = tem;
483 tem = get_doc_string (tem, 0, 0);
484 if (NILP (tem) && try_reload)
485 {
486 /* The file is newer, we need to reset the pointers. */
487 struct gcpro gcpro1, gcpro2, gcpro3;
488 GCPRO3 (symbol, prop, raw);
489 try_reload = reread_doc_file (Fcar_safe (doc));
490 UNGCPRO;
491 if (try_reload)
492 {
493 try_reload = 0;
494 goto documentation_property;
495 }
496 }
497 }
498 else if (!STRINGP (tem))
499 /* Feval protects its argument. */
500 tem = Feval (tem, Qnil);
501
502 if (NILP (raw) && STRINGP (tem))
503 tem = Fsubstitute_command_keys (tem);
504 return tem;
505 }
506 \f
507 /* Scanning the DOC files and placing docstring offsets into functions. */
508
509 static void
510 store_function_docstring (Lisp_Object obj, ptrdiff_t offset)
511 {
512 /* Don't use indirect_function here, or defaliases will apply their
513 docstrings to the base functions (Bug#2603). */
514 Lisp_Object fun = SYMBOLP (obj) ? XSYMBOL (obj)->function : obj;
515
516 /* The type determines where the docstring is stored. */
517
518 /* Lisp_Subrs have a slot for it. */
519 if (SUBRP (fun))
520 {
521 intptr_t negative_offset = - offset;
522 XSUBR (fun)->doc = (char *) negative_offset;
523 }
524
525 /* If it's a lisp form, stick it in the form. */
526 else if (CONSP (fun))
527 {
528 Lisp_Object tem;
529
530 tem = XCAR (fun);
531 if (EQ (tem, Qlambda) || EQ (tem, Qautoload)
532 || (EQ (tem, Qclosure) && (fun = XCDR (fun), 1)))
533 {
534 tem = Fcdr (Fcdr (fun));
535 if (CONSP (tem) && INTEGERP (XCAR (tem)))
536 XSETCAR (tem, make_number (offset));
537 }
538 else if (EQ (tem, Qmacro))
539 store_function_docstring (XCDR (fun), offset);
540 }
541
542 /* Bytecode objects sometimes have slots for it. */
543 else if (COMPILEDP (fun))
544 {
545 /* This bytecode object must have a slot for the
546 docstring, since we've found a docstring for it. */
547 if ((ASIZE (fun) & PSEUDOVECTOR_SIZE_MASK) > COMPILED_DOC_STRING)
548 ASET (fun, COMPILED_DOC_STRING, make_number (offset));
549 }
550 }
551
552 static const char buildobj[] = BUILDOBJ;
553
554 DEFUN ("Snarf-documentation", Fsnarf_documentation, Ssnarf_documentation,
555 1, 1, 0,
556 doc: /* Used during Emacs initialization to scan the `etc/DOC...' file.
557 This searches the `etc/DOC...' file for doc strings and
558 records them in function and variable definitions.
559 The function takes one argument, FILENAME, a string;
560 it specifies the file name (without a directory) of the DOC file.
561 That file is found in `../etc' now; later, when the dumped Emacs is run,
562 the same file name is found in the `doc-directory'. */)
563 (Lisp_Object filename)
564 {
565 int fd;
566 char buf[1024 + 1];
567 register int filled;
568 register EMACS_INT pos;
569 register char *p;
570 Lisp_Object sym;
571 char *name;
572 int skip_file = 0;
573
574 CHECK_STRING (filename);
575
576 if
577 #ifndef CANNOT_DUMP
578 (!NILP (Vpurify_flag))
579 #else /* CANNOT_DUMP */
580 (0)
581 #endif /* CANNOT_DUMP */
582 {
583 name = (char *) alloca (SCHARS (filename) + 14);
584 strcpy (name, "../etc/");
585 }
586 else
587 {
588 CHECK_STRING (Vdoc_directory);
589 name = (char *) alloca (SCHARS (filename)
590 + SCHARS (Vdoc_directory) + 1);
591 strcpy (name, SSDATA (Vdoc_directory));
592 }
593 strcat (name, SSDATA (filename)); /*** Add this line ***/
594
595 /* Vbuild_files is nil when temacs is run, and non-nil after that. */
596 if (NILP (Vbuild_files))
597 {
598 const char *beg, *end;
599
600 for (beg = buildobj; *beg; beg = end)
601 {
602 ptrdiff_t len;
603
604 while (*beg && isspace (*beg)) ++beg;
605
606 for (end = beg; *end && ! isspace (*end); ++end)
607 if (*end == '/') beg = end+1; /* skip directory part */
608
609 len = end - beg;
610 if (len > 4 && end[-4] == '.' && end[-3] == 'o')
611 len -= 2; /* Just take .o if it ends in .obj */
612
613 if (len > 0)
614 Vbuild_files = Fcons (make_string (beg, len), Vbuild_files);
615 }
616 Vbuild_files = Fpurecopy (Vbuild_files);
617 }
618
619 fd = emacs_open (name, O_RDONLY, 0);
620 if (fd < 0)
621 report_file_error ("Opening doc string file",
622 Fcons (build_string (name), Qnil));
623 Vdoc_file_name = filename;
624 filled = 0;
625 pos = 0;
626 while (1)
627 {
628 register char *end;
629 if (filled < 512)
630 filled += emacs_read (fd, &buf[filled], sizeof buf - 1 - filled);
631 if (!filled)
632 break;
633
634 buf[filled] = 0;
635 p = buf;
636 end = buf + (filled < 512 ? filled : filled - 128);
637 while (p != end && *p != '\037') p++;
638 /* p points to ^_Ffunctionname\n or ^_Vvarname\n or ^_Sfilename\n. */
639 if (p != end)
640 {
641 end = strchr (p, '\n');
642
643 /* See if this is a file name, and if it is a file in build-files. */
644 if (p[1] == 'S')
645 {
646 skip_file = 0;
647 if (end - p > 4 && end[-2] == '.'
648 && (end[-1] == 'o' || end[-1] == 'c'))
649 {
650 ptrdiff_t len = end - p - 2;
651 char *fromfile = alloca (len + 1);
652 strncpy (fromfile, &p[2], len);
653 fromfile[len] = 0;
654 if (fromfile[len-1] == 'c')
655 fromfile[len-1] = 'o';
656
657 skip_file = NILP (Fmember (build_string (fromfile),
658 Vbuild_files));
659 }
660 }
661
662 sym = oblookup (Vobarray, p + 2,
663 multibyte_chars_in_text ((unsigned char *) p + 2,
664 end - p - 2),
665 end - p - 2);
666 /* Check skip_file so that when a function is defined several
667 times in different files (typically, once in xterm, once in
668 w32term, ...), we only pay attention to the one that
669 matters. */
670 if (! skip_file && SYMBOLP (sym))
671 {
672 /* Attach a docstring to a variable? */
673 if (p[1] == 'V')
674 {
675 /* Install file-position as variable-documentation property
676 and make it negative for a user-variable
677 (doc starts with a `*'). */
678 if (!NILP (Fboundp (sym)))
679 Fput (sym, Qvariable_documentation,
680 make_number ((pos + end + 1 - buf)
681 * (end[1] == '*' ? -1 : 1)));
682 }
683
684 /* Attach a docstring to a function? */
685 else if (p[1] == 'F')
686 {
687 if (!NILP (Ffboundp (sym)))
688 store_function_docstring (sym, pos + end + 1 - buf);
689 }
690 else if (p[1] == 'S')
691 ; /* Just a source file name boundary marker. Ignore it. */
692
693 else
694 error ("DOC file invalid at position %"pI"d", pos);
695 }
696 }
697 pos += end - buf;
698 filled -= end - buf;
699 memmove (buf, end, filled);
700 }
701 emacs_close (fd);
702 return Qnil;
703 }
704 \f
705 DEFUN ("substitute-command-keys", Fsubstitute_command_keys,
706 Ssubstitute_command_keys, 1, 1, 0,
707 doc: /* Substitute key descriptions for command names in STRING.
708 Each substring of the form \\=\\[COMMAND] is replaced by either a
709 keystroke sequence that invokes COMMAND, or "M-x COMMAND" if COMMAND
710 is not on any keys.
711
712 Each substring of the form \\=\\{MAPVAR} is replaced by a summary of
713 the value of MAPVAR as a keymap. This summary is similar to the one
714 produced by `describe-bindings'. The summary ends in two newlines
715 \(used by the helper function `help-make-xrefs' to find the end of the
716 summary).
717
718 Each substring of the form \\=\\<MAPVAR> specifies the use of MAPVAR
719 as the keymap for future \\=\\[COMMAND] substrings.
720 \\=\\= quotes the following character and is discarded;
721 thus, \\=\\=\\=\\= puts \\=\\= into the output, and \\=\\=\\=\\[ puts \\=\\[ into the output.
722
723 Return the original STRING if no substitutions are made.
724 Otherwise, return a new string, without any text properties. */)
725 (Lisp_Object string)
726 {
727 char *buf;
728 int changed = 0;
729 register unsigned char *strp;
730 register char *bufp;
731 ptrdiff_t idx;
732 ptrdiff_t bsize;
733 Lisp_Object tem;
734 Lisp_Object keymap;
735 unsigned char *start;
736 ptrdiff_t length, length_byte;
737 Lisp_Object name;
738 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
739 int multibyte;
740 ptrdiff_t nchars;
741
742 if (NILP (string))
743 return Qnil;
744
745 CHECK_STRING (string);
746 tem = Qnil;
747 keymap = Qnil;
748 name = Qnil;
749 GCPRO4 (string, tem, keymap, name);
750
751 multibyte = STRING_MULTIBYTE (string);
752 nchars = 0;
753
754 /* KEYMAP is either nil (which means search all the active keymaps)
755 or a specified local map (which means search just that and the
756 global map). If non-nil, it might come from Voverriding_local_map,
757 or from a \\<mapname> construct in STRING itself.. */
758 keymap = KVAR (current_kboard, Voverriding_terminal_local_map);
759 if (NILP (keymap))
760 keymap = Voverriding_local_map;
761
762 bsize = SBYTES (string);
763 bufp = buf = (char *) xmalloc (bsize);
764
765 strp = SDATA (string);
766 while (strp < SDATA (string) + SBYTES (string))
767 {
768 if (strp[0] == '\\' && strp[1] == '=')
769 {
770 /* \= quotes the next character;
771 thus, to put in \[ without its special meaning, use \=\[. */
772 changed = 1;
773 strp += 2;
774 if (multibyte)
775 {
776 int len;
777
778 STRING_CHAR_AND_LENGTH (strp, len);
779 if (len == 1)
780 *bufp = *strp;
781 else
782 memcpy (bufp, strp, len);
783 strp += len;
784 bufp += len;
785 nchars++;
786 }
787 else
788 *bufp++ = *strp++, nchars++;
789 }
790 else if (strp[0] == '\\' && strp[1] == '[')
791 {
792 ptrdiff_t start_idx;
793 int follow_remap = 1;
794
795 changed = 1;
796 strp += 2; /* skip \[ */
797 start = strp;
798 start_idx = start - SDATA (string);
799
800 while ((strp - SDATA (string)
801 < SBYTES (string))
802 && *strp != ']')
803 strp++;
804 length_byte = strp - start;
805
806 strp++; /* skip ] */
807
808 /* Save STRP in IDX. */
809 idx = strp - SDATA (string);
810 name = Fintern (make_string ((char *) start, length_byte), Qnil);
811
812 do_remap:
813 tem = Fwhere_is_internal (name, keymap, Qt, Qnil, Qnil);
814
815 if (VECTORP (tem) && ASIZE (tem) > 1
816 && EQ (AREF (tem, 0), Qremap) && SYMBOLP (AREF (tem, 1))
817 && follow_remap)
818 {
819 name = AREF (tem, 1);
820 follow_remap = 0;
821 goto do_remap;
822 }
823
824 /* Note the Fwhere_is_internal can GC, so we have to take
825 relocation of string contents into account. */
826 strp = SDATA (string) + idx;
827 start = SDATA (string) + start_idx;
828
829 if (NILP (tem)) /* but not on any keys */
830 {
831 ptrdiff_t offset = bufp - buf;
832 if (STRING_BYTES_BOUND - 4 < bsize)
833 string_overflow ();
834 buf = (char *) xrealloc (buf, bsize += 4);
835 bufp = buf + offset;
836 memcpy (bufp, "M-x ", 4);
837 bufp += 4;
838 nchars += 4;
839 if (multibyte)
840 length = multibyte_chars_in_text (start, length_byte);
841 else
842 length = length_byte;
843 goto subst;
844 }
845 else
846 { /* function is on a key */
847 tem = Fkey_description (tem, Qnil);
848 goto subst_string;
849 }
850 }
851 /* \{foo} is replaced with a summary of the keymap (symbol-value foo).
852 \<foo> just sets the keymap used for \[cmd]. */
853 else if (strp[0] == '\\' && (strp[1] == '{' || strp[1] == '<'))
854 {
855 struct buffer *oldbuf;
856 ptrdiff_t start_idx;
857 /* This is for computing the SHADOWS arg for describe_map_tree. */
858 Lisp_Object active_maps = Fcurrent_active_maps (Qnil, Qnil);
859 Lisp_Object earlier_maps;
860
861 changed = 1;
862 strp += 2; /* skip \{ or \< */
863 start = strp;
864 start_idx = start - SDATA (string);
865
866 while ((strp - SDATA (string) < SBYTES (string))
867 && *strp != '}' && *strp != '>')
868 strp++;
869
870 length_byte = strp - start;
871 strp++; /* skip } or > */
872
873 /* Save STRP in IDX. */
874 idx = strp - SDATA (string);
875
876 /* Get the value of the keymap in TEM, or nil if undefined.
877 Do this while still in the user's current buffer
878 in case it is a local variable. */
879 name = Fintern (make_string ((char *) start, length_byte), Qnil);
880 tem = Fboundp (name);
881 if (! NILP (tem))
882 {
883 tem = Fsymbol_value (name);
884 if (! NILP (tem))
885 {
886 tem = get_keymap (tem, 0, 1);
887 /* Note that get_keymap can GC. */
888 strp = SDATA (string) + idx;
889 start = SDATA (string) + start_idx;
890 }
891 }
892
893 /* Now switch to a temp buffer. */
894 oldbuf = current_buffer;
895 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer));
896
897 if (NILP (tem))
898 {
899 name = Fsymbol_name (name);
900 insert_string ("\nUses keymap \"");
901 insert_from_string (name, 0, 0,
902 SCHARS (name),
903 SBYTES (name), 1);
904 insert_string ("\", which is not currently defined.\n");
905 if (start[-1] == '<') keymap = Qnil;
906 }
907 else if (start[-1] == '<')
908 keymap = tem;
909 else
910 {
911 /* Get the list of active keymaps that precede this one.
912 If this one's not active, get nil. */
913 earlier_maps = Fcdr (Fmemq (tem, Freverse (active_maps)));
914 describe_map_tree (tem, 1, Fnreverse (earlier_maps),
915 Qnil, (char *)0, 1, 0, 0, 1);
916 }
917 tem = Fbuffer_string ();
918 Ferase_buffer ();
919 set_buffer_internal (oldbuf);
920
921 subst_string:
922 start = SDATA (tem);
923 length = SCHARS (tem);
924 length_byte = SBYTES (tem);
925 subst:
926 {
927 ptrdiff_t offset = bufp - buf;
928 if (STRING_BYTES_BOUND - length_byte < bsize)
929 string_overflow ();
930 buf = (char *) xrealloc (buf, bsize += length_byte);
931 bufp = buf + offset;
932 memcpy (bufp, start, length_byte);
933 bufp += length_byte;
934 nchars += length;
935 /* Check STRING again in case gc relocated it. */
936 strp = SDATA (string) + idx;
937 }
938 }
939 else if (! multibyte) /* just copy other chars */
940 *bufp++ = *strp++, nchars++;
941 else
942 {
943 int len;
944
945 STRING_CHAR_AND_LENGTH (strp, len);
946 if (len == 1)
947 *bufp = *strp;
948 else
949 memcpy (bufp, strp, len);
950 strp += len;
951 bufp += len;
952 nchars++;
953 }
954 }
955
956 if (changed) /* don't bother if nothing substituted */
957 tem = make_string_from_bytes (buf, nchars, bufp - buf);
958 else
959 tem = string;
960 xfree (buf);
961 RETURN_UNGCPRO (tem);
962 }
963 \f
964 void
965 syms_of_doc (void)
966 {
967 DEFSYM (Qfunction_documentation, "function-documentation");
968
969 DEFVAR_LISP ("internal-doc-file-name", Vdoc_file_name,
970 doc: /* Name of file containing documentation strings of built-in symbols. */);
971 Vdoc_file_name = Qnil;
972
973 DEFVAR_LISP ("build-files", Vbuild_files,
974 doc: /* A list of files used to build this Emacs binary. */);
975 Vbuild_files = Qnil;
976
977 defsubr (&Sdocumentation);
978 defsubr (&Sdocumentation_property);
979 defsubr (&Ssnarf_documentation);
980 defsubr (&Ssubstitute_command_keys);
981 }