From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: (qmail 30789 invoked by alias); 24 Dec 2013 19:04:15 -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 30744 invoked by uid 89); 24 Dec 2013 19:04:15 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-0.6 required=5.0 tests=AWL,BAYES_00,FREEMAIL_ENVFROM_END_DIGIT,FREEMAIL_FROM,KAM_STOCKGEN,MSGID_FROM_MTA_HEADER,RCVD_IN_DNSWL_NONE,SPF_PASS autolearn=no version=3.3.2 X-HELO: mail-pd0-f172.google.com Received: from mail-pd0-f172.google.com (HELO mail-pd0-f172.google.com) (209.85.192.172) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with (AES128-SHA encrypted) ESMTPS; Tue, 24 Dec 2013 19:04:10 +0000 Received: by mail-pd0-f172.google.com with SMTP id g10so6547118pdj.17 for ; Tue, 24 Dec 2013 11:04:08 -0800 (PST) X-Received: by 10.68.236.35 with SMTP id ur3mr33941456pbc.137.1387911848065; Tue, 24 Dec 2013 11:04:08 -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 wp8sm43461134pbc.26.2013.12.24.11.04.05 for (version=TLSv1.2 cipher=ECDHE-RSA-AES128-GCM-SHA256 bits=128/128); Tue, 24 Dec 2013 11:04:06 -0800 (PST) Message-ID: <52b9daa6.68f2440a.1c82.ffff951e@mx.google.com> Received: by sspiff.org (sSMTP sendmail emulation); Tue, 24 Dec 2013 11:03:41 -0800 Date: Tue, 24 Dec 2013 19:04:00 -0000 From: Doug Evans To: gdb-patches@sourceware.org Subject: [PATCH v1 22/36] Guile extension language: scm-frame.c X-IsSubscribed: yes X-SW-Source: 2013-12/txt/msg00940.txt.bz2 This patch adds the interface to inferior frames. 2013-12-24 Doug Evans * guile/scm-frame.c: New file. testsuite/ * gdb.guile/scm-frame-args.c: New file. * gdb.guile/scm-frame-args.exp: New file. * gdb.guile/scm-frame-args.scm: New file. * gdb.guile/scm-frame-inline.c: New file. * gdb.guile/scm-frame-inline.exp: New file. * gdb.guile/scm-frame.c: New file. * gdb.guile/scm-frame.exp: New file. diff --git a/gdb/guile/scm-frame.c b/gdb/guile/scm-frame.c new file mode 100644 index 0000000..a54602e --- /dev/null +++ b/gdb/guile/scm-frame.c @@ -0,0 +1,1103 @@ +/* Scheme interface to stack frames. + + Copyright (C) 2008-2013 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 "block.h" +#include "frame.h" +#include "exceptions.h" +#include "inferior.h" +#include "objfiles.h" +#include "symfile.h" +#include "symtab.h" +#include "stack.h" +#include "value.h" +#include "guile-internal.h" + +/* The smob. + The typedef for this struct is in guile-internal.h. */ + +struct _frame_smob +{ + /* This always appears first. */ + eqable_gdb_smob base; + + struct frame_id frame_id; + struct gdbarch *gdbarch; + + /* Frames are tracked by inferior. + We need some place to put the eq?-able hash table, and this feels as + good a place as any. Frames in one inferior shouldn't be considered + equal to frames in a different inferior. The frame becomes invalid if + this becomes NULL (the inferior has been deleted from gdb). + It's easier to relax restrictions than impose them after the fact. + N.B. It is an outstanding question whether a frame survives reruns of + the inferior. Intuitively the answer is "No", but currently a frame + also survives, e.g., multiple invocations of the same function from + the same point. Even different threads can have the same frame, e.g., + if a thread dies and a new thread gets the same stack. */ + struct inferior *inferior; + + /* Marks that the FRAME_ID member actually holds the ID of the frame next + to this, and not this frame's ID itself. This is a hack to permit Scheme + frame objects which represent invalid frames (i.e., the last frame_info + in a corrupt stack). The problem arises from the fact that this code + relies on FRAME_ID to uniquely identify a frame, which is not always true + for the last "frame" in a corrupt stack (it can have a null ID, or the + same ID as the previous frame). Whenever get_prev_frame returns NULL, we + record the frame_id of the next frame and set FRAME_ID_IS_NEXT to 1. */ + int frame_id_is_next; +}; + +static const char frame_smob_name[] = "gdb:frame"; + +/* The tag Guile knows the frame smob by. */ +static scm_t_bits frame_smob_tag; + +/* Keywords used in argument passing. */ +static SCM frscm_block_keyword; + +static const struct inferior_data *frscm_inferior_data_key; + +/* Administrivia for frame smobs. */ + +/* Helper function to hash a frame_smob. */ + +static hashval_t +frscm_hash_frame_smob (const void *p) +{ + const frame_smob *f_smob = p; + const struct frame_id *fid = &f_smob->frame_id; + hashval_t hash = htab_hash_pointer (f_smob->inferior); + + if (fid->stack_status == FID_STACK_VALID) + hash = iterative_hash (&fid->stack_addr, sizeof (fid->stack_addr), hash); + if (fid->code_addr_p) + hash = iterative_hash (&fid->code_addr, sizeof (fid->code_addr), hash); + if (fid->special_addr_p) + hash = iterative_hash (&fid->special_addr, sizeof (fid->special_addr), + hash); + + return hash; +} + +/* Helper function to compute equality of frame_smobs. */ + +static int +frscm_eq_frame_smob (const void *ap, const void *bp) +{ + const frame_smob *a = ap; + const frame_smob *b = bp; + + return (frame_id_eq (a->frame_id, b->frame_id) + && a->inferior == b->inferior + && a->inferior != NULL); +} + +/* Return the frame -> SCM mapping table. + It is created if necessary. */ + +static htab_t +frscm_inferior_frame_map (struct inferior *inferior) +{ + htab_t htab = inferior_data (inferior, frscm_inferior_data_key); + + if (htab == NULL) + { + htab = gdbscm_create_eqable_gsmob_ptr_map (frscm_hash_frame_smob, + frscm_eq_frame_smob); + set_inferior_data (inferior, frscm_inferior_data_key, htab); + } + + return htab; +} + +/* The smob "mark" function for . */ + +static SCM +frscm_mark_frame_smob (SCM self) +{ + frame_smob *f_smob = (frame_smob *) SCM_SMOB_DATA (self); + + /* Do this last. */ + return gdbscm_mark_eqable_gsmob (&f_smob->base); +} + +/* The smob "free" function for . */ + +static size_t +frscm_free_frame_smob (SCM self) +{ + frame_smob *f_smob = (frame_smob *) SCM_SMOB_DATA (self); + + if (f_smob->inferior != NULL) + { + htab_t htab = frscm_inferior_frame_map (f_smob->inferior); + + gdbscm_clear_eqable_gsmob_ptr_slot (htab, &f_smob->base); + } + + /* Not necessary, done to catch bugs. */ + f_smob->inferior = NULL; + + return 0; +} + +/* The smob "print" function for . */ + +static int +frscm_print_frame_smob (SCM self, SCM port, scm_print_state *pstate) +{ + frame_smob *f_smob = (frame_smob *) SCM_SMOB_DATA (self); + struct ui_file *strfile; + char *s; + + gdbscm_printf (port, "#<%s ", frame_smob_name); + + strfile = mem_fileopen (); + fprint_frame_id (strfile, f_smob->frame_id); + s = ui_file_xstrdup (strfile, NULL); + gdbscm_printf (port, "%s", s); + ui_file_delete (strfile); + xfree (s); + + scm_puts (">", port); + + scm_remember_upto_here_1 (self); + + /* Non-zero means success. */ + return 1; +} + +/* Low level routine to create a object. */ + +static SCM +frscm_make_frame_smob (void) +{ + frame_smob *f_smob = (frame_smob *) + scm_gc_malloc (sizeof (frame_smob), frame_smob_name); + SCM f_scm; + + f_smob->frame_id = null_frame_id; + f_smob->gdbarch = NULL; + f_smob->inferior = NULL; + f_smob->frame_id_is_next = 0; + f_scm = scm_new_smob (frame_smob_tag, (scm_t_bits) f_smob); + gdbscm_init_eqable_gsmob (&f_smob->base); + + return f_scm; +} + +/* Return non-zero if SCM is a object. */ + +int +frscm_is_frame (SCM scm) +{ + return SCM_SMOB_PREDICATE (frame_smob_tag, scm); +} + +/* (frame? object) -> boolean */ + +static SCM +gdbscm_frame_p (SCM scm) +{ + return scm_from_bool (frscm_is_frame (scm)); +} + +/* Create a new object that encapsulates FRAME. + Returns a object if there is an error. */ + +static SCM +frscm_gsmob_from_frame (struct frame_info *frame, struct inferior *inferior) +{ + frame_smob *f_smob; + SCM f_scm; + volatile struct gdb_exception except; + struct frame_id frame_id = null_frame_id; + struct gdbarch *gdbarch = NULL; + int frame_id_is_next = 0; + + TRY_CATCH (except, RETURN_MASK_ALL) + { + /* Try to get the previous frame, to determine if this is the last frame + in a corrupt stack. If so, we need to store the frame_id of the next + frame and not of this one (which is possibly invalid). */ + if (get_prev_frame (frame) == NULL + && get_frame_unwind_stop_reason (frame) != UNWIND_NO_REASON + && get_next_frame (frame) != NULL) + { + frame_id = get_frame_id (get_next_frame (frame)); + frame_id_is_next = 1; + } + else + { + frame_id = get_frame_id (frame); + frame_id_is_next = 0; + } + gdbarch = get_frame_arch (frame); + } + if (except.reason < 0) + return gdbscm_scm_from_gdb_exception (except); + + f_scm = frscm_make_frame_smob (); + f_smob = (frame_smob *) SCM_SMOB_DATA (f_scm); + f_smob->frame_id = frame_id; + f_smob->gdbarch = gdbarch; + f_smob->inferior = inferior; + f_smob->frame_id_is_next = frame_id_is_next; + + return f_scm; +} + +/* Create a new object that encapsulates FRAME. + The object is passed through *smob->scm*. + A Scheme exception is thrown if there is an error. */ + +static SCM +frscm_scm_from_frame_unsafe (struct frame_info *frame, + struct inferior *inferior) +{ + htab_t htab; + eqable_gdb_smob **slot; + frame_smob *f_smob, f_smob_for_lookup; + SCM f_scm, result; + + /* If we've already created a gsmob for this frame, return it. + This makes frames eq?-able. */ + htab = frscm_inferior_frame_map (inferior); + f_smob_for_lookup.frame_id = get_frame_id (frame); + f_smob_for_lookup.inferior = inferior; + slot = gdbscm_find_eqable_gsmob_ptr_slot (htab, &f_smob_for_lookup.base); + if (*slot != NULL) + return (*slot)->containing_scm; + + f_scm = frscm_gsmob_from_frame (frame, inferior); + + if (gdbscm_is_exception (f_scm)) + gdbscm_throw (f_scm); + + f_smob = (frame_smob *) SCM_SMOB_DATA (f_scm); + result = gdbscm_scm_from_gsmob_unsafe (f_scm); + gdbscm_fill_eqable_gsmob_ptr_slot (slot, &f_smob->base, result); + + return result; +} + +/* Returns the object in SCM or #f if SCM is not a + object. + Returns a object if there was a problem during the + conversion. */ + +static SCM +frscm_scm_to_frame_gsmob (SCM scm) +{ + return gdbscm_scm_to_gsmob_safe (scm, frame_smob_tag); +} + +/* Returns the object in SELF. + Throws an exception if SELF is not a object + (after passing it through *scm->smob*). */ + +static SCM +frscm_get_frame_arg_unsafe (SCM self, int arg_pos, const char *func_name) +{ + SCM f_scm = frscm_scm_to_frame_gsmob (self); + + if (gdbscm_is_exception (f_scm)) + gdbscm_throw (f_scm); + + SCM_ASSERT_TYPE (frscm_is_frame (f_scm), self, arg_pos, func_name, + frame_smob_name); + + return f_scm; +} + +/* There is no gdbscm_scm_to_frame function because translating + a frame SCM object to a struct frame_info * can throw a GDB error. + Thus code working with frames has to handle both Scheme errors (e.g., the + object is not a frame) and GDB errors (e.g., the frame lookup failed). + + To help keep things clear we split gdbscm_scm_to_frame into two: + + gdbscm_get_frame_smob_arg_unsafe + - throws a Scheme error if object is not a frame, + or if the inferior is gone or is no longer current + + gdbscm_frame_smob_to_frame + - may throw a gdb error if the conversion fails + - it's not clear when it will and won't throw a GDB error, + but for robustness' sake we assume that whenever we call out to GDB + a GDB error may get thrown (and thus the call must be wrapped in a + TRY_CATCH) */ + +/* Returns the frame_smob for the object wrapped by FRAME_SCM. + A Scheme error is thrown if FRAME_SCM is not a frame. */ + +frame_smob * +frscm_get_frame_smob_arg_unsafe (SCM self, int arg_pos, const char *func_name) +{ + SCM f_scm = frscm_get_frame_arg_unsafe (self, arg_pos, func_name); + frame_smob *f_smob = (frame_smob *) SCM_SMOB_DATA (f_scm); + + if (f_smob->inferior == NULL) + { + gdbscm_invalid_object_error (func_name, arg_pos, self, + _("inferior")); + } + if (f_smob->inferior != current_inferior ()) + scm_misc_error (func_name, _("inferior has changed"), SCM_EOL); + + return f_smob; +} + +/* Returns the frame_info object wrapped by F_SMOB. + If the frame doesn't exist anymore (the frame id doesn't + correspond to any frame in the inferior), returns NULL. + This function calls GDB routines, so don't assume a GDB error will + not be thrown. */ + +struct frame_info * +frscm_frame_smob_to_frame (frame_smob *f_smob) +{ + struct frame_info *frame; + + frame = frame_find_by_id (f_smob->frame_id); + if (frame == NULL) + return NULL; + + if (f_smob->frame_id_is_next) + frame = get_prev_frame (frame); + + return frame; +} + +/* Helper function for frscm_del_inferior_frames to mark the frame + as invalid. */ + +static int +frscm_mark_frame_invalid (void **slot, void *info) +{ + frame_smob *f_smob = (frame_smob *) *slot; + + f_smob->inferior = NULL; + return 1; +} + +/* This function is called when an inferior is about to be freed. + Invalidate the frame as further actions on the frame could result + in bad data. All access to the frame should be gated by + frscm_get_frame_smob_arg_unsafe which will raise an exception on + invalid frames. */ + +static void +frscm_del_inferior_frames (struct inferior *inferior, void *datum) +{ + htab_t htab = datum; + + if (htab != NULL) + { + htab_traverse_noresize (htab, frscm_mark_frame_invalid, NULL); + htab_delete (htab); + } +} + +/* Frame methods. */ + +/* (frame-valid? ) -> bool + Returns #t if the frame corresponding to the frame_id of this + object still exists in the inferior. */ + +static SCM +gdbscm_frame_valid_p (SCM self) +{ + frame_smob *f_smob; + struct frame_info *frame = NULL; + volatile struct gdb_exception except; + + f_smob = frscm_get_frame_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME); + + TRY_CATCH (except, RETURN_MASK_ALL) + { + frame = frscm_frame_smob_to_frame (f_smob); + } + GDBSCM_HANDLE_GDB_EXCEPTION (except); + + return scm_from_bool (frame != NULL); +} + +/* (frame-name ) -> string + Returns the name of the function corresponding to this frame, + or #f if there is no function. */ + +static SCM +gdbscm_frame_name (SCM self) +{ + frame_smob *f_smob; + char *name = NULL; + enum language lang = language_minimal; + struct frame_info *frame = NULL; + SCM result; + volatile struct gdb_exception except; + + f_smob = frscm_get_frame_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME); + + TRY_CATCH (except, RETURN_MASK_ALL) + { + frame = frscm_frame_smob_to_frame (f_smob); + if (frame != NULL) + find_frame_funname (frame, &name, &lang, NULL); + } + if (except.reason < 0) + xfree (name); + GDBSCM_HANDLE_GDB_EXCEPTION (except); + + if (frame == NULL) + { + gdbscm_invalid_object_error (FUNC_NAME, SCM_ARG1, self, + _("")); + } + + if (name != NULL) + { + result = gdbscm_scm_from_c_string (name); + xfree (name); + } + else + result = SCM_BOOL_F; + + return result; +} + +/* (frame-type ) -> integer + Returns the frame type, namely one of the gdb:*_FRAME constants. */ + +static SCM +gdbscm_frame_type (SCM self) +{ + frame_smob *f_smob; + enum frame_type type = NORMAL_FRAME; + struct frame_info *frame = NULL; + volatile struct gdb_exception except; + + f_smob = frscm_get_frame_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME); + + TRY_CATCH (except, RETURN_MASK_ALL) + { + frame = frscm_frame_smob_to_frame (f_smob); + if (frame != NULL) + type = get_frame_type (frame); + } + GDBSCM_HANDLE_GDB_EXCEPTION (except); + + if (frame == NULL) + { + gdbscm_invalid_object_error (FUNC_NAME, SCM_ARG1, self, + _("")); + } + + return scm_from_int (type); +} + +/* (frame-arch ) -> + Returns the frame's architecture as a gdb:architecture object. */ + +static SCM +gdbscm_frame_arch (SCM self) +{ + frame_smob *f_smob; + struct frame_info *frame = NULL; + volatile struct gdb_exception except; + + f_smob = frscm_get_frame_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME); + + TRY_CATCH (except, RETURN_MASK_ALL) + { + frame = frscm_frame_smob_to_frame (f_smob); + } + GDBSCM_HANDLE_GDB_EXCEPTION (except); + + if (frame == NULL) + { + gdbscm_invalid_object_error (FUNC_NAME, SCM_ARG1, self, + _("")); + } + + return arscm_scm_from_arch (f_smob->gdbarch); +} + +/* (frame-unwind-stop-reason ) -> integer + Returns one of the gdb:FRAME_UNWIND_* constants. */ + +static SCM +gdbscm_frame_unwind_stop_reason (SCM self) +{ + frame_smob *f_smob; + struct frame_info *frame = NULL; + volatile struct gdb_exception except; + enum unwind_stop_reason stop_reason; + + f_smob = frscm_get_frame_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME); + + TRY_CATCH (except, RETURN_MASK_ALL) + { + frame = frscm_frame_smob_to_frame (f_smob); + } + GDBSCM_HANDLE_GDB_EXCEPTION (except); + + if (frame == NULL) + { + gdbscm_invalid_object_error (FUNC_NAME, SCM_ARG1, self, + _("")); + } + + stop_reason = get_frame_unwind_stop_reason (frame); + + return scm_from_int (stop_reason); +} + +/* (frame-pc ) -> integer + Returns the frame's resume address. */ + +static SCM +gdbscm_frame_pc (SCM self) +{ + frame_smob *f_smob; + CORE_ADDR pc = 0; + struct frame_info *frame = NULL; + volatile struct gdb_exception except; + + f_smob = frscm_get_frame_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME); + + TRY_CATCH (except, RETURN_MASK_ALL) + { + frame = frscm_frame_smob_to_frame (f_smob); + if (frame != NULL) + pc = get_frame_pc (frame); + } + GDBSCM_HANDLE_GDB_EXCEPTION (except); + + if (frame == NULL) + { + gdbscm_invalid_object_error (FUNC_NAME, SCM_ARG1, self, + _("")); + } + + return gdbscm_scm_from_ulongest (pc); +} + +/* (frame-block ) -> + Returns the frame's code block, or #f if one cannot be found. */ + +static SCM +gdbscm_frame_block (SCM self) +{ + frame_smob *f_smob; + struct block *block = NULL, *fn_block; + struct frame_info *frame = NULL; + volatile struct gdb_exception except; + + f_smob = frscm_get_frame_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME); + + TRY_CATCH (except, RETURN_MASK_ALL) + { + frame = frscm_frame_smob_to_frame (f_smob); + if (frame != NULL) + block = get_frame_block (frame, NULL); + } + GDBSCM_HANDLE_GDB_EXCEPTION (except); + + if (frame == NULL) + { + gdbscm_invalid_object_error (FUNC_NAME, SCM_ARG1, self, + _("")); + } + + for (fn_block = block; + fn_block != NULL && BLOCK_FUNCTION (fn_block) == NULL; + fn_block = BLOCK_SUPERBLOCK (fn_block)) + continue; + + if (block == NULL || fn_block == NULL || BLOCK_FUNCTION (fn_block) == NULL) + { + scm_misc_error (FUNC_NAME, _("cannot find block for frame"), + scm_list_1 (self)); + } + + if (block != NULL) + { + struct symtab *st; + SCM block_scm; + + st = SYMBOL_SYMTAB (BLOCK_FUNCTION (fn_block)); + return bkscm_scm_from_block_unsafe (block, st->objfile); + } + + return SCM_BOOL_F; +} + +/* (frame-function ) -> + Returns the symbol for the function corresponding to this frame, + or #f if there isn't one. */ + +static SCM +gdbscm_frame_function (SCM self) +{ + frame_smob *f_smob; + struct symbol *sym = NULL; + struct frame_info *frame = NULL; + volatile struct gdb_exception except; + + f_smob = frscm_get_frame_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME); + + TRY_CATCH (except, RETURN_MASK_ALL) + { + frame = frscm_frame_smob_to_frame (f_smob); + if (frame != NULL) + sym = find_pc_function (get_frame_address_in_block (frame)); + } + GDBSCM_HANDLE_GDB_EXCEPTION (except); + + if (frame == NULL) + { + gdbscm_invalid_object_error (FUNC_NAME, SCM_ARG1, self, + _("")); + } + + if (sym != NULL) + return syscm_scm_from_symbol_unsafe (sym); + + return SCM_BOOL_F; +} + +/* (frame-older ) -> + Returns the frame immediately older (outer) to this frame, + or #f if there isn't one. */ + +static SCM +gdbscm_frame_older (SCM self) +{ + frame_smob *f_smob; + struct frame_info *prev = NULL; + struct frame_info *frame = NULL; + volatile struct gdb_exception except; + + f_smob = frscm_get_frame_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME); + + TRY_CATCH (except, RETURN_MASK_ALL) + { + frame = frscm_frame_smob_to_frame (f_smob); + if (frame != NULL) + prev = get_prev_frame (frame); + } + GDBSCM_HANDLE_GDB_EXCEPTION (except); + + if (frame == NULL) + { + gdbscm_invalid_object_error (FUNC_NAME, SCM_ARG1, self, + _("")); + } + + if (prev != NULL) + return frscm_scm_from_frame_unsafe (prev, f_smob->inferior); + + return SCM_BOOL_F; +} + +/* (frame-newer ) -> + Returns the frame immediately newer (inner) to this frame, + or #f if there isn't one. */ + +static SCM +gdbscm_frame_newer (SCM self) +{ + frame_smob *f_smob; + struct frame_info *next = NULL; + struct frame_info *frame = NULL; + volatile struct gdb_exception except; + + f_smob = frscm_get_frame_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME); + + TRY_CATCH (except, RETURN_MASK_ALL) + { + frame = frscm_frame_smob_to_frame (f_smob); + if (frame != NULL) + next = get_next_frame (frame); + } + GDBSCM_HANDLE_GDB_EXCEPTION (except); + + if (frame == NULL) + { + gdbscm_invalid_object_error (FUNC_NAME, SCM_ARG1, self, + _("")); + } + + if (next != NULL) + return frscm_scm_from_frame_unsafe (next, f_smob->inferior); + + return SCM_BOOL_F; +} + +/* (frame-sal ) -> + Returns the frame's symtab and line. */ + +static SCM +gdbscm_frame_sal (SCM self) +{ + frame_smob *f_smob; + struct symtab_and_line sal; + struct frame_info *frame = NULL; + volatile struct gdb_exception except; + + f_smob = frscm_get_frame_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME); + + TRY_CATCH (except, RETURN_MASK_ALL) + { + frame = frscm_frame_smob_to_frame (f_smob); + if (frame != NULL) + find_frame_sal (frame, &sal); + } + GDBSCM_HANDLE_GDB_EXCEPTION (except); + + if (frame == NULL) + { + gdbscm_invalid_object_error (FUNC_NAME, SCM_ARG1, self, + _("")); + } + + return stscm_scm_from_sal_unsafe (sal); +} + +/* (frame-read-var ) -> + (frame-read-var string [#:block ]) -> + If the optional block argument is provided start the search from that block, + otherwise search from the frame's current block (determined by examining + the resume address of the frame). The variable argument must be a string + or an instance of a . The block argument must be an instance of + . */ + +static SCM +gdbscm_frame_read_var (SCM self, SCM symbol_scm, SCM rest) +{ + SCM keywords[] = { frscm_block_keyword, SCM_BOOL_F }; + int rc; + SCM s_scm; + frame_smob *f_smob; + int block_arg_pos = -1; + SCM block_scm = SCM_UNDEFINED; + struct frame_info *frame = NULL; + struct symbol *var = NULL; + struct value *value = NULL; + volatile struct gdb_exception except; + + f_smob = frscm_get_frame_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME); + + TRY_CATCH (except, RETURN_MASK_ALL) + { + frame = frscm_frame_smob_to_frame (f_smob); + } + GDBSCM_HANDLE_GDB_EXCEPTION (except); + + if (frame == NULL) + { + gdbscm_invalid_object_error (FUNC_NAME, SCM_ARG1, self, + _("")); + } + + gdbscm_parse_function_args (FUNC_NAME, SCM_ARG3, keywords, "#O", + rest, &block_arg_pos, &block_scm); + + s_scm = syscm_scm_to_symbol_gsmob (symbol_scm); + if (syscm_is_symbol (s_scm)) + { + var = syscm_get_valid_symbol_arg_unsafe (s_scm, SCM_ARG2, FUNC_NAME); + SCM_ASSERT (SCM_UNBNDP (block_scm), block_scm, SCM_ARG3, FUNC_NAME); + } + else if (gdbscm_is_exception (s_scm)) + gdbscm_throw (s_scm); + else if (scm_is_string (symbol_scm)) + { + char *var_name; + const struct block *block = NULL; + struct cleanup *cleanup; + volatile struct gdb_exception except; + + if (! SCM_UNBNDP (block_scm)) + { + SCM except_scm; + + gdb_assert (block_arg_pos > 0); + block = bkscm_scm_to_block (block_scm, block_arg_pos, FUNC_NAME, + &except_scm); + if (block == NULL) + gdbscm_throw (except_scm); + } + + var_name = gdbscm_scm_to_c_string (symbol_scm); + cleanup = make_cleanup (xfree, var_name); + /* N.B. Between here and the call to do_cleanups, don't do anything + to cause a Scheme exception without performing the cleanup. */ + + TRY_CATCH (except, RETURN_MASK_ALL) + { + if (block == NULL) + block = get_frame_block (frame, NULL); + var = lookup_symbol (var_name, block, VAR_DOMAIN, NULL); + } + if (except.reason < 0) + do_cleanups (cleanup); + GDBSCM_HANDLE_GDB_EXCEPTION (except); + + if (var == NULL) + { + do_cleanups (cleanup); + gdbscm_out_of_range_error (FUNC_NAME, 0, symbol_scm, + _("variable not found")); + } + + do_cleanups (cleanup); + } + else + { + /* Use SCM_ASSERT_TYPE for more consistent error messages. */ + SCM_ASSERT_TYPE (0, symbol_scm, SCM_ARG1, FUNC_NAME, + _("gdb:symbol or string")); + } + + TRY_CATCH (except, RETURN_MASK_ALL) + { + value = read_var_value (var, frame); + } + GDBSCM_HANDLE_GDB_EXCEPTION (except); + + return vlscm_scm_from_value_unsafe (value); +} + +/* (frame-select ) -> unspecified + Select this frame. */ + +static SCM +gdbscm_frame_select (SCM self) +{ + frame_smob *f_smob; + struct frame_info *frame = NULL; + volatile struct gdb_exception except; + + f_smob = frscm_get_frame_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME); + + TRY_CATCH (except, RETURN_MASK_ALL) + { + frame = frscm_frame_smob_to_frame (f_smob); + if (frame != NULL) + select_frame (frame); + } + GDBSCM_HANDLE_GDB_EXCEPTION (except); + + if (frame == NULL) + { + gdbscm_invalid_object_error (FUNC_NAME, SCM_ARG1, self, + _("")); + } + + return SCM_UNSPECIFIED; +} + +/* (newest-frame) -> + Returns the newest frame. */ + +static SCM +gdbscm_newest_frame (void) +{ + struct frame_info *frame = NULL; + volatile struct gdb_exception except; + + TRY_CATCH (except, RETURN_MASK_ALL) + { + frame = get_current_frame (); + } + GDBSCM_HANDLE_GDB_EXCEPTION (except); + + return frscm_scm_from_frame_unsafe (frame, current_inferior ()); +} + +/* (selected-frame) -> + Returns the selected frame. */ + +static SCM +gdbscm_selected_frame (void) +{ + struct frame_info *frame = NULL; + volatile struct gdb_exception except; + + TRY_CATCH (except, RETURN_MASK_ALL) + { + frame = get_selected_frame (_("No frame is currently selected")); + } + GDBSCM_HANDLE_GDB_EXCEPTION (except); + + return frscm_scm_from_frame_unsafe (frame, current_inferior ()); +} + +/* (unwind-stop-reason-string integer) -> string + Return a string explaining the unwind stop reason. */ + +static SCM +gdbscm_unwind_stop_reason_string (SCM reason_scm) +{ + int reason; + const char *str; + + gdbscm_parse_function_args (FUNC_NAME, SCM_ARG1, NULL, "i", + reason_scm, &reason); + + if (reason < UNWIND_FIRST || reason > UNWIND_LAST) + scm_out_of_range (FUNC_NAME, reason_scm); + + str = frame_stop_reason_string (reason); + return gdbscm_scm_from_c_string (str); +} + +/* Initialize the Scheme frame support. */ + +static const scheme_integer_constant frame_integer_constants[] = +{ +#define ENTRY(X) { #X, X } + + ENTRY (NORMAL_FRAME), + ENTRY (DUMMY_FRAME), + ENTRY (INLINE_FRAME), + ENTRY (TAILCALL_FRAME), + ENTRY (SIGTRAMP_FRAME), + ENTRY (ARCH_FRAME), + ENTRY (SENTINEL_FRAME), + +#undef ENTRY + +#define SET(name, description) \ + { "FRAME_" #name, name }, +#include "unwind_stop_reasons.def" +#undef SET + + END_INTEGER_CONSTANTS +}; + +static const scheme_function frame_functions[] = +{ + { "frame?", 1, 0, 0, gdbscm_frame_p, + "\ +Return #t if the object is a object." }, + + { "frame-valid?", 1, 0, 0, gdbscm_frame_valid_p, + "\ +Return #t if the object is a valid object.\n\ +Frames become invalid when the inferior returns to its caller." }, + + { "frame-name", 1, 0, 0, gdbscm_frame_name, + "\ +Return the name of the function corresponding to this frame,\n\ +or #f if there is no function." }, + + { "frame-arch", 1, 0, 0, gdbscm_frame_arch, + "\ +Return the frame's architecture as a object." }, + + { "frame-type", 1, 0, 0, gdbscm_frame_type, + "\ +Return the frame type, namely one of the gdb:*_FRAME constants." }, + + { "frame-unwind-stop-reason", 1, 0, 0, gdbscm_frame_unwind_stop_reason, + "\ +Return one of the gdb:FRAME_UNWIND_* constants explaining why\n\ +it's not possible to find frames older than this." }, + + { "frame-pc", 1, 0, 0, gdbscm_frame_pc, + "\ +Return the frame's resume address." }, + + { "frame-block", 1, 0, 0, gdbscm_frame_block, + "\ +Return the frame's code block, or #f if one cannot be found." }, + + { "frame-function", 1, 0, 0, gdbscm_frame_function, + "\ +Return the for the function corresponding to this frame,\n\ +or #f if there isn't one." }, + + { "frame-older", 1, 0, 0, gdbscm_frame_older, + "\ +Return the frame immediately older (outer) to this frame,\n\ +or #f if there isn't one." }, + + { "frame-newer", 1, 0, 0, gdbscm_frame_newer, + "\ +Return the frame immediately newer (inner) to this frame,\n\ +or #f if there isn't one." }, + + { "frame-sal", 1, 0, 0, gdbscm_frame_sal, + "\ +Return the frame's symtab-and-line object." }, + + { "frame-read-var", 2, 0, 1, gdbscm_frame_read_var, + "\ +Return the value of the symbol in the frame.\n\ +\n\ + Arguments: \n\ + Or: string [#:block ]" }, + + { "frame-select", 1, 0, 0, gdbscm_frame_select, + "\ +Select this frame." }, + + { "newest-frame", 0, 0, 0, gdbscm_newest_frame, + "\ +Return the newest frame." }, + + { "selected-frame", 0, 0, 0, gdbscm_selected_frame, + "\ +Return the selected frame." }, + + { "unwind-stop-reason-string", 1, 0, 0, gdbscm_unwind_stop_reason_string, + "\ +Return a string explaining the unwind stop reason.\n\ +\n\ + Arguments: integer (the result of frame-unwind-stop-reason)" }, + + END_FUNCTIONS +}; + +void +gdbscm_initialize_frames (void) +{ + frame_smob_tag + = gdbscm_make_smob_type (frame_smob_name, sizeof (frame_smob)); + scm_set_smob_mark (frame_smob_tag, frscm_mark_frame_smob); + scm_set_smob_free (frame_smob_tag, frscm_free_frame_smob); + scm_set_smob_print (frame_smob_tag, frscm_print_frame_smob); + + gdbscm_define_integer_constants (frame_integer_constants, 1); + gdbscm_define_functions (frame_functions, 1); + + frscm_block_keyword = scm_from_latin1_keyword ("block"); + + /* Register an inferior "free" callback so we can properly + invalidate frames when an inferior file is about to be deleted. */ + frscm_inferior_data_key + = register_inferior_data_with_cleanup (NULL, frscm_del_inferior_frames); +} diff --git a/gdb/testsuite/gdb.guile/scm-frame-args.c b/gdb/testsuite/gdb.guile/scm-frame-args.c new file mode 100644 index 0000000..7cc3dbe --- /dev/null +++ b/gdb/testsuite/gdb.guile/scm-frame-args.c @@ -0,0 +1,60 @@ +/* This testcase is part of GDB, the GNU debugger. + + Copyright 2013 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 . */ + +#include + +struct s +{ + int m; +}; + +struct ss +{ + struct s a; + struct s b; +}; + +void +init_s (struct s *s, int m) +{ + s->m = m; +} + +void +init_ss (struct ss *s, int a, int b) +{ + init_s (&s->a, a); + init_s (&s->b, b); +} + +void +foo (int x, struct ss ss) +{ + return; /* break-here */ +} + +int +main () +{ + struct ss ss; + + init_ss (&ss, 1, 2); + + foo (42, ss); + + return 0; +} diff --git a/gdb/testsuite/gdb.guile/scm-frame-args.exp b/gdb/testsuite/gdb.guile/scm-frame-args.exp new file mode 100644 index 0000000..b0ff138 --- /dev/null +++ b/gdb/testsuite/gdb.guile/scm-frame-args.exp @@ -0,0 +1,76 @@ +# Copyright (C) 2013 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 . + +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] { + return +} + +# Give the file a new name so we don't clobber the real one if +# objfile == srcdir. +set remote_guile_file [gdb_remote_download host \ + ${srcdir}/${subdir}/${testfile}.scm \ + ${subdir}/t-${testfile}.scm] + +gdb_scm_load_file "$remote_guile_file" "load script" + +gdb_breakpoint [gdb_get_line_number "break-here"] +gdb_continue_to_breakpoint "break-here" ".* break-here .*" + +# Test all combinations with raw off. + +gdb_test_no_output "set print raw frame-arguments off" + +gdb_test_no_output "set print frame-arguments none" +gdb_test "frame" ".*foo \\(x=\[.\]{3}, ss=\[.\]{3}\\).*" \ + "frame pretty,none" + +#gdb_test_no_output "set guile print-stack full" + +gdb_test_no_output "set print frame-arguments scalars" +gdb_test "frame" ".*foo \\(x=42, ss=super struct = {\[.\]{3}}\\).*" \ + "frame pretty,scalars" + +gdb_test_no_output "set print frame-arguments all" +gdb_test "frame" \ + ".*foo \\(x=42, ss=super struct = {a = m=<1>, b = m=<2>}\\).*" \ + "frame pretty,all" + +# Test all combinations with raw on. + +gdb_test_no_output "set print raw frame-arguments on" + +gdb_test_no_output "set print frame-arguments none" +gdb_test "frame" ".*foo \\(x=\[.\]{3}, ss=\[.\]{3}\\).*" \ + "frame raw,none" + +gdb_test_no_output "set print frame-arguments scalars" +gdb_test "frame" ".*foo \\(x=42, ss=\[.\]{3}\\).*" \ + "frame raw,scalars" + +gdb_test_no_output "set print frame-arguments all" +gdb_test "frame" \ + ".*foo \\(x=42, ss={a = {m = 1}, b = {m = 2}}\\).*" \ + "frame raw,all" diff --git a/gdb/testsuite/gdb.guile/scm-frame-args.scm b/gdb/testsuite/gdb.guile/scm-frame-args.scm new file mode 100644 index 0000000..9bfa30c --- /dev/null +++ b/gdb/testsuite/gdb.guile/scm-frame-args.scm @@ -0,0 +1,70 @@ +;; Copyright (C) 2013 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 . + +(use-modules (gdb) (gdb printing)) + +(define (make-pp_s-printer val) + (make-pretty-printer-worker + #f + (lambda (printer) + (let ((m (value-field val "m"))) + (format #f "m=<~A>" m))) + #f)) + +(define (make-pp_ss-printer val) + (make-pretty-printer-worker + #f + (lambda (printer) "super struct") + (lambda (printer) + (make-iterator val + (make-field-iterator (value-type val)) + (lambda (iter) + (let ((field (iterator-next! + (iterator-progress iter)))) + (and field + (let ((name (field-name field))) + (cons + name + (value-field val name)))))))))) + +(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 s" make-pp_s-printer) + (hash-set! dict "s" make-pp_s-printer) + (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-frame-inline.c b/gdb/testsuite/gdb.guile/scm-frame-inline.c new file mode 100644 index 0000000..68b93db --- /dev/null +++ b/gdb/testsuite/gdb.guile/scm-frame-inline.c @@ -0,0 +1,43 @@ +/* This test is part of GDB, the GNU debugger. + + Copyright 2011-2013 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 . */ + +volatile int v = 42; + +__attribute__((__always_inline__)) static inline int +f (void) +{ + /* Provide first stub line so that GDB understand the PC is already inside + the inlined function and does not expect a step into it. */ + v++; + v++; /* break-here */ + + return v; +} + +__attribute__((__noinline__)) static int +g (void) +{ + volatile int l = v; + + return f (); +} + +int +main (void) +{ + return g (); +} diff --git a/gdb/testsuite/gdb.guile/scm-frame-inline.exp b/gdb/testsuite/gdb.guile/scm-frame-inline.exp new file mode 100644 index 0000000..15db8dc --- /dev/null +++ b/gdb/testsuite/gdb.guile/scm-frame-inline.exp @@ -0,0 +1,43 @@ +# Copyright (C) 2011-2013 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 . + +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 ![runto main] { + fail "Can't run to main" + return +} + +gdb_install_guile_utils +gdb_install_guile_module + +gdb_breakpoint [gdb_get_line_number "break-here"] +gdb_continue_to_breakpoint "break-here" + +gdb_test "info frame" "inlined into frame 1\r\n.*" + +gdb_test "up" "#1 g .*" + +gdb_test "guile (print (frame-read-var (selected-frame) \"l\"))" \ + "= 42" diff --git a/gdb/testsuite/gdb.guile/scm-frame.c b/gdb/testsuite/gdb.guile/scm-frame.c new file mode 100644 index 0000000..82db341 --- /dev/null +++ b/gdb/testsuite/gdb.guile/scm-frame.c @@ -0,0 +1,30 @@ +int f2 (int a) +{ + return ++a; +} + +int f1 (int a, int b) +{ + return f2(a) + b; +} + +int block (void) +{ + int i = 99; + { + double i = 1.1; + double f = 2.2; + { + const char *i = "stuff"; + const char *f = "foo"; + const char *b = "bar"; + return 0; /* Block break here. */ + } + } +} + +int main (int argc, char *argv[]) +{ + block (); + return f1 (1, 2); +} diff --git a/gdb/testsuite/gdb.guile/scm-frame.exp b/gdb/testsuite/gdb.guile/scm-frame.exp new file mode 100644 index 0000000..d2ebb37 --- /dev/null +++ b/gdb/testsuite/gdb.guile/scm-frame.exp @@ -0,0 +1,122 @@ +# Copyright (C) 2009-2013 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 frame support in Guile. + +load_lib gdb-guile.exp + +standard_testfile + +if { [prepare_for_testing ${testfile}.exp ${testfile} ${srcfile}] } { + return -1 +} + +# Skip all tests if Guile scripting is not enabled. +if { [skip_guile_tests] } { continue } + +# The following tests require execution. + +if ![gdb_guile_runto_main] { + return +} + +gdb_breakpoint [gdb_get_line_number "Block break here."] +gdb_continue_to_breakpoint "Block break here." +gdb_scm_test_silent_cmd "guile (define bf1 (selected-frame))" \ + "get frame" + +# Test frame-architecture method. +gdb_scm_test_silent_cmd "guile (define show-arch-str (execute \"show architecture\" #:to-string #t))" \ + "show arch" +gdb_test "guile (print (->bool (string-contains show-arch-str (arch-name (frame-arch bf1)))))" \ + "#t" "test frame-arch" + +# First test that read-var is unaffected by PR 11036 changes. +gdb_test "guile (print (frame-read-var bf1 \"i\"))" \ + "\"stuff\"" "test i" +gdb_test "guile (print (frame-read-var bf1 \"f\"))" \ + "\"foo\"" "test f" +gdb_test "guile (print (frame-read-var bf1 \"b\"))" \ + "\"bar\"" "test b" + +# Test the read-var function in another block other than the current +# block (in this case, the super block). Test thar read-var is reading +# the correct variables of i and f but they are the correct value and type. +gdb_scm_test_silent_cmd "guile (define sb (block-superblock (frame-block bf1)))" \ + "get superblock" +gdb_test "guile (print (frame-read-var bf1 \"i\" #:block sb))" "1.1.*" \ + "test i = 1.1" +gdb_test "guile (print (value-type (frame-read-var bf1 \"i\" #:block sb)))" \ + "double" "test double i" +gdb_test "guile (print (frame-read-var bf1 \"f\" #:block sb))" \ + "2.2.*" "test f = 2.2" +gdb_test "guile (print (value-type (frame-read-var bf1 \"f\" #:block sb)))" \ + "double" "test double f" + +# And again test another outerblock, this time testing "i" is the +# correct value and type. +gdb_scm_test_silent_cmd "guile (set! sb (block-superblock sb))" \ + "get superblock #2" +gdb_test "guile (print (frame-read-var bf1 \"i\" #:block sb))" \ + "99" "test i = 99" +gdb_test "guile (print (value-type (frame-read-var bf1 \"i\" #:block sb)))" \ + "int" "test int i" + +gdb_breakpoint "f2" +gdb_continue_to_breakpoint "breakpoint at f2" +gdb_scm_test_silent_cmd "guile (define bframe (selected-frame))" \ + "get bottom-most frame" +gdb_test "up" ".*" "" + +gdb_scm_test_silent_cmd "guile (define f1 (selected-frame))" \ +"get second frame" +gdb_scm_test_silent_cmd "guile (define f0 (frame-newer f1))" \ + "get first frame" + +gdb_test "guile (print (eq? f1 (newest-frame)))" \ + #f "selected frame -vs- newest frame" +gdb_test "guile (print (eq? bframe (newest-frame)))" \ + #t "newest frame -vs- newest frame" + +gdb_test "guile (print (eq? f0 f1))" \ + "#f" "test equality comparison (false)" +gdb_test "guile (print (eq? f0 f0))" \ + "#t" "test equality comparison (true)" +gdb_test "guile (print (frame-valid? f0))" \ + "#t" "test frame-valid?" +gdb_test "guile (print (frame-name f0))" \ + "f2" "test frame-name" +gdb_test "guile (print (= (frame-type f0) NORMAL_FRAME))" \ + "#t" "test frame-type" +gdb_test "guile (print (= (frame-unwind-stop-reason f0) FRAME_UNWIND_NO_REASON))" \ + "#t" "test frame-unwind-stop-reason" +gdb_test "guile (print (unwind-stop-reason-string FRAME_UNWIND_INNER_ID))" \ + "previous frame inner to this frame \\(corrupt stack\\?\\)" \ + "test unwind-stop-reason-string" +gdb_test "guile (print (format #f \"= ~A\" (frame-pc f0)))" \ + "= \[0-9\]+" "test frame-pc" +gdb_test "guile (print (format #f \"= ~A\" (eq? (frame-older f0) f1)))" \ + "= #t" "test frame-older" +gdb_test "guile (print (format #f \"= ~A\" (eq? (frame-newer f1) f0)))" \ + "= #t" "test frame-newer" +gdb_test "guile (print (frame-read-var f0 \"variable_which_surely_doesnt_exist\"))" \ + "ERROR: .*: Out of range: variable not found: \"variable_which_surely_doesnt_exist\".*" \ + "test frame-read-var - error" +gdb_test "guile (print (format #f \"= ~A\" (frame-read-var f0 \"a\")))" \ + "= 1" "test frame-read-var - success" + +gdb_test "guile (print (format #f \"= ~A\" (eq? (selected-frame) f1)))" \ + "= #t" "test selected-frame"