[deliverable/binutils-gdb.git] / gdb / scm-valprint.c

/* Scheme/Guile language support routines for GDB, the GNU debugger.

   Copyright (C) 1995, 1996, 1998, 1999, 2000, 2001, 2005, 2007, 2008, 2009
   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, NULL, VAR_DOMAIN);
      gdb_output_len_sym =
	lookup_symbol_global ("gdb_output_length", NULL, 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))
  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_SIZE
}

static void
scm_ipruk (char *hdr, struct type *type, LONGEST ptr,
	   struct ui_file *stream)
{
#define SCM_SIZE (TYPE_LENGTH (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>", paddr_nz (ptr));
#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)
{
#define SCM_SIZE (TYPE_LENGTH (type))
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 (current_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>", paddr_nz (svalue));
	      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);
	    fputs_filtered ("#(", stream);
	    for (i = 0; i < len; ++i)
	      {
		if (i > 0)
		  fputs_filtered (" ", stream);
		scm_scmval_print (type, scm_get_field (elements, i, SCM_SIZE),
				  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_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))
    {
      LONGEST svalue = extract_signed_integer (valaddr, TYPE_LENGTH (type));

      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));
}
Commit	Line	Data
d4310edb LC	1	/* Scheme/Guile language support routines for GDB, the GNU debugger.
d4310edb LC	2
0fb0cc75	3	Copyright (C) 1995, 1996, 1998, 1999, 2000, 2001, 2005, 2007, 2008, 2009
9b254dd1	4	Free Software Foundation, Inc.
d4310edb LC	5
	6	This file is part of GDB.
	7
	8	This program is free software; you can redistribute it and/or modify
	9	it under the terms of the GNU General Public License as published by
a9762ec7	10	the Free Software Foundation; either version 3 of the License, or
d4310edb LC	11	(at your option) any later version.
	12
	13	This program is distributed in the hope that it will be useful,
	14	but WITHOUT ANY WARRANTY; without even the implied warranty of
	15	MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	16	GNU General Public License for more details.
	17
	18	You should have received a copy of the GNU General Public License
a9762ec7	19	along with this program. If not, see <http://www.gnu.org/licenses/>. */
d4310edb LC	20
	21	#include "defs.h"
	22	#include "symtab.h"
	23	#include "gdbtypes.h"
	24	#include "expression.h"
	25	#include "parser-defs.h"
	26	#include "language.h"
	27	#include "value.h"
	28	#include "scm-lang.h"
	29	#include "valprint.h"
	30	#include "gdbcore.h"
	31	#include "c-lang.h"
	32	#include "infcall.h"
3e3b026f	33	#include "objfiles.h"
d4310edb	34
6ceaaae5 UW	35	static void scm_ipruk (char , struct type , LONGEST, struct ui_file *);
	36	static void scm_scmval_print (struct type , LONGEST, struct ui_file ,
	37	int, const struct value_print_options *);
	38	static void scm_scmlist_print (struct type , LONGEST, struct ui_file ,
	39	int, const struct value_print_options *);
	40	static int scm_inferior_print (struct type , LONGEST, struct ui_file ,
	41	int, const struct value_print_options *);
d4310edb LC	42
	43	/* Prints the SCM value VALUE by invoking the inferior, if appropraite.
	44	Returns >= 0 on success; return -1 if the inferior cannot/should not
	45	print VALUE. */
	46
	47	static int
