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

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

   Copyright (C) 1995, 1996, 1998, 2000, 2001, 2002, 2003, 2004, 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 "c-lang.h"
#include "scm-lang.h"
#include "scm-tags.h"
#include "source.h"
#include "gdb_string.h"
#include "gdbcore.h"
#include "infcall.h"
#include "objfiles.h"

extern void _initialize_scheme_language (void);
static struct value *evaluate_subexp_scm (struct type *, struct expression *,
				      int *, enum noside);
static struct value *scm_lookup_name (struct gdbarch *, char *);
static int in_eval_c (void);

void
scm_printchar (int c, struct type *type, struct ui_file *stream)
{
  fprintf_filtered (stream, "#\\%c", c);
}

static void
scm_printstr (struct ui_file *stream, struct type *type, const gdb_byte *string,
	      unsigned int length, int force_ellipses,
	      const struct value_print_options *options)
{
  fprintf_filtered (stream, "\"%s\"", string);
}

int
is_scmvalue_type (struct type *type)
{
  if (TYPE_NAME (type) && strcmp (TYPE_NAME (type), "SCM") == 0)
    {
      return 1;
    }
  return 0;
}

/* Get the INDEX'th SCM value, assuming SVALUE is the address
   of the 0'th one.  */

LONGEST
scm_get_field (LONGEST svalue, int index, int size,
	       enum bfd_endian byte_order)
{
  gdb_byte buffer[20];
  read_memory (SCM2PTR (svalue) + index * size, buffer, size);
  return extract_signed_integer (buffer, size, byte_order);
}

/* Unpack a value of type TYPE in buffer VALADDR as an integer
   (if CONTEXT == TYPE_CODE_IN), a pointer (CONTEXT == TYPE_CODE_PTR),
   or Boolean (CONTEXT == TYPE_CODE_BOOL).  */

LONGEST
scm_unpack (struct type *type, const gdb_byte *valaddr, enum type_code context)
{
  if (is_scmvalue_type (type))
    {
      enum bfd_endian byte_order = gdbarch_byte_order (get_type_arch (type));
      LONGEST svalue
	= extract_signed_integer (valaddr, TYPE_LENGTH (type), byte_order);

      if (context == TYPE_CODE_BOOL)
	{
	  if (svalue == SCM_BOOL_F)
	    return 0;
	  else
	    return 1;
	}
      switch (7 & (int) svalue)
	{
	case 2:
	case 6:		/* fixnum */
	  return svalue >> 2;
	case 4:		/* other immediate value */
	  if (SCM_ICHRP (svalue))	/* character */
	    return SCM_ICHR (svalue);
	  else if (SCM_IFLAGP (svalue))
	    {
	      switch ((int) svalue)
		{
#ifndef SICP
		case SCM_EOL:
#endif
		case SCM_BOOL_F:
		  return 0;
		case SCM_BOOL_T:
		  return 1;
		}
	    }
	  error (_("Value can't be converted to integer."));
	default:
	  return svalue;
	}
    }
  else
    return unpack_long (type, valaddr);
}

/* True if we're correctly in Guile's eval.c (the evaluator and apply). */

static int
in_eval_c (void)
{
  struct symtab_and_line cursal = get_current_source_symtab_and_line ();
  
  if (cursal.symtab && cursal.symtab->filename)
    {
      char *filename = cursal.symtab->filename;
      int len = strlen (filename);
      if (len >= 6 && strcmp (filename + len - 6, "eval.c") == 0)
	return 1;
    }
  return 0;
}

/* Lookup a value for the variable named STR.
   First lookup in Scheme context (using the scm_lookup_cstr inferior
   function), then try lookup_symbol for compiled variables. */

