[PATCH 8/9] procedure-documentation works on RTL procedures

[Andy Wingo <wingo@pobox.com>]

* libguile/procprop.h:
* libguile/procprop.c (scm_procedure_documentation): Move here from
  procs.c, and to make the logic more similar to that of procedure-name,
  which allows RTL programs to dispatch to rtl-program-documentation.

* libguile/programs.c (scm_i_rtl_program_documentation):
* libguile/programs.h:
* module/system/vm/program.scm (rtl-program-documentation): New
  plumbing.

* module/system/vm/debug.scm (find-program-docstring): New interface to
  grovel ELF for a docstring.
---
 libguile/procprop.c          |   33 +++++++++++++++++++++++++++++++++
 libguile/procprop.h          |    2 ++
 libguile/procs.c             |   15 ---------------
 libguile/procs.h             |    5 +----
 libguile/programs.c          |   13 +++++++++++++
 libguile/programs.h          |    1 +
 module/system/vm/debug.scm   |   34 +++++++++++++++++++++++++++++++++-
 module/system/vm/program.scm |    6 ++++++
 test-suite/tests/rtl.test    |   11 +++++++++++
 9 files changed, 100 insertions(+), 20 deletions(-)

diff --git a/libguile/procprop.c b/libguile/procprop.c
index 62476c0..d7ce09b 100644
--- a/libguile/procprop.c
+++ b/libguile/procprop.c
@@ -238,6 +238,39 @@ SCM_DEFINE (scm_procedure_name, "procedure-name", 1, 0, 0,
 #undef FUNC_NAME
 
 
+SCM_GLOBAL_SYMBOL (scm_sym_documentation, "documentation");
+
+SCM_DEFINE (scm_procedure_documentation, "procedure-documentation", 1, 0, 0,
+           (SCM proc),
+	    "Return the documentation string associated with @code{proc}.  By\n"
+	    "convention, if a procedure contains more than one expression and the\n"
+	    "first expression is a string constant, that string is assumed to contain\n"
+	    "documentation for that procedure.")
+#define FUNC_NAME s_scm_procedure_documentation
+{
+  SCM props, ret;
+
+  SCM_VALIDATE_PROC (1, proc);
+
+  while (SCM_STRUCTP (proc) && SCM_STRUCT_APPLICABLE_P (proc))
+    proc = SCM_STRUCT_PROCEDURE (proc);
+
+  props = scm_weak_table_refq (overrides, proc, SCM_BOOL_F);
+
+  if (scm_is_pair (props))
+    ret = scm_assq_ref (props, scm_sym_documentation);
+  else if (SCM_RTL_PROGRAM_P (proc))
+    ret = scm_i_rtl_program_documentation (proc);
+  else if (SCM_PROGRAM_P (proc))
+    ret = scm_assq_ref (scm_i_program_properties (proc), scm_sym_documentation);
+  else
+    ret = SCM_BOOL_F;
+
+  return ret;
+}
+#undef FUNC_NAME
+
+
 SCM_DEFINE (scm_procedure_source, "procedure-source", 1, 0, 0,
             (SCM proc),
 	    "Return the source of the procedure @var{proc}.")
diff --git a/libguile/procprop.h b/libguile/procprop.h
index 13fbe46..41d0753 100644
--- a/libguile/procprop.h
+++ b/libguile/procprop.h
@@ -29,6 +29,7 @@
 
 SCM_API SCM scm_sym_name;
 SCM_API SCM scm_sym_system_procedure;
+SCM_INTERNAL SCM scm_sym_documentation;
 
 \f
 
@@ -42,6 +43,7 @@ SCM_API SCM scm_procedure_property (SCM proc, SCM key);
 SCM_API SCM scm_set_procedure_property_x (SCM proc, SCM key, SCM val);
 SCM_API SCM scm_procedure_source (SCM proc);
 SCM_API SCM scm_procedure_name (SCM proc);
+SCM_API SCM scm_procedure_documentation (SCM proc);
 SCM_INTERNAL void scm_init_procprop (void);
 
 #endif  /* SCM_PROCPROP_H */
diff --git a/libguile/procs.c b/libguile/procs.c
index bda6d34..8d9ef15 100644
--- a/libguile/procs.c
+++ b/libguile/procs.c
@@ -66,21 +66,6 @@ SCM_DEFINE (scm_thunk_p, "thunk?", 1, 0, 0,
 }
 #undef FUNC_NAME
 
-SCM_GLOBAL_SYMBOL (scm_sym_documentation, "documentation");
-
-SCM_DEFINE (scm_procedure_documentation, "procedure-documentation", 1, 0, 0, 
-           (SCM proc),
-	    "Return the documentation string associated with @code{proc}.  By\n"
-	    "convention, if a procedure contains more than one expression and the\n"
-	    "first expression is a string constant, that string is assumed to contain\n"
-	    "documentation for that procedure.")
-#define FUNC_NAME s_scm_procedure_documentation
-{
-  SCM_VALIDATE_PROC (SCM_ARG1, proc);
-  return scm_procedure_property (proc, scm_sym_documentation);
-}
-#undef FUNC_NAME
-
 
 /* Procedure-with-setter
  */
diff --git a/libguile/procs.h b/libguile/procs.h
index a35872e..c4c78f2 100644
--- a/libguile/procs.h
+++ b/libguile/procs.h
@@ -4,7 +4,7 @@
 #define SCM_PROCS_H
 
 /* Copyright (C) 1995, 1996, 1998, 1999, 2000, 2001, 2006, 2008, 2009,
- *   2012 Free Software Foundation, Inc.
+ *   2012, 2013 Free Software Foundation, Inc.
  *
  * This library is free software; you can redistribute it and/or
  * modify it under the terms of the GNU Lesser General Public License
@@ -30,15 +30,12 @@
 
 SCM_API SCM scm_procedure_p (SCM obj);
 SCM_API SCM scm_thunk_p (SCM obj);
-SCM_API SCM scm_procedure_documentation (SCM proc);
 SCM_API SCM scm_procedure_with_setter_p (SCM obj);
 SCM_API SCM scm_make_procedure_with_setter (SCM procedure, SCM setter);
 SCM_API SCM scm_procedure (SCM proc);
 SCM_API SCM scm_setter (SCM proc);
 SCM_INTERNAL void scm_init_procs (void);
 
-SCM_INTERNAL SCM scm_sym_documentation;
-
 #endif  /* SCM_PROCS_H */
 
 /*
diff --git a/libguile/programs.c b/libguile/programs.c
index 12561b3..567708a 100644
--- a/libguile/programs.c
+++ b/libguile/programs.c
@@ -123,6 +123,19 @@ scm_i_rtl_program_name (SCM program)
   return scm_call_1 (scm_variable_ref (rtl_program_name), program);
 }
 
+SCM
+scm_i_rtl_program_documentation (SCM program)
+{
+  static SCM rtl_program_documentation = SCM_BOOL_F;
+
+  if (scm_is_false (rtl_program_documentation) && scm_module_system_booted_p)
+    rtl_program_documentation =
+      scm_c_private_variable ("system vm program",
+                              "rtl-program-documentation");
+
+  return scm_call_1 (scm_variable_ref (rtl_program_documentation), program);
+}
+
 void
 scm_i_program_print (SCM program, SCM port, scm_print_state *pstate)
 {
diff --git a/libguile/programs.h b/libguile/programs.h
index fa46135..175059f 100644
--- a/libguile/programs.h
+++ b/libguile/programs.h
@@ -45,6 +45,7 @@ SCM_INTERNAL SCM scm_rtl_program_p (SCM obj);
 SCM_INTERNAL SCM scm_rtl_program_code (SCM program);
 
 SCM_INTERNAL SCM scm_i_rtl_program_name (SCM program);
+SCM_INTERNAL SCM scm_i_rtl_program_documentation (SCM program);
 
 /*
  * Programs
diff --git a/module/system/vm/debug.scm b/module/system/vm/debug.scm
index 81e2250..c8c2cdd 100644
--- a/module/system/vm/debug.scm
+++ b/module/system/vm/debug.scm
@@ -50,7 +50,9 @@
             find-program-debug-info
             arity-arguments-alist
             find-program-arities
-            program-minimum-arity))
+            program-minimum-arity
+
+            find-program-docstring))
 
 (define-record-type <debug-context>
   (make-debug-context elf base text-base)
@@ -308,3 +310,33 @@
            (list (arity-nreq first)
                  (arity-nopt first)
                  (arity-has-rest? first)))))))
+
+(define* (find-program-docstring addr #:optional
+                                 (context (find-debug-context addr)))
+  (and=>
+   (elf-section-by-name (debug-context-elf context) ".guile.docstrs")
+   (lambda (sec)
+     ;; struct docstr {
+     ;;   uint32_t pc;
+     ;;   uint32_t str;
+     ;; }
+     (define docstr-len 8)
+     (let* ((start (elf-section-offset sec))
+            (end (+ start (elf-section-size sec)))
+            (bv (elf-bytes (debug-context-elf context)))
+            (text-offset (- addr
+                            (debug-context-text-base context)
+                            (debug-context-base context))))
+       ;; FIXME: This is linear search.  Change to binary search.
+       (let lp ((pos start))
+         (cond
+          ((>= pos end) #f)
+          ((< text-offset (bytevector-u32-native-ref bv pos))
+           (lp (+ pos arity-header-len)))
+          ((> text-offset (bytevector-u32-native-ref bv pos))
+           #f)
+          (else
+           (let ((strtab (elf-section (debug-context-elf context)
+                                      (elf-section-link sec)))
+                 (idx (bytevector-u32-native-ref bv (+ pos 4))))
+             (string-table-ref bv (+ (elf-section-offset strtab) idx))))))))))
diff --git a/module/system/vm/program.scm b/module/system/vm/program.scm
index a4bd64e..d719e95 100644
--- a/module/system/vm/program.scm
+++ b/module/system/vm/program.scm
@@ -62,6 +62,12 @@
          program-debug-info-name))
 
 ;; This procedure is called by programs.c.
+(define (rtl-program-documentation program)
+  (unless (rtl-program? program)
+    (error "shouldn't get here"))
+  (find-program-docstring (rtl-program-code program)))
+
+;; This procedure is called by programs.c.
 (define (rtl-program-minimum-arity program)
   (unless (rtl-program? program)
     (error "shouldn't get here"))
diff --git a/test-suite/tests/rtl.test b/test-suite/tests/rtl.test
index c50aae9..8fcdb63 100644
--- a/test-suite/tests/rtl.test
+++ b/test-suite/tests/rtl.test
@@ -346,3 +346,14 @@
           (return 0)
           (end-arity)
           (end-program))))))
+
+(with-test-prefix "procedure docstrings"
+  (pass-if-equal "qux qux"
+      (procedure-documentation
+       (assemble-program
+        '((begin-program foo ((name . foo) (documentation . "qux qux")))
+          (begin-standard-arity () 1 #f)
+          (load-constant 0 42)
+          (return 0)
+          (end-arity)
+          (end-program))))))
-- 
1.7.10.4