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

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)) != 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);
  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,
  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 */
  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 */
  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"
	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,
2570f2b7	162	VAR_DOMAIN, (int *) NULL)) != NULL)
d4310edb LC	163	args[2] = value_of_variable (sym, expression_context_block);
	164	else
	165	/* FIXME in this case, we should try lookup_symbol first */
	166	args[2] = value_from_longest (builtin_type_scm, SCM_EOL);
	167
	168	func = find_function_in_inferior ("scm_lookup_cstr");
	169	val = call_function_by_hand (func, 3, args);
	170	if (!value_logical_not (val))
	171	return value_ind (val);
	172
	173	sym = lookup_symbol (str,
	174	expression_context_block,
2570f2b7	175	VAR_DOMAIN, (int *) NULL);
d4310edb LC	176	if (sym)
	177	return value_of_variable (sym, NULL);
	178	error (_("No symbol \"%s\" in current context."), str);
	179	}
	180
	181	struct value *
	182	scm_evaluate_string (char *str, int len)
	183	{
	184	struct value *func;
	185	struct value *addr = value_allocate_space_in_inferior (len + 1);
	186	LONGEST iaddr = value_as_long (addr);
	187	write_memory (iaddr, (gdb_byte *) str, len);
	188	/* FIXME - should find and pass env */
	189	write_memory (iaddr + len, (gdb_byte *) "", 1);
	190	func = find_function_in_inferior ("scm_evstr");
	191	return call_function_by_hand (func, 1, &addr);
	192	}
	193
	194	static struct value *
	195	evaluate_exp (struct type expect_type, struct expression exp,
	196	int *pos, enum noside noside)
	197	{
	198	enum exp_opcode op = exp->elts[*pos].opcode;
	199	int len, pc;
	200	char *str;
	201	switch (op)
	202	{
	203	case OP_NAME:
	204	pc = (*pos)++;
	205	len = longest_to_int (exp->elts[pc + 1].longconst);
	206	(*pos) += 3 + BYTES_TO_EXP_ELEM (len + 1);
	207	if (noside == EVAL_SKIP)
	208	goto nosideret;
	209	str = &exp->elts[pc + 2].string;
	210	return scm_lookup_name (str);
	211	case OP_STRING:
	212	pc = (*pos)++;
	213	len = longest_to_int (exp->elts[pc + 1].longconst);
	214	(*pos) += 3 + BYTES_TO_EXP_ELEM (len + 1);
	215	if (noside == EVAL_SKIP)
	216	goto nosideret;
	217	str = &exp->elts[pc + 2].string;
	218	return scm_evaluate_string (str, len);
	219	default:;
	220	}
	221	return evaluate_subexp_standard (expect_type, exp, pos, noside);
	222	nosideret:
	223	return value_from_longest (builtin_type_long, (LONGEST) 1);
	224	}
	225
	226	const struct exp_descriptor exp_descriptor_scm =
	227	{
	228	print_subexp_standard,
	229	operator_length_standard,
	230	op_name_standard,
	231	dump_subexp_body_standard,
	232	evaluate_exp
	233	};
	234
	235	const struct language_defn scm_language_defn =
	236	{
	237	"scheme", /* Language name */
	238	language_scm,
d4310edb LC	239	range_check_off,
	240	type_check_off,
	241	case_sensitive_off,
	242	array_row_major,
	243	&exp_descriptor_scm,
	244	scm_parse,
	245	c_error,
	246	null_post_parser,
	247	scm_printchar, /* Print a character constant */
	248	scm_printstr, /* Function to print string constant */
	249	NULL, /* Function to print a single character */
d4310edb LC	250	c_print_type, /* Print a type using appropriate syntax */
	251	scm_val_print, /* Print a value using appropriate syntax */
	252	scm_value_print, /* Print a top-level value */
	253	NULL, /* Language specific skip_trampoline */
2b2d9e11	254	NULL, /* name_of_this */
d4310edb LC	255	basic_lookup_symbol_nonlocal, /* lookup_symbol_nonlocal */
	256	basic_lookup_transparent_type,/* lookup_transparent_type */
	257	NULL, /* Language specific symbol demangler */
	258	NULL, /* Language specific class_name_from_physname */
	259	NULL, /* expression operators for printing */
	260	1, /* c-style arrays */
	261	0, /* String lower bound */
d4310edb	262	default_word_break_characters,
41d27058	263	default_make_symbol_completion_list,
d4310edb LC	264	c_language_arch_info,
d4310edb LC	265	default_print_array_index,
41f1b697	266	default_pass_by_reference,
d4310edb LC	267	LANG_MAGIC
	268	};
	269
	270	void
	271	_initialize_scheme_language (void)
	272	{
	273	add_language (&scm_language_defn);
	274	builtin_type_scm =
	275	init_type (TYPE_CODE_INT,
	276	gdbarch_long_bit (current_gdbarch) / TARGET_CHAR_BIT,
	277	0, "SCM", (struct objfile *) NULL);
	278	}