[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 *, LONGEST, struct ui_file *);
static void scm_scmlist_print (LONGEST, struct ui_file *, int,
			       const struct value_print_options *);
static int scm_inferior_print (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 (LONGEST value, struct ui_file *stream,
		    int recurse, const struct value_print_options *options)
{
  struct objfile *objf;
  struct gdbarch *gdbarch;
  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", &objf);
  gdbarch = get_objfile_arch (objf);
  arg = value_from_longest (builtin_type (gdbarch)->builtin_core_addr, 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 (builtin_type (gdbarch)->builtin_core_addr,
				    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 (LONGEST svalue, struct ui_file *stream, int recurse,
		   const struct value_print_options *options)
{
  unsigned int more = options->print_max;
  if (recurse > 6)
    {
      fputs_filtered ("...", stream);
      return;
    }
  scm_scmval_print (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 (SCM_CAR (svalue), stream, recurse + 1, options);
    }
  if (SCM_NNULLP (svalue))
    {
      fputs_filtered (" . ", stream);
      scm_scmval_print (svalue, stream, recurse + 1, options);
    }
}

static void
scm_ipruk (char *hdr, LONGEST ptr, struct ui_file *stream)
{
  fprintf_filtered (stream, "#<unknown-%s", hdr);
#define SCM_SIZE TYPE_LENGTH (builtin_type_scm)
  if (SCM_CELLP (ptr))
    fprintf_filtered (stream, " (0x%lx . 0x%lx) @",
		      (long) SCM_CAR (ptr), (long) SCM_CDR (ptr));
  fprintf_filtered (stream, " 0x%s>", paddr_nz (ptr));
}

void
scm_scmval_print (LONGEST svalue, struct ui_file *stream,
		  int recurse, const struct value_print_options *options)
{
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", 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 (svalue, stream, recurse + 1, options);
	  fputs_filtered (")", stream);
	  break;
	case scm_tcs_closures:
	  fputs_filtered ("#<CLOSURE ", stream);
	  scm_scmlist_print (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 (scm_get_field (elements, i), 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", svalue, stream);
	}
      break;
    }
}

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