[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, int,
			       int, enum val_prettyprint);
static int scm_inferior_print (LONGEST, struct ui_file *, int, int,
			       int, enum val_prettyprint);

/* 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 format,
		    int deref_ref, int recurse, enum val_prettyprint pretty)
{
  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 format,
		   int deref_ref, int recurse, enum val_prettyprint pretty)
{
  unsigned int more = print_max;
  if (recurse > 6)
    {
      fputs_filtered ("...", stream);
      return;
    }
  scm_scmval_print (SCM_CAR (svalue), stream, format,
		    deref_ref, recurse + 1, pretty);
  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, format,
			deref_ref, recurse + 1, pretty);
    }
  if (SCM_NNULLP (svalue))
    {
      fputs_filtered (" . ", stream);
      scm_scmval_print (svalue, stream, format,
			deref_ref, recurse + 1, pretty);
    }
}

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 format,
		  int deref_ref, int recurse, enum val_prettyprint pretty)
{
taloop:
  switch (7 & (int) svalue)
    {
    case 2:
    case 6:
      print_longest (stream, format ? 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, format,
			     deref_ref, recurse + 1, pretty);
	  fputs_filtered (")", stream);
	  break;
	case scm_tcs_closures:
	  fputs_filtered ("#<CLOSURE ", stream);
	  scm_scmlist_print (SCM_CODE (svalue), stream, format,
			     deref_ref, recurse + 1, pretty);
	  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 = print_max && len > (int) print_max;
	    if (truncate)
	      len = 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, format,
				  deref_ref, recurse + 1, pretty);
	      }
	    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 format, int deref_ref,
	       int recurse, enum val_prettyprint pretty)
{
  if (is_scmvalue_type (type))
    {
      LONGEST svalue = extract_signed_integer (valaddr, TYPE_LENGTH (type));

      if (scm_inferior_print (svalue, stream, format,
			      deref_ref, recurse, pretty) >= 0)
	{
	}
      else
	{
	  scm_scmval_print (svalue, stream, format,
			    deref_ref, recurse, pretty);
	}

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

int
scm_value_print (struct value *val, struct ui_file *stream, int format,
		 enum val_prettyprint pretty)
{
  return (common_val_print (val, stream, format, 1, 0, pretty,
			    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
	35	static void scm_ipruk (char , LONGEST, struct ui_file );
	36	static void scm_scmlist_print (LONGEST, struct ui_file *, int, int,
	37	int, enum val_prettyprint);
	38	static int scm_inferior_print (LONGEST, struct ui_file *, int, int,
	39	int, enum val_prettyprint);
	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
	46	scm_inferior_print (LONGEST value, struct ui_file *stream, int format,
	47	int deref_ref, int recurse, enum val_prettyprint pretty)
	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
	132	scm_scmlist_print (LONGEST svalue, struct ui_file *stream, int format,
	133	int deref_ref, int recurse, enum val_prettyprint pretty)
	134	{
	135	unsigned int more = print_max;
	136	if (recurse > 6)
	137	{
	138	fputs_filtered ("...", stream);
	139	return;
	140	}
	141	scm_scmval_print (SCM_CAR (svalue), stream, format,
	142	deref_ref, recurse + 1, pretty);
	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 (SCM_CAR (svalue), stream, format,
155	deref_ref, recurse + 1, pretty);
156	}
157	if (SCM_NNULLP (svalue))
158	{
159	fputs_filtered (" . ", stream);
160	scm_scmval_print (svalue, stream, format,
161	deref_ref, recurse + 1, pretty);
162	}
163	}
164
165	static void
166	scm_ipruk (char hdr, LONGEST ptr, struct ui_file stream)
167	{
168	fprintf_filtered (stream, "#<unknown-%s", hdr);
169	#define SCM_SIZE TYPE_LENGTH (builtin_type_scm)
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	}
175
176	void
177	scm_scmval_print (LONGEST svalue, struct ui_file *stream, int format,
178	int deref_ref, int recurse, enum val_prettyprint pretty)
179	{
180	taloop:
181	switch (7 & (int) svalue)
182	{
183	case 2:
184	case 6:
185	print_longest (stream, format ? format : 'd', 1, svalue >> 2);
186	break;
187	case 4:
188	if (SCM_ICHRP (svalue))
189	{
190	svalue = SCM_ICHR (svalue);
191	scm_printchar (svalue, stream);
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);
246	scm_scmlist_print (svalue, stream, format,
247	deref_ref, recurse + 1, pretty);
248	fputs_filtered (")", stream);
249	break;
250	case scm_tcs_closures:
251	fputs_filtered ("#<CLOSURE ", stream);
252	scm_scmlist_print (SCM_CODE (svalue), stream, format,
253	deref_ref, recurse + 1, pretty);
254	fputs_filtered (">", stream);
255	break;
256	case scm_tc7_string:
257	{
258	int len = SCM_LENGTH (svalue);
259	CORE_ADDR addr = (CORE_ADDR) SCM_CDR (svalue);
260	int i;
261	int done = 0;
262	int buf_size;
263	gdb_byte buffer[64];
264	int truncate = print_max && len > (int) print_max;
265	if (truncate)
266	len = print_max;
267	fputs_filtered ("\"", stream);
268	for (; done < len; done += buf_size)
269	{
270	buf_size = min (len - done, 64);
271	read_memory (addr + done, buffer, buf_size);
272
273	for (i = 0; i < buf_size; ++i)
274	switch (buffer[i])
275	{
276	case '\"':
277	case '\\':
278	fputs_filtered ("\\", stream);
279	default:
280	fprintf_filtered (stream, "%c", buffer[i]);
281	}
282	}
283	fputs_filtered (truncate ? "...\"" : "\"", stream);
284	break;
285	}
286	break;
287	case scm_tcs_symbols:
288	{
289	int len = SCM_LENGTH (svalue);
290
291	char *str = alloca (len);
292	read_memory (SCM_CDR (svalue), (gdb_byte *) str, len + 1);
293	/* Should handle weird characters FIXME */
294	str[len] = '\0';
295	fputs_filtered (str, stream);
296	break;
297	}
298	case scm_tc7_vector:
299	{
300	int len = SCM_LENGTH (svalue);
301	int i;
302	LONGEST elements = SCM_CDR (svalue);
303	fputs_filtered ("#(", stream);
304	for (i = 0; i < len; ++i)
305	{
306	if (i > 0)
307	fputs_filtered (" ", stream);
308	scm_scmval_print (scm_get_field (elements, i), stream, format,
309	deref_ref, recurse + 1, pretty);
310	}
311	fputs_filtered (")", stream);
312	}
313	break;
314	#if 0
315	case tc7_lvector:
316	{
317	SCM result;
318	SCM hook;
319	hook = scm_get_lvector_hook (exp, LV_PRINT_FN);
320	if (hook == BOOL_F)
321	{
322	scm_puts ("#<locked-vector ", port);
323	scm_intprint (CDR (exp), 16, port);
324	scm_puts (">", port);
325	}
326	else
327	{
328	result
329	= scm_apply (hook,
330	scm_listify (exp, port,
331	(writing ? BOOL_T : BOOL_F),
332	SCM_UNDEFINED),
333	EOL);
334	if (result == BOOL_F)
335	goto punk;
336	}
337	break;
338	}
339	break;
340	case tc7_bvect:
341	case tc7_ivect:
342	case tc7_uvect:
343	case tc7_fvect:
344	case tc7_dvect:
345	case tc7_cvect:
346	scm_raprin1 (exp, port, writing);
347	break;
348	#endif
349	case scm_tcs_subrs:
350	{
351	int index = SCM_CAR (svalue) >> 8;
352	#if 1
353	char str[20];
354	sprintf (str, "#%d", index);
355	#else
356	char *str = index ? SCM_CHARS (scm_heap_org + index) : "";
357	#define SCM_CHARS(x) ((char *)(SCM_CDR(x)))
358	char *str = CHARS (SNAME (exp));
359	#endif
360	fprintf_filtered (stream, "#<primitive-procedure %s>",
361	str);
362	}
363	break;
364	#if 0
365	#ifdef CCLO
366	case tc7_cclo:
367	scm_puts ("#<compiled-closure ", port);
368	scm_iprin1 (CCLO_SUBR (exp), port, writing);
369	scm_putc ('>', port);
370	break;
371	#endif
372	case tc7_contin:
373	fprintf_filtered (stream, "#<continuation %d @ #X%lx >",
374	LENGTH (svalue),
375	(long) CHARS (svalue));
376	break;
377	case tc7_port:
378	i = PTOBNUM (exp);
379	if (i < scm_numptob
380	&& scm_ptobs[i].print
381	&& (scm_ptobs[i].print) (exp, port, writing))
382	break;
383	goto punk;
384	case tc7_smob:
385	i = SMOBNUM (exp);
386	if (i < scm_numsmob && scm_smobs[i].print
387	&& (scm_smobs[i].print) (exp, port, writing))
388	break;
389	goto punk;
390	#endif
391	default:
392	#if 0
393	punk:
394	#endif
395	scm_ipruk ("type", svalue, stream);
396	}
397	break;
398	}
399	}
400
401	int
402	scm_val_print (struct type type, const gdb_byte valaddr,
403	int embedded_offset, CORE_ADDR address,
404	struct ui_file *stream, int format, int deref_ref,
405	int recurse, enum val_prettyprint pretty)
406	{
407	if (is_scmvalue_type (type))
408	{
409	LONGEST svalue = extract_signed_integer (valaddr, TYPE_LENGTH (type));
410
411	if (scm_inferior_print (svalue, stream, format,
412	deref_ref, recurse, pretty) >= 0)
413	{
414	}
415	else
416	{
417	scm_scmval_print (svalue, stream, format,
418	deref_ref, recurse, pretty);
419	}
420
421	gdb_flush (stream);
422	return (0);
423	}
424	else
425	{
426	return c_val_print (type, valaddr, 0, address, stream, format,
427	deref_ref, recurse, pretty);
428	}
429	}
430
431	int
432	scm_value_print (struct value val, struct ui_file stream, int format,
433	enum val_prettyprint pretty)
434	{
d8ca156b JB	435	return (common_val_print (val, stream, format, 1, 0, pretty,
d8ca156b JB	436	current_language));
d4310edb	437	}