diff options
| -rw-r--r-- | gdb/ChangeLog | 6 | ||||
| -rw-r--r-- | gdb/Makefile.in | 13 | ||||
| -rw-r--r-- | gdb/defs.h | 1 | ||||
| -rw-r--r-- | gdb/scm-exp.c | 497 | ||||
| -rw-r--r-- | gdb/scm-lang.c | 283 | ||||
| -rw-r--r-- | gdb/scm-lang.h | 72 | ||||
| -rw-r--r-- | gdb/scm-tags.h | 380 | ||||
| -rw-r--r-- | gdb/scm-valprint.c | 438 |
8 files changed, 1690 insertions, 0 deletions
diff --git a/gdb/ChangeLog b/gdb/ChangeLog index 914fe17..4d9853c 100644 --- a/gdb/ChangeLog +++ b/gdb/ChangeLog @@ -1,5 +1,11 @@ 2007-08-10 Ludovic Courtès <ludo@gnu.org> + * Makefile.in (SFILES): Add scm-{exp,lang,valprint}.c. + (scm_lang_h, scm_tags_h): New. + (COMMON_OBS): Add scm-{exp,lang,valprint}.o. + (scm-exp.o, scm-lang.o, scm-valprint.o): New targets. + * defs.h (enum language): Add `language_scm'. + * MAINTAINERS: Add Emacs local variables to use UTF-8 upon opening. diff --git a/gdb/Makefile.in b/gdb/Makefile.in index 55ac13d..a445af4 100644 --- a/gdb/Makefile.in +++ b/gdb/Makefile.in @@ -555,6 +555,7 @@ SFILES = ada-exp.y ada-lang.c ada-typeprint.c ada-valprint.c \ p-exp.y p-lang.c p-typeprint.c p-valprint.c parse.c printcmd.c \ prologue-value.c \ regcache.c reggroups.c remote.c remote-fileio.c \ + scm-exp.c scm-lang.c scm-valprint.c \ sentinel-frame.c \ serial.c ser-base.c ser-unix.c \ solib.c solib-null.c source.c \ @@ -787,6 +788,8 @@ remote_fileio_h = remote-fileio.h remote_h = remote.h rs6000_tdep_h = rs6000-tdep.h $(defs_h) s390_tdep_h = s390-tdep.h +scm_lang_h = scm-lang.h $(scm_tags_h) +scm_tags_h = scm-tags.h score_tdep_h = score-tdep.h sentinel_frame_h = sentinel-frame.h serial_h = serial.h @@ -958,6 +961,7 @@ COMMON_OBS = $(DEPFILES) $(CONFIG_OBS) $(YYOBJ) \ varobj.o vec.o wrapper.o \ jv-lang.o jv-valprint.o jv-typeprint.o \ m2-lang.o p-lang.o p-typeprint.o p-valprint.o \ + scm-exp.o scm-lang.o scm-valprint.o \ sentinel-frame.o \ complaints.o typeprint.o \ ada-typeprint.o c-typeprint.o f-typeprint.o m2-typeprint.o \ @@ -2534,6 +2538,15 @@ s390-tdep.o: s390-tdep.c $(defs_h) $(arch_utils_h) $(frame_h) $(inferior_h) \ $(frame_unwind_h) $(dwarf2_frame_h) $(reggroups_h) $(regset_h) \ $(value_h) $(gdb_assert_h) $(dis_asm_h) $(solib_svr4_h) \ $(prologue_value_h) $(s390_tdep_h) +scm-exp.o: scm-exp.c $(defs_h) $(symtab_h) $(gdbtypes_h) $(expression_h) \ + $(parser_defs_h) $(language_h) $(value_h) $(c_lang_h) $(scm_lang_h) \ + $(scm_tags_h) +scm-lang.o: scm-lang.c $(defs_h) $(symtab_h) $(gdbtypes_h) $(expression_h) \ + $(parser_defs_h) $(language_h) $(value_h) $(c_lang_h) $(scm_lang_h) \ + $(scm_tags_h) $(source_h) $(gdb_string_h) $(gdbcore_h) $(infcall_h) +scm-valprint.o: scm-valprint.c $(defs_h) $(symtab_h) $(gdbtypes_h) \ + $(expression_h) $(parser_defs_h) $(language_h) $(value_h) \ + $(scm_lang_h) $(valprint_h) $(gdbcore_h) $(c_lang_h) score-tdep.o: score-tdep.c $(defs_h) $(gdb_assert_h) $(inferior_h) \ $(symtab_h) $(objfiles_h) $(gdbcore_h) $(target_h) \ $(arch_utils_h) $(regcache_h) $(dis_asm_h) $(frame_unwind_h) \ @@ -212,6 +212,7 @@ enum language language_asm, /* Assembly language */ language_pascal, /* Pascal */ language_ada, /* Ada */ + language_scm, /* Guile Scheme */ language_minimal, /* All other languages, minimal support only */ nr_languages }; diff --git a/gdb/scm-exp.c b/gdb/scm-exp.c new file mode 100644 index 0000000..61eb7c4 --- /dev/null +++ b/gdb/scm-exp.c @@ -0,0 +1,497 @@ +/* Scheme/Guile language support routines for GDB, the GNU debugger. + + Copyright (C) 1995, 1996, 2000, 2003, 2005 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 2 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, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, + Boston, MA 02110-1301, USA. */ + +#include "defs.h" +#include "symtab.h" +#include "gdbtypes.h" +#include "expression.h" +#include "parser-defs.h" +#include "language.h" +#include "value.h" +#include "c-lang.h" +#include "scm-lang.h" +#include "scm-tags.h" + +#define USE_EXPRSTRING 0 + +static void scm_lreadparen (int); +static int scm_skip_ws (void); +static void scm_read_token (int, int); +static LONGEST scm_istring2number (char *, int, int); +static LONGEST scm_istr2int (char *, int, int); +static void scm_lreadr (int); + +static LONGEST +scm_istr2int (char *str, int len, int radix) +{ + int i = 0; + LONGEST inum = 0; + int c; + int sign = 0; + + if (0 >= len) + return SCM_BOOL_F; /* zero scm_length */ + switch (str[0]) + { /* leading sign */ + case '-': + case '+': + sign = str[0]; + if (++i == len) + return SCM_BOOL_F; /* bad if lone `+' or `-' */ + } + do + { + switch (c = str[i++]) + { + case '0': + case '1': + case '2': + case '3': + case '4': + case '5': + case '6': + case '7': + case '8': + case '9': + c = c - '0'; + goto accumulate; + case 'A': + case 'B': + case 'C': + case 'D': + case 'E': + case 'F': + c = c - 'A' + 10; + goto accumulate; + case 'a': + case 'b': + case 'c': + case 'd': + case 'e': + case 'f': + c = c - 'a' + 10; + accumulate: + if (c >= radix) + return SCM_BOOL_F; /* bad digit for radix */ + inum *= radix; + inum += c; + break; + default: + return SCM_BOOL_F; /* not a digit */ + } + } + while (i < len); + if (sign == '-') + inum = -inum; + return SCM_MAKINUM (inum); +} + +static LONGEST +scm_istring2number (char *str, int len, int radix) +{ + int i = 0; + char ex = 0; + char ex_p = 0, rx_p = 0; /* Only allow 1 exactness and 1 radix prefix */ +#if 0 + SCM res; +#endif + if (len == 1) + if (*str == '+' || *str == '-') /* Catches lone `+' and `-' for speed */ + return SCM_BOOL_F; + + while ((len - i) >= 2 && str[i] == '#' && ++i) + switch (str[i++]) + { + case 'b': + case 'B': + if (rx_p++) + return SCM_BOOL_F; + radix = 2; + break; + case 'o': + case 'O': + if (rx_p++) + return SCM_BOOL_F; + radix = 8; + break; + case 'd': + case 'D': + if (rx_p++) + return SCM_BOOL_F; + radix = 10; + break; + case 'x': + case 'X': + if (rx_p++) + return SCM_BOOL_F; + radix = 16; + break; + case 'i': + case 'I': + if (ex_p++) + return SCM_BOOL_F; + ex = 2; + break; + case 'e': + case 'E': + if (ex_p++) + return SCM_BOOL_F; + ex = 1; + break; + default: + return SCM_BOOL_F; + } + + switch (ex) + { + case 1: + return scm_istr2int (&str[i], len - i, radix); + case 0: + return scm_istr2int (&str[i], len - i, radix); +#if 0 + if NFALSEP + (res) return res; +#ifdef FLOATS + case 2: + return scm_istr2flo (&str[i], len - i, radix); +#endif +#endif + } + return SCM_BOOL_F; +} + +static void +scm_read_token (int c, int weird) +{ + while (1) + { + c = *lexptr++; + switch (c) + { + case '[': + case ']': + case '(': + case ')': + case '\"': + case ';': + case ' ': + case '\t': + case '\r': + case '\f': + case '\n': + if (weird) + goto default_case; + case '\0': /* End of line */ + eof_case: + --lexptr; + return; + case '\\': + if (!weird) + goto default_case; + else + { + c = *lexptr++; + if (c == '\0') + goto eof_case; + else + goto default_case; + } + case '}': + if (!weird) + goto default_case; + + c = *lexptr++; + if (c == '#') + return; + else + { + --lexptr; + c = '}'; + goto default_case; + } + + default: + default_case: + ; + } + } +} + +static int +scm_skip_ws (void) +{ + int c; + while (1) + switch ((c = *lexptr++)) + { + case '\0': + goteof: + return c; + case ';': + lp: + switch ((c = *lexptr++)) + { + case '\0': + goto goteof; + default: + goto lp; + case '\n': + break; + } + case ' ': + case '\t': + case '\r': + case '\f': + case '\n': + break; + default: + return c; + } +} + +static void +scm_lreadparen (int skipping) +{ + for (;;) + { + int c = scm_skip_ws (); + if (')' == c || ']' == c) + return; + --lexptr; + if (c == '\0') + error ("missing close paren"); + scm_lreadr (skipping); + } +} + +static void +scm_lreadr (int skipping) +{ + int c, j; + struct stoken str; + LONGEST svalue = 0; +tryagain: + c = *lexptr++; + switch (c) + { + case '\0': + lexptr--; + return; + case '[': + case '(': + scm_lreadparen (skipping); + return; + case ']': + case ')': + error ("unexpected #\\%c", c); + goto tryagain; + case '\'': + case '`': + str.ptr = lexptr - 1; + scm_lreadr (skipping); + if (!skipping) + { + struct value *val = scm_evaluate_string (str.ptr, lexptr - str.ptr); + if (!is_scmvalue_type (value_type (val))) + error ("quoted scm form yields non-SCM value"); + svalue = extract_signed_integer (value_contents (val), + TYPE_LENGTH (value_type (val))); + goto handle_immediate; + } + return; + case ',': + c = *lexptr++; + if ('@' != c) + lexptr--; + scm_lreadr (skipping); + return; + case '#': + c = *lexptr++; + switch (c) + { + case '[': + case '(': + scm_lreadparen (skipping); + return; + case 't': + case 'T': + svalue = SCM_BOOL_T; + goto handle_immediate; + case 'f': + case 'F': + svalue = SCM_BOOL_F; + goto handle_immediate; + case 'b': + case 'B': + case 'o': + case 'O': + case 'd': + case 'D': + case 'x': + case 'X': + case 'i': + case 'I': + case 'e': + case 'E': + lexptr--; + c = '#'; + goto num; + case '*': /* bitvector */ + scm_read_token (c, 0); + return; + case '{': + scm_read_token (c, 1); + return; + case '\\': /* character */ + c = *lexptr++; + scm_read_token (c, 0); + return; + case '|': + j = 1; /* here j is the comment nesting depth */ + lp: + c = *lexptr++; + lpc: + switch (c) + { + case '\0': + error ("unbalanced comment"); + default: + goto lp; + case '|': + if ('#' != (c = *lexptr++)) + goto lpc; + if (--j) + goto lp; + break; + case '#': + if ('|' != (c = *lexptr++)) + goto lpc; + ++j; + goto lp; + } + goto tryagain; + case '.': + default: +#if 0 + callshrp: +#endif + scm_lreadr (skipping); + return; + } + case '\"': + while ('\"' != (c = *lexptr++)) + { + if (c == '\\') + switch (c = *lexptr++) + { + case '\0': + error ("non-terminated string literal"); + case '\n': + continue; + case '0': + case 'f': + case 'n': + case 'r': + case 't': + case 'a': + case 'v': + break; + } + } + return; + case '0': + case '1': + case '2': + case '3': + case '4': + case '5': + case '6': + case '7': + case '8': + case '9': + case '.': + case '-': + case '+': + num: + { + str.ptr = lexptr - 1; + scm_read_token (c, 0); + if (!skipping) + { + svalue = scm_istring2number (str.ptr, lexptr - str.ptr, 10); + if (svalue != SCM_BOOL_F) + goto handle_immediate; + goto tok; + } + } + return; + case ':': + scm_read_token ('-', 0); + return; +#if 0 + do_symbol: +#endif + default: + str.ptr = lexptr - 1; + scm_read_token (c, 0); + tok: + if (!skipping) + { + str.length = lexptr - str.ptr; + if (str.ptr[0] == '$') + { + write_dollar_variable (str); + return; + } + write_exp_elt_opcode (OP_NAME); + write_exp_string (str); + write_exp_elt_opcode (OP_NAME); + } + return; + } +handle_immediate: + if (!skipping) + { + write_exp_elt_opcode (OP_LONG); + write_exp_elt_type (builtin_type_scm); + write_exp_elt_longcst (svalue); + write_exp_elt_opcode (OP_LONG); + } +} + +int +scm_parse (void) +{ + char *start; + while (*lexptr == ' ') + lexptr++; + start = lexptr; + scm_lreadr (USE_EXPRSTRING); +#if USE_EXPRSTRING + str.length = lexptr - start; + str.ptr = start; + write_exp_elt_opcode (OP_EXPRSTRING); + write_exp_string (str); + write_exp_elt_opcode (OP_EXPRSTRING); +#endif + return 0; +} diff --git a/gdb/scm-lang.c b/gdb/scm-lang.c new file mode 100644 index 0000000..02287b8 --- /dev/null +++ b/gdb/scm-lang.c @@ -0,0 +1,283 @@ +/* Scheme/Guile language support routines for GDB, the GNU debugger. + + Copyright (C) 1995, 1996, 1998, 2000, 2001, 2002, 2003, 2004, 2005, 2007 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 2 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, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, + Boston, MA 02110-1301, USA. */ + +#include "defs.h" +#include "symtab.h" +#include "gdbtypes.h" +#include "expression.h" +#include "parser-defs.h" +#include "language.h" +#include "value.h" +#include "c-lang.h" +#include "scm-lang.h" +#include "scm-tags.h" +#include "source.h" +#include "gdb_string.h" +#include "gdbcore.h" +#include "infcall.h" + +extern void _initialize_scheme_language (void); +static struct value *evaluate_subexp_scm (struct type *, struct expression *, + int *, enum noside); +static struct value *scm_lookup_name (char *); +static int in_eval_c (void); + +struct type *builtin_type_scm; + +void +scm_printchar (int c, struct ui_file *stream) +{ + fprintf_filtered (stream, "#\\%c", c); +} + +static void +scm_printstr (struct ui_file *stream, const gdb_byte *string, + unsigned int length, int width, int force_ellipses) +{ + fprintf_filtered (stream, "\"%s\"", string); +} + +int +is_scmvalue_type (struct type *type) +{ + if (TYPE_NAME (type) && strcmp (TYPE_NAME (type), "SCM") == 0) + { + return 1; + } + return 0; +} + +/* Get the INDEX'th SCM value, assuming SVALUE is the address + of the 0'th one. */ + +LONGEST +scm_get_field (LONGEST svalue, int index) +{ + gdb_byte buffer[20]; + read_memory (SCM2PTR (svalue) + index * TYPE_LENGTH (builtin_type_scm), + buffer, TYPE_LENGTH (builtin_type_scm)); + return extract_signed_integer (buffer, TYPE_LENGTH (builtin_type_scm)); +} + +/* Unpack a value of type TYPE in buffer VALADDR as an integer + (if CONTEXT == TYPE_CODE_IN), a pointer (CONTEXT == TYPE_CODE_PTR), + or Boolean (CONTEXT == TYPE_CODE_BOOL). */ + +LONGEST +scm_unpack (struct type *type, const gdb_byte *valaddr, enum type_code context) +{ + if (is_scmvalue_type (type)) + { + LONGEST svalue = extract_signed_integer (valaddr, TYPE_LENGTH (type)); + if (context == TYPE_CODE_BOOL) + { + if (svalue == SCM_BOOL_F) + return 0; + else + return 1; + } + switch (7 & (int) svalue) + { + case 2: + case 6: /* fixnum */ + return svalue >> 2; + case 4: /* other immediate value */ + if (SCM_ICHRP (svalue)) /* character */ + return SCM_ICHR (svalue); + else if (SCM_IFLAGP (svalue)) + { + switch ((int) svalue) + { +#ifndef SICP + case SCM_EOL: +#endif + case SCM_BOOL_F: + return 0; + case SCM_BOOL_T: + return 1; + } + } + error (_("Value can't be converted to integer.")); + default: + return svalue; + } + } + else + return unpack_long (type, valaddr); +} + +/* True if we're correctly in Guile's eval.c (the evaluator and apply). */ + +static int +in_eval_c (void) +{ + struct symtab_and_line cursal = get_current_source_symtab_and_line (); + + if (cursal.symtab && cursal.symtab->filename) + { + char *filename = cursal.symtab->filename; + int len = strlen (filename); + if (len >= 6 && strcmp (filename + len - 6, "eval.c") == 0) + return 1; + } + return 0; +} + +/* Lookup a value for the variable named STR. + First lookup in Scheme context (using the scm_lookup_cstr inferior + function), then try lookup_symbol for compiled variables. */ + +static struct value * +scm_lookup_name (char *str) +{ + struct value *args[3]; + int len = strlen (str); + struct value *func; + struct value *val; + struct symbol *sym; + args[0] = value_allocate_space_in_inferior (len); + args[1] = value_from_longest (builtin_type_int, len); + write_memory (value_as_long (args[0]), (gdb_byte *) str, len); + + if (in_eval_c () + && (sym = lookup_symbol ("env", + expression_context_block, + VAR_DOMAIN, (int *) NULL, + (struct symtab **) NULL)) != NULL) + args[2] = value_of_variable (sym, expression_context_block); + else + /* FIXME in this case, we should try lookup_symbol first */ + args[2] = value_from_longest (builtin_type_scm, SCM_EOL); + + func = find_function_in_inferior ("scm_lookup_cstr"); + val = call_function_by_hand (func, 3, args); + if (!value_logical_not (val)) + return value_ind (val); + + sym = lookup_symbol (str, + expression_context_block, + VAR_DOMAIN, (int *) NULL, + (struct symtab **) NULL); + if (sym) + return value_of_variable (sym, NULL); + error (_("No symbol \"%s\" in current context."), str); +} + +struct value * +scm_evaluate_string (char *str, int len) +{ + struct value *func; + struct value *addr = value_allocate_space_in_inferior (len + 1); + LONGEST iaddr = value_as_long (addr); + write_memory (iaddr, (gdb_byte *) str, len); + /* FIXME - should find and pass env */ + write_memory (iaddr + len, (gdb_byte *) "", 1); + func = find_function_in_inferior ("scm_evstr"); + return call_function_by_hand (func, 1, &addr); +} + +static struct value * +evaluate_exp (struct type *expect_type, struct expression *exp, + int *pos, enum noside noside) +{ + enum exp_opcode op = exp->elts[*pos].opcode; + int len, pc; + char *str; + switch (op) + { + case OP_NAME: + pc = (*pos)++; + len = longest_to_int (exp->elts[pc + 1].longconst); + (*pos) += 3 + BYTES_TO_EXP_ELEM (len + 1); + if (noside == EVAL_SKIP) + goto nosideret; + str = &exp->elts[pc + 2].string; + return scm_lookup_name (str); + case OP_STRING: + pc = (*pos)++; + len = longest_to_int (exp->elts[pc + 1].longconst); + (*pos) += 3 + BYTES_TO_EXP_ELEM (len + 1); + if (noside == EVAL_SKIP) + goto nosideret; + str = &exp->elts[pc + 2].string; + return scm_evaluate_string (str, len); + default:; + } + return evaluate_subexp_standard (expect_type, exp, pos, noside); +nosideret: + return value_from_longest (builtin_type_long, (LONGEST) 1); +} + +const struct exp_descriptor exp_descriptor_scm = +{ + print_subexp_standard, + operator_length_standard, + op_name_standard, + dump_subexp_body_standard, + evaluate_exp +}; + +const struct language_defn scm_language_defn = +{ + "scheme", /* Language name */ + language_scm, + NULL, + range_check_off, + type_check_off, + case_sensitive_off, + array_row_major, + &exp_descriptor_scm, + scm_parse, + c_error, + null_post_parser, + scm_printchar, /* Print a character constant */ + scm_printstr, /* Function to print string constant */ + NULL, /* Function to print a single character */ + NULL, /* Create fundamental type in this language */ + c_print_type, /* Print a type using appropriate syntax */ + scm_val_print, /* Print a value using appropriate syntax */ + scm_value_print, /* Print a top-level value */ + NULL, /* Language specific skip_trampoline */ + value_of_this, /* value_of_this */ + basic_lookup_symbol_nonlocal, /* lookup_symbol_nonlocal */ + basic_lookup_transparent_type,/* lookup_transparent_type */ + NULL, /* Language specific symbol demangler */ + NULL, /* Language specific class_name_from_physname */ + NULL, /* expression operators for printing */ + 1, /* c-style arrays */ + 0, /* String lower bound */ + NULL, + default_word_break_characters, + c_language_arch_info, + default_print_array_index, + LANG_MAGIC +}; + +void +_initialize_scheme_language (void) +{ + add_language (&scm_language_defn); + builtin_type_scm = + init_type (TYPE_CODE_INT, + gdbarch_long_bit (current_gdbarch) / TARGET_CHAR_BIT, + 0, "SCM", (struct objfile *) NULL); +} diff --git a/gdb/scm-lang.h b/gdb/scm-lang.h new file mode 100644 index 0000000..2507566 --- /dev/null +++ b/gdb/scm-lang.h @@ -0,0 +1,72 @@ +/* Scheme/Guile language support routines for GDB, the GNU debugger. + + Copyright (C) 1995, 1996, 1998, 1999, 2000, 2003, 2005 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 2 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, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, + Boston, MA 02110-1301, USA. */ + +#define SICP +#include "scm-tags.h" +#undef SCM_NCELLP +#define SCM_NCELLP(x) ((SCM_SIZE-1) & (int)(x)) +#define SCM_ITAG8_DATA(X) ((X)>>8) +#define SCM_ICHR(x) ((unsigned char)SCM_ITAG8_DATA(x)) +#define SCM_ICHRP(x) (SCM_ITAG8(x) == scm_tc8_char) +#define scm_tc8_char 0xf4 +#define SCM_IFLAGP(n) ((0x87 & (int)(n))==4) +#define SCM_ISYMNUM(n) ((int)((n)>>9)) +#define SCM_ISYMCHARS(n) (scm_isymnames[SCM_ISYMNUM(n)]) +#define SCM_ILOCP(n) ((0xff & (int)(n))==0xfc) +#define SCM_ITAG8(X) ((int)(X) & 0xff) +#define SCM_TYP7(x) (0x7f & (int)SCM_CAR(x)) +#define SCM_LENGTH(x) (((unsigned long)SCM_CAR(x))>>8) +#define SCM_NCONSP(x) (1 & (int)SCM_CAR(x)) +#define SCM_NECONSP(x) (SCM_NCONSP(x) && (1 != SCM_TYP3(x))) +#define SCM_CAR(x) scm_get_field (x, 0) +#define SCM_CDR(x) scm_get_field (x, 1) +#define SCM_VELTS(x) ((SCM *)SCM_CDR(x)) +#define SCM_CLOSCAR(x) (SCM_CAR(x)-scm_tc3_closure) +#define SCM_CODE(x) SCM_CAR(SCM_CLOSCAR (x)) +#define SCM_MAKINUM(x) (((x)<<2)+2L) + +/* Forward decls for prototypes */ +struct value; + +extern int scm_value_print (struct value *, struct ui_file *, + int, enum val_prettyprint); + +extern int scm_val_print (struct type *, const gdb_byte *, int, CORE_ADDR, + struct ui_file *, int, int, int, + enum val_prettyprint); + +extern LONGEST scm_get_field (LONGEST, int); + +extern void scm_scmval_print (LONGEST, struct ui_file *, int, int, int, + enum val_prettyprint); + +extern int is_scmvalue_type (struct type *); + +extern void scm_printchar (int, struct ui_file *); + +extern struct value *scm_evaluate_string (char *, int); + +extern struct type *builtin_type_scm; + +extern int scm_parse (void); + +extern LONGEST scm_unpack (struct type *, const gdb_byte *, enum type_code); diff --git a/gdb/scm-tags.h b/gdb/scm-tags.h new file mode 100644 index 0000000..3d4e7cf --- /dev/null +++ b/gdb/scm-tags.h @@ -0,0 +1,380 @@ +/* This is a minimally edited version of Guile's tags.h. */ +/* classes: h_files */ + +#ifndef TAGSH +#define TAGSH +/* Copyright (C) 1995, 1999 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 2, 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, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, + * Boston, MA 02110-1301, USA. + * + * As a special exception, the Free Software Foundation gives permission + * for additional uses of the text contained in its release of GUILE. + * + * The exception is that, if you link the GUILE library with other files + * to produce an executable, this does not by itself cause the + * resulting executable to be covered by the GNU General Public License. + * Your use of that executable is in no way restricted on account of + * linking the GUILE library code into it. + * + * This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU General Public License. + * + * This exception applies only to the code released by the + * Free Software Foundation under the name GUILE. If you copy + * code from other Free Software Foundation releases into a copy of + * GUILE, as the General Public License permits, the exception does + * not apply to the code that you add in this way. To avoid misleading + * anyone as to the status of such modified files, you must delete + * this exception notice from them. + * + * If you write modifications of your own for GUILE, it is your choice + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. + */ + + +/** This file defines the format of SCM values and cons pairs. + ** It is here that tag bits are assigned for various purposes. + **/ + + +/* Three Bit Tags + + * 000 -- a non-immediate value. Points into the pair heap. + * + * 001 -- a gloc (i.e., a resolved global variable in a CAR in a code graph) + * or the CAR of an object handle (i.e., the tagged pointer to the + * vtable part of a user-defined object). + * + * If X has this tag, the value at CDAR(X - 1) distinguishes + * glocs from object handles. The distinction only needs + * to be made in a few places. Only a few parts of the code know + * about glocs. In most cases, when a value in the CAR of a pair + * has the tag 001, it means that the pair is an object handle. + * + * 010 -- the tag for immediate, exact integers. + * + * 011 -- in the CAR of a pair, this tag indicates that the pair is a closure. + * The remaining bits of the CAR are a pointer into the pair heap + * to the code graph for the closure. + * + * 1xy -- an extension tag which means that there is a five or six bit + * tag to the left of the low three bits. See the nice diagrams + * in ../doc/code.doc if you want to know what the bits mean. + */ + + + + + +#define scm_tc3_cons 0 +#define scm_tc3_cons_gloc 1 +#define scm_tc3_closure 3 + +#define scm_tc7_ssymbol 5 +#define scm_tc7_msymbol 7 +#define scm_tc7_string 13 +#define scm_tc7_bvect 15 +#define scm_tc7_vector 21 +#define scm_tc7_lvector 23 +#define scm_tc7_ivect 29 +#define scm_tc7_uvect 31 +/* spare 37 39 */ +#define scm_tc7_fvect 45 +#define scm_tc7_dvect 47 +#define scm_tc7_cvect 53 +#define scm_tc7_port 55 +#define scm_tc7_contin 61 +#define scm_tc7_cclo 63 +/* spare 69 71 77 79 */ +#define scm_tc7_subr_0 85 +#define scm_tc7_subr_1 87 +#define scm_tc7_cxr 93 +#define scm_tc7_subr_3 95 +#define scm_tc7_subr_2 101 +#define scm_tc7_asubr 103 +#define scm_tc7_subr_1o 109 +#define scm_tc7_subr_2o 111 +#define scm_tc7_lsubr_2 117 +#define scm_tc7_lsubr 119 +#define scm_tc7_rpsubr 125 + +#define scm_tc7_smob 127 +#define scm_tc_free_cell 127 + +#define scm_tc16_flo 0x017f +#define scm_tc_flo 0x017fL + +#define SCM_REAL_PART (1L<<16) +#define SCM_IMAG_PART (2L<<16) +#define scm_tc_dblr (scm_tc16_flo|REAL_PART) +#define scm_tc_dblc (scm_tc16_flo|REAL_PART|IMAG_PART) + +#define scm_tc16_bigpos 0x027f +#define scm_tc16_bigneg 0x037f + +#define scm_tc16_fport (scm_tc7_port + 0*256L) +#define scm_tc16_pipe (scm_tc7_port + 1*256L) +#define scm_tc16_strport (scm_tc7_port + 2*256L) +#define scm_tc16_sfport (scm_tc7_port + 3*256L) + + + +/* For cons pairs with immediate values in the CAR */ +#define scm_tcs_cons_imcar 2:case 4:case 6:case 10:\ + case 12:case 14:case 18:case 20:\ + case 22:case 26:case 28:case 30:\ + case 34:case 36:case 38:case 42:\ + case 44:case 46:case 50:case 52:\ + case 54:case 58:case 60:case 62:\ + case 66:case 68:case 70:case 74:\ + case 76:case 78:case 82:case 84:\ + case 86:case 90:case 92:case 94:\ + case 98:case 100:case 102:case 106:\ + case 108:case 110:case 114:case 116:\ + case 118:case 122:case 124:case 126 + +/* For cons pairs with non-immediate values in the CAR */ +#define scm_tcs_cons_nimcar 0:case 8:case 16:case 24:\ + case 32:case 40:case 48:case 56:\ + case 64:case 72:case 80:case 88:\ + case 96:case 104:case 112:case 120 + +/* A CONS_GLOC occurs in code. It's CAR is a pointer to the + * CDR of a variable. The low order bits of the CAR are 001. + * The CDR of the gloc is the code continuation. + */ +#define scm_tcs_cons_gloc 1:case 9:case 17:case 25:\ + case 33:case 41:case 49:case 57:\ + case 65:case 73:case 81:case 89:\ + case 97:case 105:case 113:case 121 + +#define scm_tcs_closures 3:case 11:case 19:case 27:\ + case 35:case 43:case 51:case 59:\ + case 67:case 75:case 83:case 91:\ + case 99:case 107:case 115:case 123 + +#define scm_tcs_subrs scm_tc7_asubr:case scm_tc7_subr_0:case scm_tc7_subr_1:case scm_tc7_cxr:\ + case scm_tc7_subr_3:case scm_tc7_subr_2:case scm_tc7_rpsubr:case scm_tc7_subr_1o:\ + case scm_tc7_subr_2o:case scm_tc7_lsubr_2:case scm_tc7_lsubr + +#define scm_tcs_symbols scm_tc7_ssymbol:case scm_tc7_msymbol + +#define scm_tcs_bignums tc16_bigpos:case tc16_bigneg + + + +/* References to objects are of type SCM. Values may be non-immediate + * (pointers) or immediate (encoded, immutable, scalar values that fit + * in an SCM variable). + */ + +typedef long SCM; + +/* Cray machines have pointers that are incremented once for each word, + * rather than each byte, the 3 most significant bits encode the byte + * within the word. The following macros deal with this by storing the + * native Cray pointers like the ones that looks like scm expects. This + * is done for any pointers that might appear in the car of a scm_cell, pointers + * to scm_vector elts, functions, &c are not munged. + */ +#ifdef _UNICOS +#define SCM2PTR(x) ((int)(x) >> 3) +#define PTR2SCM(x) (((SCM)(x)) << 3) +#define SCM_POINTERS_MUNGED +#else +#define SCM2PTR(x) (x) +#define PTR2SCM(x) ((SCM)(x)) +#endif /* def _UNICOS */ + + + +/* Immediate? Predicates + */ +#define SCM_IMP(x) (6 & (int)(x)) +#define SCM_NIMP(x) (!SCM_IMP(x)) + + + +enum scm_tags + { + scm_tc8_char = 0xf4 + }; + +#define SCM_ITAG8(X) ((int)(X) & 0xff) +#define SCM_MAKE_ITAG8(X, TAG) (((X)<<8) + TAG) +#define SCM_ITAG8_DATA(X) ((X)>>8) + + + +/* Local Environment Structure + */ +#define SCM_ILOCP(n) ((0xff & (int)(n))==0xfc) +#define SCM_ILOC00 (0x000000fcL) +#define SCM_IDINC (0x00100000L) +#define SCM_ICDR (0x00080000L) +#define SCM_IFRINC (0x00000100L) +#define SCM_IDSTMSK (-SCM_IDINC) +#define SCM_IFRAME(n) ((int)((SCM_ICDR-SCM_IFRINC)>>8) & ((int)(n)>>8)) +#define SCM_IDIST(n) (((unsigned long)(n))>>20) +#define SCM_ICDRP(n) (SCM_ICDR & (n)) + + +/* Immediate Symbols, Special Symbols, Flags (various constants). + */ + +/* ISYMP tests for ISPCSYM and ISYM */ +#define SCM_ISYMP(n) ((0x187 & (int)(n))==4) + +/* IFLAGP tests for ISPCSYM, ISYM and IFLAG */ +#define SCM_IFLAGP(n) ((0x87 & (int)(n))==4) +#define SCM_ISYMNUM(n) ((int)((n)>>9)) +#define SCM_ISYMCHARS(n) (scm_isymnames[SCM_ISYMNUM(n)]) +#define SCM_MAKSPCSYM(n) (((n)<<9)+((n)<<3)+4L) +#define SCM_MAKISYM(n) (((n)<<9)+0x74L) +#define SCM_MAKIFLAG(n) (((n)<<9)+0x174L) + +/* This table must agree with the declarations + * in repl.c: {Names of immediate symbols}. + * + * These are used only in eval but their values + * have to be allocated here. + * + */ + +#define SCM_IM_AND SCM_MAKSPCSYM(0) +#define SCM_IM_BEGIN SCM_MAKSPCSYM(1) +#define SCM_IM_CASE SCM_MAKSPCSYM(2) +#define SCM_IM_COND SCM_MAKSPCSYM(3) +#define SCM_IM_DO SCM_MAKSPCSYM(4) +#define SCM_IM_IF SCM_MAKSPCSYM(5) +#define SCM_IM_LAMBDA SCM_MAKSPCSYM(6) +#define SCM_IM_LET SCM_MAKSPCSYM(7) +#define SCM_IM_LETSTAR SCM_MAKSPCSYM(8) +#define SCM_IM_LETREC SCM_MAKSPCSYM(9) +#define SCM_IM_OR SCM_MAKSPCSYM(10) +#define SCM_IM_QUOTE SCM_MAKSPCSYM(11) +#define SCM_IM_SET SCM_MAKSPCSYM(12) +#define SCM_IM_DEFINE SCM_MAKSPCSYM(13) +#define SCM_IM_APPLY SCM_MAKISYM(14) +#define SCM_IM_CONT SCM_MAKISYM(15) +#define SCM_NUM_ISYMS 16 + +/* Important immediates + */ + +#define SCM_BOOL_F SCM_MAKIFLAG(SCM_NUM_ISYMS+0) +#define SCM_BOOL_T SCM_MAKIFLAG(SCM_NUM_ISYMS+1) +#define SCM_UNDEFINED SCM_MAKIFLAG(SCM_NUM_ISYMS+2) +#define SCM_EOF_VAL SCM_MAKIFLAG(SCM_NUM_ISYMS+3) + +#ifdef SICP +#define SCM_EOL SCM_BOOL_F +#else +#define SCM_EOL SCM_MAKIFLAG(SCM_NUM_ISYMS+4) +#endif + +#define SCM_UNSPECIFIED SCM_MAKIFLAG(SCM_NUM_ISYMS+5) + + + +/* Heap Pairs and the Empty List Predicates + */ +#define SCM_NULLP(x) (SCM_EOL == (x)) +#define SCM_NNULLP(x) (SCM_EOL != (x)) +#define SCM_CELLP(x) (!SCM_NCELLP(x)) +#define SCM_NCELLP(x) ((sizeof(scm_cell)-1) & (int)(x)) + + + +#define SCM_UNBNDP(x) (SCM_UNDEFINED==(x)) + + + +/* Testing and Changing GC Marks in Various Standard Positions + */ +#define SCM_GCMARKP(x) (1 & (int)SCM_CDR(x)) +#define SCM_GC8MARKP(x) (0x80 & (int)SCM_CAR(x)) +#define SCM_SETGCMARK(x) (SCM_CDR(x) |= 1) +#define SCM_CLRGCMARK(x) (SCM_CDR(x) &= ~1L) +#define SCM_SETGC8MARK(x) (SCM_CAR(x) |= 0x80) +#define SCM_CLRGC8MARK(x) (SCM_CAR(x) &= ~0x80L) + + +/* Extracting Tag Bits, With or Without GC Safety and Optional Bits + */ +#define SCM_TYP3(x) (7 & (int)SCM_CAR(x)) +#define SCM_TYP7(x) (0x7f & (int)SCM_CAR(x)) +#define SCM_TYP7S(x) (0x7d & (int)SCM_CAR(x)) +#define SCM_TYP16(x) (0xffff & (int)SCM_CAR(x)) +#define SCM_TYP16S(x) (0xfeff & (int)SCM_CAR(x)) +#define SCM_GCTYP16(x) (0xff7f & (int)SCM_CAR(x)) + + +/* Two slightly extensible types: smobs and ptobs. + + */ +#define SCM_SMOBNUM(x) (0x0ff & (CAR(x)>>8)); +#define SCM_PTOBNUM(x) (0x0ff & (CAR(x)>>8)); + + + + +#define SCM_DIRP(x) (SCM_NIMP(x) && (TYP16(x)==(scm_tc16_dir))) +#define SCM_OPDIRP(x) (SCM_NIMP(x) && (CAR(x)==(scm_tc16_dir | OPN))) + + + +/* Lvectors + */ +#define SCM_LVECTORP(x) (TYP7(x)==tc7_lvector) + + +#if 0 + +/* Sockets + */ +#define tc_socket (tc7_port | OPN) +#define SCM_SOCKP(x) (((0x7f | OPN | RDNG | WRTNG) & CAR(x))==(tc_socket)) +#define SCM_SOCKTYP(x) (CAR(x)>>24) + + + +extern int scm_tc16_key_vector; +#define SCM_KEYVECP(X) (scm_tc16_key_vector == TYP16 (X)) +#define SCM_KEYVECLEN(OBJ) (((unsigned long)CAR (obj)) >> 16) + + +#define SCM_MALLOCDATA(obj) ((char *)CDR(obj)) +#define SCM_MALLOCLEN(obj) (((unsigned long)CAR (obj)) >> 16) +#define SCM_WORDDATA(obj) (CDR (obj)) + + +#define SCM_BYTECODEP(X) ((TYP7 (X) == tc7_cclo) && (CCLO_SUBR (X) == rb_proc)) +#define SCM_BYTECODE_CONSTANTS(X) (VELTS(X)[1]) +#define SCM_BYTECODE_CODE(X) (VELTS(X)[2]) +#define SCM_BYTECODE_NAME(X) (VELTS(X)[3]) +#define SCM_BYTECODE_BCODE(X) (VELTS(X)[4]) +#define SCM_BYTECODE_ELTS 5 + + +#define SCM_FREEP(x) (CAR(x)==tc_free_cell) +#define SCM_NFREEP(x) (!FREEP(x)) + +#endif /* 0 */ + + +#endif /* TAGSH */ diff --git a/gdb/scm-valprint.c b/gdb/scm-valprint.c new file mode 100644 index 0000000..57f04e1 --- /dev/null +++ b/gdb/scm-valprint.c @@ -0,0 +1,438 @@ +/* Scheme/Guile language support routines for GDB, the GNU debugger. + + Copyright (C) 1995, 1996, 1998, 1999, 2000, 2001, 2005, 2007 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 2 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, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, + Boston, MA 02110-1301, USA. */ + +#include "defs.h" +#include "symtab.h" +#include "gdbtypes.h" +#include "expression.h" +#include "parser-defs.h" +#include "language.h" +#include "value.h" +#include "scm-lang.h" +#include "valprint.h" +#include "gdbcore.h" +#include "c-lang.h" +#include "infcall.h" + +static void scm_ipruk (char *, LONGEST, struct ui_file *); +static void scm_scmlist_print (LONGEST, struct ui_file *, int, int, + int, enum val_prettyprint); +static int scm_inferior_print (LONGEST, struct ui_file *, int, int, + int, enum val_prettyprint); + +/* Prints the SCM value VALUE by invoking the inferior, if appropraite. + Returns >= 0 on success; return -1 if the inferior cannot/should not + print VALUE. */ + +static int +scm_inferior_print (LONGEST value, struct ui_file *stream, int format, + int deref_ref, int recurse, enum val_prettyprint pretty) +{ + struct value *func, *arg, *result; + struct symbol *gdb_output_sym, *gdb_output_len_sym; + char *output; + int ret, output_len; + + func = find_function_in_inferior ("gdb_print"); + arg = value_from_longest (builtin_type_CORE_ADDR, value); + + result = call_function_by_hand (func, 1, &arg); + ret = (int) value_as_long (result); + if (ret == 0) + { + /* XXX: Should we cache these symbols? */ + gdb_output_sym = + lookup_symbol_global ("gdb_output", NULL, NULL, + VAR_DOMAIN, + (struct symtab **) NULL); + gdb_output_len_sym = + lookup_symbol_global ("gdb_output_length", NULL, NULL, + VAR_DOMAIN, + (struct symtab **) NULL); + + if ((gdb_output_sym == NULL) || (gdb_output_len_sym == NULL)) + ret = -1; + else + { + struct value *remote_buffer; + + read_memory (SYMBOL_VALUE_ADDRESS (gdb_output_len_sym), + (char *) &output_len, sizeof (output_len)); + + output = (char *) alloca (output_len); + remote_buffer = value_at (builtin_type_CORE_ADDR, + SYMBOL_VALUE_ADDRESS (gdb_output_sym)); + read_memory (value_as_address (remote_buffer), + output, output_len); + + ui_file_write (stream, output, output_len); + } + } + + return ret; +} + +/* {Names of immediate symbols} + * This table must agree with the declarations in scm.h: {Immediate Symbols}.*/ + +static char *scm_isymnames[] = +{ + /* This table must agree with the declarations */ + "and", + "begin", + "case", + "cond", + "do", + "if", + "lambda", + "let", + "let*", + "letrec", + "or", + "quote", + "set!", + "define", +#if 0 + "literal-variable-ref", + "literal-variable-set!", +#endif + "apply", + "call-with-current-continuation", + + /* user visible ISYMS */ + /* other keywords */ + /* Flags */ + + "#f", + "#t", + "#<undefined>", + "#<eof>", + "()", + "#<unspecified>" +}; + +static void +scm_scmlist_print (LONGEST svalue, struct ui_file *stream, int format, + int deref_ref, int recurse, enum val_prettyprint pretty) +{ + unsigned int more = print_max; + if (recurse > 6) + { + fputs_filtered ("...", stream); + return; + } + scm_scmval_print (SCM_CAR (svalue), stream, format, + deref_ref, recurse + 1, pretty); + svalue = SCM_CDR (svalue); + for (; SCM_NIMP (svalue); svalue = SCM_CDR (svalue)) + { + if (SCM_NECONSP (svalue)) + break; + fputs_filtered (" ", stream); + if (--more == 0) + { + fputs_filtered ("...", stream); + return; + } + scm_scmval_print (SCM_CAR (svalue), stream, format, + deref_ref, recurse + 1, pretty); + } + if (SCM_NNULLP (svalue)) + { + fputs_filtered (" . ", stream); + scm_scmval_print (svalue, stream, format, + deref_ref, recurse + 1, pretty); + } +} + +static void +scm_ipruk (char *hdr, LONGEST ptr, struct ui_file *stream) +{ + fprintf_filtered (stream, "#<unknown-%s", hdr); +#define SCM_SIZE TYPE_LENGTH (builtin_type_scm) + if (SCM_CELLP (ptr)) + fprintf_filtered (stream, " (0x%lx . 0x%lx) @", + (long) SCM_CAR (ptr), (long) SCM_CDR (ptr)); + fprintf_filtered (stream, " 0x%s>", paddr_nz (ptr)); +} + +void +scm_scmval_print (LONGEST svalue, struct ui_file *stream, int format, + int deref_ref, int recurse, enum val_prettyprint pretty) +{ +taloop: + switch (7 & (int) svalue) + { + case 2: + case 6: + print_longest (stream, format ? format : 'd', 1, svalue >> 2); + break; + case 4: + if (SCM_ICHRP (svalue)) + { + svalue = SCM_ICHR (svalue); + scm_printchar (svalue, stream); + break; + } + else if (SCM_IFLAGP (svalue) + && (SCM_ISYMNUM (svalue) + < (sizeof scm_isymnames / sizeof (char *)))) + { + fputs_filtered (SCM_ISYMCHARS (svalue), stream); + break; + } + else if (SCM_ILOCP (svalue)) + { + fprintf_filtered (stream, "#@%ld%c%ld", + (long) SCM_IFRAME (svalue), + SCM_ICDRP (svalue) ? '-' : '+', + (long) SCM_IDIST (svalue)); + break; + } + else + goto idef; + break; + case 1: + /* gloc */ + svalue = SCM_CAR (svalue - 1); + goto taloop; + default: + idef: + scm_ipruk ("immediate", svalue, stream); + break; + case 0: + + switch (SCM_TYP7 (svalue)) + { + case scm_tcs_cons_gloc: + if (SCM_CDR (SCM_CAR (svalue) - 1L) == 0) + { +#if 0 + SCM name; +#endif + fputs_filtered ("#<latte ", stream); +#if 1 + fputs_filtered ("???", stream); +#else + name = ((SCM n *) (STRUCT_TYPE (exp)))[struct_i_name]; + scm_lfwrite (CHARS (name), + (sizet) sizeof (char), + (sizet) LENGTH (name), + port); +#endif + fprintf_filtered (stream, " #X%s>", paddr_nz (svalue)); + break; + } + case scm_tcs_cons_imcar: + case scm_tcs_cons_nimcar: + fputs_filtered ("(", stream); + scm_scmlist_print (svalue, stream, format, + deref_ref, recurse + 1, pretty); + fputs_filtered (")", stream); + break; + case scm_tcs_closures: + fputs_filtered ("#<CLOSURE ", stream); + scm_scmlist_print (SCM_CODE (svalue), stream, format, + deref_ref, recurse + 1, pretty); + fputs_filtered (">", stream); + break; + case scm_tc7_string: + { + int len = SCM_LENGTH (svalue); + CORE_ADDR addr = (CORE_ADDR) SCM_CDR (svalue); + int i; + int done = 0; + int buf_size; + gdb_byte buffer[64]; + int truncate = print_max && len > (int) print_max; + if (truncate) + len = print_max; + fputs_filtered ("\"", stream); + for (; done < len; done += buf_size) + { + buf_size = min (len - done, 64); + read_memory (addr + done, buffer, buf_size); + + for (i = 0; i < buf_size; ++i) + switch (buffer[i]) + { + case '\"': + case '\\': + fputs_filtered ("\\", stream); + default: + fprintf_filtered (stream, "%c", buffer[i]); + } + } + fputs_filtered (truncate ? "...\"" : "\"", stream); + break; + } + break; + case scm_tcs_symbols: + { + int len = SCM_LENGTH (svalue); + + char *str = alloca (len); + read_memory (SCM_CDR (svalue), (gdb_byte *) str, len + 1); + /* Should handle weird characters FIXME */ + str[len] = '\0'; + fputs_filtered (str, stream); + break; + } + case scm_tc7_vector: + { + int len = SCM_LENGTH (svalue); + int i; + LONGEST elements = SCM_CDR (svalue); + fputs_filtered ("#(", stream); + for (i = 0; i < len; ++i) + { + if (i > 0) + fputs_filtered (" ", stream); + scm_scmval_print (scm_get_field (elements, i), stream, format, + deref_ref, recurse + 1, pretty); + } + fputs_filtered (")", stream); + } + break; +#if 0 + case tc7_lvector: + { + SCM result; + SCM hook; + hook = scm_get_lvector_hook (exp, LV_PRINT_FN); + if (hook == BOOL_F) + { + scm_puts ("#<locked-vector ", port); + scm_intprint (CDR (exp), 16, port); + scm_puts (">", port); + } + else + { + result + = scm_apply (hook, + scm_listify (exp, port, + (writing ? BOOL_T : BOOL_F), + SCM_UNDEFINED), + EOL); + if (result == BOOL_F) + goto punk; + } + break; + } + break; + case tc7_bvect: + case tc7_ivect: + case tc7_uvect: + case tc7_fvect: + case tc7_dvect: + case tc7_cvect: + scm_raprin1 (exp, port, writing); + break; +#endif + case scm_tcs_subrs: + { + int index = SCM_CAR (svalue) >> 8; +#if 1 + char str[20]; + sprintf (str, "#%d", index); +#else + char *str = index ? SCM_CHARS (scm_heap_org + index) : ""; +#define SCM_CHARS(x) ((char *)(SCM_CDR(x))) + char *str = CHARS (SNAME (exp)); +#endif + fprintf_filtered (stream, "#<primitive-procedure %s>", + str); + } + break; +#if 0 +#ifdef CCLO + case tc7_cclo: + scm_puts ("#<compiled-closure ", port); + scm_iprin1 (CCLO_SUBR (exp), port, writing); + scm_putc ('>', port); + break; +#endif + case tc7_contin: + fprintf_filtered (stream, "#<continuation %d @ #X%lx >", + LENGTH (svalue), + (long) CHARS (svalue)); + break; + case tc7_port: + i = PTOBNUM (exp); + if (i < scm_numptob + && scm_ptobs[i].print + && (scm_ptobs[i].print) (exp, port, writing)) + break; + goto punk; + case tc7_smob: + i = SMOBNUM (exp); + if (i < scm_numsmob && scm_smobs[i].print + && (scm_smobs[i].print) (exp, port, writing)) + break; + goto punk; +#endif + default: +#if 0 + punk: +#endif + scm_ipruk ("type", svalue, stream); + } + break; + } +} + +int +scm_val_print (struct type *type, const gdb_byte *valaddr, + int embedded_offset, CORE_ADDR address, + struct ui_file *stream, int format, int deref_ref, + int recurse, enum val_prettyprint pretty) +{ + if (is_scmvalue_type (type)) + { + LONGEST svalue = extract_signed_integer (valaddr, TYPE_LENGTH (type)); + + if (scm_inferior_print (svalue, stream, format, + deref_ref, recurse, pretty) >= 0) + { + } + else + { + scm_scmval_print (svalue, stream, format, + deref_ref, recurse, pretty); + } + + gdb_flush (stream); + return (0); + } + else + { + return c_val_print (type, valaddr, 0, address, stream, format, + deref_ref, recurse, pretty); + } +} + +int +scm_value_print (struct value *val, struct ui_file *stream, int format, + enum val_prettyprint pretty) +{ + return (common_val_print (val, stream, format, 1, 0, pretty)); +} |