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

/* Scheme/Guile language support routines for GDB, the GNU debugger.
   Copyright 1995, 1996, 1998, 2000, 2001
   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 "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_PTR (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, 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)
{
  if (current_source_symtab && current_source_symtab->filename)
    {
      char *filename = current_source_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)
{
  value_ptr 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.");
}

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