X-Git-Url: http://drtracing.org/?a=blobdiff_plain;f=gdb%2Fscm-lang.c;h=de348940bab1ba64057d8f9eaefa0a97bdd5cc04;hb=e17a4113357102b55cfa5b80557d590a46a43300;hp=f3d2df46ff906c414d18189707a70b4c4bfbbc41;hpb=0e4ca328e1d046bc478f61273b1cb3a86d5c592e;p=deliverable%2Fbinutils-gdb.git
diff --git a/gdb/scm-lang.c b/gdb/scm-lang.c
index f3d2df46ff..de348940ba 100644
--- a/gdb/scm-lang.c
+++ b/gdb/scm-lang.c
@@ -1,21 +1,22 @@
/* Scheme/Guile language support routines for GDB, the GNU debugger.
- Copyright 1995 Free Software Foundation, Inc.
-This file is part of GDB.
+ Copyright (C) 1995, 1996, 1998, 2000, 2001, 2002, 2003, 2004, 2005, 2007,
+ 2008, 2009 Free Software Foundation, Inc.
-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 file is part of GDB.
-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.
+ 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.
-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. */
+ 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 . */
#include "defs.h"
#include "symtab.h"
@@ -23,491 +24,282 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */
#include "expression.h"
#include "parser-defs.h"
#include "language.h"
-#include "c-lang.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"
+#include "objfiles.h"
-extern struct type ** const (c_builtin_types[]);
-extern value_ptr value_allocate_space_in_inferior PARAMS ((int));
-extern value_ptr find_function_in_inferior PARAMS ((char*));
-
-static void scm_lreadr ();
-
-static void
-scm_read_token (c, weird)
- int c;
- int weird;
-{
- while (1)
- {
- c = *lexptr++;
- switch (c)
- {
- case '[':
- case ']':
- case '(':
- case ')':
- case '\"':
- case ';':
- case ' ': case '\t': case '\r': case '\f':
- case '\n':
- if (weird)
- goto default_case;
- case '\0': /* End of line */
- eof_case:
- --lexptr;
- return;
- case '\\':
- if (!weird)
- goto default_case;
- else
- {
- c = *lexptr++;
- if (c == '\0')
- goto eof_case;
- else
- goto default_case;
- }
- case '}':
- if (!weird)
- goto default_case;
-
- c = *lexptr++;
- if (c == '#')
- return;
- else
- {
- --lexptr;
- c = '}';
- goto default_case;
- }
-
- default:
- default_case:
- ;
- }
- }
-}
-
-static int
-scm_skip_ws ()
-{
- register int c;
- while (1)
- switch ((c = *lexptr++))
- {
- case '\0':
- goteof:
- return c;
- case ';':
- lp:
- switch ((c = *lexptr++))
- {
- case '\0':
- goto goteof;
- default:
- goto lp;
- case '\n':
- break;
- }
- case ' ': case '\t': case '\r': case '\f': case '\n':
- break;
- default:
- return c;
- }
-}
-
-static void
-scm_lreadparen ()
-{
- for (;;)
- {
- int c = scm_skip_ws ();
- if (')' == c || ']' == c)
- return;
- --lexptr;
- if (c == '\0')
- error ("missing close paren");
- scm_lreadr ();
- }
-}
-
-static void
-scm_lreadr ()
-{
- int c, j;
- tryagain:
- c = *lexptr++;
- switch (c)
- {
- case '\0':
- lexptr--;
- return;
- case '[':
- case '(':
- scm_lreadparen ();
- return;
- case ']':
- case ')':
- error ("unexpected #\\%c", c);
- goto tryagain;
- case '\'':
- case '`':
- scm_lreadr ();
- return;
- case ',':
- c = *lexptr++;
- if ('@' != c)
- lexptr--;
- scm_lreadr ();
- return;
- case '#':
- c = *lexptr++;
- switch (c)
- {
- case '[':
- case '(':
- scm_lreadparen ();
- return;
- case 't': case 'T':
- case 'f': case 'F':
- return;
- case 'b': case 'B':
- case 'o': case 'O':
- case 'd': case 'D':
- case 'x': case 'X':
- case 'i': case 'I':
- case 'e': case 'E':
- lexptr--;
- c = '#';
- goto num;
- case '*': /* bitvector */
- scm_read_token (c, 0);
- return;
- case '{':
- scm_read_token (c, 1);
- return;
- case '\\': /* character */
- c = *lexptr++;
- scm_read_token (c, 0);
- return;
- case '|':
- j = 1; /* here j is the comment nesting depth */
- lp:
- c = *lexptr++;
- lpc:
- switch (c)
- {
- case '\0':
- error ("unbalanced comment");
- default:
- goto lp;
- case '|':
- if ('#' != (c = *lexptr++))
- goto lpc;
- if (--j)
- goto lp;
- break;
- case '#':
- if ('|' != (c = *lexptr++))
- goto lpc;
- ++j;
- goto lp;
- }
- goto tryagain;
- case '.':
- default:
- callshrp:
- scm_lreadr ();
- return;
- }
- case '\"':
- while ('\"' != (c = *lexptr++))
- {
- if (c == '\\')
- switch (c = *lexptr++)
- {
- case '\0':
- error ("non-terminated string literal");
- case '\n':
- continue;
- case '0':
- case 'f':
- case 'n':
- case 'r':
- case 't':
- case 'a':
- case 'v':
- break;
- }
- }
- return;
- case '0': case '1': case '2': case '3': case '4':
- case '5': case '6': case '7': case '8': case '9':
- case '.':
- case '-':
- case '+':
- num:
- scm_read_token (c, 0);
- return;
- case ':':
- scm_read_token ('-', 0);
- return;
- default:
- scm_read_token (c, 0);
- tok:
- return;
- }
-}
-
-int
-scm_parse ()
-{
- char* start;
- struct stoken str;
- while (*lexptr == ' ')
- lexptr++;
- start = lexptr;
- scm_lreadr ();
- str.length = lexptr - start;
- str.ptr = start;
- write_exp_elt_opcode (OP_EXPRSTRING);
- write_exp_string (str);
- write_exp_elt_opcode (OP_EXPRSTRING);
- return 0;
-}
+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 (struct gdbarch *, char *);
+static int in_eval_c (void);
-static void
-scm_printchar (c, stream)
- int c;
- GDB_FILE *stream;
+void
+scm_printchar (int c, struct type *type, struct ui_file *stream)
{
fprintf_filtered (stream, "#\\%c", c);
}
static void
-scm_printstr (stream, string, length, force_ellipses)
- GDB_FILE *stream;
- char *string;
- unsigned int length;
- int force_ellipses;
+scm_printstr (struct ui_file *stream, struct type *type, const gdb_byte *string,
+ unsigned int length, int force_ellipses,
+ const struct value_print_options *options)
{
fprintf_filtered (stream, "\"%s\"", string);
}
int
-is_object_type (type)
- struct type *type;
+is_scmvalue_type (struct type *type)
{
- /* FIXME - this should test for the SCM type, but we can't do that ! */
- return TYPE_CODE (type) == TYPE_CODE_INT
- && TYPE_NAME (type)
-#if 1
- && strcmp (TYPE_NAME (type), "SCM") == 0;
-#else
- && TYPE_LENGTH (type) == TYPE_LENGTH (builtin_type_long)
- && strcmp (TYPE_NAME (type), "long int") == 0;
-#endif
+ if (TYPE_NAME (type) && strcmp (TYPE_NAME (type), "SCM") == 0)
+ {
+ return 1;
+ }
+ return 0;
}
-/* Prints the SCM value VALUE by invoking the inferior, if appropraite.
- Returns >= 0 on succes; retunr -1 if the inferior cannot/should not
- print VALUE. */
+/* Get the INDEX'th SCM value, assuming SVALUE is the address
+ of the 0'th one. */
-int
-scm_inferior_print (value, stream, format, deref_ref, recurse, pretty)
- LONGEST value;
- GDB_FILE *stream;
- int format;
- int deref_ref;
- int recurse;
- enum val_prettyprint pretty;
+LONGEST
+scm_get_field (LONGEST svalue, int index, int size,
+ enum bfd_endian byte_order)
{
- return -1;
+ gdb_byte buffer[20];
+ read_memory (SCM2PTR (svalue) + index * size, buffer, size);
+ return extract_signed_integer (buffer, size, byte_order);
}
-#define SCM_ITAG8_DATA(X) ((X)>>8)
-#define SCM_ICHR(x) ((unsigned char)SCM_ITAG8_DATA(x))
-#define SCM_ICHRP(x) (SCM_ITAG8(x) == scm_tc8_char)
-#define scm_tc8_char 0xf4
-#define SCM_IFLAGP(n) ((0x87 & (int)(n))==4)
-#define SCM_ISYMNUM(n) ((int)((n)>>9))
-#define SCM_ISYMCHARS(n) (scm_isymnames[SCM_ISYMNUM(n)])
-#define SCM_ILOCP(n) ((0xff & (int)(n))==0xfc)
-#define SCM_ITAG8(X) ((int)(X) & 0xff)
-
-/* {Names of immediate symbols}
- * This table must agree with the declarations in scm.h: {Immediate Symbols}.*/
+/* 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). */
-static char *scm_isymnames[] =
+LONGEST
+scm_unpack (struct type *type, const gdb_byte *valaddr, enum type_code context)
{
- /* This table must agree with the declarations */
- "#@and",
- "#@begin",
- "#@case",
- "#@cond",
- "#@do",
- "#@if",
- "#@lambda",
- "#@let",
- "#@let*",
- "#@letrec",
- "#@or",
- "#@quote",
- "#@set!",
- "#@define",
-#if 0
- "#@literal-variable-ref",
- "#@literal-variable-set!",
-#endif
- "#@apply",
- "#@call-with-current-continuation",
-
- /* user visible ISYMS */
- /* other keywords */
- /* Flags */
-
- "#f",
- "#t",
- "#",
- "#",
- "()",
- "#"
-};
-
-int
-scm_val_print (type, valaddr, address, stream, format, deref_ref, recurse,
- pretty)
- struct type *type;
- char *valaddr;
- CORE_ADDR address;
- GDB_FILE *stream;
- int format;
- int deref_ref;
- int recurse;
- enum val_prettyprint pretty;
-{
- if (is_object_type (type))
+ if (is_scmvalue_type (type))
{
- LONGEST svalue = unpack_long (type, valaddr);
- if (scm_inferior_print (svalue, stream, format,
- deref_ref, recurse, pretty) >= 0)
+ enum bfd_endian byte_order = gdbarch_byte_order (get_type_arch (type));
+ LONGEST svalue
+ = extract_signed_integer (valaddr, TYPE_LENGTH (type), byte_order);
+
+ if (context == TYPE_CODE_BOOL)
{
+ if (svalue == SCM_BOOL_F)
+ return 0;
+ else
+ return 1;
}
- else
+ switch (7 & (int) svalue)
{
- switch (7 & 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))
{
- case 2:
- case 6:
- print_longest (stream, format ? format : 'd', 1, svalue >> 2);
- break;
- case 4:
- if (SCM_ICHRP (svalue))
- {
- svalue = SCM_ICHR (svalue);
- scm_printchar (svalue, stream);
- break;
- }
- else if (SCM_IFLAGP (svalue)
- && (SCM_ISYMNUM (svalue)
- < (sizeof scm_isymnames / sizeof (char *))))
+ switch ((int) svalue)
{
- fputs_filtered (SCM_ISYMCHARS (svalue), stream);
- break;
- }
- else if (SCM_ILOCP (svalue))
- {
-#if 0
- fputs_filtered ("#@", stream);
- scm_intprint ((long) IFRAME (exp), 10, port);
- scm_putc (ICDRP (exp) ? '-' : '+', port);
- scm_intprint ((long) IDIST (exp), 10, port);
- break;
+#ifndef SICP
+ case SCM_EOL:
#endif
+ case SCM_BOOL_F:
+ return 0;
+ case SCM_BOOL_T:
+ return 1;
}
- default:
- fprintf_filtered (stream, "#<%lX>", svalue);
}
+ error (_("Value can't be converted to integer."));
+ default:
+ return svalue;
}
- gdb_flush (stream);
- return (0);
}
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)
{
- return c_val_print (type, valaddr, address, stream, format,
- deref_ref, recurse, pretty);
+ char *filename = cursal.symtab->filename;
+ int len = strlen (filename);
+ if (len >= 6 && strcmp (filename + len - 6, "eval.c") == 0)
+ return 1;
}
+ return 0;
}
-int
-scm_value_print (val, stream, format, pretty)
- value_ptr val;
- GDB_FILE *stream;
- int format;
- enum val_prettyprint pretty;
+/* 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 (struct gdbarch *gdbarch, char *str)
{
- return (val_print (VALUE_TYPE (val), VALUE_CONTENTS (val),
- VALUE_ADDRESS (val), stream, format, 1, 0, pretty));
+ struct value *args[3];
+ int len = strlen (str);
+ struct value *func;
+ struct value *val;
+ struct symbol *sym;
+
+ func = find_function_in_inferior ("scm_lookup_cstr", NULL);
+
+ args[0] = value_allocate_space_in_inferior (len);
+ args[1] = value_from_longest (builtin_type (gdbarch)->builtin_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_scm_type (gdbarch)->builtin_scm,
+ SCM_EOL);
+
+ 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);
}
-static value_ptr
-evaluate_subexp_scm (expect_type, exp, pos, noside)
- struct type *expect_type;
- register struct expression *exp;
- register int *pos;
- enum noside noside;
+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", NULL);
+ 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;
- value_ptr func, addr;
- int len, pc; char *str;
+ int len, pc;
+ char *str;
switch (op)
{
- case OP_EXPRSTRING:
+ 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[ + 2].string;
- addr = value_allocate_space_in_inferior (len);
- write_memory (value_as_long (addr), str, len);
- func = find_function_in_inferior ("scm_evstr");
- return call_function_by_hand (func, 1, &addr);
- default: ;
+ str = &exp->elts[pc + 2].string;
+ return scm_lookup_name (exp->gdbarch, 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);
+nosideret:
+ return value_from_longest (builtin_type (exp->gdbarch)->builtin_int, 1);
}
-const struct language_defn scm_language_defn = {
+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,
- c_builtin_types,
range_check_off,
type_check_off,
+ case_sensitive_off,
+ array_row_major,
+ macro_expansion_no,
+ &exp_descriptor_scm,
scm_parse,
c_error,
- evaluate_subexp_scm,
- scm_printchar, /* Print a character constant */
+ null_post_parser,
+ scm_printchar, /* Print a character constant */
scm_printstr, /* Function to print string constant */
- NULL, /* Create fundamental type in this language */
+ NULL, /* Function to print a single character */
c_print_type, /* Print a type using appropriate syntax */
+ default_print_typedef, /* Print a typedef 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, /* 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 */
- &builtin_type_char, /* Type of string elements */
+ default_word_break_characters,
+ default_make_symbol_completion_list,
+ c_language_arch_info,
+ default_print_array_index,
+ default_pass_by_reference,
+ default_get_string,
LANG_MAGIC
};
+static void *
+build_scm_types (struct gdbarch *gdbarch)
+{
+ struct builtin_scm_type *builtin_scm_type
+ = GDBARCH_OBSTACK_ZALLOC (gdbarch, struct builtin_scm_type);
+
+ builtin_scm_type->builtin_scm
+ = arch_integer_type (gdbarch, gdbarch_long_bit (gdbarch), 0, "SCM");
+
+ return builtin_scm_type;
+}
+
+static struct gdbarch_data *scm_type_data;
+
+const struct builtin_scm_type *
+builtin_scm_type (struct gdbarch *gdbarch)
+{
+ return gdbarch_data (gdbarch, scm_type_data);
+}
+
void
-_initialize_scheme_language ()
+_initialize_scheme_language (void)
{
+ scm_type_data = gdbarch_data_register_post_init (build_scm_types);
+
add_language (&scm_language_defn);
}