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

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

   Copyright (C) 1995, 1996, 1998, 1999, 2000, 2001, 2005, 2007, 2008, 2009
   Free Software Foundation, Inc.

   This file is part of GDB.

   This program is free software; you can redistribute it and/or modify
   it under the terms of the GNU General Public License as published by
   the Free Software Foundation; either version 3 of the License, or
   (at your option) any later version.

   This program is distributed in the hope that it will be useful,
   but WITHOUT ANY WARRANTY; without even the implied warranty of
   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   GNU General Public License for more details.

   You should have received a copy of the GNU General Public License
   along with this program.  If not, see <http://www.gnu.org/licenses/>.  */

#include "defs.h"
#include "symtab.h"
#include "gdbtypes.h"
#include "expression.h"
#include "parser-defs.h"
#include "language.h"
#include "value.h"
#include "scm-lang.h"
#include "valprint.h"
#include "gdbcore.h"
#include "c-lang.h"
#include "infcall.h"
#include "objfiles.h"

static void scm_ipruk (char *, struct type *, LONGEST, struct ui_file *);
static void scm_scmval_print (struct type *, LONGEST, struct ui_file *,
			      int, const struct value_print_options *);
static void scm_scmlist_print (struct type *, LONGEST, struct ui_file *,
			       int, const struct value_print_options *);
static int scm_inferior_print (struct type *, LONGEST, struct ui_file *,
			       int, const struct value_print_options *);

/* Prints the SCM value VALUE by invoking the inferior, if appropraite.
   Returns >= 0 on success;  return -1 if the inferior cannot/should not
   print VALUE. */

static int
scm_inferior_print (struct type *type, LONGEST value, struct ui_file *stream,
		    int recurse, const struct value_print_options *options)
{
  struct value *func, *arg, *result;
  struct symbol *gdb_output_sym, *gdb_output_len_sym;
  char *output;
  int ret, output_len;

  func = find_function_in_inferior ("gdb_print", NULL);
  arg = value_from_longest (type, value);

  result = call_function_by_hand (func, 1, &arg);
  ret = (int) value_as_long (result);
  if (ret == 0)
    {
      /* XXX: Should we cache these symbols?  */
      gdb_output_sym =
	lookup_symbol_global ("gdb_output", NULL, NULL, VAR_DOMAIN);
      gdb_output_len_sym =
	lookup_symbol_global ("gdb_output_length", NULL, NULL, VAR_DOMAIN);

      if ((gdb_output_sym == NULL) || (gdb_output_len_sym == NULL))
	ret = -1;
      else
	{
	  struct value *remote_buffer;

	  read_memory (SYMBOL_VALUE_ADDRESS (gdb_output_len_sym),
		       (char *) &output_len, sizeof (output_len));

	  output = (char *) alloca (output_len);
	  remote_buffer = value_at (type,
				    SYMBOL_VALUE_ADDRESS (gdb_output_sym));
	  read_memory (value_as_address (remote_buffer),
		       output, output_len);

	  ui_file_write (stream, output, output_len);
	}
    }

  return ret;
}

/* {Names of immediate symbols}
 * This table must agree with the declarations in scm.h: {Immediate Symbols}.*/

static char *scm_isymnames[] =
{
  /* This table must agree with the declarations */
  "and",
  "begin",
  "case",
  "cond",
  "do",
  "if",
  "lambda",
  "let",
  "let*",
  "letrec",
  "or",
  "quote",
  "set!",
  "define",
#if 0
  "literal-variable-ref",
  "literal-variable-set!",
#endif
  "apply",
  "call-with-current-continuation",

 /* user visible ISYMS */
 /* other keywords */
 /* Flags */

  "#f",
  "#t",
  "#<undefined>",
  "#<eof>",
  "()",
  "#<unspecified>"
};

