From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: (qmail 6803 invoked by alias); 20 Jan 2014 21:54:05 -0000 Mailing-List: contact gdb-patches-help@sourceware.org; run by ezmlm Precedence: bulk List-Id: List-Subscribe: List-Archive: List-Post: List-Help: , Sender: gdb-patches-owner@sourceware.org Received: (qmail 6718 invoked by uid 89); 20 Jan 2014 21:54:04 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-1.8 required=5.0 tests=AWL,BAYES_00,FREEMAIL_ENVFROM_END_DIGIT,FREEMAIL_FROM,MSGID_FROM_MTA_HEADER,RCVD_IN_DNSWL_LOW,SPF_PASS autolearn=ham version=3.3.2 X-HELO: mail-pa0-f46.google.com Received: from mail-pa0-f46.google.com (HELO mail-pa0-f46.google.com) (209.85.220.46) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with (AES128-SHA encrypted) ESMTPS; Mon, 20 Jan 2014 21:54:01 +0000 Received: by mail-pa0-f46.google.com with SMTP id rd3so7448567pab.5 for ; Mon, 20 Jan 2014 13:53:59 -0800 (PST) X-Received: by 10.66.164.70 with SMTP id yo6mr21126769pab.85.1390254839215; Mon, 20 Jan 2014 13:53:59 -0800 (PST) Received: from sspiff.org (173-13-178-53-sfba.hfc.comcastbusiness.net. [173.13.178.53]) by mx.google.com with ESMTPSA id zc6sm11792467pab.18.2014.01.20.13.53.56 for (version=TLSv1.2 cipher=ECDHE-RSA-AES128-GCM-SHA256 bits=128/128); Mon, 20 Jan 2014 13:53:58 -0800 (PST) Message-ID: <52dd9af6.06a6420a.6df5.01c1@mx.google.com> Received: by sspiff.org (sSMTP sendmail emulation); Mon, 20 Jan 2014 13:53:33 -0800 Date: Mon, 20 Jan 2014 21:54:00 -0000 From: Doug Evans To: gdb-patches@sourceware.org Subject: [PATCH v2 25/36] Guile extension language: scm-objfile.c X-IsSubscribed: yes X-SW-Source: 2014-01/txt/msg00784.txt.bz2 This patch adds the interface to objfiles. 2014-01-20 Doug Evans * guile/scm-objfile.c: New file. testsuite/ * gdb.guile/scm-objfile-script-gdb.in: New file. * gdb.guile/scm-objfile-script.c: New file. * gdb.guile/scm-objfile-script.exp: New file. * gdb.guile/scm-objfile.c: New file. * gdb.guile/scm-objfile.exp: New file. diff --git a/gdb/guile/scm-objfile.c b/gdb/guile/scm-objfile.c new file mode 100644 index 0000000..9a20dc7 --- /dev/null +++ b/gdb/guile/scm-objfile.c @@ -0,0 +1,413 @@ +/* Scheme interface to objfiles. + + Copyright (C) 2008-2014 Free Software Foundation, Inc. + + This file is part of GDB. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . */ + +/* See README file in this directory for implementation notes, coding + conventions, et.al. */ + +#include "defs.h" +#include "objfiles.h" +#include "language.h" +#include "guile-internal.h" + +/* The smob. + The typedef for this struct is in guile-internal.h. */ + +struct _objfile_smob +{ + /* This always appears first. */ + gdb_smob base; + + /* The corresponding objfile. */ + struct objfile *objfile; + + /* The pretty-printer list of functions. */ + SCM pretty_printers; + + /* The object we are contained in, needed to protect/unprotect + the object since a reference to it comes from non-gc-managed space + (the objfile). */ + SCM containing_scm; +}; + +static const char objfile_smob_name[] = "gdb:objfile"; + +/* The tag Guile knows the objfile smob by. */ +static scm_t_bits objfile_smob_tag; + +static const struct objfile_data *ofscm_objfile_data_key; + +/* Return the list of pretty-printers registered with O_SMOB. */ + +SCM +ofscm_objfile_smob_pretty_printers (objfile_smob *o_smob) +{ + return o_smob->pretty_printers; +} + +/* Administrivia for objfile smobs. */ + +/* The smob "mark" function for . */ + +static SCM +ofscm_mark_objfile_smob (SCM self) +{ + objfile_smob *o_smob = (objfile_smob *) SCM_SMOB_DATA (self); + + scm_gc_mark (o_smob->pretty_printers); + + /* We don't mark containing_scm here. It is just a backlink to our + container, and is gc'protected until the objfile is deleted. */ + + /* Do this last. */ + return gdbscm_mark_gsmob (&o_smob->base); +} + +/* The smob "print" function for . */ + +static int +ofscm_print_objfile_smob (SCM self, SCM port, scm_print_state *pstate) +{ + objfile_smob *o_smob = (objfile_smob *) SCM_SMOB_DATA (self); + + gdbscm_printf (port, "#<%s ", objfile_smob_name); + gdbscm_printf (port, "%s", + o_smob->objfile != NULL + ? objfile_name (o_smob->objfile) + : "{invalid}"); + scm_puts (">", port); + + scm_remember_upto_here_1 (self); + + /* Non-zero means success. */ + return 1; +} + +/* Low level routine to create a object. + It's empty in the sense that an OBJFILE still needs to be associated + with it. */ + +static SCM +ofscm_make_objfile_smob (void) +{ + objfile_smob *o_smob = (objfile_smob *) + scm_gc_malloc (sizeof (objfile_smob), objfile_smob_name); + SCM o_scm; + + o_smob->objfile = NULL; + o_smob->pretty_printers = SCM_EOL; + o_scm = scm_new_smob (objfile_smob_tag, (scm_t_bits) o_smob); + o_smob->containing_scm = o_scm; + gdbscm_init_gsmob (&o_smob->base); + + return o_scm; +} + +/* Clear the OBJFILE pointer in O_SMOB and unprotect the object from GC. */ + +static void +ofscm_release_objfile (objfile_smob *o_smob) +{ + o_smob->objfile = NULL; + scm_gc_unprotect_object (o_smob->containing_scm); +} + +/* Objfile registry cleanup handler for when an objfile is deleted. */ + +static void +ofscm_handle_objfile_deleted (struct objfile *objfile, void *datum) +{ + objfile_smob *o_smob = datum; + + gdb_assert (o_smob->objfile == objfile); + + ofscm_release_objfile (o_smob); +} + +/* Return non-zero if SCM is a object. */ + +static int +ofscm_is_objfile (SCM scm) +{ + return SCM_SMOB_PREDICATE (objfile_smob_tag, scm); +} + +/* (objfile? object) -> boolean */ + +static SCM +gdbscm_objfile_p (SCM scm) +{ + return scm_from_bool (ofscm_is_objfile (scm)); +} + +/* Return a pointer to the objfile_smob that encapsulates OBJFILE, + creating one if necessary. + The result is cached so that we have only one copy per objfile. */ + +objfile_smob * +ofscm_objfile_smob_from_objfile (struct objfile *objfile) +{ + objfile_smob *o_smob; + + o_smob = objfile_data (objfile, ofscm_objfile_data_key); + if (o_smob == NULL) + { + SCM o_scm = ofscm_make_objfile_smob (); + + o_smob = (objfile_smob *) SCM_SMOB_DATA (o_scm); + o_smob->objfile = objfile; + + set_objfile_data (objfile, ofscm_objfile_data_key, o_smob); + scm_gc_protect_object (o_smob->containing_scm); + } + + return o_smob; +} + +/* Return the object that encapsulates OBJFILE. */ + +SCM +ofscm_scm_from_objfile (struct objfile *objfile) +{ + objfile_smob *o_smob = ofscm_objfile_smob_from_objfile (objfile); + + return o_smob->containing_scm; +} + +/* Returns the object in SELF. + Throws an exception if SELF is not a object. */ + +static SCM +ofscm_get_objfile_arg_unsafe (SCM self, int arg_pos, const char *func_name) +{ + SCM_ASSERT_TYPE (ofscm_is_objfile (self), self, arg_pos, func_name, + objfile_smob_name); + + return self; +} + +/* Returns a pointer to the objfile smob of SELF. + Throws an exception if SELF is not a object. */ + +static objfile_smob * +ofscm_get_objfile_smob_arg_unsafe (SCM self, int arg_pos, + const char *func_name) +{ + SCM o_scm = ofscm_get_objfile_arg_unsafe (self, arg_pos, func_name); + objfile_smob *o_smob = (objfile_smob *) SCM_SMOB_DATA (o_scm); + + return o_smob; +} + +/* Return non-zero if objfile O_SMOB is valid. */ + +static int +ofscm_is_valid (objfile_smob *o_smob) +{ + return o_smob->objfile != NULL; +} + +/* Return the objfile smob in SELF, verifying it's valid. + Throws an exception if SELF is not a object or is invalid. */ + +static objfile_smob * +ofscm_get_valid_objfile_smob_arg_unsafe (SCM self, int arg_pos, + const char *func_name) +{ + objfile_smob *o_smob + = ofscm_get_objfile_smob_arg_unsafe (self, arg_pos, func_name); + + if (!ofscm_is_valid (o_smob)) + { + gdbscm_invalid_object_error (func_name, arg_pos, self, + _("")); + } + + return o_smob; +} + +/* Objfile methods. */ + +/* (objfile-valid? ) -> boolean + Returns #t if this object file still exists in GDB. */ + +static SCM +gdbscm_objfile_valid_p (SCM self) +{ + objfile_smob *o_smob + = ofscm_get_objfile_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME); + + return scm_from_bool (o_smob->objfile != NULL); +} + +/* (objfile-filename ) -> string + Returns the objfile's file name. + Throw's an exception if the underlying objfile is invalid. */ + +static SCM +gdbscm_objfile_filename (SCM self) +{ + objfile_smob *o_smob + = ofscm_get_valid_objfile_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME); + + return gdbscm_scm_from_c_string (objfile_name (o_smob->objfile)); +} + +/* (objfile-pretty-printers ) -> list + Returns the list of pretty-printers for this objfile. */ + +static SCM +gdbscm_objfile_pretty_printers (SCM self) +{ + objfile_smob *o_smob + = ofscm_get_objfile_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME); + + return o_smob->pretty_printers; +} + +/* (set-objfile-pretty-printers! list) -> unspecified + Set the pretty-printers for this objfile. */ + +static SCM +gdbscm_set_objfile_pretty_printers_x (SCM self, SCM printers) +{ + objfile_smob *o_smob + = ofscm_get_objfile_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME); + + SCM_ASSERT_TYPE (gdbscm_is_true (scm_list_p (printers)), printers, + SCM_ARG2, FUNC_NAME, _("list")); + + o_smob->pretty_printers = printers; + + return SCM_UNSPECIFIED; +} + +/* The "current" objfile. This is set when gdb detects that a new + objfile has been loaded. It is only set for the duration of a call to + gdbscm_source_objfile_script; it is NULL at other times. */ +static struct objfile *ofscm_current_objfile; + +/* Set the current objfile to OBJFILE and then read FILE named FILENAME + as Guile code. This does not throw any errors. If an exception + occurs Guile will print the backtrace. + This is the extension_language_script_ops.objfile_script_sourcer + "method". */ + +void +gdbscm_source_objfile_script (const struct extension_language_defn *extlang, + struct objfile *objfile, FILE *file, + const char *filename) +{ + char *msg; + + ofscm_current_objfile = objfile; + + msg = gdbscm_safe_source_script (filename); + if (msg != NULL) + { + fprintf_filtered (gdb_stderr, "%s", msg); + xfree (msg); + } + + ofscm_current_objfile = NULL; +} + +/* (current-objfile) -> + Return the current objfile, or #f if there isn't one. + Ideally this would be named ofscm_current_objfile, but that name is + taken by the variable recording the current objfile. */ + +static SCM +gdbscm_get_current_objfile (void) +{ + if (ofscm_current_objfile == NULL) + return SCM_BOOL_F; + + return ofscm_scm_from_objfile (ofscm_current_objfile); +} + +/* (objfiles) -> list + Return a list of all objfiles in the current program space. */ + +static SCM +gdbscm_objfiles (void) +{ + struct objfile *objf; + SCM result; + + result = SCM_EOL; + + ALL_OBJFILES (objf) + { + SCM item = ofscm_scm_from_objfile (objf); + + result = scm_cons (item, result); + } + + return scm_reverse_x (result, SCM_EOL); +} + +/* Initialize the Scheme objfile support. */ + +static const scheme_function objfile_functions[] = +{ + { "objfile?", 1, 0, 0, gdbscm_objfile_p, + "\ +Return #t if the object is a object." }, + + { "objfile-valid?", 1, 0, 0, gdbscm_objfile_valid_p, + "\ +Return #t if the objfile is valid (hasn't been deleted from gdb)." }, + + { "objfile-filename", 1, 0, 0, gdbscm_objfile_filename, + "\ +Return the file name of the objfile." }, + + { "objfile-pretty-printers", 1, 0, 0, gdbscm_objfile_pretty_printers, + "\ +Return a list of pretty-printers of the objfile." }, + + { "set-objfile-pretty-printers!", 2, 0, 0, + gdbscm_set_objfile_pretty_printers_x, + "\ +Set the list of pretty-printers of the objfile." }, + + { "current-objfile", 0, 0, 0, gdbscm_get_current_objfile, + "\ +Return the current objfile if there is one or #f if there isn't one." }, + + { "objfiles", 0, 0, 0, gdbscm_objfiles, + "\ +Return a list of all objfiles in the current program space." }, + + END_FUNCTIONS +}; + +void +gdbscm_initialize_objfiles (void) +{ + objfile_smob_tag + = gdbscm_make_smob_type (objfile_smob_name, sizeof (objfile_smob)); + scm_set_smob_mark (objfile_smob_tag, ofscm_mark_objfile_smob); + scm_set_smob_print (objfile_smob_tag, ofscm_print_objfile_smob); + + gdbscm_define_functions (objfile_functions, 1); + + ofscm_objfile_data_key + = register_objfile_data_with_cleanup (NULL, ofscm_handle_objfile_deleted); +} diff --git a/gdb/testsuite/gdb.guile/scm-objfile-script-gdb.in b/gdb/testsuite/gdb.guile/scm-objfile-script-gdb.in new file mode 100644 index 0000000..e576721 --- /dev/null +++ b/gdb/testsuite/gdb.guile/scm-objfile-script-gdb.in @@ -0,0 +1,55 @@ +;; Copyright (C) 2011-2014 Free Software Foundation, Inc. +;; +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;; This file is part of the GDB testsuite. + +(use-modules (gdb) (gdb printing)) + +(define (make-pp_ss-printer val) + (make-pretty-printer-worker + #f + (lambda (printer) + (let ((a (value-field val "a")) + (b (value-field val "b"))) + (format #f "a=<~A> b=<~A>" a b))) + #f)) + +(define (get-type-for-printing val) + "Return type of val, stripping away typedefs, etc." + (let ((type (value-type val))) + (if (= (type-code type) TYPE_CODE_REF) + (set! type (type-target type))) + (type-strip-typedefs (type-unqualified type)))) + +(define (make-pretty-printer-dict) + (let ((dict (make-hash-table))) + (hash-set! dict "struct ss" make-pp_ss-printer) + (hash-set! dict "ss" make-pp_ss-printer) + dict)) + +(define *pretty-printer* + (make-pretty-printer + "pretty-printer-test" + (let ((pretty-printers-dict (make-pretty-printer-dict))) + (lambda (matcher val) + "Look-up and return a pretty-printer that can print val." + (let ((type (get-type-for-printing val))) + (let ((typename (type-tag type))) + (if typename + (let ((printer-maker (hash-ref pretty-printers-dict typename))) + (and printer-maker (printer-maker val))) + #f))))))) + +(append-pretty-printer! #f *pretty-printer*) diff --git a/gdb/testsuite/gdb.guile/scm-objfile-script.c b/gdb/testsuite/gdb.guile/scm-objfile-script.c new file mode 100644 index 0000000..10f4776 --- /dev/null +++ b/gdb/testsuite/gdb.guile/scm-objfile-script.c @@ -0,0 +1,39 @@ +/* This testcase is part of GDB, the GNU debugger. + + Copyright 2011-2014 Free Software Foundation, Inc. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . */ + +struct ss +{ + int a; + int b; +}; + +void +init_ss (struct ss *s, int a, int b) +{ + s->a = a; + s->b = b; +} + +int +main () +{ + struct ss ss; + + init_ss (&ss, 1, 2); + + return 0; /* break to inspect struct and union */ +} diff --git a/gdb/testsuite/gdb.guile/scm-objfile-script.exp b/gdb/testsuite/gdb.guile/scm-objfile-script.exp new file mode 100644 index 0000000..65d0c44 --- /dev/null +++ b/gdb/testsuite/gdb.guile/scm-objfile-script.exp @@ -0,0 +1,57 @@ +# Copyright (C) 2011-2014 Free Software Foundation, Inc. + +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . + +# This file is part of the GDB testsuite. +# It tests automagic loading of -gdb.scm scripts. + +load_lib gdb-guile.exp + +standard_testfile + +if {[build_executable $testfile.exp $testfile $srcfile debug] == -1} { + return +} + +# Start with a fresh gdb. +gdb_exit +gdb_start + +# Skip all tests if Guile scripting is not enabled. +if { [skip_guile_tests] } { continue } + +# Make the -gdb.scm script available to gdb, it is automagically loaded by gdb. +# Care is taken to put it in the same directory as the binary so that +# gdb will find it. +set remote_guile_file [remote_download host \ + ${srcdir}/${subdir}/${testfile}-gdb.in \ + [standard_output_file ${testfile}-gdb.scm]] + +gdb_reinitialize_dir $srcdir/$subdir +gdb_test_no_output "set auto-load safe-path ${remote_guile_file}" \ + "set auto-load safe-path" +gdb_load ${binfile} + +# Verify gdb loaded the script. +gdb_test "info auto-load guile-scripts" "Yes.*/${testfile}-gdb.scm.*" + +if ![gdb_guile_runto_main] { + return +} + +gdb_test "b [gdb_get_line_number {break to inspect} ${testfile}.c ]" \ + ".*Breakpoint.*" +gdb_test "continue" ".*Breakpoint.*" + +gdb_test "print ss" " = a=<1> b=<2>" diff --git a/gdb/testsuite/gdb.guile/scm-objfile.c b/gdb/testsuite/gdb.guile/scm-objfile.c new file mode 100644 index 0000000..dbdc9b3 --- /dev/null +++ b/gdb/testsuite/gdb.guile/scm-objfile.c @@ -0,0 +1,23 @@ +/* This testcase is part of GDB, the GNU debugger. + + Copyright 2011-2014 Free Software Foundation, Inc. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . */ + +int +main () +{ + int some_var = 0; + return 0; +} diff --git a/gdb/testsuite/gdb.guile/scm-objfile.exp b/gdb/testsuite/gdb.guile/scm-objfile.exp new file mode 100644 index 0000000..70da488 --- /dev/null +++ b/gdb/testsuite/gdb.guile/scm-objfile.exp @@ -0,0 +1,57 @@ +# Copyright (C) 2011-2014 Free Software Foundation, Inc. + +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . + +# This file is part of the GDB testsuite. +# It tests the objfile support in Guile. + +load_lib gdb-guile.exp + +standard_testfile + +if { [prepare_for_testing ${testfile}.exp ${testfile} ${srcfile}] } { + return +} + +# Skip all tests if Guile scripting is not enabled. +if { [skip_guile_tests] } { continue } + +if ![gdb_guile_runto_main] { + fail "Can't run to main" + return +} + +gdb_scm_test_silent_cmd "gu (define sym (lookup-symbol \"some_var\"))" \ + "Find a symbol in objfile" +gdb_scm_test_silent_cmd "gu (define objfile (symtab-objfile (symbol-symtab (car sym))))" \ + "Get backing object file" + +gdb_test "gu (print (objfile-filename objfile))" \ + ".*scm-objfile.*" "Get objfile filename" +gdb_test "gu (print (objfile-valid? objfile))" \ + "#t" "Get objfile validity" + +gdb_test "gu (print (->bool (or-map (lambda (o) (string-contains (objfile-filename o) \"scm-objfile\")) (objfiles))))" \ + "= #t" "scm-objfile in objfile list" + +gdb_test "gu (print (objfile-pretty-printers objfile))" \ + "= \\(\\)" + +gdb_test "guile (set-objfile-pretty-printers! objfile 0)" \ + "ERROR: .*: Wrong type argument in position 2 \\(expecting list\\): 0.*" + +# Do this last. +gdb_unload +gdb_test "gu (print (objfile-valid? objfile))" \ + "#f" "Get objfile validity after unload"