Fix FSF address.
[emacs.git] / src / doc.c
blob5c26e6c6a33b4d693af3c37c876b5148b3a89c8a
1 /* Record indices of function doc strings stored in a file.
2 Copyright (C) 1985, 1986, 1993, 1994, 1995 Free Software Foundation, Inc.
4 This file is part of GNU Emacs.
6 GNU Emacs is free software; you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation; either version 2, or (at your option)
9 any later version.
11 GNU Emacs is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
16 You should have received a copy of the GNU General Public License
17 along with GNU Emacs; see the file COPYING. If not, write to
18 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
19 Boston, MA 02111-1307, USA. */
22 #include <config.h>
24 #include <sys/types.h>
25 #include <sys/file.h> /* Must be after sys/types.h for USG and BSD4_1*/
27 #ifdef USG5
28 #include <fcntl.h>
29 #endif
31 #ifdef HAVE_UNISTD_H
32 #include <unistd.h>
33 #endif
35 #ifndef O_RDONLY
36 #define O_RDONLY 0
37 #endif
39 #include "lisp.h"
40 #include "buffer.h"
41 #include "keyboard.h"
43 Lisp_Object Vdoc_file_name;
45 extern char *index ();
47 extern Lisp_Object Voverriding_local_map;
49 /* For VMS versions with limited file name syntax,
50 convert the name to something VMS will allow. */
51 static void
52 munge_doc_file_name (name)
53 char *name;
55 #ifdef VMS
56 #ifndef VMS4_4
57 /* For VMS versions with limited file name syntax,
58 convert the name to something VMS will allow. */
59 p = name;
60 while (*p)
62 if (*p == '-')
63 *p = '_';
64 p++;
66 #endif /* not VMS4_4 */
67 #ifdef VMS4_4
68 strcpy (name, sys_translate_unix (name));
69 #endif /* VMS4_4 */
70 #endif /* VMS */
73 /* Buffer used for reading from documentation file. */
74 static char *get_doc_string_buffer;
75 static int get_doc_string_buffer_size;
77 /* Extract a doc string from a file. FILEPOS says where to get it.
78 If it is an integer, use that position in the standard DOC-... file.
79 If it is (FILE . INTEGER), use FILE as the file name
80 and INTEGER as the position in that file.
81 But if INTEGER is negative, make it positive.
82 (A negative integer is used for user variables, so we can distinguish
83 them without actually fetching the doc string.) */
85 static Lisp_Object
86 get_doc_string (filepos)
87 Lisp_Object filepos;
89 char *from, *to;
90 register int fd;
91 register char *name;
92 register char *p, *p1;
93 int minsize;
94 int offset, position;
95 Lisp_Object file, tem;
97 if (INTEGERP (filepos))
99 file = Vdoc_file_name;
100 position = XINT (filepos);
102 else if (CONSP (filepos))
104 file = XCONS (filepos)->car;
105 position = XINT (XCONS (filepos)->cdr);
106 if (position < 0)
107 position = - position;
109 else
110 return Qnil;
112 if (!STRINGP (Vdoc_directory))
113 return Qnil;
115 if (!STRINGP (file))
116 return Qnil;
118 /* Put the file name in NAME as a C string.
119 If it is relative, combine it with Vdoc_directory. */
121 tem = Ffile_name_absolute_p (file);
122 if (NILP (tem))
124 minsize = XSTRING (Vdoc_directory)->size;
125 /* sizeof ("../etc/") == 8 */
126 if (minsize < 8)
127 minsize = 8;
128 name = (char *) alloca (minsize + XSTRING (file)->size + 8);
129 strcpy (name, XSTRING (Vdoc_directory)->data);
130 strcat (name, XSTRING (file)->data);
131 munge_doc_file_name (name);
133 else
135 name = (char *) XSTRING (file)->data;
138 fd = open (name, O_RDONLY, 0);
139 if (fd < 0)
141 #ifndef CANNOT_DUMP
142 if (!NILP (Vpurify_flag))
144 /* Preparing to dump; DOC file is probably not installed.
145 So check in ../etc. */
146 strcpy (name, "../etc/");
147 strcat (name, XSTRING (file)->data);
148 munge_doc_file_name (name);
150 fd = open (name, O_RDONLY, 0);
152 #endif
153 if (fd < 0)
154 error ("Cannot open doc string file \"%s\"", name);
157 /* Seek only to beginning of disk block. */
158 offset = position % (8 * 1024);
159 if (0 > lseek (fd, position - offset, 0))
161 close (fd);
162 error ("Position %ld out of range in doc string file \"%s\"",
163 position, name);
166 /* Read the doc string into get_doc_string_buffer.
167 P points beyond the data just read. */
169 p = get_doc_string_buffer;
170 while (1)
172 int space_left = (get_doc_string_buffer_size
173 - (p - get_doc_string_buffer));
174 int nread;
176 /* Allocate or grow the buffer if we need to. */
177 if (space_left == 0)
179 int in_buffer = p - get_doc_string_buffer;
180 get_doc_string_buffer_size += 16 * 1024;
181 get_doc_string_buffer
182 = (char *) xrealloc (get_doc_string_buffer,
183 get_doc_string_buffer_size + 1);
184 p = get_doc_string_buffer + in_buffer;
185 space_left = (get_doc_string_buffer_size
186 - (p - get_doc_string_buffer));
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 = read (fd, p, space_left);
194 if (nread < 0)
196 close (fd);
197 error ("Read error on documentation file");
199 p[nread] = 0;
200 if (!nread)
201 break;
202 if (p == get_doc_string_buffer)
203 p1 = index (p + offset, '\037');
204 else
205 p1 = index (p, '\037');
206 if (p1)
208 *p1 = 0;
209 p = p1;
210 break;
212 p += nread;
214 close (fd);
216 /* Scan the text and perform quoting with ^A (char code 1).
217 ^A^A becomes ^A, ^A0 becomes a null char, and ^A_ becomes a ^_. */
218 from = get_doc_string_buffer + offset;
219 to = get_doc_string_buffer + offset;
220 while (from != p)
222 if (*from == 1)
224 int c;
226 from++;
227 c = *from++;
228 if (c == 1)
229 *to++ = c;
230 else if (c == '0')
231 *to++ = 0;
232 else if (c == '_')
233 *to++ = 037;
234 else
235 error ("Invalid data in documentation file -- ^A followed by code 0%o", c);
237 else
238 *to++ = *from++;
241 return make_string (get_doc_string_buffer + offset,
242 to - (get_doc_string_buffer + offset));
245 /* Get a string from position FILEPOS and pass it through the Lisp reader.
246 We use this for fetching the bytecode string and constants vector
247 of a compiled function from the .elc file. */
249 Lisp_Object
250 read_doc_string (filepos)
251 Lisp_Object filepos;
253 return Fread (get_doc_string (filepos));
256 DEFUN ("documentation", Fdocumentation, Sdocumentation, 1, 2, 0,
257 "Return the documentation string of FUNCTION.\n\
258 Unless a non-nil second argument RAW is given, the\n\
259 string is passed through `substitute-command-keys'.")
260 (function, raw)
261 Lisp_Object function, raw;
263 Lisp_Object fun;
264 Lisp_Object funcar;
265 Lisp_Object tem, doc;
267 fun = Findirect_function (function);
269 if (SUBRP (fun))
271 if (XSUBR (fun)->doc == 0) return Qnil;
272 if ((EMACS_INT) XSUBR (fun)->doc >= 0)
273 doc = build_string (XSUBR (fun)->doc);
274 else
275 doc = get_doc_string (make_number (- (EMACS_INT) XSUBR (fun)->doc));
277 else if (COMPILEDP (fun))
279 if ((XVECTOR (fun)->size & PSEUDOVECTOR_SIZE_MASK) <= COMPILED_DOC_STRING)
280 return Qnil;
281 tem = XVECTOR (fun)->contents[COMPILED_DOC_STRING];
282 if (STRINGP (tem))
283 doc = tem;
284 else if (NATNUMP (tem) || CONSP (tem))
285 doc = get_doc_string (tem);
286 else
287 return Qnil;
289 else if (STRINGP (fun) || VECTORP (fun))
291 return build_string ("Keyboard macro.");
293 else if (CONSP (fun))
295 funcar = Fcar (fun);
296 if (!SYMBOLP (funcar))
297 return Fsignal (Qinvalid_function, Fcons (fun, Qnil));
298 else if (EQ (funcar, Qkeymap))
299 return build_string ("Prefix command (definition is a keymap associating keystrokes with\n\
300 subcommands.)");
301 else if (EQ (funcar, Qlambda)
302 || EQ (funcar, Qautoload))
304 Lisp_Object tem1;
305 tem1 = Fcdr (Fcdr (fun));
306 tem = Fcar (tem1);
307 if (STRINGP (tem))
308 doc = tem;
309 /* Handle a doc reference--but these never come last
310 in the function body, so reject them if they are last. */
311 else if ((NATNUMP (tem) || CONSP (tem))
312 && ! NILP (XCONS (tem1)->cdr))
313 doc = get_doc_string (tem);
314 else
315 return Qnil;
317 else if (EQ (funcar, Qmocklisp))
318 return Qnil;
319 else if (EQ (funcar, Qmacro))
320 return Fdocumentation (Fcdr (fun), raw);
321 else
322 goto oops;
324 else
326 oops:
327 Fsignal (Qinvalid_function, Fcons (fun, Qnil));
330 if (NILP (raw))
332 struct gcpro gcpro1;
334 GCPRO1 (doc);
335 doc = Fsubstitute_command_keys (doc);
336 UNGCPRO;
338 return doc;
341 DEFUN ("documentation-property", Fdocumentation_property, Sdocumentation_property, 2, 3, 0,
342 "Return the documentation string that is SYMBOL's PROP property.\n\
343 This is like `get', but it can refer to strings stored in the\n\
344 `etc/DOC' file; and if the value is a string, it is passed through\n\
345 `substitute-command-keys'. A non-nil third argument RAW avoids this\n\
346 translation.")
347 (symbol, prop, raw)
348 Lisp_Object symbol, prop, raw;
350 register Lisp_Object tem;
352 tem = Fget (symbol, prop);
353 if (INTEGERP (tem))
354 tem = get_doc_string (XINT (tem) > 0 ? tem : make_number (- XINT (tem)));
355 else if (CONSP (tem))
356 tem = get_doc_string (tem);
357 if (NILP (raw) && STRINGP (tem))
358 return Fsubstitute_command_keys (tem);
359 return tem;
362 /* Scanning the DOC files and placing docstring offsets into functions. */
364 static void
365 store_function_docstring (fun, offset)
366 Lisp_Object fun;
367 /* Use EMACS_INT because we get this from pointer subtraction. */
368 EMACS_INT offset;
370 fun = indirect_function (fun);
372 /* The type determines where the docstring is stored. */
374 /* Lisp_Subrs have a slot for it. */
375 if (SUBRP (fun))
376 XSUBR (fun)->doc = (char *) - offset;
378 /* If it's a lisp form, stick it in the form. */
379 else if (CONSP (fun))
381 Lisp_Object tem;
383 tem = XCONS (fun)->car;
384 if (EQ (tem, Qlambda) || EQ (tem, Qautoload))
386 tem = Fcdr (Fcdr (fun));
387 if (CONSP (tem) && INTEGERP (XCONS (tem)->car))
388 XSETFASTINT (XCONS (tem)->car, offset);
390 else if (EQ (tem, Qmacro))
391 store_function_docstring (XCONS (fun)->cdr, offset);
394 /* Bytecode objects sometimes have slots for it. */
395 else if (COMPILEDP (fun))
397 /* This bytecode object must have a slot for the
398 docstring, since we've found a docstring for it. */
399 if ((XVECTOR (fun)->size & PSEUDOVECTOR_SIZE_MASK) > COMPILED_DOC_STRING)
400 XSETFASTINT (XVECTOR (fun)->contents[COMPILED_DOC_STRING], offset);
405 DEFUN ("Snarf-documentation", Fsnarf_documentation, Ssnarf_documentation,
406 1, 1, 0,
407 "Used during Emacs initialization, before dumping runnable Emacs,\n\
408 to find pointers to doc strings stored in `etc/DOC...' and\n\
409 record them in function definitions.\n\
410 One arg, FILENAME, a string which does not include a directory.\n\
411 The file is found in `../etc' now; found in the `data-directory'\n\
412 when doc strings are referred to later in the dumped Emacs.")
413 (filename)
414 Lisp_Object filename;
416 int fd;
417 char buf[1024 + 1];
418 register int filled;
419 register int pos;
420 register char *p, *end;
421 Lisp_Object sym, fun, tem;
422 char *name;
423 extern char *index ();
425 #ifndef CANNOT_DUMP
426 if (NILP (Vpurify_flag))
427 error ("Snarf-documentation can only be called in an undumped Emacs");
428 #endif
430 CHECK_STRING (filename, 0);
432 #ifndef CANNOT_DUMP
433 name = (char *) alloca (XSTRING (filename)->size + 14);
434 strcpy (name, "../etc/");
435 #else /* CANNOT_DUMP */
436 CHECK_STRING (Vdoc_directory, 0);
437 name = (char *) alloca (XSTRING (filename)->size +
438 XSTRING (Vdoc_directory)->size + 1);
439 strcpy (name, XSTRING (Vdoc_directory)->data);
440 #endif /* CANNOT_DUMP */
441 strcat (name, XSTRING (filename)->data); /*** Add this line ***/
442 #ifdef VMS
443 #ifndef VMS4_4
444 /* For VMS versions with limited file name syntax,
445 convert the name to something VMS will allow. */
446 p = name;
447 while (*p)
449 if (*p == '-')
450 *p = '_';
451 p++;
453 #endif /* not VMS4_4 */
454 #ifdef VMS4_4
455 strcpy (name, sys_translate_unix (name));
456 #endif /* VMS4_4 */
457 #endif /* VMS */
459 fd = open (name, O_RDONLY, 0);
460 if (fd < 0)
461 report_file_error ("Opening doc string file",
462 Fcons (build_string (name), Qnil));
463 Vdoc_file_name = filename;
464 filled = 0;
465 pos = 0;
466 while (1)
468 if (filled < 512)
469 filled += read (fd, &buf[filled], sizeof buf - 1 - filled);
470 if (!filled)
471 break;
473 buf[filled] = 0;
474 p = buf;
475 end = buf + (filled < 512 ? filled : filled - 128);
476 while (p != end && *p != '\037') p++;
477 /* p points to ^_Ffunctionname\n or ^_Vvarname\n. */
478 if (p != end)
480 end = index (p, '\n');
481 sym = oblookup (Vobarray, p + 2, end - p - 2);
482 if (SYMBOLP (sym))
484 /* Attach a docstring to a variable? */
485 if (p[1] == 'V')
487 /* Install file-position as variable-documentation property
488 and make it negative for a user-variable
489 (doc starts with a `*'). */
490 Fput (sym, Qvariable_documentation,
491 make_number ((pos + end + 1 - buf)
492 * (end[1] == '*' ? -1 : 1)));
495 /* Attach a docstring to a function? */
496 else if (p[1] == 'F')
497 store_function_docstring (sym, pos + end + 1 - buf);
499 else
500 error ("DOC file invalid at position %d", pos);
503 pos += end - buf;
504 filled -= end - buf;
505 bcopy (end, buf, filled);
507 close (fd);
508 return Qnil;
511 DEFUN ("substitute-command-keys", Fsubstitute_command_keys,
512 Ssubstitute_command_keys, 1, 1, 0,
513 "Substitute key descriptions for command names in STRING.\n\
514 Return a new string which is STRING with substrings of the form \\=\\[COMMAND]\n\
515 replaced by either: a keystroke sequence that will invoke COMMAND,\n\
516 or \"M-x COMMAND\" if COMMAND is not on any keys.\n\
517 Substrings of the form \\=\\{MAPVAR} are replaced by summaries\n\
518 \(made by describe-bindings) of the value of MAPVAR, taken as a keymap.\n\
519 Substrings of the form \\=\\<MAPVAR> specify to use the value of MAPVAR\n\
520 as the keymap for future \\=\\[COMMAND] substrings.\n\
521 \\=\\= quotes the following character and is discarded;\n\
522 thus, \\=\\=\\=\\= puts \\=\\= into the output, and \\=\\=\\=\\[ puts \\=\\[ into the output.")
523 (string)
524 Lisp_Object string;
526 unsigned char *buf;
527 int changed = 0;
528 register unsigned char *strp;
529 register unsigned char *bufp;
530 int idx;
531 int bsize;
532 unsigned char *new;
533 Lisp_Object tem;
534 Lisp_Object keymap;
535 unsigned char *start;
536 int length;
537 Lisp_Object name;
538 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
540 if (NILP (string))
541 return Qnil;
543 CHECK_STRING (string, 0);
544 tem = Qnil;
545 keymap = Qnil;
546 name = Qnil;
547 GCPRO4 (string, tem, keymap, name);
549 /* KEYMAP is either nil (which means search all the active keymaps)
550 or a specified local map (which means search just that and the
551 global map). If non-nil, it might come from Voverriding_local_map,
552 or from a \\<mapname> construct in STRING itself.. */
553 keymap = current_kboard->Voverriding_terminal_local_map;
554 if (NILP (keymap))
555 keymap = Voverriding_local_map;
557 bsize = XSTRING (string)->size;
558 bufp = buf = (unsigned char *) xmalloc (bsize);
560 strp = (unsigned char *) XSTRING (string)->data;
561 while (strp < (unsigned char *) XSTRING (string)->data + XSTRING (string)->size)
563 if (strp[0] == '\\' && strp[1] == '=')
565 /* \= quotes the next character;
566 thus, to put in \[ without its special meaning, use \=\[. */
567 changed = 1;
568 *bufp++ = strp[2];
569 strp += 3;
571 else if (strp[0] == '\\' && strp[1] == '[')
573 Lisp_Object firstkey;
575 changed = 1;
576 strp += 2; /* skip \[ */
577 start = strp;
579 while ((strp - (unsigned char *) XSTRING (string)->data
580 < XSTRING (string)->size)
581 && *strp != ']')
582 strp++;
583 length = strp - start;
584 strp++; /* skip ] */
586 /* Save STRP in IDX. */
587 idx = strp - (unsigned char *) XSTRING (string)->data;
588 tem = Fintern (make_string (start, length), Qnil);
589 tem = Fwhere_is_internal (tem, keymap, Qt, Qnil);
591 /* Disregard menu bar bindings; it is positively annoying to
592 mention them when there's no menu bar, and it isn't terribly
593 useful even when there is a menu bar. */
594 if (!NILP (tem))
596 firstkey = Faref (tem, make_number (0));
597 if (EQ (firstkey, Qmenu_bar))
598 tem = Qnil;
601 if (NILP (tem)) /* but not on any keys */
603 new = (unsigned char *) xrealloc (buf, bsize += 4);
604 bufp += new - buf;
605 buf = new;
606 bcopy ("M-x ", bufp, 4);
607 bufp += 4;
608 goto subst;
610 else
611 { /* function is on a key */
612 tem = Fkey_description (tem);
613 goto subst_string;
616 /* \{foo} is replaced with a summary of the keymap (symbol-value foo).
617 \<foo> just sets the keymap used for \[cmd]. */
618 else if (strp[0] == '\\' && (strp[1] == '{' || strp[1] == '<'))
620 struct buffer *oldbuf;
622 changed = 1;
623 strp += 2; /* skip \{ or \< */
624 start = strp;
626 while ((strp - (unsigned char *) XSTRING (string)->data
627 < XSTRING (string)->size)
628 && *strp != '}' && *strp != '>')
629 strp++;
630 length = strp - start;
631 strp++; /* skip } or > */
633 /* Save STRP in IDX. */
634 idx = strp - (unsigned char *) XSTRING (string)->data;
636 /* Get the value of the keymap in TEM, or nil if undefined.
637 Do this while still in the user's current buffer
638 in case it is a local variable. */
639 name = Fintern (make_string (start, length), Qnil);
640 tem = Fboundp (name);
641 if (! NILP (tem))
643 tem = Fsymbol_value (name);
644 if (! NILP (tem))
645 tem = get_keymap_1 (tem, 0, 1);
648 /* Now switch to a temp buffer. */
649 oldbuf = current_buffer;
650 set_buffer_internal (XBUFFER (Vprin1_to_string_buffer));
652 if (NILP (tem))
654 name = Fsymbol_name (name);
655 insert_string ("\nUses keymap \"");
656 insert_from_string (name, 0, XSTRING (name)->size, 1);
657 insert_string ("\", which is not currently defined.\n");
658 if (start[-1] == '<') keymap = Qnil;
660 else if (start[-1] == '<')
661 keymap = tem;
662 else
663 describe_map_tree (tem, 1, Qnil, Qnil, (char *)0, 1, 0);
664 tem = Fbuffer_string ();
665 Ferase_buffer ();
666 set_buffer_internal (oldbuf);
668 subst_string:
669 start = XSTRING (tem)->data;
670 length = XSTRING (tem)->size;
671 subst:
672 new = (unsigned char *) xrealloc (buf, bsize += length);
673 bufp += new - buf;
674 buf = new;
675 bcopy (start, bufp, length);
676 bufp += length;
677 /* Check STRING again in case gc relocated it. */
678 strp = (unsigned char *) XSTRING (string)->data + idx;
680 else /* just copy other chars */
681 *bufp++ = *strp++;
684 if (changed) /* don't bother if nothing substituted */
685 tem = make_string (buf, bufp - buf);
686 else
687 tem = string;
688 xfree (buf);
689 RETURN_UNGCPRO (tem);
692 syms_of_doc ()
694 DEFVAR_LISP ("internal-doc-file-name", &Vdoc_file_name,
695 "Name of file containing documentation strings of built-in symbols.");
696 Vdoc_file_name = Qnil;
698 defsubr (&Sdocumentation);
699 defsubr (&Sdocumentation_property);
700 defsubr (&Ssnarf_documentation);
701 defsubr (&Ssubstitute_command_keys);