diff options
author | Andy Wingo <wingo@pobox.com> | 2013-05-16 23:38:29 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2013-06-09 23:59:01 +0200 |
commit | bf8328ec16cbe76b7af9703bb41e964865034561 (patch) | |
tree | 53957dcaa2955689353c2cab6c8435b190fb1978 | |
parent | 9128b1a19fe89de1aacafe5ccffd06e193f531bc (diff) | |
download | guile-bf8328ec16cbe76b7af9703bb41e964865034561.tar.gz |
procedure-documentation works on RTL procedures
* 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.
-rw-r--r-- | libguile/procprop.c | 33 | ||||
-rw-r--r-- | libguile/procprop.h | 2 | ||||
-rw-r--r-- | libguile/procs.c | 15 | ||||
-rw-r--r-- | libguile/procs.h | 5 | ||||
-rw-r--r-- | libguile/programs.c | 13 | ||||
-rw-r--r-- | libguile/programs.h | 1 | ||||
-rw-r--r-- | module/system/vm/debug.scm | 34 | ||||
-rw-r--r-- | module/system/vm/program.scm | 6 | ||||
-rw-r--r-- | test-suite/tests/rtl.test | 11 |
9 files changed, 100 insertions, 20 deletions
diff --git a/libguile/procprop.c b/libguile/procprop.c index 62476c037..d7ce09b95 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 13fbe46e8..41d0753e3 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; @@ -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 bda6d3448..8d9ef15b4 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 a35872e3d..c4c78f23e 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 12561b30d..567708a51 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 fa4613571..175059fbc 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 5196ecae1..cee0892c7 100644 --- a/module/system/vm/debug.scm +++ b/module/system/vm/debug.scm @@ -56,7 +56,9 @@ find-program-debug-info arity-arguments-alist find-program-arities - program-minimum-arity)) + program-minimum-arity + + find-program-docstring)) ;;; A compiled procedure comes from a specific loaded ELF image. A ;;; debug context identifies that image. @@ -332,3 +334,33 @@ section of the ELF image. Returns an ELF symbol, or @code{#f}." (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 docstr-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 a4bd64e28..d719e954c 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 c50aae966..8fcdb6373 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)))))) |