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

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

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