[binutils.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)
{
  struct gdbarch *gdbarch = get_type_arch (type);

#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 (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	{
50810684 UW	182	struct gdbarch *gdbarch = get_type_arch (type);
50810684 UW	183
6ceaaae5	184	#define SCM_SIZE (TYPE_LENGTH (type))
d4310edb LC	185	taloop:
	186	switch (7 & (int) svalue)
	187	{
	188	case 2:
	189	case 6:
79a45b7d TT	190	print_longest (stream,
	191	options->format ? options->format : 'd',
	192	1, svalue >> 2);
d4310edb LC	193	break;
	194	case 4:
	195	if (SCM_ICHRP (svalue))
	196	{
	197	svalue = SCM_ICHR (svalue);
50810684	198	scm_printchar (svalue, builtin_type (gdbarch)->builtin_char,
6c7a06a3	199	stream);
d4310edb LC	200	break;
	201	}
	202	else if (SCM_IFLAGP (svalue)
	203	&& (SCM_ISYMNUM (svalue)
	204	< (sizeof scm_isymnames / sizeof (char *))))
	205	{
	206	fputs_filtered (SCM_ISYMCHARS (svalue), stream);
	207	break;
	208	}
	209	else if (SCM_ILOCP (svalue))
	210	{
	211	fprintf_filtered (stream, "#@%ld%c%ld",
	212	(long) SCM_IFRAME (svalue),
	213	SCM_ICDRP (svalue) ? '-' : '+',
	214	(long) SCM_IDIST (svalue));
	215	break;
	216	}
	217	else
	218	goto idef;
	219	break;
	220	case 1:
	221	/* gloc */
	222	svalue = SCM_CAR (svalue - 1);
	223	goto taloop;
	224	default:
	225	idef:
6ceaaae5	226	scm_ipruk ("immediate", type, svalue, stream);
d4310edb LC	227	break;
	228	case 0:
	229
	230	switch (SCM_TYP7 (svalue))
	231	{
	232	case scm_tcs_cons_gloc:
	233	if (SCM_CDR (SCM_CAR (svalue) - 1L) == 0)
	234	{
	235	#if 0
	236	SCM name;
	237	#endif
	238	fputs_filtered ("#<latte ", stream);
	239	#if 1
	240	fputs_filtered ("???", stream);
	241	#else
	242	name = ((SCM n *) (STRUCT_TYPE (exp)))[struct_i_name];
	243	scm_lfwrite (CHARS (name),
	244	(sizet) sizeof (char),
	245	(sizet) LENGTH (name),
	246	port);
	247	#endif
	248	fprintf_filtered (stream, " #X%s>", paddr_nz (svalue));
	249	break;
	250	}
	251	case scm_tcs_cons_imcar:
	252	case scm_tcs_cons_nimcar:
	253	fputs_filtered ("(", stream);
6ceaaae5	254	scm_scmlist_print (type, svalue, stream, recurse + 1, options);
d4310edb LC	255	fputs_filtered (")", stream);
	256	break;
	257	case scm_tcs_closures:
	258	fputs_filtered ("#<CLOSURE ", stream);
6ceaaae5 UW	259	scm_scmlist_print (type, SCM_CODE (svalue), stream,
6ceaaae5 UW	260	recurse + 1, options);
d4310edb LC	261	fputs_filtered (">", stream);
	262	break;
	263	case scm_tc7_string:
	264	{
	265	int len = SCM_LENGTH (svalue);
	266	CORE_ADDR addr = (CORE_ADDR) SCM_CDR (svalue);
	267	int i;
	268	int done = 0;
	269	int buf_size;
	270	gdb_byte buffer[64];
79a45b7d	271	int truncate = options->print_max && len > (int) options->print_max;
d4310edb	272	if (truncate)
79a45b7d	273	len = options->print_max;
d4310edb LC	274	fputs_filtered ("\"", stream);
	275	for (; done < len; done += buf_size)
	276	{
	277	buf_size = min (len - done, 64);
	278	read_memory (addr + done, buffer, buf_size);
	279
	280	for (i = 0; i < buf_size; ++i)
	281	switch (buffer[i])
	282	{
	283	case '\"':
	284	case '\\':
	285	fputs_filtered ("\\", stream);
	286	default:
	287	fprintf_filtered (stream, "%c", buffer[i]);
	288	}
	289	}
	290	fputs_filtered (truncate ? "...\"" : "\"", stream);
	291	break;
	292	}
	293	break;
	294	case scm_tcs_symbols:
	295	{
	296	int len = SCM_LENGTH (svalue);
	297
	298	char *str = alloca (len);
	299	read_memory (SCM_CDR (svalue), (gdb_byte *) str, len + 1);
	300	/* Should handle weird characters FIXME */
	301	str[len] = '\0';
	302	fputs_filtered (str, stream);
	303	break;
	304	}
	305	case scm_tc7_vector:
	306	{
	307	int len = SCM_LENGTH (svalue);
	308	int i;
	309	LONGEST elements = SCM_CDR (svalue);
	310	fputs_filtered ("#(", stream);
	311	for (i = 0; i < len; ++i)
	312	{
	313	if (i > 0)
	314	fputs_filtered (" ", stream);
6ceaaae5 UW	315	scm_scmval_print (type, scm_get_field (elements, i, SCM_SIZE),
6ceaaae5 UW	316	stream, recurse + 1, options);
d4310edb LC	317	}
	318	fputs_filtered (")", stream);
	319	}
	320	break;
	321	#if 0
	322	case tc7_lvector:
	323	{
	324	SCM result;
	325	SCM hook;
	326	hook = scm_get_lvector_hook (exp, LV_PRINT_FN);
	327	if (hook == BOOL_F)
	328	{
	329	scm_puts ("#<locked-vector ", port);
	330	scm_intprint (CDR (exp), 16, port);
	331	scm_puts (">", port);
	332	}
	333	else
	334	{
	335	result
	336	= scm_apply (hook,
	337	scm_listify (exp, port,
	338	(writing ? BOOL_T : BOOL_F),
	339	SCM_UNDEFINED),
	340	EOL);
	341	if (result == BOOL_F)
	342	goto punk;
	343	}
	344	break;
	345	}
	346	break;
	347	case tc7_bvect:
	348	case tc7_ivect:
	349	case tc7_uvect:
	350	case tc7_fvect:
	351	case tc7_dvect:
	352	case tc7_cvect:
	353	scm_raprin1 (exp, port, writing);
	354	break;
	355	#endif
	356	case scm_tcs_subrs:
	357	{
	358	int index = SCM_CAR (svalue) >> 8;
	359	#if 1
	360	char str[20];
	361	sprintf (str, "#%d", index);
	362	#else
	363	char *str = index ? SCM_CHARS (scm_heap_org + index) : "";
	364	#define SCM_CHARS(x) ((char *)(SCM_CDR(x)))
	365	char *str = CHARS (SNAME (exp));
	366	#endif
	367	fprintf_filtered (stream, "#<primitive-procedure %s>",
	368	str);
	369	}
	370	break;
	371	#if 0
	372	#ifdef CCLO
	373	case tc7_cclo:
	374	scm_puts ("#<compiled-closure ", port);
	375	scm_iprin1 (CCLO_SUBR (exp), port, writing);
	376	scm_putc ('>', port);
	377	break;
	378	#endif
	379	case tc7_contin:
	380	fprintf_filtered (stream, "#<continuation %d @ #X%lx >",
381	LENGTH (svalue),
382	(long) CHARS (svalue));
383	break;
384	case tc7_port:
385	i = PTOBNUM (exp);
386	if (i < scm_numptob
387	&& scm_ptobs[i].print
388	&& (scm_ptobs[i].print) (exp, port, writing))
389	break;
390	goto punk;
391	case tc7_smob:
392	i = SMOBNUM (exp);
393	if (i < scm_numsmob && scm_smobs[i].print
394	&& (scm_smobs[i].print) (exp, port, writing))
395	break;
396	goto punk;
397	#endif
398	default:
399	#if 0
400	punk:
401	#endif
6ceaaae5	402	scm_ipruk ("type", type, svalue, stream);
d4310edb LC	403	}
	404	break;
	405	}
6ceaaae5	406	#undef SCM_SIZE
d4310edb LC	407	}
	408
	409	int
	410	scm_val_print (struct type type, const gdb_byte valaddr,
	411	int embedded_offset, CORE_ADDR address,
79a45b7d TT	412	struct ui_file *stream, int recurse,
79a45b7d TT	413	const struct value_print_options *options)
d4310edb LC	414	{
	415	if (is_scmvalue_type (type))
	416	{
	417	LONGEST svalue = extract_signed_integer (valaddr, TYPE_LENGTH (type));
	418
6ceaaae5	419	if (scm_inferior_print (type, svalue, stream, recurse, options) >= 0)
d4310edb LC	420	{
	421	}
	422	else
	423	{
6ceaaae5	424	scm_scmval_print (type, svalue, stream, recurse, options);
d4310edb LC	425	}
	426
	427	gdb_flush (stream);
	428	return (0);
	429	}
	430	else
	431	{
79a45b7d	432	return c_val_print (type, valaddr, 0, address, stream, recurse, options);
d4310edb LC	433	}
	434	}
	435
	436	int
79a45b7d TT	437	scm_value_print (struct value val, struct ui_file stream,
79a45b7d TT	438	const struct value_print_options *options)
d4310edb	439	{
79a45b7d TT	440	struct value_print_options opts = *options;
	441	opts.deref_ref = 1;
	442	return (common_val_print (val, stream, 0, &opts, current_language));
d4310edb	443	}