/* Scheme/Guile language support routines for GDB, the GNU debugger. Copyright (C) 1995, 1996, 1998, 1999, 2000, 2001, 2005, 2007, 2008, 2009, 2010 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 <http://www.gnu.org/licenses/>. */ #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" #include "objfiles.h" static void scm_ipruk (char *, struct type *, LONGEST, struct ui_file *); static void scm_scmval_print (struct type *, LONGEST, struct ui_file *, int, const struct value_print_options *); static void scm_scmlist_print (struct type *, LONGEST, struct ui_file *, int, const struct value_print_options *); static int scm_inferior_print (struct type *, LONGEST, struct ui_file *, int, const struct value_print_options *); /* 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 (struct type *type, LONGEST value, struct ui_file *stream, int recurse, const struct value_print_options *options) { 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", NULL); arg = value_from_longest (type, 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, VAR_DOMAIN); gdb_output_len_sym = lookup_symbol_global ("gdb_output_length", NULL, VAR_DOMAIN); 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 (type, 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 (struct type *type, LONGEST svalue, struct ui_file *stream, int recurse, const struct value_print_options *options) { #define SCM_SIZE (TYPE_LENGTH (type)) #define SCM_BYTE_ORDER (gdbarch_byte_order (get_type_arch (type))) unsigned int more = options->print_max; if (recurse > 6) { fputs_filtered ("...", stream); return; } scm_scmval_print (type, SCM_CAR (svalue), stream, recurse + 1, options); 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 (type, SCM_CAR (svalue), stream, recurse + 1, options); } if (SCM_NNULLP (svalue)) { fputs_filtered (" . ", stream); scm_scmval_print (type, svalue, stream, recurse + 1, options); } #undef SCM_BYTE_ORDER #undef SCM_SIZE } static void scm_ipruk (char *hdr, struct type *type, LONGEST ptr, struct ui_file *stream) { #define SCM_SIZE (TYPE_LENGTH (type)) #define SCM_BYTE_ORDER (gdbarch_byte_order (get_type_arch (type))) fprintf_filtered (stream, "#<unknown-%s", hdr); if (SCM_CELLP (ptr)) fprintf_filtered (stream, " (0x%lx . 0x%lx) @", (long) SCM_CAR (ptr), (long) SCM_CDR (ptr)); fprintf_filtered (stream, " 0x%s>", phex_nz (ptr, SCM_SIZE)); #undef SCM_BYTE_ORDER #undef SCM_SIZE } static void scm_scmval_print (struct type *type, LONGEST svalue, struct ui_file *stream, int recurse, const struct value_print_options *options) { struct gdbarch *gdbarch = get_type_arch (type); #define SCM_SIZE (TYPE_LENGTH (type)) #define SCM_BYTE_ORDER (gdbarch_byte_order (gdbarch)) taloop: switch (7 & (int) svalue) { case 2: case 6: print_longest (stream, options->format ? options->format : 'd', 1, svalue >> 2); break; case 4: if (SCM_ICHRP (svalue)) { svalue = SCM_ICHR (svalue); scm_printchar (svalue, builtin_type (gdbarch)->builtin_char, 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", type, 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>", phex_nz (svalue, SCM_SIZE)); break; } case scm_tcs_cons_imcar: case scm_tcs_cons_nimcar: fputs_filtered ("(", stream); scm_scmlist_print (type, svalue, stream, recurse + 1, options); fputs_filtered (")", stream); break; case scm_tcs_closures: fputs_filtered ("#<CLOSURE ", stream); scm_scmlist_print (type, SCM_CODE (svalue), stream, recurse + 1, options); 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 = options->print_max && len > (int) options->print_max; if (truncate) len = options->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); LONGEST val; fputs_filtered ("#(", stream); for (i = 0; i < len; ++i) { if (i > 0) fputs_filtered (" ", stream); val = scm_get_field (elements, i, SCM_SIZE, SCM_BYTE_ORDER); scm_scmval_print (type, val, stream, recurse + 1, options); } 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", type, svalue, stream); } break; } #undef SCM_BYTE_ORDER #undef SCM_SIZE } int scm_val_print (struct type *type, const gdb_byte *valaddr, int embedded_offset, CORE_ADDR address, struct ui_file *stream, int recurse, const struct value_print_options *options) { if (is_scmvalue_type (type)) { enum bfd_endian byte_order = gdbarch_byte_order (get_type_arch (type)); LONGEST svalue = extract_signed_integer (valaddr, TYPE_LENGTH (type), byte_order); if (scm_inferior_print (type, svalue, stream, recurse, options) >= 0) { } else { scm_scmval_print (type, svalue, stream, recurse, options); } gdb_flush (stream); return (0); } else { return c_val_print (type, valaddr, 0, address, stream, recurse, options); } } int scm_value_print (struct value *val, struct ui_file *stream, const struct value_print_options *options) { struct value_print_options opts = *options; opts.deref_ref = 1; return (common_val_print (val, stream, 0, &opts, current_language)); }