aboutsummaryrefslogtreecommitdiff
path: root/gdb/scm-exp.c
diff options
context:
space:
mode:
Diffstat (limited to 'gdb/scm-exp.c')
-rw-r--r--gdb/scm-exp.c423
1 files changed, 423 insertions, 0 deletions
diff --git a/gdb/scm-exp.c b/gdb/scm-exp.c
new file mode 100644
index 0000000..6399563
--- /dev/null
+++ b/gdb/scm-exp.c
@@ -0,0 +1,423 @@
+/* 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 "value.h"
+#include "c-lang.h"
+#include "scm-lang.h"
+#include "scm-tags.h"
+
+#define USE_EXPRSTRING 0
+
+static void scm_lreadparen PARAMS ((int));
+static int scm_skip_ws PARAMS ((void));
+static void scm_read_token PARAMS ((int, int));
+static LONGEST scm_istring2number PARAMS ((char *, int, int));
+static LONGEST scm_istr2int PARAMS ((char *, int, int));
+static void scm_lreadr PARAMS ((int));
+
+static LONGEST
+scm_istr2int(str, len, radix)
+ 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(str, len, radix)
+ 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 (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 (skipping)
+ 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 (skipping)
+ 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)
+ {
+ value_ptr 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 ()
+{
+ 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;
+}
generated by cgit v1.1 at 2024-12-04 13:51:46 +0000