[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
   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"

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