static struct value *
scm_lookup_name (struct gdbarch *gdbarch, char *str)
{
  struct value *args[3];
  int len = strlen (str);
  struct value *func;
  struct value *val;
  struct symbol *sym;

  func = find_function_in_inferior ("scm_lookup_cstr", NULL);

  args[0] = value_allocate_space_in_inferior (len);
  args[1] = value_from_longest (builtin_type (gdbarch)->builtin_int, len);
  write_memory (value_as_long (args[0]), (gdb_byte *) str, len);

  if (in_eval_c ()
      && (sym = lookup_symbol ("env",
			       expression_context_block,
			       VAR_DOMAIN, (int *) NULL)) != NULL)
    args[2] = value_of_variable (sym, expression_context_block);
  else
    /* FIXME in this case, we should try lookup_symbol first */
    args[2] = value_from_longest (builtin_scm_type (gdbarch)->builtin_scm,
				  SCM_EOL);

  val = call_function_by_hand (func, 3, args);
  if (!value_logical_not (val))
    return value_ind (val);

  sym = lookup_symbol (str,
		       expression_context_block,
		       VAR_DOMAIN, (int *) NULL);
  if (sym)
    return value_of_variable (sym, NULL);
  error (_("No symbol \"%s\" in current context."), str);
}

struct value *
scm_evaluate_string (char *str, int len)
{
  struct value *func;
  struct value *addr = value_allocate_space_in_inferior (len + 1);
  LONGEST iaddr = value_as_long (addr);
  write_memory (iaddr, (gdb_byte *) str, len);
  /* FIXME - should find and pass env */
  write_memory (iaddr + len, (gdb_byte *) "", 1);
  func = find_function_in_inferior ("scm_evstr", NULL);
  return call_function_by_hand (func, 1, &addr);
}

static struct value *
evaluate_exp (struct type *expect_type, struct expression *exp,
	      int *pos, enum noside noside)
{
  enum exp_opcode op = exp->elts[*pos].opcode;
  int len, pc;
  char *str;
  switch (op)
    {
    case OP_NAME:
      pc = (*pos)++;
      len = longest_to_int (exp->elts[pc + 1].longconst);
      (*pos) += 3 + BYTES_TO_EXP_ELEM (len + 1);
      if (noside == EVAL_SKIP)
	goto nosideret;
      str = &exp->elts[pc + 2].string;
      return scm_lookup_name (exp->gdbarch, str);
    case OP_STRING:
      pc = (*pos)++;
      len = longest_to_int (exp->elts[pc + 1].longconst);
      (*pos) += 3 + BYTES_TO_EXP_ELEM (len + 1);
      if (noside == EVAL_SKIP)
	goto nosideret;
      str = &exp->elts[pc + 2].string;
      return scm_evaluate_string (str, len);
    default:;
    }
  return evaluate_subexp_standard (expect_type, exp, pos, noside);
nosideret:
  return value_from_longest (builtin_type (exp->gdbarch)->builtin_int, 1);
}

const struct exp_descriptor exp_descriptor_scm = 
{
  print_subexp_standard,
  operator_length_standard,
  op_name_standard,
  dump_subexp_body_standard,
  evaluate_exp
};

const struct language_defn scm_language_defn =
{
  "scheme",			/* Language name */
  language_scm,
  range_check_off,
  type_check_off,
  case_sensitive_off,
  array_row_major,
  macro_expansion_no,
  &exp_descriptor_scm,
  scm_parse,
  c_error,
  null_post_parser,
  scm_printchar,		/* Print a character constant */
  scm_printstr,			/* Function to print string constant */
  NULL,				/* Function to print a single character */
  c_print_type,			/* Print a type using appropriate syntax */
  default_print_typedef,	/* Print a typedef using appropriate syntax */
  scm_val_print,		/* Print a value using appropriate syntax */
  scm_value_print,		/* Print a top-level value */
  NULL,				/* Language specific skip_trampoline */
  NULL,	                        /* name_of_this */
  basic_lookup_symbol_nonlocal,	/* lookup_symbol_nonlocal */
  basic_lookup_transparent_type,/* lookup_transparent_type */
  NULL,				/* Language specific symbol demangler */
  NULL,				/* Language specific class_name_from_physname */
  NULL,				/* expression operators for printing */
  1,				/* c-style arrays */
  0,				/* String lower bound */
  default_word_break_characters,
  default_make_symbol_completion_list,
  c_language_arch_info,
  default_print_array_index,
  default_pass_by_reference,
  default_get_string,
  LANG_MAGIC
};

