/* 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", "#", "#", "()", "#" }; 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); }