From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!not-for-mail From: Andy Wingo Newsgroups: gmane.lisp.guile.devel Subject: [PATCH 8/9] procedure-documentation works on RTL procedures Date: Tue, 4 Jun 2013 16:44:09 +0200 Message-ID: <1370357050-26337-9-git-send-email-wingo@pobox.com> References: <1370357050-26337-1-git-send-email-wingo@pobox.com> NNTP-Posting-Host: plane.gmane.org X-Trace: ger.gmane.org 1370357140 4178 80.91.229.3 (4 Jun 2013 14:45:40 GMT) X-Complaints-To: usenet@ger.gmane.org NNTP-Posting-Date: Tue, 4 Jun 2013 14:45:40 +0000 (UTC) Cc: Andy Wingo To: guile-devel@gnu.org Original-X-From: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Tue Jun 04 16:45:41 2013 Return-path: Envelope-to: guile-devel@m.gmane.org Original-Received: from lists.gnu.org ([208.118.235.17]) by plane.gmane.org with esmtp (Exim 4.69) (envelope-from ) id 1UjsUX-0001Pd-7M for guile-devel@m.gmane.org; Tue, 04 Jun 2013 16:45:41 +0200 Original-Received: from localhost ([::1]:52870 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1UjsUW-0007UT-OH for guile-devel@m.gmane.org; Tue, 04 Jun 2013 10:45:40 -0400 Original-Received: from eggs.gnu.org ([2001:4830:134:3::10]:55375) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1UjsU1-00071a-5s for guile-devel@gnu.org; Tue, 04 Jun 2013 10:45:36 -0400 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1UjsTq-00020T-Cl for guile-devel@gnu.org; Tue, 04 Jun 2013 10:45:09 -0400 Original-Received: from a-pb-sasl-quonix.pobox.com ([208.72.237.25]:59018 helo=sasl.smtp.pobox.com) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1UjsTq-000209-6f for guile-devel@gnu.org; Tue, 04 Jun 2013 10:44:58 -0400 Original-Received: from sasl.smtp.pobox.com (unknown [127.0.0.1]) by a-pb-sasl-quonix.pobox.com (Postfix) with ESMTP id D9E53C82F; Tue, 4 Jun 2013 10:44:57 -0400 (EDT) DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=pobox.com; h=from:to:cc :subject:date:message-id:in-reply-to:references; s=sasl; bh=S9Af JukUnsQyWrXkbDvNRgRufl8=; b=xH17gtPxNsdxWXnDYfeWhgRcS3TTUzUGK9X5 TEQpAeqiklTgEoChs/GwIMYoTbYFCBmk8gswrXre7L1ixyUnCBh4RviY6qZve8tm l/k5CoeMp9DxBAPYLho2Ea1y7lzQzOSUN71ox1L3DcsO3wo+2a6VO36N78LyDo/d ewLypq0= DomainKey-Signature: a=rsa-sha1; c=nofws; d=pobox.com; h=from:to:cc :subject:date:message-id:in-reply-to:references; q=dns; s=sasl; b= omhsZBrcSQjuqQ5H+s4XFoXdpQOZwcAFzSfivSbLJVjcseTg3S4M6VhHp/MAidun qnInVqouvsddoofczKXVphyC7AoNyqvBQ5X/tmSPz3+omxJOMI/+AVj91pdISyZp k+/n9T/Yt7RMLACf/s5+HVpncXuemPWDoxJxEms69bk= Original-Received: from a-pb-sasl-quonix.pobox.com (unknown [127.0.0.1]) by a-pb-sasl-quonix.pobox.com (Postfix) with ESMTP id D007EC82E; Tue, 4 Jun 2013 10:44:57 -0400 (EDT) Original-Received: from localhost.localdomain (unknown [88.5.174.195]) (using TLSv1 with cipher DHE-RSA-AES256-SHA (256/256 bits)) (No client certificate requested) by a-pb-sasl-quonix.pobox.com (Postfix) with ESMTPSA id 7C244C82C; Tue, 4 Jun 2013 10:44:55 -0400 (EDT) X-Mailer: git-send-email 1.7.10.4 In-Reply-To: <1370357050-26337-1-git-send-email-wingo@pobox.com> X-Pobox-Relay-ID: 53395204-CD25-11E2-A676-9F710E5B5709-02397024!a-pb-sasl-quonix.pobox.com X-detected-operating-system: by eggs.gnu.org: Solaris 10 X-Received-From: 208.72.237.25 X-BeenThere: guile-devel@gnu.org X-Mailman-Version: 2.1.14 Precedence: list List-Id: "Developers list for Guile, the GNU extensibility library" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Original-Sender: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Xref: news.gmane.org gmane.lisp.guile.devel:16465 Archived-At: * 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; @@ -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 (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