Browse Source
* NEWS: Mention Guile removal. * defs.h (enum language) <language_scm>: Remove. * Makefile.in (SFILES): Remove scm-exp.c, scm-lang.c, scm-valprint.c. (HFILES_NO_SRCDIR): Remove scm-lang.h, scm-tags.h. (COMMON_OBS): Remove scm-exp.o, scm-lang.o, scm-valprint.o. * scm-exp.c, scm-lang.c, scm-valprint.c, scm-lang.h, scm-tags.h: Remove. gdb/testsuite * gdb.base/default.exp: Remove "scheme" from language list.binutils-2_21-branch
Tom Tromey
16 years ago
11 changed files with 20 additions and 1733 deletions
@ -1,502 +0,0 @@ |
|||
/* Scheme/Guile language support routines for GDB, the GNU debugger.
|
|||
|
|||
Copyright (C) 1995, 1996, 2000, 2003, 2005, 2008, 2009, 2010 |
|||
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" |
|||
|
|||
#define USE_EXPRSTRING 0 |
|||
|
|||
static void scm_lreadparen (int); |
|||
static int scm_skip_ws (void); |
|||
static void scm_read_token (int, int); |
|||
static LONGEST scm_istring2number (char *, int, int); |
|||
static LONGEST scm_istr2int (char *, int, int); |
|||
static void scm_lreadr (int); |
|||
|
|||
static LONGEST |
|||
scm_istr2int (char *str, int len, int radix) |
|||
{ |
|||
int i = 0; |
|||
LONGEST inum = 0; |
|||
int c; |
|||
int sign = 0; |
|||
|
|||
if (0 >= len) |
|||
return SCM_BOOL_F; /* zero scm_length */ |
|||
switch (str[0]) |
|||
{ /* leading sign */ |
|||
case '-': |
|||
case '+': |
|||
sign = str[0]; |
|||
if (++i == len) |
|||
return SCM_BOOL_F; /* bad if lone `+' or `-' */ |
|||
} |
|||
do |
|||
{ |
|||
switch (c = str[i++]) |
|||
{ |
|||
case '0': |
|||
case '1': |
|||
case '2': |
|||
case '3': |
|||
case '4': |
|||
case '5': |
|||
case '6': |
|||
case '7': |
|||
case '8': |
|||
case '9': |
|||
c = c - '0'; |
|||
goto accumulate; |
|||
case 'A': |
|||
case 'B': |
|||
case 'C': |
|||
case 'D': |
|||
case 'E': |
|||
case 'F': |
|||
c = c - 'A' + 10; |
|||
goto accumulate; |
|||
case 'a': |
|||
case 'b': |
|||
case 'c': |
|||
case 'd': |
|||
case 'e': |
|||
case 'f': |
|||
c = c - 'a' + 10; |
|||
accumulate: |
|||
if (c >= radix) |
|||
return SCM_BOOL_F; /* bad digit for radix */ |
|||
inum *= radix; |
|||
inum += c; |
|||
break; |
|||
default: |
|||
return SCM_BOOL_F; /* not a digit */ |
|||
} |
|||
} |
|||
while (i < len); |
|||
if (sign == '-') |
|||
inum = -inum; |
|||
return SCM_MAKINUM (inum); |
|||
} |
|||
|
|||
static LONGEST |
|||
scm_istring2number (char *str, int len, int radix) |
|||
{ |
|||
int i = 0; |
|||
char ex = 0; |
|||
char ex_p = 0, rx_p = 0; /* Only allow 1 exactness and 1 radix prefix */ |
|||
#if 0 |
|||
SCM res; |
|||
#endif |
|||
|
|||
if (len == 1) |
|||
if (*str == '+' || *str == '-') /* Catches lone `+' and `-' for speed */ |
|||
return SCM_BOOL_F; |
|||
|
|||
while ((len - i) >= 2 && str[i] == '#' && ++i) |
|||
switch (str[i++]) |
|||
{ |
|||
case 'b': |
|||
case 'B': |
|||
if (rx_p++) |
|||
return SCM_BOOL_F; |
|||
radix = 2; |
|||
break; |
|||
case 'o': |
|||
case 'O': |
|||
if (rx_p++) |
|||
return SCM_BOOL_F; |
|||
radix = 8; |
|||
break; |
|||
case 'd': |
|||
case 'D': |
|||
if (rx_p++) |
|||
return SCM_BOOL_F; |
|||
radix = 10; |
|||
break; |
|||
case 'x': |
|||
case 'X': |
|||
if (rx_p++) |
|||
return SCM_BOOL_F; |
|||
radix = 16; |
|||
break; |
|||
case 'i': |
|||
case 'I': |
|||
if (ex_p++) |
|||
return SCM_BOOL_F; |
|||
ex = 2; |
|||
break; |
|||
case 'e': |
|||
case 'E': |
|||
if (ex_p++) |
|||
return SCM_BOOL_F; |
|||
ex = 1; |
|||
break; |
|||
default: |
|||
return SCM_BOOL_F; |
|||
} |
|||
|
|||
switch (ex) |
|||
{ |
|||
case 1: |
|||
return scm_istr2int (&str[i], len - i, radix); |
|||
case 0: |
|||
return scm_istr2int (&str[i], len - i, radix); |
|||
#if 0 |
|||
if NFALSEP |
|||
(res) return res; |
|||
#ifdef FLOATS |
|||
case 2: |
|||
return scm_istr2flo (&str[i], len - i, radix); |
|||
#endif |
|||
#endif |
|||
} |
|||
return SCM_BOOL_F; |
|||
} |
|||
|
|||
static void |
|||
scm_read_token (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 (void) |
|||
{ |
|||
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 (int skipping) |
|||
{ |
|||
for (;;) |
|||
{ |
|||
int c = scm_skip_ws (); |
|||
|
|||
if (')' == c || ']' == c) |
|||
return; |
|||
--lexptr; |
|||
if (c == '\0') |
|||
error ("missing close paren"); |
|||
scm_lreadr (skipping); |
|||
} |
|||
} |
|||
|
|||
static void |
|||
scm_lreadr (int skipping) |
|||
{ |
|||
int c, j; |
|||
struct stoken str; |
|||
LONGEST svalue = 0; |
|||
|
|||
tryagain: |
|||
c = *lexptr++; |
|||
switch (c) |
|||
{ |
|||
case '\0': |
|||
lexptr--; |
|||
return; |
|||
case '[': |
|||
case '(': |
|||
scm_lreadparen (skipping); |
|||
return; |
|||
case ']': |
|||
case ')': |
|||
error ("unexpected #\\%c", c); |
|||
goto tryagain; |
|||
case '\'': |
|||
case '`': |
|||
str.ptr = lexptr - 1; |
|||
scm_lreadr (skipping); |
|||
if (!skipping) |
|||
{ |
|||
struct value *val = scm_evaluate_string (str.ptr, lexptr - str.ptr); |
|||
|
|||
if (!is_scmvalue_type (value_type (val))) |
|||
error ("quoted scm form yields non-SCM value"); |
|||
svalue = extract_signed_integer (value_contents (val), |
|||
TYPE_LENGTH (value_type (val)), |
|||
gdbarch_byte_order (parse_gdbarch)); |
|||
goto handle_immediate; |
|||
} |
|||
return; |
|||
case ',': |
|||
c = *lexptr++; |
|||
if ('@' != c) |
|||
lexptr--; |
|||
scm_lreadr (skipping); |
|||
return; |
|||
case '#': |
|||
c = *lexptr++; |
|||
switch (c) |
|||
{ |
|||
case '[': |
|||
case '(': |
|||
scm_lreadparen (skipping); |
|||
return; |
|||
case 't': |
|||
case 'T': |
|||
svalue = SCM_BOOL_T; |
|||
goto handle_immediate; |
|||
case 'f': |
|||
case 'F': |
|||
svalue = SCM_BOOL_F; |
|||
goto handle_immediate; |
|||
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: |
|||
#if 0 |
|||
callshrp: |
|||
#endif |
|||
scm_lreadr (skipping); |
|||
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: |
|||
{ |
|||
str.ptr = lexptr - 1; |
|||
scm_read_token (c, 0); |
|||
if (!skipping) |
|||
{ |
|||
svalue = scm_istring2number (str.ptr, lexptr - str.ptr, 10); |
|||
if (svalue != SCM_BOOL_F) |
|||
goto handle_immediate; |
|||
goto tok; |
|||
} |
|||
} |
|||
return; |
|||
case ':': |
|||
scm_read_token ('-', 0); |
|||
return; |
|||
#if 0 |
|||
do_symbol: |
|||
#endif |
|||
default: |
|||
str.ptr = lexptr - 1; |
|||
scm_read_token (c, 0); |
|||
tok: |
|||
if (!skipping) |
|||
{ |
|||
str.length = lexptr - str.ptr; |
|||
if (str.ptr[0] == '$') |
|||
{ |
|||
write_dollar_variable (str); |
|||
return; |
|||
} |
|||
write_exp_elt_opcode (OP_NAME); |
|||
write_exp_string (str); |
|||
write_exp_elt_opcode (OP_NAME); |
|||
} |
|||
return; |
|||
} |
|||
handle_immediate: |
|||
if (!skipping) |
|||
{ |
|||
write_exp_elt_opcode (OP_LONG); |
|||
write_exp_elt_type (builtin_scm_type (parse_gdbarch)->builtin_scm); |
|||
write_exp_elt_longcst (svalue); |
|||
write_exp_elt_opcode (OP_LONG); |
|||
} |
|||
} |
|||
|
|||
int |
|||
scm_parse (void) |
|||
{ |
|||
char *start; |
|||
|
|||
while (*lexptr == ' ') |
|||
lexptr++; |
|||
start = lexptr; |
|||
scm_lreadr (USE_EXPRSTRING); |
|||
#if USE_EXPRSTRING |
|||
str.length = lexptr - start; |
|||
str.ptr = start; |
|||
write_exp_elt_opcode (OP_EXPRSTRING); |
|||
write_exp_string (str); |
|||
write_exp_elt_opcode (OP_EXPRSTRING); |
|||
#endif |
|||
return 0; |
|||
} |
|||
@ -1,308 +0,0 @@ |
|||
/* Scheme/Guile language support routines for GDB, the GNU debugger.
|
|||
|
|||
Copyright (C) 1995, 1996, 1998, 2000, 2001, 2002, 2003, 2004, 2005, 2007, |
|||
2008, 2009, 2010 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" |
|||
#include "objfiles.h" |
|||
|
|||
extern void _initialize_scheme_language (void); |
|||
static struct value *scm_lookup_name (struct gdbarch *, char *); |
|||
static int in_eval_c (void); |
|||
|
|||
void |
|||
scm_printchar (int c, struct type *type, struct ui_file *stream) |
|||
{ |
|||
fprintf_filtered (stream, "#\\%c", c); |
|||
} |
|||
|
|||
static void |
|||
scm_printstr (struct ui_file *stream, struct type *type, const gdb_byte *string, |
|||
unsigned int length, const char *encoding, int force_ellipses, |
|||
const struct value_print_options *options) |
|||
{ |
|||
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, int size, |
|||
enum bfd_endian byte_order) |
|||
{ |
|||
gdb_byte buffer[20]; |
|||
|
|||
read_memory (SCM2PTR (svalue) + index * size, buffer, size); |
|||
return extract_signed_integer (buffer, size, byte_order); |
|||
} |
|||
|
|||
/* 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)) |
|||
{ |
|||
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; |
|||
} |
|||
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 (struct gdbarch *gdbarch, char *str) |
|||
{ |
|||
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); |
|||
} |
|||
|
|||
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; |
|||
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 (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 (exp->gdbarch)->builtin_int, 1); |
|||
} |
|||
|
|||
const struct exp_descriptor exp_descriptor_scm = |
|||
{ |
|||
print_subexp_standard, |
|||
operator_length_standard, |
|||
operator_check_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, |
|||
macro_expansion_no, |
|||
&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 */ |
|||
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 */ |
|||
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, |
|||
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 (void) |
|||
{ |
|||
scm_type_data = gdbarch_data_register_post_init (build_scm_types); |
|||
|
|||
add_language (&scm_language_defn); |
|||
} |
|||
@ -1,77 +0,0 @@ |
|||
/* Scheme/Guile language support routines for GDB, the GNU debugger.
|
|||
|
|||
Copyright (C) 1995, 1996, 1998, 1999, 2000, 2003, 2005, 2008, 2009, 2010 |
|||
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/>. */
|
|||
|
|||
#define SICP |
|||
#include "scm-tags.h" |
|||
#undef SCM_NCELLP |
|||
#define SCM_NCELLP(x) ((SCM_SIZE-1) & (int)(x)) |
|||
#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) |
|||
#define SCM_TYP7(x) (0x7f & (int)SCM_CAR(x)) |
|||
#define SCM_LENGTH(x) (((unsigned long)SCM_CAR(x))>>8) |
|||
#define SCM_NCONSP(x) (1 & (int)SCM_CAR(x)) |
|||
#define SCM_NECONSP(x) (SCM_NCONSP(x) && (1 != SCM_TYP3(x))) |
|||
#define SCM_CAR(x) scm_get_field (x, 0, SCM_SIZE, SCM_BYTE_ORDER) |
|||
#define SCM_CDR(x) scm_get_field (x, 1, SCM_SIZE, SCM_BYTE_ORDER) |
|||
#define SCM_VELTS(x) ((SCM *)SCM_CDR(x)) |
|||
#define SCM_CLOSCAR(x) (SCM_CAR(x)-scm_tc3_closure) |
|||
#define SCM_CODE(x) SCM_CAR(SCM_CLOSCAR (x)) |
|||
#define SCM_MAKINUM(x) (((x)<<2)+2L) |
|||
|
|||
/* Forward decls for prototypes */ |
|||
struct value; |
|||
|
|||
extern int scm_value_print (struct value *, struct ui_file *, |
|||
const struct value_print_options *); |
|||
|
|||
extern int scm_val_print (struct type *, const gdb_byte *, int, CORE_ADDR, |
|||
struct ui_file *, int, |
|||
const struct value *, |
|||
const struct value_print_options *); |
|||
|
|||
extern LONGEST scm_get_field (LONGEST, int, int, enum bfd_endian); |
|||
|
|||
extern int is_scmvalue_type (struct type *); |
|||
|
|||
extern void scm_printchar (int, struct type *, struct ui_file *); |
|||
|
|||
extern struct value *scm_evaluate_string (char *, int); |
|||
|
|||
extern int scm_parse (void); |
|||
|
|||
extern LONGEST scm_unpack (struct type *, const gdb_byte *, enum type_code); |
|||
|
|||
/* Scheme types */ |
|||
|
|||
struct builtin_scm_type |
|||
{ |
|||
struct type *builtin_scm; |
|||
}; |
|||
|
|||
/* Return the Scheme type table for the specified architecture. */ |
|||
extern const struct builtin_scm_type *builtin_scm_type (struct gdbarch *gdbarch); |
|||
|
|||
@ -1,378 +0,0 @@ |
|||
/* This is a minimally edited version of Guile's tags.h. */ |
|||
/* classes: h_files */ |
|||
|
|||
#ifndef TAGSH |
|||
#define TAGSH |
|||
/* Copyright (C) 1995, 1999, 2008, 2009, 2010
|
|||
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 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/>.
|
|||
|
|||
As a special exception, the Free Software Foundation gives permission |
|||
for additional uses of the text contained in its release of GUILE. |
|||
|
|||
The exception is that, if you link the GUILE library with other files |
|||
to produce an executable, this does not by itself cause the |
|||
resulting executable to be covered by the GNU General Public License. |
|||
Your use of that executable is in no way restricted on account of |
|||
linking the GUILE library code into it. |
|||
|
|||
This exception does not however invalidate any other reasons why |
|||
the executable file might be covered by the GNU General Public License. |
|||
|
|||
This exception applies only to the code released by the |
|||
Free Software Foundation under the name GUILE. If you copy |
|||
code from other Free Software Foundation releases into a copy of |
|||
GUILE, as the General Public License permits, the exception does |
|||
not apply to the code that you add in this way. To avoid misleading |
|||
anyone as to the status of such modified files, you must delete |
|||
this exception notice from them. |
|||
|
|||
If you write modifications of your own for GUILE, it is your choice |
|||
whether to permit this exception to apply to your modifications. |
|||
If you do not wish that, delete this exception notice. */ |
|||
|
|||
|
|||
/** This file defines the format of SCM values and cons pairs.
|
|||
** It is here that tag bits are assigned for various purposes. |
|||
**/ |
|||
|
|||
|
|||
/* Three Bit Tags
|
|||
|
|||
* 000 -- a non-immediate value. Points into the pair heap. |
|||
* |
|||
* 001 -- a gloc (i.e., a resolved global variable in a CAR in a code graph) |
|||
* or the CAR of an object handle (i.e., the tagged pointer to the |
|||
* vtable part of a user-defined object). |
|||
* |
|||
* If X has this tag, the value at CDAR(X - 1) distinguishes |
|||
* glocs from object handles. The distinction only needs |
|||
* to be made in a few places. Only a few parts of the code know |
|||
* about glocs. In most cases, when a value in the CAR of a pair |
|||
* has the tag 001, it means that the pair is an object handle. |
|||
* |
|||
* 010 -- the tag for immediate, exact integers. |
|||
* |
|||
* 011 -- in the CAR of a pair, this tag indicates that the pair is a closure. |
|||
* The remaining bits of the CAR are a pointer into the pair heap |
|||
* to the code graph for the closure. |
|||
* |
|||
* 1xy -- an extension tag which means that there is a five or six bit |
|||
* tag to the left of the low three bits. See the nice diagrams |
|||
* in ../doc/code.doc if you want to know what the bits mean. |
|||
*/ |
|||
|
|||
|
|||
|
|||
|
|||
|
|||
#define scm_tc3_cons 0 |
|||
#define scm_tc3_cons_gloc 1 |
|||
#define scm_tc3_closure 3 |
|||
|
|||
#define scm_tc7_ssymbol 5 |
|||
#define scm_tc7_msymbol 7 |
|||
#define scm_tc7_string 13 |
|||
#define scm_tc7_bvect 15 |
|||
#define scm_tc7_vector 21 |
|||
#define scm_tc7_lvector 23 |
|||
#define scm_tc7_ivect 29 |
|||
#define scm_tc7_uvect 31 |
|||
/* spare 37 39 */ |
|||
#define scm_tc7_fvect 45 |
|||
#define scm_tc7_dvect 47 |
|||
#define scm_tc7_cvect 53 |
|||
#define scm_tc7_port 55 |
|||
#define scm_tc7_contin 61 |
|||
#define scm_tc7_cclo 63 |
|||
/* spare 69 71 77 79 */ |
|||
#define scm_tc7_subr_0 85 |
|||
#define scm_tc7_subr_1 87 |
|||
#define scm_tc7_cxr 93 |
|||
#define scm_tc7_subr_3 95 |
|||
#define scm_tc7_subr_2 101 |
|||
#define scm_tc7_asubr 103 |
|||
#define scm_tc7_subr_1o 109 |
|||
#define scm_tc7_subr_2o 111 |
|||
#define scm_tc7_lsubr_2 117 |
|||
#define scm_tc7_lsubr 119 |
|||
#define scm_tc7_rpsubr 125 |
|||
|
|||
#define scm_tc7_smob 127 |
|||
#define scm_tc_free_cell 127 |
|||
|
|||
#define scm_tc16_flo 0x017f |
|||
#define scm_tc_flo 0x017fL |
|||
|
|||
#define SCM_REAL_PART (1L<<16) |
|||
#define SCM_IMAG_PART (2L<<16) |
|||
#define scm_tc_dblr (scm_tc16_flo|REAL_PART) |
|||
#define scm_tc_dblc (scm_tc16_flo|REAL_PART|IMAG_PART) |
|||
|
|||
#define scm_tc16_bigpos 0x027f |
|||
#define scm_tc16_bigneg 0x037f |
|||
|
|||
#define scm_tc16_fport (scm_tc7_port + 0*256L) |
|||
#define scm_tc16_pipe (scm_tc7_port + 1*256L) |
|||
#define scm_tc16_strport (scm_tc7_port + 2*256L) |
|||
#define scm_tc16_sfport (scm_tc7_port + 3*256L) |
|||
|
|||
|
|||
|
|||
/* For cons pairs with immediate values in the CAR */ |
|||
#define scm_tcs_cons_imcar 2:case 4:case 6:case 10:\ |
|||
case 12:case 14:case 18:case 20:\ |
|||
case 22:case 26:case 28:case 30:\ |
|||
case 34:case 36:case 38:case 42:\ |
|||
case 44:case 46:case 50:case 52:\ |
|||
case 54:case 58:case 60:case 62:\ |
|||
case 66:case 68:case 70:case 74:\ |
|||
case 76:case 78:case 82:case 84:\ |
|||
case 86:case 90:case 92:case 94:\ |
|||
case 98:case 100:case 102:case 106:\ |
|||
case 108:case 110:case 114:case 116:\ |
|||
case 118:case 122:case 124:case 126 |
|||
|
|||
/* For cons pairs with non-immediate values in the CAR */ |
|||
#define scm_tcs_cons_nimcar 0:case 8:case 16:case 24:\ |
|||
case 32:case 40:case 48:case 56:\ |
|||
case 64:case 72:case 80:case 88:\ |
|||
case 96:case 104:case 112:case 120 |
|||
|
|||
/* A CONS_GLOC occurs in code. It's CAR is a pointer to the
|
|||
* CDR of a variable. The low order bits of the CAR are 001. |
|||
* The CDR of the gloc is the code continuation. |
|||
*/ |
|||
#define scm_tcs_cons_gloc 1:case 9:case 17:case 25:\ |
|||
case 33:case 41:case 49:case 57:\ |
|||
case 65:case 73:case 81:case 89:\ |
|||
case 97:case 105:case 113:case 121 |
|||
|
|||
#define scm_tcs_closures 3:case 11:case 19:case 27:\ |
|||
case 35:case 43:case 51:case 59:\ |
|||
case 67:case 75:case 83:case 91:\ |
|||
case 99:case 107:case 115:case 123 |
|||
|
|||
#define scm_tcs_subrs scm_tc7_asubr:case scm_tc7_subr_0:case scm_tc7_subr_1:case scm_tc7_cxr:\ |
|||
case scm_tc7_subr_3:case scm_tc7_subr_2:case scm_tc7_rpsubr:case scm_tc7_subr_1o:\ |
|||
case scm_tc7_subr_2o:case scm_tc7_lsubr_2:case scm_tc7_lsubr |
|||
|
|||
#define scm_tcs_symbols scm_tc7_ssymbol:case scm_tc7_msymbol |
|||
|
|||
#define scm_tcs_bignums tc16_bigpos:case tc16_bigneg |
|||
|
|||
|
|||
|
|||
/* References to objects are of type SCM. Values may be non-immediate
|
|||
* (pointers) or immediate (encoded, immutable, scalar values that fit |
|||
* in an SCM variable). |
|||
*/ |
|||
|
|||
typedef long SCM; |
|||
|
|||
/* Cray machines have pointers that are incremented once for each word,
|
|||
* rather than each byte, the 3 most significant bits encode the byte |
|||
* within the word. The following macros deal with this by storing the |
|||
* native Cray pointers like the ones that looks like scm expects. This |
|||
* is done for any pointers that might appear in the car of a scm_cell, pointers |
|||
* to scm_vector elts, functions, &c are not munged. |
|||
*/ |
|||
#ifdef _UNICOS |
|||
#define SCM2PTR(x) ((int)(x) >> 3) |
|||
#define PTR2SCM(x) (((SCM)(x)) << 3) |
|||
#define SCM_POINTERS_MUNGED |
|||
#else |
|||
#define SCM2PTR(x) (x) |
|||
#define PTR2SCM(x) ((SCM)(x)) |
|||
#endif /* def _UNICOS */ |
|||
|
|||
|
|||
|
|||
/* Immediate? Predicates
|
|||
*/ |
|||
#define SCM_IMP(x) (6 & (int)(x)) |
|||
#define SCM_NIMP(x) (!SCM_IMP(x)) |
|||
|
|||
|
|||
|
|||
enum scm_tags |
|||
{ |
|||
scm_tc8_char = 0xf4 |
|||
}; |
|||
|
|||
#define SCM_ITAG8(X) ((int)(X) & 0xff) |
|||
#define SCM_MAKE_ITAG8(X, TAG) (((X)<<8) + TAG) |
|||
#define SCM_ITAG8_DATA(X) ((X)>>8) |
|||
|
|||
|
|||
|
|||
/* Local Environment Structure
|
|||
*/ |
|||
#define SCM_ILOCP(n) ((0xff & (int)(n))==0xfc) |
|||
#define SCM_ILOC00 (0x000000fcL) |
|||
#define SCM_IDINC (0x00100000L) |
|||
#define SCM_ICDR (0x00080000L) |
|||
#define SCM_IFRINC (0x00000100L) |
|||
#define SCM_IDSTMSK (-SCM_IDINC) |
|||
#define SCM_IFRAME(n) ((int)((SCM_ICDR-SCM_IFRINC)>>8) & ((int)(n)>>8)) |
|||
#define SCM_IDIST(n) (((unsigned long)(n))>>20) |
|||
#define SCM_ICDRP(n) (SCM_ICDR & (n)) |
|||
|
|||
|
|||
/* Immediate Symbols, Special Symbols, Flags (various constants).
|
|||
*/ |
|||
|
|||
/* ISYMP tests for ISPCSYM and ISYM */ |
|||
#define SCM_ISYMP(n) ((0x187 & (int)(n))==4) |
|||
|
|||
/* IFLAGP tests for ISPCSYM, ISYM and IFLAG */ |
|||
#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_MAKSPCSYM(n) (((n)<<9)+((n)<<3)+4L) |
|||
#define SCM_MAKISYM(n) (((n)<<9)+0x74L) |
|||
#define SCM_MAKIFLAG(n) (((n)<<9)+0x174L) |
|||
|
|||
/* This table must agree with the declarations
|
|||
* in repl.c: {Names of immediate symbols}. |
|||
* |
|||
* These are used only in eval but their values |
|||
* have to be allocated here. |
|||
* |
|||
*/ |
|||
|
|||
#define SCM_IM_AND SCM_MAKSPCSYM(0) |
|||
#define SCM_IM_BEGIN SCM_MAKSPCSYM(1) |
|||
#define SCM_IM_CASE SCM_MAKSPCSYM(2) |
|||
#define SCM_IM_COND SCM_MAKSPCSYM(3) |
|||
#define SCM_IM_DO SCM_MAKSPCSYM(4) |
|||
#define SCM_IM_IF SCM_MAKSPCSYM(5) |
|||
#define SCM_IM_LAMBDA SCM_MAKSPCSYM(6) |
|||
#define SCM_IM_LET SCM_MAKSPCSYM(7) |
|||
#define SCM_IM_LETSTAR SCM_MAKSPCSYM(8) |
|||
#define SCM_IM_LETREC SCM_MAKSPCSYM(9) |
|||
#define SCM_IM_OR SCM_MAKSPCSYM(10) |
|||
#define SCM_IM_QUOTE SCM_MAKSPCSYM(11) |
|||
#define SCM_IM_SET SCM_MAKSPCSYM(12) |
|||
#define SCM_IM_DEFINE SCM_MAKSPCSYM(13) |
|||
#define SCM_IM_APPLY SCM_MAKISYM(14) |
|||
#define SCM_IM_CONT SCM_MAKISYM(15) |
|||
#define SCM_NUM_ISYMS 16 |
|||
|
|||
/* Important immediates
|
|||
*/ |
|||
|
|||
#define SCM_BOOL_F SCM_MAKIFLAG(SCM_NUM_ISYMS+0) |
|||
#define SCM_BOOL_T SCM_MAKIFLAG(SCM_NUM_ISYMS+1) |
|||
#define SCM_UNDEFINED SCM_MAKIFLAG(SCM_NUM_ISYMS+2) |
|||
#define SCM_EOF_VAL SCM_MAKIFLAG(SCM_NUM_ISYMS+3) |
|||
|
|||
#ifdef SICP |
|||
#define SCM_EOL SCM_BOOL_F |
|||
#else |
|||
#define SCM_EOL SCM_MAKIFLAG(SCM_NUM_ISYMS+4) |
|||
#endif |
|||
|
|||
#define SCM_UNSPECIFIED SCM_MAKIFLAG(SCM_NUM_ISYMS+5) |
|||
|
|||
|
|||
|
|||
/* Heap Pairs and the Empty List Predicates
|
|||
*/ |
|||
#define SCM_NULLP(x) (SCM_EOL == (x)) |
|||
#define SCM_NNULLP(x) (SCM_EOL != (x)) |
|||
#define SCM_CELLP(x) (!SCM_NCELLP(x)) |
|||
#define SCM_NCELLP(x) ((sizeof(scm_cell)-1) & (int)(x)) |
|||
|
|||
|
|||
|
|||
#define SCM_UNBNDP(x) (SCM_UNDEFINED==(x)) |
|||
|
|||
|
|||
|
|||
/* Testing and Changing GC Marks in Various Standard Positions
|
|||
*/ |
|||
#define SCM_GCMARKP(x) (1 & (int)SCM_CDR(x)) |
|||
#define SCM_GC8MARKP(x) (0x80 & (int)SCM_CAR(x)) |
|||
#define SCM_SETGCMARK(x) (SCM_CDR(x) |= 1) |
|||
#define SCM_CLRGCMARK(x) (SCM_CDR(x) &= ~1L) |
|||
#define SCM_SETGC8MARK(x) (SCM_CAR(x) |= 0x80) |
|||
#define SCM_CLRGC8MARK(x) (SCM_CAR(x) &= ~0x80L) |
|||
|
|||
|
|||
/* Extracting Tag Bits, With or Without GC Safety and Optional Bits
|
|||
*/ |
|||
#define SCM_TYP3(x) (7 & (int)SCM_CAR(x)) |
|||
#define SCM_TYP7(x) (0x7f & (int)SCM_CAR(x)) |
|||
#define SCM_TYP7S(x) (0x7d & (int)SCM_CAR(x)) |
|||
#define SCM_TYP16(x) (0xffff & (int)SCM_CAR(x)) |
|||
#define SCM_TYP16S(x) (0xfeff & (int)SCM_CAR(x)) |
|||
#define SCM_GCTYP16(x) (0xff7f & (int)SCM_CAR(x)) |
|||
|
|||
|
|||
/* Two slightly extensible types: smobs and ptobs.
|
|||
|
|||
*/ |
|||
#define SCM_SMOBNUM(x) (0x0ff & (CAR(x)>>8)); |
|||
#define SCM_PTOBNUM(x) (0x0ff & (CAR(x)>>8)); |
|||
|
|||
|
|||
|
|||
|
|||
#define SCM_DIRP(x) (SCM_NIMP(x) && (TYP16(x)==(scm_tc16_dir))) |
|||
#define SCM_OPDIRP(x) (SCM_NIMP(x) && (CAR(x)==(scm_tc16_dir | OPN))) |
|||
|
|||
|
|||
|
|||
/* Lvectors
|
|||
*/ |
|||
#define SCM_LVECTORP(x) (TYP7(x)==tc7_lvector) |
|||
|
|||
|
|||
#if 0 |
|||
|
|||
/* Sockets
|
|||
*/ |
|||
#define tc_socket (tc7_port | OPN) |
|||
#define SCM_SOCKP(x) (((0x7f | OPN | RDNG | WRTNG) & CAR(x))==(tc_socket)) |
|||
#define SCM_SOCKTYP(x) (CAR(x)>>24) |
|||
|
|||
|
|||
|
|||
extern int scm_tc16_key_vector; |
|||
#define SCM_KEYVECP(X) (scm_tc16_key_vector == TYP16 (X)) |
|||
#define SCM_KEYVECLEN(OBJ) (((unsigned long)CAR (obj)) >> 16) |
|||
|
|||
|
|||
#define SCM_MALLOCDATA(obj) ((char *)CDR(obj)) |
|||
#define SCM_MALLOCLEN(obj) (((unsigned long)CAR (obj)) >> 16) |
|||
#define SCM_WORDDATA(obj) (CDR (obj)) |
|||
|
|||
|
|||
#define SCM_BYTECODEP(X) ((TYP7 (X) == tc7_cclo) && (CCLO_SUBR (X) == rb_proc)) |
|||
#define SCM_BYTECODE_CONSTANTS(X) (VELTS(X)[1]) |
|||
#define SCM_BYTECODE_CODE(X) (VELTS(X)[2]) |
|||
#define SCM_BYTECODE_NAME(X) (VELTS(X)[3]) |
|||
#define SCM_BYTECODE_BCODE(X) (VELTS(X)[4]) |
|||
#define SCM_BYTECODE_ELTS 5 |
|||
|
|||
|
|||
#define SCM_FREEP(x) (CAR(x)==tc_free_cell) |
|||
#define SCM_NFREEP(x) (!FREEP(x)) |
|||
|
|||
#endif /* 0 */ |
|||
|
|||
|
|||
#endif /* TAGSH */ |
|||
@ -1,462 +0,0 @@ |
|||
/* Scheme/Guile language support routines for GDB, the GNU debugger.
|
|||
|
|||
Copyright (C) 1995, 1996, 1998, 1999, 2000, 2001, 2005, 2007, 2008, 2009, |
|||
2010 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 "scm-lang.h" |
|||
#include "valprint.h" |
|||
#include "gdbcore.h" |
|||
#include "c-lang.h" |
|||
#include "infcall.h" |
|||
#include "objfiles.h" |
|||
|
|||
static void scm_ipruk (char *, struct type *, LONGEST, struct ui_file *); |
|||
static void scm_scmval_print (struct type *, LONGEST, struct ui_file *, |
|||
int, const struct value_print_options *); |
|||
static void scm_scmlist_print (struct type *, LONGEST, struct ui_file *, |
|||
int, const struct value_print_options *); |
|||
static int scm_inferior_print (struct type *, LONGEST, struct ui_file *, |
|||
int, const struct value_print_options *); |
|||
|
|||
/* Prints the SCM value VALUE by invoking the inferior, if appropraite.
|
|||
Returns >= 0 on success; return -1 if the inferior cannot/should not |
|||
print VALUE. */ |
|||
|
|||
static int |
|||
scm_inferior_print (struct type *type, LONGEST value, struct ui_file *stream, |
|||
int recurse, const struct value_print_options *options) |
|||
{ |
|||
struct value *func, *arg, *result; |
|||
struct symbol *gdb_output_sym, *gdb_output_len_sym; |
|||
char *output; |
|||
int ret, output_len; |
|||
|
|||
func = find_function_in_inferior ("gdb_print", NULL); |
|||
arg = value_from_longest (type, value); |
|||
|
|||
result = call_function_by_hand (func, 1, &arg); |
|||
ret = (int) value_as_long (result); |
|||
if (ret == 0) |
|||
{ |
|||
/* XXX: Should we cache these symbols? */ |
|||
gdb_output_sym = |
|||
lookup_symbol_global ("gdb_output", NULL, VAR_DOMAIN); |
|||
gdb_output_len_sym = |
|||
lookup_symbol_global ("gdb_output_length", NULL, VAR_DOMAIN); |
|||
|
|||
if ((gdb_output_sym == NULL) || (gdb_output_len_sym == NULL)) |
|||
ret = -1; |
|||
else |
|||
{ |
|||
struct value *remote_buffer; |
|||
|
|||
read_memory (SYMBOL_VALUE_ADDRESS (gdb_output_len_sym), |
|||
(char *) &output_len, sizeof (output_len)); |
|||
|
|||
output = (char *) alloca (output_len); |
|||
remote_buffer = value_at (type, |
|||
SYMBOL_VALUE_ADDRESS (gdb_output_sym)); |
|||
read_memory (value_as_address (remote_buffer), |
|||
output, output_len); |
|||
|
|||
ui_file_write (stream, output, output_len); |
|||
} |
|||
} |
|||
|
|||
return ret; |
|||
} |
|||
|
|||
/* {Names of immediate symbols}
|
|||
* This table must agree with the declarations in scm.h: {Immediate Symbols}.*/ |
|||
|
|||
static char *scm_isymnames[] = |
|||
{ |
|||
/* 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", |
|||
"#<undefined>", |
|||
"#<eof>", |
|||
"()", |
|||
"#<unspecified>" |
|||
}; |
|||
|
|||
static void |
|||
scm_scmlist_print (struct type *type, LONGEST svalue, |
|||
struct ui_file *stream, int recurse, |
|||
const struct value_print_options *options) |
|||
{ |
|||
#define SCM_SIZE (TYPE_LENGTH (type)) |
|||
#define SCM_BYTE_ORDER (gdbarch_byte_order (get_type_arch (type))) |
|||
unsigned int more = options->print_max; |
|||
|
|||
if (recurse > 6) |
|||
{ |
|||
fputs_filtered ("...", stream); |
|||
return; |
|||
} |
|||
scm_scmval_print (type, SCM_CAR (svalue), stream, recurse + 1, options); |
|||
svalue = SCM_CDR (svalue); |
|||
for (; SCM_NIMP (svalue); svalue = SCM_CDR (svalue)) |
|||
{ |
|||
if (SCM_NECONSP (svalue)) |
|||
break; |
|||
fputs_filtered (" ", stream); |
|||
if (--more == 0) |
|||
{ |
|||
fputs_filtered ("...", stream); |
|||
return; |
|||
} |
|||
scm_scmval_print (type, SCM_CAR (svalue), stream, recurse + 1, options); |
|||
} |
|||
if (SCM_NNULLP (svalue)) |
|||
{ |
|||
fputs_filtered (" . ", stream); |
|||
scm_scmval_print (type, svalue, stream, recurse + 1, options); |
|||
} |
|||
#undef SCM_BYTE_ORDER |
|||
#undef SCM_SIZE |
|||
} |
|||
|
|||
static void |
|||
scm_ipruk (char *hdr, struct type *type, LONGEST ptr, |
|||
struct ui_file *stream) |
|||
{ |
|||
#define SCM_SIZE (TYPE_LENGTH (type)) |
|||
#define SCM_BYTE_ORDER (gdbarch_byte_order (get_type_arch (type))) |
|||
fprintf_filtered (stream, "#<unknown-%s", hdr); |
|||
if (SCM_CELLP (ptr)) |
|||
fprintf_filtered (stream, " (0x%lx . 0x%lx) @", |
|||
(long) SCM_CAR (ptr), (long) SCM_CDR (ptr)); |
|||
fprintf_filtered (stream, " 0x%s>", phex_nz (ptr, SCM_SIZE)); |
|||
#undef SCM_BYTE_ORDER |
|||
#undef SCM_SIZE |
|||
} |
|||
|
|||
static void |
|||
scm_scmval_print (struct type *type, LONGEST svalue, |
|||
struct ui_file *stream, int recurse, |
|||
const struct value_print_options *options) |
|||
{ |
|||
struct gdbarch *gdbarch = get_type_arch (type); |
|||
|
|||
#define SCM_SIZE (TYPE_LENGTH (type)) |
|||
#define SCM_BYTE_ORDER (gdbarch_byte_order (gdbarch)) |
|||
taloop: |
|||
switch (7 & (int) svalue) |
|||
{ |
|||
case 2: |
|||
case 6: |
|||
print_longest (stream, |
|||
options->format ? options->format : 'd', |
|||
1, svalue >> 2); |
|||
break; |
|||
case 4: |
|||
if (SCM_ICHRP (svalue)) |
|||
{ |
|||
svalue = SCM_ICHR (svalue); |
|||
scm_printchar (svalue, builtin_type (gdbarch)->builtin_char, |
|||
stream); |
|||
break; |
|||
} |
|||
else if (SCM_IFLAGP (svalue) |
|||
&& (SCM_ISYMNUM (svalue) |
|||
< (sizeof scm_isymnames / sizeof (char *)))) |
|||
{ |
|||
fputs_filtered (SCM_ISYMCHARS (svalue), stream); |
|||
break; |
|||
} |
|||
else if (SCM_ILOCP (svalue)) |
|||
{ |
|||
fprintf_filtered (stream, "#@%ld%c%ld", |
|||
(long) SCM_IFRAME (svalue), |
|||
SCM_ICDRP (svalue) ? '-' : '+', |
|||
(long) SCM_IDIST (svalue)); |
|||
break; |
|||
} |
|||
else |
|||
goto idef; |
|||
break; |
|||
case 1: |
|||
/* gloc */ |
|||
svalue = SCM_CAR (svalue - 1); |
|||
goto taloop; |
|||
default: |
|||
idef: |
|||
scm_ipruk ("immediate", type, svalue, stream); |
|||
break; |
|||
case 0: |
|||
|
|||
switch (SCM_TYP7 (svalue)) |
|||
{ |
|||
case scm_tcs_cons_gloc: |
|||
if (SCM_CDR (SCM_CAR (svalue) - 1L) == 0) |
|||
{ |
|||
#if 0 |
|||
SCM name; |
|||
#endif |
|||
|
|||
fputs_filtered ("#<latte ", stream); |
|||
#if 1 |
|||
fputs_filtered ("???", stream); |
|||
#else |
|||
name = ((SCM n *) (STRUCT_TYPE (exp)))[struct_i_name]; |
|||
scm_lfwrite (CHARS (name), |
|||
(sizet) sizeof (char), |
|||
(sizet) LENGTH (name), |
|||
port); |
|||
#endif |
|||
fprintf_filtered (stream, " #X%s>", phex_nz (svalue, SCM_SIZE)); |
|||
break; |
|||
} |
|||
case scm_tcs_cons_imcar: |
|||
case scm_tcs_cons_nimcar: |
|||
fputs_filtered ("(", stream); |
|||
scm_scmlist_print (type, svalue, stream, recurse + 1, options); |
|||
fputs_filtered (")", stream); |
|||
break; |
|||
case scm_tcs_closures: |
|||
fputs_filtered ("#<CLOSURE ", stream); |
|||
scm_scmlist_print (type, SCM_CODE (svalue), stream, |
|||
recurse + 1, options); |
|||
fputs_filtered (">", stream); |
|||
break; |
|||
case scm_tc7_string: |
|||
{ |
|||
int len = SCM_LENGTH (svalue); |
|||
CORE_ADDR addr = (CORE_ADDR) SCM_CDR (svalue); |
|||
int i; |
|||
int done = 0; |
|||
int buf_size; |
|||
gdb_byte buffer[64]; |
|||
int truncate = options->print_max && len > (int) options->print_max; |
|||
if (truncate) |
|||
len = options->print_max; |
|||
fputs_filtered ("\"", stream); |
|||
for (; done < len; done += buf_size) |
|||
{ |
|||
buf_size = min (len - done, 64); |
|||
read_memory (addr + done, buffer, buf_size); |
|||
|
|||
for (i = 0; i < buf_size; ++i) |
|||
switch (buffer[i]) |
|||
{ |
|||
case '\"': |
|||
case '\\': |
|||
fputs_filtered ("\\", stream); |
|||
default: |
|||
fprintf_filtered (stream, "%c", buffer[i]); |
|||
} |
|||
} |
|||
fputs_filtered (truncate ? "...\"" : "\"", stream); |
|||
break; |
|||
} |
|||
break; |
|||
case scm_tcs_symbols: |
|||
{ |
|||
int len = SCM_LENGTH (svalue); |
|||
|
|||
char *str = alloca (len); |
|||
read_memory (SCM_CDR (svalue), (gdb_byte *) str, len + 1); |
|||
/* Should handle weird characters FIXME */ |
|||
str[len] = '\0'; |
|||
fputs_filtered (str, stream); |
|||
break; |
|||
} |
|||
case scm_tc7_vector: |
|||
{ |
|||
int len = SCM_LENGTH (svalue); |
|||
int i; |
|||
LONGEST elements = SCM_CDR (svalue); |
|||
LONGEST val; |
|||
|
|||
fputs_filtered ("#(", stream); |
|||
for (i = 0; i < len; ++i) |
|||
{ |
|||
if (i > 0) |
|||
fputs_filtered (" ", stream); |
|||
val = scm_get_field (elements, i, SCM_SIZE, SCM_BYTE_ORDER); |
|||
scm_scmval_print (type, val, stream, recurse + 1, options); |
|||
} |
|||
fputs_filtered (")", stream); |
|||
} |
|||
break; |
|||
#if 0 |
|||
case tc7_lvector: |
|||
{ |
|||
SCM result; |
|||
SCM hook; |
|||
|
|||
hook = scm_get_lvector_hook (exp, LV_PRINT_FN); |
|||
if (hook == BOOL_F) |
|||
{ |
|||
scm_puts ("#<locked-vector ", port); |
|||
scm_intprint (CDR (exp), 16, port); |
|||
scm_puts (">", port); |
|||
} |
|||
else |
|||
{ |
|||
result |
|||
= scm_apply (hook, |
|||
scm_listify (exp, port, |
|||
(writing ? BOOL_T : BOOL_F), |
|||
SCM_UNDEFINED), |
|||
EOL); |
|||
if (result == BOOL_F) |
|||
goto punk; |
|||
} |
|||
break; |
|||
} |
|||
break; |
|||
case tc7_bvect: |
|||
case tc7_ivect: |
|||
case tc7_uvect: |
|||
case tc7_fvect: |
|||
case tc7_dvect: |
|||
case tc7_cvect: |
|||
scm_raprin1 (exp, port, writing); |
|||
break; |
|||
#endif |
|||
case scm_tcs_subrs: |
|||
{ |
|||
int index = SCM_CAR (svalue) >> 8; |
|||
#if 1 |
|||
char str[20]; |
|||
sprintf (str, "#%d", index); |
|||
#else |
|||
char *str = index ? SCM_CHARS (scm_heap_org + index) : ""; |
|||
#define SCM_CHARS(x) ((char *)(SCM_CDR(x))) |
|||
char *str = CHARS (SNAME (exp)); |
|||
#endif |
|||
|
|||
fprintf_filtered (stream, "#<primitive-procedure %s>", |
|||
str); |
|||
} |
|||
break; |
|||
#if 0 |
|||
#ifdef CCLO |
|||
case tc7_cclo: |
|||
scm_puts ("#<compiled-closure ", port); |
|||
scm_iprin1 (CCLO_SUBR (exp), port, writing); |
|||
scm_putc ('>', port); |
|||
break; |
|||
#endif |
|||
case tc7_contin: |
|||
fprintf_filtered (stream, "#<continuation %d @ #X%lx >", |
|||
LENGTH (svalue), |
|||
(long) CHARS (svalue)); |
|||
break; |
|||
case tc7_port: |
|||
i = PTOBNUM (exp); |
|||
if (i < scm_numptob |
|||
&& scm_ptobs[i].print |
|||
&& (scm_ptobs[i].print) (exp, port, writing)) |
|||
break; |
|||
goto punk; |
|||
case tc7_smob: |
|||
i = SMOBNUM (exp); |
|||
if (i < scm_numsmob && scm_smobs[i].print |
|||
&& (scm_smobs[i].print) (exp, port, writing)) |
|||
break; |
|||
goto punk; |
|||
#endif |
|||
default: |
|||
#if 0 |
|||
punk: |
|||
#endif |
|||
scm_ipruk ("type", type, svalue, stream); |
|||
} |
|||
break; |
|||
} |
|||
#undef SCM_BYTE_ORDER |
|||
#undef SCM_SIZE |
|||
} |
|||
|
|||
int |
|||
scm_val_print (struct type *type, const gdb_byte *valaddr, |
|||
int embedded_offset, CORE_ADDR address, |
|||
struct ui_file *stream, int recurse, |
|||
const struct value *val, |
|||
const struct value_print_options *options) |
|||
{ |
|||
if (is_scmvalue_type (type) |
|||
&& value_bits_valid (val, TARGET_CHAR_BIT * embedded_offset, |
|||
TARGET_CHAR_BIT * TYPE_LENGTH (type))) |
|||
{ |
|||
enum bfd_endian byte_order = gdbarch_byte_order (get_type_arch (type)); |
|||
LONGEST svalue |
|||
= extract_signed_integer (valaddr, TYPE_LENGTH (type), byte_order); |
|||
|
|||
if (scm_inferior_print (type, svalue, stream, recurse, options) >= 0) |
|||
{ |
|||
} |
|||
else |
|||
{ |
|||
scm_scmval_print (type, svalue, stream, recurse, options); |
|||
} |
|||
|
|||
gdb_flush (stream); |
|||
return (0); |
|||
} |
|||
else |
|||
{ |
|||
return c_val_print (type, valaddr, 0, address, stream, recurse, |
|||
val, options); |
|||
} |
|||
} |
|||
|
|||
int |
|||
scm_value_print (struct value *val, struct ui_file *stream, |
|||
const struct value_print_options *options) |
|||
{ |
|||
struct value_print_options opts = *options; |
|||
|
|||
opts.deref_ref = 1; |
|||
return (common_val_print (val, stream, 0, &opts, current_language)); |
|||
} |
|||
Loading…
Reference in new issue