static void *
build_scm_types (struct gdbarch *gdbarch)
{
  struct builtin_scm_type *builtin_scm_type
    = GDBARCH_OBSTACK_ZALLOC (gdbarch, struct builtin_scm_type);

  builtin_scm_type->builtin_scm
    = arch_integer_type (gdbarch, gdbarch_long_bit (gdbarch), 0, "SCM");

  return builtin_scm_type;
}

static struct gdbarch_data *scm_type_data;

const struct builtin_scm_type *
builtin_scm_type (struct gdbarch *gdbarch)
{
  return gdbarch_data (gdbarch, scm_type_data);
}

void
_initialize_scheme_language (void)
{
  scm_type_data = gdbarch_data_register_post_init (build_scm_types);

  add_language (&scm_language_defn);
}
Commit	Line	Data
d4310edb LC	1	/* Scheme/Guile language support routines for GDB, the GNU debugger.
d4310edb LC	2
9b254dd1	3	Copyright (C) 1995, 1996, 1998, 2000, 2001, 2002, 2003, 2004, 2005, 2007,
0fb0cc75	4	2008, 2009 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 "c-lang.h"
	29	#include "scm-lang.h"
	30	#include "scm-tags.h"
	31	#include "source.h"
	32	#include "gdb_string.h"
	33	#include "gdbcore.h"
	34	#include "infcall.h"
3e3b026f	35	#include "objfiles.h"
d4310edb LC	36
	37	extern void _initialize_scheme_language (void);
	38	static struct value evaluate_subexp_scm (struct type , struct expression *,
	39	int *, enum noside);
6ceaaae5	40	static struct value scm_lookup_name (struct gdbarch , char *);
d4310edb LC	41	static int in_eval_c (void);
d4310edb LC	42
d4310edb	43	void
6c7a06a3	44	scm_printchar (int c, struct type type, struct ui_file stream)
d4310edb LC	45	{
	46	fprintf_filtered (stream, "#\\%c", c);
	47	}
	48
	49	static void
6c7a06a3 TT	50	scm_printstr (struct ui_file stream, struct type type, const gdb_byte *string,
6c7a06a3 TT	51	unsigned int length, int force_ellipses,
79a45b7d	52	const struct value_print_options *options)
d4310edb LC	53	{
	54	fprintf_filtered (stream, "\"%s\"", string);
	55	}
	56
	57	int
	58	is_scmvalue_type (struct type *type)
	59	{
	60	if (TYPE_NAME (type) && strcmp (TYPE_NAME (type), "SCM") == 0)
	61	{
	62	return 1;
	63	}
	64	return 0;
	65	}
	66
	67	/* Get the INDEX'th SCM value, assuming SVALUE is the address
	68	of the 0'th one. */
	69
	70	LONGEST
e17a4113 UW	71	scm_get_field (LONGEST svalue, int index, int size,
e17a4113 UW	72	enum bfd_endian byte_order)
d4310edb LC	73	{
d4310edb LC	74	gdb_byte buffer[20];
6ceaaae5	75	read_memory (SCM2PTR (svalue) + index * size, buffer, size);
e17a4113	76	return extract_signed_integer (buffer, size, byte_order);
d4310edb LC	77	}
	78
	79	/* Unpack a value of type TYPE in buffer VALADDR as an integer
	80	(if CONTEXT == TYPE_CODE_IN), a pointer (CONTEXT == TYPE_CODE_PTR),
	81	or Boolean (CONTEXT == TYPE_CODE_BOOL). */
	82
	83	LONGEST
	84	scm_unpack (struct type type, const gdb_byte valaddr, enum type_code context)
	85	{
	86	if (is_scmvalue_type (type))
	87	{
e17a4113 UW	88	enum bfd_endian byte_order = gdbarch_byte_order (get_type_arch (type));
	89	LONGEST svalue
	90	= extract_signed_integer (valaddr, TYPE_LENGTH (type), byte_order);
	91
d4310edb LC	92	if (context == TYPE_CODE_BOOL)
	93	{
	94	if (svalue == SCM_BOOL_F)
	95	return 0;
	96	else
	97	return 1;
	98	}
	99	switch (7 & (int) svalue)
	100	{
	101	case 2:
	102	case 6: /* fixnum */
	103	return svalue >> 2;
	104	case 4: /* other immediate value */
	105	if (SCM_ICHRP (svalue)) /* character */
	106	return SCM_ICHR (svalue);
	107	else if (SCM_IFLAGP (svalue))
	108	{
	109	switch ((int) svalue)
	110	{
	111	#ifndef SICP
	112	case SCM_EOL:
	113	#endif
	114	case SCM_BOOL_F:
	115	return 0;
	116	case SCM_BOOL_T:
	117	return 1;
	118	}
	119	}
	120	error (_("Value can't be converted to integer."));
	121	default:
	122	return svalue;
	123	}
	124	}
	125	else
	126	return unpack_long (type, valaddr);
	127	}
	128
	129	/* True if we're correctly in Guile's eval.c (the evaluator and apply). */
	130
	131	static int
	132	in_eval_c (void)
	133	{
	134	struct symtab_and_line cursal = get_current_source_symtab_and_line ();
	135
	136	if (cursal.symtab && cursal.symtab->filename)
	137	{
	138	char *filename = cursal.symtab->filename;
	139	int len = strlen (filename);
	140	if (len >= 6 && strcmp (filename + len - 6, "eval.c") == 0)
	141	return 1;
	142	}
	143	return 0;
	144	}
	145
	146	/* Lookup a value for the variable named STR.
	147	First lookup in Scheme context (using the scm_lookup_cstr inferior
	148	function), then try lookup_symbol for compiled variables. */
	149
	150	static struct value *
