* defs.h (enum language): Add language_scm.
* 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
This commit is contained in:
Per Bothner
parent
38fe0f1fc7
commit
0e4ca328e1
|
|
@ -286,6 +286,7 @@ rs6000-nat.c
|
|||
rs6000-tdep.c
|
||||
rom68k-rom.c
|
||||
saber.suppress
|
||||
scm-lang.c
|
||||
ser-e7kpc.c
|
||||
ser-go32.c
|
||||
ser-mac.c
|
||||
|
|
|
|||
|
|
@ -1,3 +1,16 @@
|
|||
Thu Sep 28 17:43:39 1995 Per Bothner <bothner@kalessin.cygnus.com>
|
||||
|
||||
* defs.h (enum language): Add language_scm.
|
||||
* 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
|
||||
|
||||
Thu Sep 28 14:32:11 1995 steve chamberlain <sac@slash.cygnus.com>
|
||||
|
||||
* callback.[ch]: New files.
|
||||
|
|
|
|||
|
|
@ -355,7 +355,8 @@ SFILES = blockframe.c breakpoint.c buildsym.c callback.c c-exp.y c-lang.c \
|
|||
gdbtypes.c infcmd.c inflow.c infrun.c language.c \
|
||||
m2-exp.y m2-lang.c m2-typeprint.c m2-valprint.c main.c maint.c \
|
||||
mem-break.c minsyms.c mipsread.c nlmread.c objfiles.c parse.c \
|
||||
printcmd.c remote.c remote-nrom.c source.c stabsread.c stack.c symfile.c symmisc.c \
|
||||
printcmd.c remote.c remote-nrom.c scm-lang.c \
|
||||
source.c stabsread.c stack.c symfile.c symmisc.c \
|
||||
symtab.c target.c thread.c top.c \
|
||||
typeprint.c utils.c valarith.c valops.c \
|
||||
valprint.c values.c serial.c ser-unix.c mdebugread.c os9kread.c
|
||||
|
|
@ -465,7 +466,7 @@ COMMON_OBS = version.o blockframe.o breakpoint.o findvar.o stack.o thread.o \
|
|||
exec.o objfiles.o minsyms.o maint.o demangle.o \
|
||||
dbxread.o coffread.o elfread.o \
|
||||
dwarfread.o mipsread.o stabsread.o core.o \
|
||||
c-lang.o ch-lang.o f-lang.o m2-lang.o \
|
||||
c-lang.o ch-lang.o f-lang.o m2-lang.o scm-lang.o \
|
||||
complaints.o typeprint.o \
|
||||
c-typeprint.o ch-typeprint.o f-typeprint.o m2-typeprint.o \
|
||||
c-valprint.o cp-valprint.o ch-valprint.o f-valprint.o m2-valprint.o \
|
||||
|
|
|
|||
|
|
@ -115,7 +115,8 @@ enum language
|
|||
language_chill, /* Chill */
|
||||
language_fortran, /* Fortran */
|
||||
language_m2, /* Modula-2 */
|
||||
language_asm /* Assembly language */
|
||||
language_asm, /* Assembly language */
|
||||
language_scm /* Scheme / Guile */
|
||||
};
|
||||
|
||||
/* the cleanup list records things that have to be undone
|
||||
|
|
|
|||
|
|
@ -512,6 +512,7 @@ length_of_subexp (expr, endpos)
|
|||
/* fall through */
|
||||
case OP_M2_STRING:
|
||||
case OP_STRING:
|
||||
case OP_EXPRSTRING:
|
||||
oplen = longest_to_int (expr->elts[endpos - 2].longconst);
|
||||
oplen = 4 + BYTES_TO_EXP_ELEM (oplen + 1);
|
||||
break;
|
||||
|
|
@ -649,6 +650,7 @@ prefixify_subexp (inexpr, outexpr, inend, outbeg)
|
|||
/* fall through */
|
||||
case OP_M2_STRING:
|
||||
case OP_STRING:
|
||||
case OP_EXPRSTRING:
|
||||
oplen = longest_to_int (inexpr->elts[inend - 2].longconst);
|
||||
oplen = 4 + BYTES_TO_EXP_ELEM (oplen + 1);
|
||||
break;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,513 @@
|
|||
/* 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);
|
||||
}
|
||||
Loading…
Reference in New Issue