| /* Scheme/Guile language support routines for GDB, the GNU debugger. |
| |
| Copyright (C) 1995, 1996, 2000, 2003, 2005 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., 51 Franklin Street, Fifth Floor, |
| Boston, MA 02110-1301, USA. */ |
| |
| #include "defs.h" |
| #include "symtab.h" |
| #include "gdbtypes.h" |
| #include "expression.h" |
| #include "parser-defs.h" |
| #include "language.h" |
| #include "value.h" |
| #include "c-lang.h" |
| #include "scm-lang.h" |
| #include "scm-tags.h" |
| |
| #define USE_EXPRSTRING 0 |
| |
| static void scm_lreadparen (int); |
| static int scm_skip_ws (void); |
| static void scm_read_token (int, int); |
| static LONGEST scm_istring2number (char *, int, int); |
| static LONGEST scm_istr2int (char *, int, int); |
| static void scm_lreadr (int); |
| |
| static LONGEST |
| scm_istr2int (char *str, int len, int radix) |
| { |
| int i = 0; |
| LONGEST inum = 0; |
| int c; |
| int sign = 0; |
| |
| if (0 >= len) |
| return SCM_BOOL_F; /* zero scm_length */ |
| switch (str[0]) |
| { /* leading sign */ |
| case '-': |
| case '+': |
| sign = str[0]; |
| if (++i == len) |
| return SCM_BOOL_F; /* bad if lone `+' or `-' */ |
| } |
| do |
| { |
| switch (c = str[i++]) |
| { |
| case '0': |
| case '1': |
| case '2': |
| case '3': |
| case '4': |
| case '5': |
| case '6': |
| case '7': |
| case '8': |
| case '9': |
| c = c - '0'; |
| goto accumulate; |
| case 'A': |
| case 'B': |
| case 'C': |
| case 'D': |
| case 'E': |
| case 'F': |
| c = c - 'A' + 10; |
| goto accumulate; |
| case 'a': |
| case 'b': |
| case 'c': |
| case 'd': |
| case 'e': |
| case 'f': |
| c = c - 'a' + 10; |
| accumulate: |
| if (c >= radix) |
| return SCM_BOOL_F; /* bad digit for radix */ |
| inum *= radix; |
| inum += c; |
| break; |
| default: |
| return SCM_BOOL_F; /* not a digit */ |
| } |
| } |
| while (i < len); |
| if (sign == '-') |
| inum = -inum; |
| return SCM_MAKINUM (inum); |
| } |
| |
| static LONGEST |
| scm_istring2number (char *str, int len, int radix) |
| { |
| int i = 0; |
| char ex = 0; |
| char ex_p = 0, rx_p = 0; /* Only allow 1 exactness and 1 radix prefix */ |
| #if 0 |
| SCM res; |
| #endif |
| if (len == 1) |
| if (*str == '+' || *str == '-') /* Catches lone `+' and `-' for speed */ |
| return SCM_BOOL_F; |
| |
| while ((len - i) >= 2 && str[i] == '#' && ++i) |
| switch (str[i++]) |
| { |
| case 'b': |
| case 'B': |
| if (rx_p++) |
| return SCM_BOOL_F; |
| radix = 2; |
| break; |
| case 'o': |
| case 'O': |
| if (rx_p++) |
| return SCM_BOOL_F; |
| radix = 8; |
| break; |
| case 'd': |
| case 'D': |
| if (rx_p++) |
| return SCM_BOOL_F; |
| radix = 10; |
| break; |
| case 'x': |
| case 'X': |
| if (rx_p++) |
| return SCM_BOOL_F; |
| radix = 16; |
| break; |
| case 'i': |
| case 'I': |
| if (ex_p++) |
| return SCM_BOOL_F; |
| ex = 2; |
| break; |
| case 'e': |
| case 'E': |
| if (ex_p++) |
| return SCM_BOOL_F; |
| ex = 1; |
| break; |
| default: |
| return SCM_BOOL_F; |
| } |
| |
| switch (ex) |
| { |
| case 1: |
| return scm_istr2int (&str[i], len - i, radix); |
| case 0: |
| return scm_istr2int (&str[i], len - i, radix); |
| #if 0 |
| if NFALSEP |
| (res) return res; |
| #ifdef FLOATS |
| case 2: |
| return scm_istr2flo (&str[i], len - i, radix); |
| #endif |
| #endif |
| } |
| return SCM_BOOL_F; |
| } |
| |
| static void |
| scm_read_token (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 (void) |
| { |
| 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 (int skipping) |
| { |
| for (;;) |
| { |
| int c = scm_skip_ws (); |
| if (')' == c || ']' == c) |
| return; |
| --lexptr; |
| if (c == '\0') |
| error ("missing close paren"); |
| scm_lreadr (skipping); |
| } |
| } |
| |
| static void |
| scm_lreadr (int skipping) |
| { |
| int c, j; |
| struct stoken str; |
| LONGEST svalue = 0; |
| tryagain: |
| c = *lexptr++; |
| switch (c) |
| { |
| case '\0': |
| lexptr--; |
| return; |
| case '[': |
| case '(': |
| scm_lreadparen (skipping); |
| return; |
| case ']': |
| case ')': |
| error ("unexpected #\\%c", c); |
| goto tryagain; |
| case '\'': |
| case '`': |
| str.ptr = lexptr - 1; |
| scm_lreadr (skipping); |
| if (!skipping) |
| { |
| struct value *val = scm_evaluate_string (str.ptr, lexptr - str.ptr); |
| if (!is_scmvalue_type (value_type (val))) |
| error ("quoted scm form yields non-SCM value"); |
| svalue = extract_signed_integer (value_contents (val), |
| TYPE_LENGTH (value_type (val))); |
| goto handle_immediate; |
| } |
| return; |
| case ',': |
| c = *lexptr++; |
| if ('@' != c) |
| lexptr--; |
| scm_lreadr (skipping); |
| return; |
| case '#': |
| c = *lexptr++; |
| switch (c) |
| { |
| case '[': |
| case '(': |
| scm_lreadparen (skipping); |
| return; |
| case 't': |
| case 'T': |
| svalue = SCM_BOOL_T; |
| goto handle_immediate; |
| case 'f': |
| case 'F': |
| svalue = SCM_BOOL_F; |
| goto handle_immediate; |
| 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: |
| #if 0 |
| callshrp: |
| #endif |
| scm_lreadr (skipping); |
| 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: |
| { |
| str.ptr = lexptr - 1; |
| scm_read_token (c, 0); |
| if (!skipping) |
| { |
| svalue = scm_istring2number (str.ptr, lexptr - str.ptr, 10); |
| if (svalue != SCM_BOOL_F) |
| goto handle_immediate; |
| goto tok; |
| } |
| } |
| return; |
| case ':': |
| scm_read_token ('-', 0); |
| return; |
| #if 0 |
| do_symbol: |
| #endif |
| default: |
| str.ptr = lexptr - 1; |
| scm_read_token (c, 0); |
| tok: |
| if (!skipping) |
| { |
| str.length = lexptr - str.ptr; |
| if (str.ptr[0] == '$') |
| { |
| write_dollar_variable (str); |
| return; |
| } |
| write_exp_elt_opcode (OP_NAME); |
| write_exp_string (str); |
| write_exp_elt_opcode (OP_NAME); |
| } |
| return; |
| } |
| handle_immediate: |
| if (!skipping) |
| { |
| write_exp_elt_opcode (OP_LONG); |
| write_exp_elt_type (builtin_type_scm); |
| write_exp_elt_longcst (svalue); |
| write_exp_elt_opcode (OP_LONG); |
| } |
| } |
| |
| int |
| scm_parse (void) |
| { |
| char *start; |
| while (*lexptr == ' ') |
| lexptr++; |
| start = lexptr; |
| scm_lreadr (USE_EXPRSTRING); |
| #if USE_EXPRSTRING |
| str.length = lexptr - start; |
| str.ptr = start; |
| write_exp_elt_opcode (OP_EXPRSTRING); |
| write_exp_string (str); |
| write_exp_elt_opcode (OP_EXPRSTRING); |
| #endif |
| return 0; |
| } |