mirror of
https://github.com/espressif/binutils-gdb.git
synced 2025-05-28 14:08:09 +08:00

* expression.h (enum exp_code): Added OP_EXPRSTRING. * scm-lang.c: Preliminary support for Guile /SCM dialect of Scheme. * expprint.c (print_subexp): Add OP_EXPRSTRING support. * parse.c (length_of_subexp, prefixify_subexp): Likewise. * valops.c (find_function_in_inferior): New function. (value_allocate_space_in_inferior): New function. (allocate_space_in_inferior): Redefine using previous function. * Makefile.in (SFILES): Add scm-lang.c. (COMMON_OBS): Add scm-lang.o
514 lines
11 KiB
C
514 lines
11 KiB
C
/* Scheme/Guile language support routines for GDB, the GNU debugger.
|
|
Copyright 1995 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 "c-lang.h"
|
|
#include "value.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;
|
|
}
|
|
|
|
static void
|
|
scm_printchar (c, stream)
|
|
int c;
|
|
GDB_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;
|
|
{
|
|
fprintf_filtered (stream, "\"%s\"", string);
|
|
}
|
|
|
|
int
|
|
is_object_type (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
|
|
}
|
|
|
|
/* 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. */
|
|
|
|
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;
|
|
{
|
|
return -1;
|
|
}
|
|
|
|
#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}.*/
|
|
|
|
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>"
|
|
};
|
|
|
|
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))
|
|
{
|
|
LONGEST svalue = unpack_long (type, valaddr);
|
|
if (scm_inferior_print (svalue, stream, format,
|
|
deref_ref, recurse, pretty) >= 0)
|
|
{
|
|
}
|
|
else
|
|
{
|
|
switch (7 & 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 *))))
|
|
{
|
|
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;
|
|
#endif
|
|
}
|
|
default:
|
|
fprintf_filtered (stream, "#<%lX>", svalue);
|
|
}
|
|
}
|
|
gdb_flush (stream);
|
|
return (0);
|
|
}
|
|
else
|
|
{
|
|
return c_val_print (type, valaddr, address, stream, format,
|
|
deref_ref, recurse, pretty);
|
|
}
|
|
}
|
|
|
|
int
|
|
scm_value_print (val, stream, format, pretty)
|
|
value_ptr val;
|
|
GDB_FILE *stream;
|
|
int format;
|
|
enum val_prettyprint pretty;
|
|
{
|
|
return (val_print (VALUE_TYPE (val), VALUE_CONTENTS (val),
|
|
VALUE_ADDRESS (val), stream, format, 1, 0, pretty));
|
|
}
|
|
|
|
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;
|
|
{
|
|
enum exp_opcode op = exp->elts[*pos].opcode;
|
|
value_ptr func, addr;
|
|
int len, pc; char *str;
|
|
switch (op)
|
|
{
|
|
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[ + 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: ;
|
|
}
|
|
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,
|
|
scm_parse,
|
|
c_error,
|
|
evaluate_subexp_scm,
|
|
scm_printchar, /* Print a character constant */
|
|
scm_printstr, /* Function to print string constant */
|
|
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 ()
|
|
{
|
|
add_language (&scm_language_defn);
|
|
}
|