[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 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 (char *);
static int in_eval_c (void);

struct type *builtin_type_scm;

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

static void
scm_printstr (struct ui_file *stream, const gdb_byte *string,
	      unsigned int length, int width, 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)
{
  gdb_byte buffer[20];
  read_memory (SCM2PTR (svalue) + index * TYPE_LENGTH (builtin_type_scm),
	       buffer, TYPE_LENGTH (builtin_type_scm));
  return extract_signed_integer (buffer, TYPE_LENGTH (builtin_type_scm));
}

/* 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 (char *str)
{
  struct objfile *objf;
  struct gdbarch *gdbarch;
  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", &objf);
  gdbarch = get_objfile_arch (objf);

  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_type_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 (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_int8, (LONGEST) 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,
  LANG_MAGIC
};

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