6ceaaae5	48	scm_inferior_print (struct type type, LONGEST value, struct ui_file stream,
79a45b7d	49	int recurse, const struct value_print_options *options)
d4310edb LC	50	{
	51	struct value func, arg, *result;
	52	struct symbol gdb_output_sym, gdb_output_len_sym;
	53	char *output;
	54	int ret, output_len;
	55
6ceaaae5 UW	56	func = find_function_in_inferior ("gdb_print", NULL);
6ceaaae5 UW	57	arg = value_from_longest (type, value);
d4310edb LC	58
	59	result = call_function_by_hand (func, 1, &arg);
	60	ret = (int) value_as_long (result);
	61	if (ret == 0)
	62	{
	63	/* XXX: Should we cache these symbols? */
	64	gdb_output_sym =
21b556f4	65	lookup_symbol_global ("gdb_output", NULL, NULL, VAR_DOMAIN);
d4310edb	66	gdb_output_len_sym =
21b556f4	67	lookup_symbol_global ("gdb_output_length", NULL, NULL, VAR_DOMAIN);
d4310edb LC	68
	69	if ((gdb_output_sym == NULL) \|\| (gdb_output_len_sym == NULL))
	70	ret = -1;
	71	else
	72	{
	73	struct value *remote_buffer;
	74
	75	read_memory (SYMBOL_VALUE_ADDRESS (gdb_output_len_sym),
	76	(char *) &output_len, sizeof (output_len));
	77
	78	output = (char *) alloca (output_len);
6ceaaae5	79	remote_buffer = value_at (type,
d4310edb LC	80	SYMBOL_VALUE_ADDRESS (gdb_output_sym));
	81	read_memory (value_as_address (remote_buffer),
	82	output, output_len);
	83
	84	ui_file_write (stream, output, output_len);
	85	}
	86	}
	87
	88	return ret;
	89	}
	90
	91	/* {Names of immediate symbols}
	92	* This table must agree with the declarations in scm.h: {Immediate Symbols}.*/
	93
	94	static char *scm_isymnames[] =
	95	{
	96	/* This table must agree with the declarations */
	97	"and",
	98	"begin",
	99	"case",
	100	"cond",
	101	"do",
	102	"if",
	103	"lambda",
	104	"let",
	105	"let*",
	106	"letrec",
	107	"or",
	108	"quote",
	109	"set!",
	110	"define",
	111	#if 0
	112	"literal-variable-ref",
	113	"literal-variable-set!",
	114	#endif
	115	"apply",
	116	"call-with-current-continuation",
	117
	118	/* user visible ISYMS */
	119	/* other keywords */
	120	/* Flags */
	121
	122	"#f",
	123	"#t",
	124	"#<undefined>",
	125	"#<eof>",
	126	"()",
	127	"#<unspecified>"
	128	};
	129
	130	static void
6ceaaae5 UW	131	scm_scmlist_print (struct type *type, LONGEST svalue,
6ceaaae5 UW	132	struct ui_file *stream, int recurse,
79a45b7d	133	const struct value_print_options *options)
d4310edb	134	{
6ceaaae5	135	#define SCM_SIZE (TYPE_LENGTH (type))
79a45b7d	136	unsigned int more = options->print_max;
d4310edb LC	137	if (recurse > 6)
	138	{
	139	fputs_filtered ("...", stream);
	140	return;
	141	}
6ceaaae5	142	scm_scmval_print (type, SCM_CAR (svalue), stream, recurse + 1, options);
d4310edb LC	143	svalue = SCM_CDR (svalue);
	144	for (; SCM_NIMP (svalue); svalue = SCM_CDR (svalue))
	145	{
	146	if (SCM_NECONSP (svalue))
	147	break;
	148	fputs_filtered (" ", stream);
	149	if (--more == 0)
	150	{
	151	fputs_filtered ("...", stream);
	152	return;
	153	}
6ceaaae5	154	scm_scmval_print (type, SCM_CAR (svalue), stream, recurse + 1, options);
d4310edb LC	155	}
	156	if (SCM_NNULLP (svalue))
	157	{
	158	fputs_filtered (" . ", stream);
6ceaaae5	159	scm_scmval_print (type, svalue, stream, recurse + 1, options);
d4310edb	160	}
6ceaaae5	161	#undef SCM_SIZE
d4310edb LC	162	}
	163
	164	static void
6ceaaae5 UW	165	scm_ipruk (char hdr, struct type type, LONGEST ptr,
6ceaaae5 UW	166	struct ui_file *stream)
d4310edb	167	{
6ceaaae5	168	#define SCM_SIZE (TYPE_LENGTH (type))
d4310edb	169	fprintf_filtered (stream, "#<unknown-%s", hdr);
d4310edb LC	170	if (SCM_CELLP (ptr))
	171	fprintf_filtered (stream, " (0x%lx . 0x%lx) @",
	172	(long) SCM_CAR (ptr), (long) SCM_CDR (ptr));
	173	fprintf_filtered (stream, " 0x%s>", paddr_nz (ptr));
6ceaaae5	174	#undef SCM_SIZE
d4310edb LC	175	}
d4310edb LC	176
6ceaaae5 UW	177	static void
	178	scm_scmval_print (struct type *type, LONGEST svalue,
	179	struct ui_file *stream, int recurse,
	180	const struct value_print_options *options)
