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