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