gdb/scm-lang.c

   1 /* Scheme/Guile language support routines for GDB, the GNU debugger.
   2    Copyright 1995 Free Software Foundation, Inc.
   3
   4 This file is part of GDB.
   5
   6 This program is free software; you can redistribute it and/or modify
   7 it under the terms of the GNU General Public License as published by
   8 the Free Software Foundation; either version 2 of the License, or
   9 (at your option) any later version.
  10
  11 This program is distributed in the hope that it will be useful,
  12 but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 GNU General Public License for more details.
  15
  16 You should have received a copy of the GNU General Public License
  17 along with this program; if not, write to the Free Software
  18 Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.  */
  19
  20 #include "defs.h"
  21 #include "symtab.h"
  22 #include "gdbtypes.h"
  23 #include "expression.h"
  24 #include "parser-defs.h"
  25 #include "language.h"
  26 #include "value.h"
  27 #include "c-lang.h"
  28 #include "scm-lang.h"
  29 #include "scm-tags.h"
  30
  31 extern struct type ** const (c_builtin_types[]);
  32 extern value_ptr value_allocate_space_in_inferior PARAMS ((int));
  33 extern value_ptr find_function_in_inferior PARAMS ((char*));
  34
  35 static void scm_lreadr ();
  36
  37 struct type *SCM_TYPE = NULL;
  38
  39 static void
  40 scm_read_token (c, weird)
  41      int c;
  42      int weird;
  43 {
  44   while (1)
  45     {
  46       c = *lexptr++;
  47       switch (c)
  48         {
  49         case '[':
  50         case ']':
  51         case '(':
  52         case ')':
  53         case '\"':
  54         case ';':
  55         case ' ':  case '\t':  case '\r':  case '\f':
  56         case '\n':
  57           if (weird)
  58             goto default_case;
  59         case '\0':  /* End of line */
  60         eof_case:
  61           --lexptr;
  62           return;
  63         case '\\':
  64           if (!weird)
  65             goto default_case;
  66           else
  67             {
  68               c = *lexptr++;
  69               if (c == '\0')
  70                 goto eof_case;
  71               else
  72                 goto default_case;
  73             }
  74         case '}':
  75           if (!weird)
  76             goto default_case;
  77
  78           c = *lexptr++;
  79           if (c == '#')
  80             return;
  81           else
  82             {
  83               --lexptr;
  84               c = '}';
  85               goto default_case;
  86             }
  87
  88         default:
  89         default_case:
  90           ;
  91         }
  92     }
  93 }
  94
  95 static int
  96 scm_skip_ws ()
  97 {
  98   register int c;
  99   while (1)
 100     switch ((c = *lexptr++))
 101       {
 102       case '\0':
 103       goteof:
 104         return c;
 105       case ';':
 106       lp:
 107         switch ((c = *lexptr++))
 108           {
 109           case '\0':
 110             goto goteof;
 111           default:
 112             goto lp;
 113           case '\n':
 114             break;
 115           }
 116       case ' ':  case '\t':  case '\r':  case '\f':  case '\n':
 117         break;
 118       default:
 119         return c;
 120       }
 121 }
 122
 123 static void
 124 scm_lreadparen ()
 125 {
 126   for (;;)
 127     {
 128       int c = scm_skip_ws ();
 129       if (')' == c || ']' == c)
 130         return;
 131       --lexptr;
 132       if (c == '\0')
 133         error ("missing close paren");
 134       scm_lreadr ();
 135     }
 136 }
 137
 138 static void
 139 scm_lreadr ()
 140 {
 141   int c, j;
 142  tryagain:
 143   c = *lexptr++;
 144   switch (c)
 145     {
 146     case '\0':
 147       lexptr--;
 148       return;
 149     case '[':
 150     case '(':
 151       scm_lreadparen ();
 152       return;
 153     case ']':
 154     case ')':
 155       error ("unexpected #\\%c", c);
 156       goto tryagain;
 157     case '\'':
 158     case '`':
 159       scm_lreadr ();
 160       return;
 161     case ',':
 162       c = *lexptr++;
 163       if ('@' != c)
 164         lexptr--;
 165       scm_lreadr ();
 166       return;
 167     case '#':
 168       c = *lexptr++;
 169       switch (c)
 170         {
 171         case '[':
 172         case '(':
 173           scm_lreadparen ();
 174           return;
 175         case 't':  case 'T':
 176         case 'f':  case 'F':
 177           return;
 178         case 'b':  case 'B':
 179         case 'o':  case 'O':
 180         case 'd':  case 'D':
 181         case 'x':  case 'X':
 182         case 'i':  case 'I':
 183         case 'e':  case 'E':
 184           lexptr--;
 185           c = '#';
 186           goto num;
 187         case '*': /* bitvector */
 188           scm_read_token (c, 0);
 189           return;
 190         case '{':
 191           scm_read_token (c, 1);
 192           return;
 193         case '\\': /* character */
 194           c = *lexptr++;
 195           scm_read_token (c, 0);
 196           return;
 197         case '|':
 198           j = 1;                /* here j is the comment nesting depth */
 199         lp:
 200           c = *lexptr++;
 201         lpc:
 202           switch (c)
 203             {
 204             case '\0':
 205               error ("unbalanced comment");
 206             default:
 207               goto lp;
 208             case '|':
 209               if ('#' != (c = *lexptr++))
 210                 goto lpc;
 211               if (--j)
 212                 goto lp;
 213               break;
 214             case '#':
 215               if ('|' != (c = *lexptr++))
 216                 goto lpc;
 217               ++j;
 218               goto lp;
 219             }
 220           goto tryagain;
 221         case '.':
 222         default:
 223         callshrp:
 224           scm_lreadr ();
 225           return;
 226         }
 227     case '\"':
 228       while ('\"' != (c = *lexptr++))
 229         {
 230           if (c == '\\')
 231             switch (c = *lexptr++)
 232               {
 233               case '\0':
 234                 error ("non-terminated string literal");
 235               case '\n':
 236                 continue;
 237               case '0':
 238               case 'f':
 239               case 'n':
 240               case 'r':
 241               case 't':
 242               case 'a':
 243               case 'v':
 244                 break;
 245               }
 246         }
 247       return;
 248     case '0': case '1': case '2': case '3': case '4':
 249     case '5': case '6': case '7': case '8': case '9':
 250     case '.':
 251     case '-':
 252     case '+':
 253     num:
 254       scm_read_token (c, 0);
 255       return;
 256     case ':':
 257       scm_read_token ('-', 0);
 258       return;
 259     default:
 260       scm_read_token (c, 0);
 261     tok:
 262       return;
 263     }
 264 }
 265
 266 int
 267 scm_parse ()
 268 {
 269   char* start;
 270   struct stoken str;
 271   while (*lexptr == ' ')
 272     lexptr++;
 273   start = lexptr;
 274   scm_lreadr ();
 275   str.length = lexptr - start;
 276   str.ptr = start;
 277   write_exp_elt_opcode (OP_EXPRSTRING);
 278   write_exp_string (str);
 279   write_exp_elt_opcode (OP_EXPRSTRING);
 280   return 0;
 281 }
 282
 283 void
 284 scm_printchar (c, stream)
 285      int c;
 286      GDB_FILE *stream;
 287 {
 288   fprintf_filtered (stream, "#\\%c", c);
 289 }
 290
 291 static void
 292 scm_printstr (stream, string, length, force_ellipses)
 293      GDB_FILE *stream;
 294      char *string;
 295      unsigned int length;
 296      int force_ellipses;
 297 {
 298   fprintf_filtered (stream, "\"%s\"", string);
 299 }
 300
 301 int
 302 is_scmvalue_type (type)
 303      struct type *type;
 304 {
 305   if (TYPE_CODE (type) == TYPE_CODE_INT
 306       && TYPE_NAME (type) && strcmp (TYPE_NAME (type), "SCM") == 0)
 307     {
 308       SCM_TYPE = type;
 309       return 1;
 310     }
 311   return 0;
 312 }
 313
 314 /* Get the INDEX'th SCM value, assuming SVALUE is the address
 315    of the 0'th one.  */
 316
 317 LONGEST
 318 scm_get_field (svalue, index)
 319      LONGEST svalue;
 320      int index;
 321 {
 322   value_ptr val;
 323   char buffer[20];
 324   if (SCM_TYPE == NULL)
 325     error ("internal error - no SCM type");
 326   read_memory (SCM2PTR (svalue) + index * TYPE_LENGTH (SCM_TYPE),
 327                buffer, TYPE_LENGTH (SCM_TYPE));
 328   return unpack_long (SCM_TYPE, buffer);
 329 }
 330
 331 static value_ptr
 332 evaluate_subexp_scm (expect_type, exp, pos, noside)
 333      struct type *expect_type;
 334      register struct expression *exp;
 335      register int *pos;
 336      enum noside noside;
 337 {
 338   enum exp_opcode op = exp->elts[*pos].opcode;
 339   value_ptr func, addr;
 340   int len, pc;  char *str;
 341   switch (op)
 342     {
 343     case OP_EXPRSTRING:
 344       pc = (*pos)++;
 345       len = longest_to_int (exp->elts[pc + 1].longconst);
 346       (*pos) += 3 + BYTES_TO_EXP_ELEM (len + 1);
 347       if (noside == EVAL_SKIP)
 348         goto nosideret;
 349       str = &exp->elts[ + 2].string;
 350       addr = value_allocate_space_in_inferior (len);
 351       write_memory (value_as_long (addr), str, len);
 352       func = find_function_in_inferior ("scm_evstr");
 353       return call_function_by_hand (func, 1, &addr);
 354     default: ;
 355     }
 356   return evaluate_subexp_standard (expect_type, exp, pos, noside);
 357  nosideret:
 358   return value_from_longest (builtin_type_long, (LONGEST) 1);
 359 }
 360
 361 const struct language_defn scm_language_defn = {
 362   "scheme",                     /* Language name */
 363   language_scm,
 364   c_builtin_types,
 365   range_check_off,
 366   type_check_off,
 367   scm_parse,
 368   c_error,
 369   evaluate_subexp_scm,
 370   scm_printchar,                        /* Print a character constant */
 371   scm_printstr,                 /* Function to print string constant */
 372   NULL, /* Create fundamental type in this language */
 373   c_print_type,                 /* Print a type using appropriate syntax */
 374   scm_val_print,                /* Print a value using appropriate syntax */
 375   scm_value_print,              /* Print a top-level value */
 376   {"",     "",    "",  ""},     /* Binary format info */
 377   {"#o%lo",  "#o",   "o", ""},  /* Octal format info */
 378   {"%ld",   "",    "d", ""},    /* Decimal format info */
 379   {"#x%lX", "#X",  "X", ""},    /* Hex format info */
 380   NULL,                         /* expression operators for printing */
 381   1,                            /* c-style arrays */
 382   0,                            /* String lower bound */
 383   &builtin_type_char,           /* Type of string elements */
 384   LANG_MAGIC
 385 };
 386
 387 void
 388 _initialize_scheme_language ()
 389 {
 390   add_language (&scm_language_defn);
 391 }