FreeChainXenon/binutils-gdb
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

* defs.h (enum language): Add language_scm.

Browse source 
* 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 1995-09-29 01:43:54 +00:00
parent 38fe0f1fc7
commit 0e4ca328e1
6 changed files with 534 additions and 3 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
gdb/.Sanitize
View file

@ -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

13
gdb/ChangeLog
View file

@ -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.

5
gdb/Makefile.in
View file

@ -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 \

3
gdb/defs.h
View file

@ -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

2
gdb/parse.c
View file

@ -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;

513
gdb/scm-lang.c Normal file
View file

@ -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);
}