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

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)
{
  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 value *args[3];
  int len = strlen (str);
  struct value *func;
  struct value *val;
  struct symbol *sym;
  args[0] = value_allocate_space_in_inferior (len);
  args[1] = value_from_longest (builtin_type_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,
			       (struct symtab **) 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);

  func = find_function_in_inferior ("scm_lookup_cstr");
  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,
		       (struct symtab **) 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");
  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_long, (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,
  NULL,
  range_check_off,
  type_check_off,
  case_sensitive_off,
  array_row_major,
  &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 */
  NULL,				/* Create fundamental type in this language */
  c_print_type,			/* Print a type 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 */
  value_of_this,		/* value_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 */
  NULL,
  default_word_break_characters,
  c_language_arch_info,
  default_print_array_index,
  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.
	2
	3	Copyright (C) 1995, 1996, 1998, 2000, 2001, 2002, 2003, 2004, 2005, 2007 Free
	4	Software 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
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"
	35
	36	extern void _initialize_scheme_language (void);
	37	static struct value evaluate_subexp_scm (struct type , struct expression *,
	38	int *, enum noside);
	39	static struct value scm_lookup_name (char );
	40	static int in_eval_c (void);
	41
	42	struct type *builtin_type_scm;
	43
	44	void
	45	scm_printchar (int c, struct ui_file *stream)
	46	{
	47	fprintf_filtered (stream, "#\\%c", c);
	48	}
	49
	50	static void
	51	scm_printstr (struct ui_file stream, const gdb_byte string,
	52	unsigned int length, int width, int force_ellipses)
	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
	71	scm_get_field (LONGEST svalue, int index)
	72	{
	73	gdb_byte buffer[20];
	74	read_memory (SCM2PTR (svalue) + index * TYPE_LENGTH (builtin_type_scm),
	75	buffer, TYPE_LENGTH (builtin_type_scm));
	76	return extract_signed_integer (buffer, TYPE_LENGTH (builtin_type_scm));
	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	{
88	LONGEST svalue = extract_signed_integer (valaddr, TYPE_LENGTH (type));
89	if (context == TYPE_CODE_BOOL)
90	{
91	if (svalue == SCM_BOOL_F)
92	return 0;
93	else
94	return 1;
95	}
96	switch (7 & (int) svalue)
97	{
98	case 2:
99	case 6: /* fixnum */
100	return svalue >> 2;
101	case 4: /* other immediate value */
102	if (SCM_ICHRP (svalue)) /* character */
103	return SCM_ICHR (svalue);
104	else if (SCM_IFLAGP (svalue))
105	{
106	switch ((int) svalue)
107	{
108	#ifndef SICP
109	case SCM_EOL:
110	#endif
111	case SCM_BOOL_F:
112	return 0;
113	case SCM_BOOL_T:
114	return 1;
115	}
116	}
117	error (_("Value can't be converted to integer."));
118	default:
119	return svalue;
120	}
121	}
122	else
123	return unpack_long (type, valaddr);
124	}
125
126	/* True if we're correctly in Guile's eval.c (the evaluator and apply). */
127
128	static int
129	in_eval_c (void)
130	{
131	struct symtab_and_line cursal = get_current_source_symtab_and_line ();
132
133	if (cursal.symtab && cursal.symtab->filename)
134	{
135	char *filename = cursal.symtab->filename;
136	int len = strlen (filename);
137	if (len >= 6 && strcmp (filename + len - 6, "eval.c") == 0)
138	return 1;
139	}
140	return 0;
141	}
142
143	/* Lookup a value for the variable named STR.
144	First lookup in Scheme context (using the scm_lookup_cstr inferior
145	function), then try lookup_symbol for compiled variables. */
146
147	static struct value *
148	scm_lookup_name (char *str)
149	{
150	struct value *args[3];
151	int len = strlen (str);
152	struct value *func;
153	struct value *val;
154	struct symbol *sym;
155	args[0] = value_allocate_space_in_inferior (len);
156	args[1] = value_from_longest (builtin_type_int, len);
157	write_memory (value_as_long (args[0]), (gdb_byte *) str, len);
158
159	if (in_eval_c ()
160	&& (sym = lookup_symbol ("env",
161	expression_context_block,
162	VAR_DOMAIN, (int *) NULL,
163	(struct symtab **) NULL)) != NULL)
164	args[2] = value_of_variable (sym, expression_context_block);
165	else
166	/* FIXME in this case, we should try lookup_symbol first */
167	args[2] = value_from_longest (builtin_type_scm, SCM_EOL);
168
169	func = find_function_in_inferior ("scm_lookup_cstr");
170	val = call_function_by_hand (func, 3, args);
171	if (!value_logical_not (val))
172	return value_ind (val);
173
174	sym = lookup_symbol (str,
175	expression_context_block,
176	VAR_DOMAIN, (int *) NULL,
177	(struct symtab **) NULL);
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);
192	func = find_function_in_inferior ("scm_evstr");
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;
212	return scm_lookup_name (str);
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:
225	return value_from_longest (builtin_type_long, (LONGEST) 1);
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,
241	NULL,
242	range_check_off,
243	type_check_off,
244	case_sensitive_off,
245	array_row_major,
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 */
253	NULL, /* Create fundamental type in this language */
254	c_print_type, /* Print a type using appropriate syntax */
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 */
258	value_of_this, /* value_of_this */
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 */
266	NULL,
267	default_word_break_characters,
268	c_language_arch_info,
269	default_print_array_index,
270	LANG_MAGIC
271	};
272
273	void
274	_initialize_scheme_language (void)
275	{
276	add_language (&scm_language_defn);
277	builtin_type_scm =
278	init_type (TYPE_CODE_INT,
279	gdbarch_long_bit (current_gdbarch) / TARGET_CHAR_BIT,
280	0, "SCM", (struct objfile *) NULL);
281	}