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