d4310edb	181	{
6ceaaae5	182	#define SCM_SIZE (TYPE_LENGTH (type))
d4310edb LC	183	taloop:
	184	switch (7 & (int) svalue)
	185	{
	186	case 2:
	187	case 6:
79a45b7d TT	188	print_longest (stream,
	189	options->format ? options->format : 'd',
	190	1, svalue >> 2);
d4310edb LC	191	break;
	192	case 4:
	193	if (SCM_ICHRP (svalue))
	194	{
	195	svalue = SCM_ICHR (svalue);
6c7a06a3 TT	196	scm_printchar (svalue, builtin_type (current_gdbarch)->builtin_char,
6c7a06a3 TT	197	stream);
d4310edb LC	198	break;
	199	}
	200	else if (SCM_IFLAGP (svalue)
	201	&& (SCM_ISYMNUM (svalue)
	202	< (sizeof scm_isymnames / sizeof (char *))))
	203	{
	204	fputs_filtered (SCM_ISYMCHARS (svalue), stream);
	205	break;
	206	}
	207	else if (SCM_ILOCP (svalue))
	208	{
	209	fprintf_filtered (stream, "#@%ld%c%ld",
	210	(long) SCM_IFRAME (svalue),
	211	SCM_ICDRP (svalue) ? '-' : '+',
	212	(long) SCM_IDIST (svalue));
	213	break;
	214	}
	215	else
	216	goto idef;
	217	break;
	218	case 1:
	219	/* gloc */
	220	svalue = SCM_CAR (svalue - 1);
	221	goto taloop;
	222	default:
	223	idef:
6ceaaae5	224	scm_ipruk ("immediate", type, svalue, stream);
d4310edb LC	225	break;
	226	case 0:
	227
	228	switch (SCM_TYP7 (svalue))
	229	{
	230	case scm_tcs_cons_gloc:
	231	if (SCM_CDR (SCM_CAR (svalue) - 1L) == 0)
	232	{
	233	#if 0
	234	SCM name;
	235	#endif
	236	fputs_filtered ("#<latte ", stream);
	237	#if 1
	238	fputs_filtered ("???", stream);
	239	#else
	240	name = ((SCM n *) (STRUCT_TYPE (exp)))[struct_i_name];
	241	scm_lfwrite (CHARS (name),
	242	(sizet) sizeof (char),
	243	(sizet) LENGTH (name),
	244	port);
	245	#endif
	246	fprintf_filtered (stream, " #X%s>", paddr_nz (svalue));
	247	break;
	248	}
	249	case scm_tcs_cons_imcar:
	250	case scm_tcs_cons_nimcar:
	251	fputs_filtered ("(", stream);
6ceaaae5	252	scm_scmlist_print (type, svalue, stream, recurse + 1, options);
d4310edb LC	253	fputs_filtered (")", stream);
	254	break;
	255	case scm_tcs_closures:
	256	fputs_filtered ("#<CLOSURE ", stream);
6ceaaae5 UW	257	scm_scmlist_print (type, SCM_CODE (svalue), stream,
6ceaaae5 UW	258	recurse + 1, options);
d4310edb LC	259	fputs_filtered (">", stream);
	260	break;
	261	case scm_tc7_string:
	262	{
	263	int len = SCM_LENGTH (svalue);
	264	CORE_ADDR addr = (CORE_ADDR) SCM_CDR (svalue);
	265	int i;
	266	int done = 0;
	267	int buf_size;
	268	gdb_byte buffer[64];
79a45b7d	269	int truncate = options->print_max && len > (int) options->print_max;
d4310edb	270	if (truncate)
79a45b7d	271	len = options->print_max;
d4310edb LC	272	fputs_filtered ("\"", stream);
	273	for (; done < len; done += buf_size)
	274	{
	275	buf_size = min (len - done, 64);
	276	read_memory (addr + done, buffer, buf_size);
	277
	278	for (i = 0; i < buf_size; ++i)
	279	switch (buffer[i])
	280	{
	281	case '\"':
	282	case '\\':
	283	fputs_filtered ("\\", stream);
	284	default:
	285	fprintf_filtered (stream, "%c", buffer[i]);
	286	}
	287	}
	288	fputs_filtered (truncate ? "...\"" : "\"", stream);
	289	break;
	290	}
	291	break;
	292	case scm_tcs_symbols:
	293	{
	294	int len = SCM_LENGTH (svalue);
	295
	296	char *str = alloca (len);
	297	read_memory (SCM_CDR (svalue), (gdb_byte *) str, len + 1);
	298	/* Should handle weird characters FIXME */
	299	str[len] = '\0';
	300	fputs_filtered (str, stream);
	301	break;
	302	}
	303	case scm_tc7_vector:
	304	{
	305	int len = SCM_LENGTH (svalue);
	306	int i;
	307	LONGEST elements = SCM_CDR (svalue);
	308	fputs_filtered ("#(", stream);
	309	for (i = 0; i < len; ++i)
	310	{
	311	if (i > 0)
	312	fputs_filtered (" ", stream);
6ceaaae5 UW	313	scm_scmval_print (type, scm_get_field (elements, i, SCM_SIZE),
6ceaaae5 UW	314	stream, recurse + 1, options);
d4310edb LC	315	}
	316	fputs_filtered (")", stream);
	317	}
	318	break;
	319	#if 0
	320	case tc7_lvector:
	321	{
	322	SCM result;
	323	SCM hook;
	324	hook = scm_get_lvector_hook (exp, LV_PRINT_FN);
	325	if (hook == BOOL_F)
	326	{
	327	scm_puts ("#<locked-vector ", port);
	328	scm_intprint (CDR (exp), 16, port);
	329	scm_puts (">", port);
	330	}
	331	else
	332	{
	333	result
	334	= scm_apply (hook,
	335	scm_listify (exp, port,
	336	(writing ? BOOL_T : BOOL_F),
	337	SCM_UNDEFINED),
	338	EOL);
	339	if (result == BOOL_F)
	340	goto punk;
	341	}
	342	break;
	343	}
	344	break;
	345	case tc7_bvect:
	346	case tc7_ivect:
	347	case tc7_uvect:
	348	case tc7_fvect:
	349	case tc7_dvect:
	350	case tc7_cvect:
	351	scm_raprin1 (exp, port, writing);
	352	break;
	353	#endif
	354	case scm_tcs_subrs:
	355	{
	356	int index = SCM_CAR (svalue) >> 8;
	357	#if 1
	358	char str[20];
	359	sprintf (str, "#%d", index);
	360	#else
	361	char *str = index ? SCM_CHARS (scm_heap_org + index) : "";
	362	#define SCM_CHARS(x) ((char *)(SCM_CDR(x)))
	363	char *str = CHARS (SNAME (exp));
	364	#endif
	365	fprintf_filtered (stream, "#<primitive-procedure %s>",
	366	str);
	367	}
	368	break;
	369	#if 0
	370	#ifdef CCLO
	371	case tc7_cclo:
	372	scm_puts ("#<compiled-closure ", port);
	373	scm_iprin1 (CCLO_SUBR (exp), port, writing);
	374	scm_putc ('>', port);
	375	break;
	376	#endif
	377	case tc7_contin:
	378	fprintf_filtered (stream, "#<continuation %d @ #X%lx >",
379	LENGTH (svalue),
380	(long) CHARS (svalue));
381	break;
382	case tc7_port:
383	i = PTOBNUM (exp);
384	if (i < scm_numptob
385	&& scm_ptobs[i].print
386	&& (scm_ptobs[i].print) (exp, port, writing))
387	break;
388	goto punk;
389	case tc7_smob:
390	i = SMOBNUM (exp);
391	if (i < scm_numsmob && scm_smobs[i].print
392	&& (scm_smobs[i].print) (exp, port, writing))
393	break;
394	goto punk;
395	#endif
396	default:
397	#if 0
398	punk:
399	#endif
6ceaaae5	400	scm_ipruk ("type", type, svalue, stream);
d4310edb LC	401	}
	402	break;
	403	}
6ceaaae5	404	#undef SCM_SIZE
d4310edb LC	405	}
	406
	407	int
	408	scm_val_print (struct type type, const gdb_byte valaddr,
	409	int embedded_offset, CORE_ADDR address,
79a45b7d TT	410	struct ui_file *stream, int recurse,
79a45b7d TT	411	const struct value_print_options *options)
d4310edb LC	412	{
	413	if (is_scmvalue_type (type))
	414	{
	415	LONGEST svalue = extract_signed_integer (valaddr, TYPE_LENGTH (type));
	416
6ceaaae5	417	if (scm_inferior_print (type, svalue, stream, recurse, options) >= 0)
d4310edb LC	418	{
	419	}
	420	else
	421	{
6ceaaae5	422	scm_scmval_print (type, svalue, stream, recurse, options);
d4310edb LC	423	}
	424
	425	gdb_flush (stream);
	426	return (0);
	427	}
	428	else
	429	{
79a45b7d	430	return c_val_print (type, valaddr, 0, address, stream, recurse, options);
d4310edb LC	431	}
	432	}
	433
	434	int
79a45b7d TT	435	scm_value_print (struct value val, struct ui_file stream,
79a45b7d TT	436	const struct value_print_options *options)
d4310edb	437	{
79a45b7d TT	438	struct value_print_options opts = *options;
	439	opts.deref_ref = 1;
	440	return (common_val_print (val, stream, 0, &opts, current_language));
d4310edb	441	}