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

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

   Copyright 1995, 1996, 1998, 2000, 2001, 2002, 2003 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 2 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, write to the Free Software
   Foundation, Inc., 59 Temple Place - Suite 330,
   Boston, MA 02111-1307, USA.  */

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

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);
static void scm_printstr (struct ui_file * stream, char *string,
			  unsigned int length, int width,
			  int force_ellipses);

extern struct type **const (c_builtin_types[]);

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, char *string, unsigned int length,
	      int width, int force_ellipses)
{
  fprintf_filtered (stream, "\"%s\"", string);
}

int
is_scmvalue_type (struct type *type)
{
  if (TYPE_CODE (type) == TYPE_CODE_INT
      && 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)
{
  char 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 char *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]), str, len);

  if (in_eval_c ()
      && (sym = lookup_symbol ("env",
			       expression_context_block,
			       VAR_NAMESPACE, (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_NAMESPACE, (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, str, len);
  /* FIXME - should find and pass env */
  write_memory (iaddr + len, "", 1);
  func = find_function_in_inferior ("scm_evstr");
  return call_function_by_hand (func, 1, &addr);
}

static struct value *
evaluate_subexp_scm (struct type *expect_type, register struct expression *exp,
		     register 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_EXPRSTRING:
      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 language_defn scm_language_defn =
{
  "scheme",			/* Language name */
  language_scm,
  c_builtin_types,
  range_check_off,
  type_check_off,
  case_sensitive_off,
  scm_parse,
  c_error,
  evaluate_subexp_scm,
  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 */
  NULL,				/* Language specific symbol demangler */
  {"", "", "", ""},		/* Binary format info */
  {"#o%lo", "#o", "o", ""},	/* Octal format info */
  {"%ld", "", "d", ""},		/* Decimal format info */
  {"#x%lX", "#X", "X", ""},	/* Hex format info */
  NULL,				/* expression operators for printing */
  1,				/* c-style arrays */
  0,				/* String lower bound */
  &builtin_type_char,		/* Type of string elements */
  LANG_MAGIC
};

void
_initialize_scheme_language (void)
{
  add_language (&scm_language_defn);
  builtin_type_scm = init_type (TYPE_CODE_INT,
				TARGET_LONG_BIT / TARGET_CHAR_BIT,
				0, "SCM", (struct objfile *) NULL);
}
Commit	Line	Data
c906108c	1	/* Scheme/Guile language support routines for GDB, the GNU debugger.
1bac305b AC	2
	3	Copyright 1995, 1996, 1998, 2000, 2001, 2002, 2003 Free Software
	4	Foundation, Inc.
c906108c	5
c5aa993b	6	This file is part of GDB.
c906108c	7
c5aa993b JM	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
	10	the Free Software Foundation; either version 2 of the License, or
	11	(at your option) any later version.
c906108c	12
c5aa993b JM	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.
c906108c	17
c5aa993b JM	18	You should have received a copy of the GNU General Public License
	19	along with this program; if not, write to the Free Software
	20	Foundation, Inc., 59 Temple Place - Suite 330,
	21	Boston, MA 02111-1307, USA. */
c906108c SS	22
	23	#include "defs.h"
	24	#include "symtab.h"
	25	#include "gdbtypes.h"
	26	#include "expression.h"
	27	#include "parser-defs.h"
	28	#include "language.h"
	29	#include "value.h"
	30	#include "c-lang.h"
	31	#include "scm-lang.h"
	32	#include "scm-tags.h"
0378c332	33	#include "source.h"
c906108c SS	34	#include "gdb_string.h"
	35	#include "gdbcore.h"
	36
a14ed312	37	extern void _initialize_scheme_language (void);
6943961c	38	static struct value evaluate_subexp_scm (struct type , struct expression *,
a14ed312	39	int *, enum noside);
6943961c	40	static struct value scm_lookup_name (char );
a14ed312	41	static int in_eval_c (void);
d9fcf2fb JM	42	static void scm_printstr (struct ui_file * stream, char *string,
	43	unsigned int length, int width,
	44	int force_ellipses);
c906108c	45
6c6ea35e	46	extern struct type **const (c_builtin_types[]);
c906108c SS	47
	48	struct type *builtin_type_scm;
	49
	50	void
fba45db2	51	scm_printchar (int c, struct ui_file *stream)
c906108c SS	52	{
	53	fprintf_filtered (stream, "#\\%c", c);
	54	}
	55
	56	static void
fba45db2 KB	57	scm_printstr (struct ui_file stream, char string, unsigned int length,
fba45db2 KB	58	int width, int force_ellipses)
c906108c SS	59	{
	60	fprintf_filtered (stream, "\"%s\"", string);
	61	}
	62
	63	int
fba45db2	64	is_scmvalue_type (struct type *type)
c906108c SS	65	{
	66	if (TYPE_CODE (type) == TYPE_CODE_INT
	67	&& TYPE_NAME (type) && strcmp (TYPE_NAME (type), "SCM") == 0)
	68	{
	69	return 1;
	70	}
	71	return 0;
	72	}
	73
	74	/* Get the INDEX'th SCM value, assuming SVALUE is the address
	75	of the 0'th one. */
	76
	77	LONGEST
fba45db2	78	scm_get_field (LONGEST svalue, int index)
c906108c SS	79	{
	80	char buffer[20];
	81	read_memory (SCM2PTR (svalue) + index * TYPE_LENGTH (builtin_type_scm),
	82	buffer, TYPE_LENGTH (builtin_type_scm));
	83	return extract_signed_integer (buffer, TYPE_LENGTH (builtin_type_scm));
	84	}
	85
	86	/* Unpack a value of type TYPE in buffer VALADDR as an integer
	87	(if CONTEXT == TYPE_CODE_IN), a pointer (CONTEXT == TYPE_CODE_PTR),
	88	or Boolean (CONTEXT == TYPE_CODE_BOOL). */
	89
	90	LONGEST
66140c26	91	scm_unpack (struct type type, const char valaddr, enum type_code context)
c906108c SS	92	{
	93	if (is_scmvalue_type (type))
	94	{
	95	LONGEST svalue = extract_signed_integer (valaddr, TYPE_LENGTH (type));
	96	if (context == TYPE_CODE_BOOL)
	97	{
	98	if (svalue == SCM_BOOL_F)
	99	return 0;
	100	else
	101	return 1;
	102	}
	103	switch (7 & (int) svalue)
	104	{
c5aa993b JM	105	case 2:
c5aa993b JM	106	case 6: /* fixnum */
c906108c	107	return svalue >> 2;
c5aa993b JM	108	case 4: /* other immediate value */
c5aa993b JM	109	if (SCM_ICHRP (svalue)) /* character */
c906108c SS	110	return SCM_ICHR (svalue);
	111	else if (SCM_IFLAGP (svalue))
	112	{
	113	switch ((int) svalue)
	114	{
	115	#ifndef SICP
	116	case SCM_EOL:
	117	#endif
	118	case SCM_BOOL_F:
	119	return 0;
	120	case SCM_BOOL_T:
	121	return 1;
	122	}
	123	}
	124	error ("Value can't be converted to integer.");
	125	default:
	126	return svalue;
	127	}
	128	}
	129	else
	130	return unpack_long (type, valaddr);
	131	}
	132
	133	/* True if we're correctly in Guile's eval.c (the evaluator and apply). */
	134
	135	static int
fba45db2	136	in_eval_c (void)
c906108c	137	{
c214a6fd	138	struct symtab_and_line cursal = get_current_source_symtab_and_line ();
0378c332 FN	139
0378c332 FN	140	if (cursal.symtab && cursal.symtab->filename)
c906108c	141	{
0378c332	142	char *filename = cursal.symtab->filename;
c906108c SS	143	int len = strlen (filename);
	144	if (len >= 6 && strcmp (filename + len - 6, "eval.c") == 0)
	145	return 1;
	146	}
	147	return 0;
	148	}
	149
	150	/* Lookup a value for the variable named STR.
	151	First lookup in Scheme context (using the scm_lookup_cstr inferior
	152	function), then try lookup_symbol for compiled variables. */
	153
6943961c	154	static struct value *
fba45db2	155	scm_lookup_name (char *str)
c906108c	156	{
f23631e4	157	struct value *args[3];
c906108c	158	int len = strlen (str);
6943961c AC	159	struct value *func;
6943961c AC	160	struct value *val;
c906108c SS	161	struct symbol *sym;
	162	args[0] = value_allocate_space_in_inferior (len);
	163	args[1] = value_from_longest (builtin_type_int, len);
	164	write_memory (value_as_long (args[0]), str, len);
	165
	166	if (in_eval_c ()
	167	&& (sym = lookup_symbol ("env",
	168	expression_context_block,
	169	VAR_NAMESPACE, (int *) NULL,
	170	(struct symtab **) NULL)) != NULL)
	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
	176	func = find_function_in_inferior ("scm_lookup_cstr");
	177	val = call_function_by_hand (func, 3, args);
	178	if (!value_logical_not (val))
	179	return value_ind (val);
	180
	181	sym = lookup_symbol (str,
	182	expression_context_block,
	183	VAR_NAMESPACE, (int *) NULL,
	184	(struct symtab **) NULL);
	185	if (sym)
	186	return value_of_variable (sym, NULL);
823ca731	187	error ("No symbol \"%s\" in current context.", str);
c906108c SS	188	}
c906108c SS	189
6943961c	190	struct value *
fba45db2	191	scm_evaluate_string (char *str, int len)
c906108c	192	{
6943961c AC	193	struct value *func;
6943961c AC	194	struct value *addr = value_allocate_space_in_inferior (len + 1);
c906108c SS	195	LONGEST iaddr = value_as_long (addr);
	196	write_memory (iaddr, str, len);
	197	/* FIXME - should find and pass env */
	198	write_memory (iaddr + len, "", 1);
	199	func = find_function_in_inferior ("scm_evstr");
	200	return call_function_by_hand (func, 1, &addr);
	201	}
	202
6943961c	203	static struct value *
fba45db2 KB	204	evaluate_subexp_scm (struct type expect_type, register struct expression exp,
fba45db2 KB	205	register int *pos, enum noside noside)
c906108c SS	206	{
c906108c SS	207	enum exp_opcode op = exp->elts[*pos].opcode;
c5aa993b JM	208	int len, pc;
c5aa993b JM	209	char *str;
c906108c SS	210	switch (op)
	211	{
	212	case OP_NAME:
	213	pc = (*pos)++;
	214	len = longest_to_int (exp->elts[pc + 1].longconst);
	215	(*pos) += 3 + BYTES_TO_EXP_ELEM (len + 1);
	216	if (noside == EVAL_SKIP)
	217	goto nosideret;
	218	str = &exp->elts[pc + 2].string;
	219	return scm_lookup_name (str);
	220	case OP_EXPRSTRING:
	221	pc = (*pos)++;
	222	len = longest_to_int (exp->elts[pc + 1].longconst);
	223	(*pos) += 3 + BYTES_TO_EXP_ELEM (len + 1);
	224	if (noside == EVAL_SKIP)
	225	goto nosideret;
	226	str = &exp->elts[pc + 2].string;
	227	return scm_evaluate_string (str, len);
c5aa993b	228	default:;
c906108c SS	229	}
c906108c SS	230	return evaluate_subexp_standard (expect_type, exp, pos, noside);
c5aa993b	231	nosideret:
c906108c SS	232	return value_from_longest (builtin_type_long, (LONGEST) 1);
	233	}
	234
c5aa993b JM	235	const struct language_defn scm_language_defn =
c5aa993b JM	236	{
c906108c SS	237	"scheme", /* Language name */
	238	language_scm,
	239	c_builtin_types,
	240	range_check_off,
	241	type_check_off,
63872f9d	242	case_sensitive_off,
c906108c SS	243	scm_parse,
	244	c_error,
	245	evaluate_subexp_scm,
	246	scm_printchar, /* Print a character constant */
	247	scm_printstr, /* Function to print string constant */
	248	NULL, /* Function to print a single character */
	249	NULL, /* Create fundamental type in this language */
	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 */
f636b87d	253	NULL, /* Language specific skip_trampoline */
9a3d7dfd	254	NULL, /* Language specific symbol demangler */
c5aa993b JM	255	{"", "", "", ""}, /* Binary format info */
	256	{"#o%lo", "#o", "o", ""}, /* Octal format info */
	257	{"%ld", "", "d", ""}, /* Decimal format info */
	258	{"#x%lX", "#X", "X", ""}, /* Hex format info */
c906108c SS	259	NULL, /* expression operators for printing */
	260	1, /* c-style arrays */
	261	0, /* String lower bound */
c5aa993b	262	&builtin_type_char, /* Type of string elements */
c906108c SS	263	LANG_MAGIC
	264	};
	265
	266	void
fba45db2	267	_initialize_scheme_language (void)
c906108c SS	268	{
	269	add_language (&scm_language_defn);
	270	builtin_type_scm = init_type (TYPE_CODE_INT,
	271	TARGET_LONG_BIT / TARGET_CHAR_BIT,
	272	0, "SCM", (struct objfile *) NULL);
	273	}