[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 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 2 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, write to the Free Software
   Foundation, Inc., 51 Franklin Street, Fifth Floor,
   Boston, MA 02110-1301, USA.  */

#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,
			      (struct symtab **) NULL);
      gdb_output_len_sym =
	lookup_symbol_global ("gdb_output_length", NULL, NULL,
			      VAR_DOMAIN,
			      (struct symtab **) NULL);

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