* defs.h (enum language): Add language_scm.
authorPer Bothner <per@bothner.com>
Fri, 29 Sep 1995 01:43:54 +0000 (01:43 +0000)
committerPer Bothner <per@bothner.com>
Fri, 29 Sep 1995 01:43:54 +0000 (01:43 +0000)
* 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

gdb/.Sanitize
gdb/ChangeLog
gdb/Makefile.in
gdb/defs.h
gdb/parse.c
gdb/scm-lang.c [new file with mode: 0644]

index d633a066cfe0b10eb5f1abb7b6e35e026e2fb138..972b9a43966078f1d6b0fb5a1f31ec13053dce3c 100644 (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
index bbc916b7d0e56472d35e84979c9efc3879b73f7e..b9ccf723c4b04029f3aeb62e8f2fc70a54350b46 100644 (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.
index c2d2d40976f9d1c952b945aa9be6b3d6861b2b27..2938c631a06db42b2f70037f0426b4451d256fa2 100644 (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 \
index cd13c2ea8ca9a85d994600596b21f7237b2ed1df..af94db80b67b9e379109143f21f09fe07649d007 100644 (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
index ad38e8be6046fe4ba92cfcc3b84961320d6b70f2..a545814b526dd7f4143ea16e9e1966d49927efdd 100644 (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;
diff --git a/gdb/scm-lang.c b/gdb/scm-lang.c
new file mode 100644 (file)
index 0000000..f3d2df4
--- /dev/null
@@ -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);
+}