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
10   the Free Software Foundation; either version 3 of the License, or
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
19   along with this program.  If not, see <http://www.gnu.org/licenses/>.  */
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
36extern void _initialize_scheme_language (void);
37static struct value *evaluate_subexp_scm (struct type *, struct expression *,
38				      int *, enum noside);
39static struct value *scm_lookup_name (char *);
40static int in_eval_c (void);
41
42struct type *builtin_type_scm;
43
44void
45scm_printchar (int c, struct ui_file *stream)
46{
47  fprintf_filtered (stream, "#\\%c", c);
48}
49
50static void
51scm_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
57int
58is_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
70LONGEST
71scm_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
83LONGEST
84scm_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
128static int
129in_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
147static struct value *
148scm_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
183struct value *
184scm_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
196static struct value *
197evaluate_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);
224nosideret:
225  return value_from_longest (builtin_type_long, (LONGEST) 1);
226}
227
228const 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
237const 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
273void
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}
282