static void
scm_scmlist_print (struct type *type, LONGEST svalue,
		   struct ui_file *stream, int recurse,
		   const struct value_print_options *options)
{
#define SCM_SIZE (TYPE_LENGTH (type))
  unsigned int more = options->print_max;
  if (recurse > 6)
    {
      fputs_filtered ("...", stream);
      return;
    }
  scm_scmval_print (type, SCM_CAR (svalue), stream, recurse + 1, options);
  svalue = SCM_CDR (svalue);
  for (; SCM_NIMP (svalue); svalue = SCM_CDR (svalue))
    {
      if (SCM_NECONSP (svalue))
	break;
      fputs_filtered (" ", stream);
      if (--more == 0)
	{
	  fputs_filtered ("...", stream);
	  return;
	}
      scm_scmval_print (type, SCM_CAR (svalue), stream, recurse + 1, options);
    }
  if (SCM_NNULLP (svalue))
    {
      fputs_filtered (" . ", stream);
      scm_scmval_print (type, svalue, stream, recurse + 1, options);
    }
#undef SCM_SIZE
}

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

static void
scm_scmval_print (struct type *type, LONGEST svalue,
		  struct ui_file *stream, int recurse,
		  const struct value_print_options *options)
{
#define SCM_SIZE (TYPE_LENGTH (type))
taloop:
  switch (7 & (int) svalue)
    {
    case 2:
    case 6:
      print_longest (stream,
		     options->format ? options->format : 'd',
		     1, svalue >> 2);
      break;
    case 4:
      if (SCM_ICHRP (svalue))
	{
	  svalue = SCM_ICHR (svalue);
	  scm_printchar (svalue, builtin_type (current_gdbarch)->builtin_char,
			 stream);
	  break;
	}
      else if (SCM_IFLAGP (svalue)
	       && (SCM_ISYMNUM (svalue)
		   < (sizeof scm_isymnames / sizeof (char *))))
	{
	  fputs_filtered (SCM_ISYMCHARS (svalue), stream);
	  break;
	}
      else if (SCM_ILOCP (svalue))
	{
	  fprintf_filtered (stream, "#@%ld%c%ld",
			    (long) SCM_IFRAME (svalue),
			    SCM_ICDRP (svalue) ? '-' : '+',
			    (long) SCM_IDIST (svalue));
	  break;
	}
      else
	goto idef;
      break;
    case 1:
      /* gloc */
      svalue = SCM_CAR (svalue - 1);
      goto taloop;
    default:
    idef:
      scm_ipruk ("immediate", type, svalue, stream);
      break;
    case 0:

      switch (SCM_TYP7 (svalue))
	{
	case scm_tcs_cons_gloc:
	  if (SCM_CDR (SCM_CAR (svalue) - 1L) == 0)
	    {
#if 0
	      SCM name;
#endif
	      fputs_filtered ("#<latte ", stream);
#if 1
	      fputs_filtered ("???", stream);
#else
	      name = ((SCM n *) (STRUCT_TYPE (exp)))[struct_i_name];
	      scm_lfwrite (CHARS (name),
			   (sizet) sizeof (char),
			     (sizet) LENGTH (name),
			   port);
#endif
	      fprintf_filtered (stream, " #X%s>", paddr_nz (svalue));
	      break;
	    }
	case scm_tcs_cons_imcar:
	case scm_tcs_cons_nimcar:
	  fputs_filtered ("(", stream);
	  scm_scmlist_print (type, svalue, stream, recurse + 1, options);
	  fputs_filtered (")", stream);
	  break;
	case scm_tcs_closures:
	  fputs_filtered ("#<CLOSURE ", stream);
	  scm_scmlist_print (type, SCM_CODE (svalue), stream,
			     recurse + 1, options);
	  fputs_filtered (">", stream);
	  break;
	case scm_tc7_string:
	  {
	    int len = SCM_LENGTH (svalue);
	    CORE_ADDR addr = (CORE_ADDR) SCM_CDR (svalue);
	    int i;
	    int done = 0;
	    int buf_size;
	    gdb_byte buffer[64];
	    int truncate = options->print_max && len > (int) options->print_max;
	    if (truncate)
	      len = options->print_max;
	    fputs_filtered ("\"", stream);
	    for (; done < len; done += buf_size)
	      {
		buf_size = min (len - done, 64);
		read_memory (addr + done, buffer, buf_size);

		for (i = 0; i < buf_size; ++i)
		  switch (buffer[i])
		    {
		    case '\"':
		    case '\\':
		      fputs_filtered ("\\", stream);
		    default:
		      fprintf_filtered (stream, "%c", buffer[i]);
		    }
	      }
	    fputs_filtered (truncate ? "...\"" : "\"", stream);
	    break;
	  }
	  break;
	case scm_tcs_symbols:
	  {
	    int len = SCM_LENGTH (svalue);

	    char *str = alloca (len);
	    read_memory (SCM_CDR (svalue), (gdb_byte *) str, len + 1);
	    /* Should handle weird characters FIXME */
	    str[len] = '\0';
	    fputs_filtered (str, stream);
	    break;
	  }
	case scm_tc7_vector:
	  {
	    int len = SCM_LENGTH (svalue);
	    int i;
	    LONGEST elements = SCM_CDR (svalue);
	    fputs_filtered ("#(", stream);
	    for (i = 0; i < len; ++i)
	      {
		if (i > 0)
		  fputs_filtered (" ", stream);
		scm_scmval_print (type, scm_get_field (elements, i, SCM_SIZE),
				  stream, recurse + 1, options);
	      }
	    fputs_filtered (")", stream);
	  }
	  break;
#if 0
	case tc7_lvector:
	  {
	    SCM result;
	    SCM hook;
	    hook = scm_get_lvector_hook (exp, LV_PRINT_FN);
	    if (hook == BOOL_F)
	      {
		scm_puts ("#<locked-vector ", port);
		scm_intprint (CDR (exp), 16, port);
		scm_puts (">", port);
	      }
	    else
	      {
		result
		  = scm_apply (hook,
			       scm_listify (exp, port, 
					    (writing ? BOOL_T : BOOL_F),
					    SCM_UNDEFINED),
			       EOL);
		if (result == BOOL_F)
		  goto punk;
	      }
	    break;
	  }
	  break;
	case tc7_bvect:
	case tc7_ivect:
	case tc7_uvect:
	case tc7_fvect:
	case tc7_dvect:
	case tc7_cvect:
	  scm_raprin1 (exp, port, writing);
	  break;
#endif
	case scm_tcs_subrs:
	  {
	    int index = SCM_CAR (svalue) >> 8;
#if 1
	    char str[20];
	    sprintf (str, "#%d", index);
#else
	    char *str = index ? SCM_CHARS (scm_heap_org + index) : "";
#define SCM_CHARS(x) ((char *)(SCM_CDR(x)))
	    char *str = CHARS (SNAME (exp));
#endif
	    fprintf_filtered (stream, "#<primitive-procedure %s>",
			      str);
	  }
	  break;
#if 0
#ifdef CCLO
	case tc7_cclo:
	  scm_puts ("#<compiled-closure ", port);
	  scm_iprin1 (CCLO_SUBR (exp), port, writing);
	  scm_putc ('>', port);
	  break;
#endif
	case tc7_contin:
	  fprintf_filtered (stream, "#<continuation %d @ #X%lx >",
			    LENGTH (svalue),
			    (long) CHARS (svalue));
	  break;
	case tc7_port:
	  i = PTOBNUM (exp);
	  if (i < scm_numptob 
	      && scm_ptobs[i].print 
	      && (scm_ptobs[i].print) (exp, port, writing))
	    break;
	  goto punk;
	case tc7_smob:
	  i = SMOBNUM (exp);
	  if (i < scm_numsmob && scm_smobs[i].print
	      && (scm_smobs[i].print) (exp, port, writing))
	    break;
	  goto punk;
#endif
	default:
#if 0
	punk:
#endif
	  scm_ipruk ("type", type, svalue, stream);
	}
      break;
    }
#undef SCM_SIZE
}

int
scm_val_print (struct type *type, const gdb_byte *valaddr,
	       int embedded_offset, CORE_ADDR address,
	       struct ui_file *stream, int recurse,
	       const struct value_print_options *options)
{
  if (is_scmvalue_type (type))
    {
      LONGEST svalue = extract_signed_integer (valaddr, TYPE_LENGTH (type));

      if (scm_inferior_print (type, svalue, stream, recurse, options) >= 0)
	{
	}
      else
	{
	  scm_scmval_print (type, svalue, stream, recurse, options);
	}

      gdb_flush (stream);
      return (0);
    }
  else
    {
      return c_val_print (type, valaddr, 0, address, stream, recurse, options);
    }
}

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