[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)
{
  gdb_byte buffer[20];
  read_memory (SCM2PTR (svalue) + index * size, buffer, size);
  return extract_signed_integer (buffer, size);
}

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