6ceaaae5	151	scm_lookup_name (struct gdbarch gdbarch, char str)
d4310edb LC	152	{
	153	struct value *args[3];
	154	int len = strlen (str);
	155	struct value *func;
	156	struct value *val;
	157	struct symbol *sym;
3e3b026f	158
6ceaaae5	159	func = find_function_in_inferior ("scm_lookup_cstr", NULL);
3e3b026f	160
d4310edb	161	args[0] = value_allocate_space_in_inferior (len);
3e3b026f	162	args[1] = value_from_longest (builtin_type (gdbarch)->builtin_int, len);
d4310edb LC	163	write_memory (value_as_long (args[0]), (gdb_byte *) str, len);
	164
	165	if (in_eval_c ()
	166	&& (sym = lookup_symbol ("env",
	167	expression_context_block,
2570f2b7	168	VAR_DOMAIN, (int *) NULL)) != NULL)
d4310edb LC	169	args[2] = value_of_variable (sym, expression_context_block);
	170	else
	171	/* FIXME in this case, we should try lookup_symbol first */
6ceaaae5 UW	172	args[2] = value_from_longest (builtin_scm_type (gdbarch)->builtin_scm,
6ceaaae5 UW	173	SCM_EOL);
d4310edb	174
d4310edb LC	175	val = call_function_by_hand (func, 3, args);
	176	if (!value_logical_not (val))
	177	return value_ind (val);
	178
	179	sym = lookup_symbol (str,
	180	expression_context_block,
2570f2b7	181	VAR_DOMAIN, (int *) NULL);
d4310edb LC	182	if (sym)
	183	return value_of_variable (sym, NULL);
	184	error (_("No symbol \"%s\" in current context."), str);
	185	}
	186
	187	struct value *
	188	scm_evaluate_string (char *str, int len)
	189	{
	190	struct value *func;
	191	struct value *addr = value_allocate_space_in_inferior (len + 1);
	192	LONGEST iaddr = value_as_long (addr);
	193	write_memory (iaddr, (gdb_byte *) str, len);
	194	/* FIXME - should find and pass env */
	195	write_memory (iaddr + len, (gdb_byte *) "", 1);
3e3b026f	196	func = find_function_in_inferior ("scm_evstr", NULL);
d4310edb LC	197	return call_function_by_hand (func, 1, &addr);
	198	}
	199
	200	static struct value *
	201	evaluate_exp (struct type expect_type, struct expression exp,
	202	int *pos, enum noside noside)
	203	{
	204	enum exp_opcode op = exp->elts[*pos].opcode;
	205	int len, pc;
	206	char *str;
	207	switch (op)
	208	{
	209	case OP_NAME:
	210	pc = (*pos)++;
	211	len = longest_to_int (exp->elts[pc + 1].longconst);
	212	(*pos) += 3 + BYTES_TO_EXP_ELEM (len + 1);
	213	if (noside == EVAL_SKIP)
	214	goto nosideret;
	215	str = &exp->elts[pc + 2].string;
6ceaaae5	216	return scm_lookup_name (exp->gdbarch, str);
d4310edb LC	217	case OP_STRING:
	218	pc = (*pos)++;
	219	len = longest_to_int (exp->elts[pc + 1].longconst);
	220	(*pos) += 3 + BYTES_TO_EXP_ELEM (len + 1);
	221	if (noside == EVAL_SKIP)
	222	goto nosideret;
	223	str = &exp->elts[pc + 2].string;
	224	return scm_evaluate_string (str, len);
	225	default:;
	226	}
	227	return evaluate_subexp_standard (expect_type, exp, pos, noside);
	228	nosideret:
22601c15	229	return value_from_longest (builtin_type (exp->gdbarch)->builtin_int, 1);
d4310edb LC	230	}
	231
	232	const struct exp_descriptor exp_descriptor_scm =
	233	{
	234	print_subexp_standard,
	235	operator_length_standard,
	236	op_name_standard,
	237	dump_subexp_body_standard,
	238	evaluate_exp
	239	};
	240
	241	const struct language_defn scm_language_defn =
	242	{
	243	"scheme", /* Language name */
	244	language_scm,
d4310edb LC	245	range_check_off,
	246	type_check_off,
	247	case_sensitive_off,
	248	array_row_major,
9a044a89	249	macro_expansion_no,
d4310edb LC	250	&exp_descriptor_scm,
	251	scm_parse,
	252	c_error,
	253	null_post_parser,
	254	scm_printchar, /* Print a character constant */
	255	scm_printstr, /* Function to print string constant */
	256	NULL, /* Function to print a single character */
d4310edb	257	c_print_type, /* Print a type using appropriate syntax */
5c6ce71d	258	default_print_typedef, /* Print a typedef using appropriate syntax */
d4310edb LC	259	scm_val_print, /* Print a value using appropriate syntax */
	260	scm_value_print, /* Print a top-level value */
	261	NULL, /* Language specific skip_trampoline */
2b2d9e11	262	NULL, /* name_of_this */
d4310edb LC	263	basic_lookup_symbol_nonlocal, /* lookup_symbol_nonlocal */
	264	basic_lookup_transparent_type,/* lookup_transparent_type */
	265	NULL, /* Language specific symbol demangler */
	266	NULL, /* Language specific class_name_from_physname */
	267	NULL, /* expression operators for printing */
	268	1, /* c-style arrays */
	269	0, /* String lower bound */
d4310edb	270	default_word_break_characters,
41d27058	271	default_make_symbol_completion_list,
d4310edb LC	272	c_language_arch_info,
d4310edb LC	273	default_print_array_index,
41f1b697	274	default_pass_by_reference,
ae6a3a4c	275	default_get_string,
d4310edb LC	276	LANG_MAGIC
	277	};
	278
6ceaaae5 UW	279	static void *
	280	build_scm_types (struct gdbarch *gdbarch)
	281	{
	282	struct builtin_scm_type *builtin_scm_type
	283	= GDBARCH_OBSTACK_ZALLOC (gdbarch, struct builtin_scm_type);
	284
e9bb382b UW	285	builtin_scm_type->builtin_scm
e9bb382b UW	286	= arch_integer_type (gdbarch, gdbarch_long_bit (gdbarch), 0, "SCM");
6ceaaae5 UW	287
	288	return builtin_scm_type;
	289	}
	290
	291	static struct gdbarch_data *scm_type_data;
	292
	293	const struct builtin_scm_type *
	294	builtin_scm_type (struct gdbarch *gdbarch)
	295	{
	296	return gdbarch_data (gdbarch, scm_type_data);
	297	}
	298
d4310edb LC	299	void
	300	_initialize_scheme_language (void)
	301	{
6ceaaae5 UW	302	scm_type_data = gdbarch_data_register_post_init (build_scm_types);
6ceaaae5 UW	303
d4310edb	304	add_language (&scm_language_defn);
d4310edb	305	}