diff options
Diffstat (limited to 'gdb/scm-lang.c')
| -rw-r--r-- | gdb/scm-lang.c | 513 |
1 files changed, 513 insertions, 0 deletions
diff --git a/gdb/scm-lang.c b/gdb/scm-lang.c new file mode 100644 index 0000000..f3d2df4 --- /dev/null +++ b/gdb/scm-lang.c @@ -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); +} |