diff src/doc.c @ 5118:e0db3c197671 ben-lisp-object

merge up to latest default branch, doesn't compile yet
author Ben Wing <ben@xemacs.org>
date Sat, 26 Dec 2009 21:18:49 -0600
parents 061e030e3270
children 755ae5b97edb 19a72041c5ed
line wrap: on
line diff
--- a/src/doc.c	Sat Dec 26 00:20:27 2009 -0600
+++ b/src/doc.c	Sat Dec 26 21:18:49 2009 -0600
@@ -37,12 +37,129 @@
 
 Lisp_Object Vinternal_doc_file_name;
 
-Lisp_Object QSsubstitute;
+Lisp_Object QSsubstitute, Qdefvar;
+
+/* Work out what source file a function or variable came from, taking the
+   information from the documentation file. */
+
+static Lisp_Object
+extract_object_file_name (int fd, EMACS_INT doc_pos,
+			  Ibyte *name_nonreloc, Lisp_Object name_reloc,
+			  int standard_doc_file)
+{
+  Ibyte buf[DOC_MAX_FILENAME_LENGTH+1];
+  Ibyte *buffer = buf;
+  int buffer_size = sizeof (buf) - 1, space_left;
+  Ibyte *from, *to;
+  REGISTER Ibyte *p = buffer;
+  Lisp_Object return_me;
+  Lisp_Object fdstream = Qnil, instream = Qnil;
+  struct gcpro gcpro1, gcpro2;
+  EMACS_INT position, seenS = 0;
+
+  GCPRO2 (fdstream, instream);
+
+  position = doc_pos > buffer_size  ? 
+    doc_pos - buffer_size : 0; 
+
+  if (0 > lseek (fd, position, 0))
+    {
+      if (name_nonreloc)
+	name_reloc = build_intstring (name_nonreloc);
+      return_me = list3 (build_msg_string
+			 ("Position out of range in doc string file"),
+			  name_reloc, make_int (position));
+      goto done;
+    }
+
+  fdstream = make_filedesc_input_stream (fd, 0, -1, 0);
+  Lstream_set_buffering (XLSTREAM (fdstream), LSTREAM_UNBUFFERED, 0);
+  instream =
+    make_coding_input_stream
+      (XLSTREAM (fdstream), standard_doc_file ? Qescape_quoted : Qbinary,
+       CODING_DECODE, 0);
+  Lstream_set_buffering (XLSTREAM (instream), LSTREAM_UNBUFFERED, 0);
+
+  space_left = buffer_size - (p - buffer);
+  while (space_left > 0)
+    {
+      int nread;
+
+      nread = Lstream_read (XLSTREAM (instream), p, space_left);
+      if (nread < 0)
+	{
+	  return_me = list1 (build_msg_string
+			     ("Read error on documentation file"));
+	  goto done;
+	}
+
+      p[nread] = 0;
+
+      if (!nread)
+	break;
 
-/* Read and return doc string or instructions from open file descriptor FD
-   at position POSITION.  Does not close the file.  Returns string; or if
-   error, returns a cons holding the error data to pass to Fsignal.
-   NAME_NONRELOC and NAME_RELOC are only used for the error messages. */
+      p += nread;
+      space_left = buffer_size - (p - buffer);
+    }
+
+  /* First, search backward for the "\037S" that marks the beginning of the
+     file name, then search forward from that to the newline or to the end
+     of the buffer. */
+  from = p; 
+
+  while (from > buf)
+    {
+      --from;
+      if (seenS)
+	{
+	  if ('\037' == *from) 
+	    {
+	      /* Got a file name; adjust `from' to point to it, break out of
+		 the loop.  */
+	      from += 2;
+	      break; 
+	    }
+	}
+      /* Is *from 'S' ? */
+      seenS = ('S' == *from);
+    }
+
+  if (buf == from)
+    {
+      /* We've scanned back to the beginning of the buffer without hitting
+	 the file name. Either the file name plus the symbol name is longer
+	 than DOC_MAX_FILENAME_LENGTH--which shouldn't happen, because it'll
+	 trigger an assertion failure in make-docfile, the DOC file is
+	 corrupt, or it was produced by a version of make-docfile that
+	 doesn't store the file name with the symbol name and docstring.  */ 
+      return_me = list1 (build_msg_string
+			 ("Object file name not stored in doc file"));
+      goto done;
+    }
+
+  to = from;
+  /* Search for the end of the file name. */
+  while (++to < p)
+    {
+      if ('\n' == *to || '\037' == *to)
+	{
+	  break;
+	}
+    }
+
+  /* Don't require the file name to end in a newline. */
+  return_me = make_string (from, to - from);
+
+ done:
+  if (!NILP (instream))
+    {
+      Lstream_delete (XLSTREAM (instream));
+      Lstream_delete (XLSTREAM (fdstream));
+    }
+
+  UNGCPRO;
+  return return_me;
+}
 
 Lisp_Object
 unparesseuxify_doc_string (int fd, EMACS_INT position,
@@ -51,7 +168,7 @@
 {
   Ibyte buf[512 * 32 + 1];
   Ibyte *buffer = buf;
-  int buffer_size = sizeof (buf);
+  int buffer_size = sizeof (buf) - 1;
   Ibyte *from, *to;
   REGISTER Ibyte *p = buffer;
   Lisp_Object return_me;
@@ -98,13 +215,15 @@
       if (space_left == 0)
 	{
           Ibyte *old_buffer = buffer;
+	  buffer_size *= 2;
+
 	  if (buffer == buf)
 	    {
-	      buffer = xnew_ibytes (buffer_size *= 2);
+	      buffer = xnew_ibytes (buffer_size + 1);
 	      memcpy (buffer, old_buffer, p - old_buffer);
 	    }
 	  else
-            XREALLOC_ARRAY (buffer, Ibyte, buffer_size *= 2);
+            XREALLOC_ARRAY (buffer, Ibyte, buffer_size + 1);
           p += buffer - old_buffer;
 	  space_left = buffer_size - (p - buffer);
 	}
@@ -287,6 +406,180 @@
   return Fread (string);
 }
 
+static Lisp_Object
+get_object_file_name (Lisp_Object filepos)
+{
+  REGISTER int fd;
+  REGISTER Ibyte *name_nonreloc = 0;
+  EMACS_INT position;
+  Lisp_Object file, tem;
+  Lisp_Object name_reloc = Qnil;
+  int standard_doc_file = 0;
+
+  if (INTP (filepos))
+    {
+      file = Vinternal_doc_file_name;
+      standard_doc_file = 1;
+      position = XINT (filepos);
+    }
+  else if (CONSP (filepos) && INTP (XCDR (filepos)))
+    {
+      file = XCAR (filepos);
+      position = XINT (XCDR (filepos));
+      if (position < 0)
+	position = - position;
+    }
+  else
+    return Qnil;
+
+  if (!STRINGP (file))
+    return Qnil;
+
+  /* Put the file name in NAME as a C string.
+     If it is relative, combine it with Vdoc_directory.  */
+
+  tem = Ffile_name_absolute_p (file);
+  if (NILP (tem))
+    {
+      Bytecount minsize;
+      /* XEmacs: Move this check here.  OK if called during loadup to
+	 load byte code instructions. */
+      if (!STRINGP (Vdoc_directory))
+	return Qnil;
+
+      minsize = XSTRING_LENGTH (Vdoc_directory);
+      /* sizeof ("../lib-src/") == 12 */
+      if (minsize < 12)
+	minsize = 12;
+      name_nonreloc = alloca_ibytes (minsize + XSTRING_LENGTH (file) + 8);
+      string_join (name_nonreloc, Vdoc_directory, file);
+    }
+  else
+    name_reloc = file;
+
+  fd = qxe_open (name_nonreloc ? name_nonreloc :
+		 XSTRING_DATA (name_reloc), O_RDONLY | OPEN_BINARY, 0);
+  if (fd < 0)
+    {
+      if (purify_flag)
+	{
+	    /* sizeof ("../lib-src/") == 12 */
+	  name_nonreloc = alloca_ibytes (12 + XSTRING_LENGTH (file) + 8);
+	  /* Preparing to dump; DOC file is probably not installed.
+	     So check in ../lib-src. */
+	  qxestrcpy_ascii (name_nonreloc, "../lib-src/");
+	  qxestrcat (name_nonreloc, XSTRING_DATA (file));
+
+	  fd = qxe_open (name_nonreloc, O_RDONLY | OPEN_BINARY, 0);
+	}
+
+      if (fd < 0)
+	report_file_error ("Cannot open doc string file",
+			   name_nonreloc ? build_intstring (name_nonreloc) :
+			   name_reloc);
+    }
+
+  tem = extract_object_file_name (fd, position, name_nonreloc, name_reloc,
+			      standard_doc_file);
+  retry_close (fd);
+
+  if (!STRINGP (tem))
+    signal_error_1 (Qinvalid_byte_code, tem);
+
+  return tem;
+}
+
+
+static void
+weird_doc (Lisp_Object sym, const CIbyte *weirdness, const CIbyte *type,
+	   int pos)
+{
+  if (!strcmp (weirdness, GETTEXT ("duplicate"))) return;
+  message ("Note: Strange doc (%s) for %s %s @ %d",
+           weirdness, type, XSTRING_DATA (XSYMBOL (sym)->name), pos);
+}
+
+DEFUN ("built-in-symbol-file", Fbuilt_in_symbol_file, 1, 2, 0, /*
+Return the C source file built-in symbol SYM comes from. 
+Don't use this.  Use the more general `symbol-file' (q.v.) instead. 
+
+If TYPE is nil or omitted, any kind of definition is acceptable. 
+If TYPE is `defun', then function, subr, special form or macro definitions
+are acceptable.
+If TYPE is `defvar', then variable definitions are acceptable.
+*/
+       (symbol, type))
+{
+  /* This function can GC */
+  Lisp_Object fun;
+  Lisp_Object filename = Qnil;
+
+  if (EQ(Ffboundp(symbol), Qt) && (EQ(type, Qnil) || EQ(type, Qdefun)))
+    {
+      fun = Findirect_function (symbol);
+
+      if (SUBRP (fun) || (CONSP(fun) && (EQ (Qmacro, Fcar_safe (fun)))
+                          && (fun = Fcdr_safe (fun), SUBRP (fun))))
+	{
+	  if (XSUBR (fun)->doc == 0)
+	    return Qnil;
+
+	  if ((EMACS_INT) XSUBR (fun)->doc >= 0)
+	    {
+	      weird_doc (symbol, "No file info available for function",
+			 GETTEXT("function"), 0);
+	      return Qnil;
+	    }
+	  else
+	    {
+	      filename = get_object_file_name 
+		(make_int (- (EMACS_INT) XSUBR (fun)->doc));
+	      return filename;
+	    }
+	}
+
+      if (COMPILED_FUNCTIONP (fun) || (CONSP(fun) &&
+				       (EQ (Qmacro, Fcar_safe (fun)))
+				       && (fun = Fcdr_safe (fun),
+					   COMPILED_FUNCTIONP (fun))))
+	{
+	  Lisp_Object tem;
+	  Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (fun);
+
+	  if (! (f->flags.documentationp))
+	    return Qnil;
+	  tem = compiled_function_documentation (f);
+	  if (NATNUMP (tem) || CONSP (tem))
+	    {
+	      filename = get_object_file_name (tem);
+	      return filename;
+	    }
+	}
+    }
+
+  if (EQ(Fboundp(symbol), Qt) && (EQ(type, Qnil) || EQ(type, Qdefvar)))
+    {
+      Lisp_Object doc_offset = Fget (symbol, Qvariable_documentation, Qnil);
+
+      if (!NILP(doc_offset)) 
+	{
+	  if (INTP(doc_offset))
+	    {
+	      filename = get_object_file_name 
+		(XINT (doc_offset) > 0 ? doc_offset
+		 : make_int (- XINT (doc_offset)));
+	    }
+	  else if (CONSP(doc_offset))
+	    {
+	      filename = get_object_file_name(doc_offset);
+	    }
+	  return filename;
+	}
+    }
+
+  return Qnil;
+}
+
 DEFUN ("documentation", Fdocumentation, 1, 2, 0, /*
 Return the documentation string of FUNCTION.
 Unless a non-nil second argument RAW is given, the
@@ -419,14 +712,6 @@
   return doc;
 }
 
-static void
-weird_doc (Lisp_Object sym, const CIbyte *weirdness, const CIbyte *type,
-	   int pos)
-{
-  if (!strcmp (weirdness, GETTEXT ("duplicate"))) return;
-  message ("Note: Strange doc (%s) for %s %s @ %d",
-           weirdness, type, XSTRING_DATA (XSYMBOL (sym)->name), pos);
-}
 
 DEFUN ("Snarf-documentation", Fsnarf_documentation, 1, 1, 0, /*
 Used during Emacs initialization, before dumping runnable Emacs,
@@ -487,6 +772,10 @@
       if (p != end)
 	{
 	  end = qxestrchr (p, '\n');
+	  /* If you trigger a failure with this assertion, you probably
+	     configured with --quick-build and need to rebuild your DOC
+	     file. */
+	  assert((end - p - 2) > -1);
 	  sym = oblookup (Vobarray, p + 2, end - p - 2);
 	  if (SYMBOLP (sym))
 	    {
@@ -1008,11 +1297,14 @@
 void
 syms_of_doc (void)
 {
+  DEFSUBR (Fbuilt_in_symbol_file);
   DEFSUBR (Fdocumentation);
   DEFSUBR (Fdocumentation_property);
   DEFSUBR (Fsnarf_documentation);
   DEFSUBR (Fverify_documentation);
   DEFSUBR (Fsubstitute_command_keys);
+
+  DEFSYMBOL (Qdefvar);
 }
 
 void