diff options
Diffstat (limited to 'gdb/scm-valprint.c')
| -rw-r--r-- | gdb/scm-valprint.c | 422 |
1 files changed, 422 insertions, 0 deletions
diff --git a/gdb/scm-valprint.c b/gdb/scm-valprint.c new file mode 100644 index 00000000000..71acc69d351 --- /dev/null +++ b/gdb/scm-valprint.c @@ -0,0 +1,422 @@ +/* Scheme/Guile language support routines for GDB, the GNU debugger. + Copyright 1995 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., 59 Temple Place - Suite 330, Boston, MA 02111-1307, 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" + +/* FIXME: Should be in a header file that we import. */ +extern int +c_val_print PARAMS ((struct type *, char *, int, CORE_ADDR, GDB_FILE *, int, int, + int, enum val_prettyprint)); + +static void scm_ipruk PARAMS ((char *, LONGEST, GDB_FILE *)); +static void scm_scmlist_print PARAMS ((LONGEST, GDB_FILE *, int, int, + int, enum val_prettyprint)); +static int scm_inferior_print PARAMS ((LONGEST, GDB_FILE *, int, int, + int, enum val_prettyprint)); + +/* Prints the SCM value VALUE by invoking the inferior, if appropraite. + Returns >= 0 on succes; retunr -1 if the inferior cannot/should not + print VALUE. */ + +static int +scm_inferior_print (value, stream, format, deref_ref, recurse, pretty) + LONGEST value; + GDB_FILE *stream; + int format; + int deref_ref; + int recurse; + enum val_prettyprint pretty; +{ + return -1; +} + +/* {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 (svalue, stream, format, deref_ref, recurse, pretty) + LONGEST svalue; + GDB_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 (hdr, ptr, stream) + char *hdr; + LONGEST ptr; + GDB_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%x>", ptr); +} + +void +scm_scmval_print (svalue, stream, format, deref_ref, recurse, pretty) + LONGEST svalue; + GDB_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%lX>", 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; + char 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 = (char*) alloca (len); + read_memory (SCM_CDR (svalue), 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 (type, valaddr, embedded_offset, address, + stream, format, deref_ref, recurse, pretty) + struct type *type; + char *valaddr; + int embedded_offset; + CORE_ADDR address; + GDB_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 (val, stream, format, pretty) + value_ptr val; + GDB_FILE *stream; + int format; + enum val_prettyprint pretty; +{ + return (val_print (VALUE_TYPE (val), VALUE_CONTENTS (val), 0, + VALUE_ADDRESS (val), stream, format, 1, 0, pretty)); +} |