diff options
Diffstat (limited to 'libguile/gdbint.c')
-rw-r--r-- | libguile/gdbint.c | 266 |
1 files changed, 0 insertions, 266 deletions
diff --git a/libguile/gdbint.c b/libguile/gdbint.c deleted file mode 100644 index 2df3c5c46..000000000 --- a/libguile/gdbint.c +++ /dev/null @@ -1,266 +0,0 @@ -/* GDB interface for Guile - * Copyright (C) 1996,1997,1999,2000,2001,2002,2004,2009,2011,2012 - * 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 - * as published by the Free Software Foundation; either version 3 of - * the License, or (at your option) any later version. - * - * This library 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA - * 02110-1301 USA - */ - -#ifdef HAVE_CONFIG_H -# include <config.h> -#endif - -#include "libguile/_scm.h" - -#include <stdio.h> -#include <string.h> -#ifdef HAVE_UNISTD_H -#include <unistd.h> -#endif - -#include "libguile/strports.h" -#include "libguile/read.h" -#include "libguile/eval.h" -#include "libguile/chars.h" -#include "libguile/modules.h" -#include "libguile/ports.h" -#include "libguile/fluids.h" -#include "libguile/strings.h" -#include "libguile/init.h" - -#include "libguile/gdbint.h" - -/* {Support for debugging with gdb} - * - * TODO: - * - * 1. Redirect outputs - * 2. Catch errors - * 3. Prevent print from causing segmentation fault when given broken pairs - */ - -#define GDB_TYPE SCM - -#include "libguile/gdb_interface.h" - - - -/* Be carefull when this macro is true. - scm_gc_running_p is set during gc. - */ -#define SCM_GC_P (scm_gc_running_p) - -/* Macros that encapsulate blocks of code which can be called by the - * debugger. - */ -#define SCM_BEGIN_FOREIGN_BLOCK \ -do { \ - scm_print_carefully_p = 1; \ -} while (0) - - -#define SCM_END_FOREIGN_BLOCK \ -do { \ - scm_print_carefully_p = 0; \ -} while (0) - - -#define RESET_STRING { gdb_output_length = 0; } - -#define SEND_STRING(str) \ -do { \ - gdb_output = (char *) (str); \ - gdb_output_length = strlen ((const char *) (str)); \ -} while (0) - - -/* {Gdb interface} - */ - -unsigned short gdb_options = GDB_HAVE_BINDINGS; - -char *gdb_language = "lisp/c"; - -SCM gdb_result; - -char *gdb_output; - -int gdb_output_length; - -int scm_print_carefully_p; - -static SCM gdb_input_port; -static SCM gdb_output_port; - - -int -gdb_maybe_valid_type_p (SCM value) -{ - return SCM_IMP (value); /* || scm_in_heap_p (value); */ /* FIXME: What to - do? */ -} - - -int -gdb_read (char *str) -{ -#if 0 - SCM ans; - int status = 0; - RESET_STRING; - /* Need to be restrictive about what to read? */ - if (1) /* (SCM_GC_P) */ /* FIXME */ - { - char *p; - for (p = str; *p != '\0'; ++p) - switch (*p) - { - case '(': - case '\'': - case '"': - SEND_STRING ("Can't read this kind of expressions during gc"); - return -1; - case '#': - if (*++p == '\0') - goto premature; - if (*p == '\\') - { - if (*++p != '\0') - continue; - premature: - SEND_STRING ("Premature end of lisp expression"); - return -1; - } - default: - continue; - } - } - SCM_BEGIN_FOREIGN_BLOCK; - unmark_port (gdb_input_port); - scm_seek (gdb_input_port, SCM_INUM0, scm_from_int (SEEK_SET)); - scm_puts_unlocked (str, gdb_input_port); - scm_truncate_file (gdb_input_port, SCM_UNDEFINED); - scm_seek (gdb_input_port, SCM_INUM0, scm_from_int (SEEK_SET)); - - /* Read one object */ - ans = scm_read (gdb_input_port); - if (SCM_GC_P) - { - if (SCM_HEAP_OBJECT_P (ans)) - { - SEND_STRING ("Non-immediate created during gc. Memory may be trashed."); - status = -1; - goto exit; - } - } - gdb_result = ans; - /* Protect answer from future GC (FIXME: still needed with BDW-GC?) */ - if (SCM_HEAP_OBJECT_P (ans)) - scm_permanent_object (ans); -exit: - remark_port (gdb_input_port); - SCM_END_FOREIGN_BLOCK; - return status; -#else - abort (); -#endif -} - - -int -gdb_eval (SCM exp) -{ - RESET_STRING; - if (SCM_GC_P) - { - SEND_STRING ("Can't evaluate lisp expressions during gc"); - return -1; - } - SCM_BEGIN_FOREIGN_BLOCK; - { - gdb_result = scm_permanent_object (scm_primitive_eval (exp)); - } - SCM_END_FOREIGN_BLOCK; - return 0; -} - - -int -gdb_print (SCM obj) -{ - if (!scm_initialized_p) - SEND_STRING ("*** Guile not initialized ***"); - else - { - RESET_STRING; - SCM_BEGIN_FOREIGN_BLOCK; - /* Reset stream */ - scm_seek (gdb_output_port, SCM_INUM0, scm_from_int (SEEK_SET)); - scm_write (obj, gdb_output_port); - scm_truncate_file (gdb_output_port, SCM_UNDEFINED); - { - scm_t_port *pt = SCM_PTAB_ENTRY (gdb_output_port); - - scm_flush_unlocked (gdb_output_port); - *(pt->write_buf + pt->read_buf_size) = 0; - SEND_STRING (pt->read_buf); - } - SCM_END_FOREIGN_BLOCK; - } - return 0; -} - - -int -gdb_binding (SCM name, SCM value) -{ - RESET_STRING; - if (SCM_GC_P) - { - SEND_STRING ("Can't create new bindings during gc"); - return -1; - } - SCM_BEGIN_FOREIGN_BLOCK; - { - scm_define (name, value); - } - SCM_END_FOREIGN_BLOCK; - return 0; -} - -void -scm_init_gdbint () -{ - static char *s = "scm_init_gdb_interface"; - SCM port; - - scm_print_carefully_p = 0; - - port = scm_mkstrport (SCM_INUM0, SCM_BOOL_F, - SCM_OPN | SCM_WRTNG, - s); - gdb_output_port = scm_permanent_object (port); - - port = scm_mkstrport (SCM_INUM0, SCM_BOOL_F, - SCM_OPN | SCM_RDNG | SCM_WRTNG, - s); - gdb_input_port = scm_permanent_object (port); -} - -/* - Local Variables: - c-file-style: "gnu" - End: -*/ |