contrib/gdb-7/gdb/scm-exp.c

   1 /* Scheme/Guile language support routines for GDB, the GNU debugger.
   2
   3    Copyright (C) 1995, 1996, 2000, 2003, 2005, 2008, 2009, 2010
   4    Free Software Foundation, Inc.
   5
   6    This file is part of GDB.
   7
   8    This program is free software; you can redistribute it and/or modify
   9    it under the terms of the GNU General Public License as published by
  10    the Free Software Foundation; either version 3 of the License, or
  11    (at your option) any later version.
  12
  13    This program is distributed in the hope that it will be useful,
  14    but WITHOUT ANY WARRANTY; without even the implied warranty of
  15    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16    GNU General Public License for more details.
  17
  18    You should have received a copy of the GNU General Public License
  19    along with this program.  If not, see <http://www.gnu.org/licenses/>.  */
  20
  21 #include "defs.h"
  22 #include "symtab.h"
  23 #include "gdbtypes.h"
  24 #include "expression.h"
  25 #include "parser-defs.h"
  26 #include "language.h"
  27 #include "value.h"
  28 #include "c-lang.h"
  29 #include "scm-lang.h"
  30 #include "scm-tags.h"
  31
  32 #define USE_EXPRSTRING 0
  33
  34 static void scm_lreadparen (int);
  35 static int scm_skip_ws (void);
  36 static void scm_read_token (int, int);
  37 static LONGEST scm_istring2number (char *, int, int);
  38 static LONGEST scm_istr2int (char *, int, int);
  39 static void scm_lreadr (int);
  40
  41 static LONGEST
  42 scm_istr2int (char *str, int len, int radix)
  43 {
  44   int i = 0;
  45   LONGEST inum = 0;
  46   int c;
  47   int sign = 0;
  48
  49   if (0 >= len)
  50     return SCM_BOOL_F;          /* zero scm_length */
  51   switch (str[0])
  52     {                           /* leading sign */
  53     case '-':
  54     case '+':
  55       sign = str[0];
  56       if (++i == len)
  57         return SCM_BOOL_F;      /* bad if lone `+' or `-' */
  58     }
  59   do
  60     {
  61       switch (c = str[i++])
  62         {
  63         case '0':
  64         case '1':
  65         case '2':
  66         case '3':
  67         case '4':
  68         case '5':
  69         case '6':
  70         case '7':
  71         case '8':
  72         case '9':
  73           c = c - '0';
  74           goto accumulate;
  75         case 'A':
  76         case 'B':
  77         case 'C':
  78         case 'D':
  79         case 'E':
  80         case 'F':
  81           c = c - 'A' + 10;
  82           goto accumulate;
  83         case 'a':
  84         case 'b':
  85         case 'c':
  86         case 'd':
  87         case 'e':
  88         case 'f':
  89           c = c - 'a' + 10;
  90         accumulate:
  91           if (c >= radix)
  92             return SCM_BOOL_F;  /* bad digit for radix */
  93           inum *= radix;
  94           inum += c;
  95           break;
  96         default:
  97           return SCM_BOOL_F;    /* not a digit */
  98         }
  99     }
 100   while (i < len);
 101   if (sign == '-')
 102     inum = -inum;
 103   return SCM_MAKINUM (inum);
 104 }
 105
 106 static LONGEST
 107 scm_istring2number (char *str, int len, int radix)
 108 {
 109   int i = 0;
 110   char ex = 0;
 111   char ex_p = 0, rx_p = 0;      /* Only allow 1 exactness and 1 radix prefix */
 112 #if 0
 113   SCM res;
 114 #endif
 115
 116   if (len == 1)
 117     if (*str == '+' || *str == '-')     /* Catches lone `+' and `-' for speed */
 118       return SCM_BOOL_F;
 119
 120   while ((len - i) >= 2 && str[i] == '#' && ++i)
 121     switch (str[i++])
 122       {
 123       case 'b':
 124       case 'B':
 125         if (rx_p++)
 126           return SCM_BOOL_F;
 127         radix = 2;
 128         break;
 129       case 'o':
 130       case 'O':
 131         if (rx_p++)
 132           return SCM_BOOL_F;
 133         radix = 8;
 134         break;
 135       case 'd':
 136       case 'D':
 137         if (rx_p++)
 138           return SCM_BOOL_F;
 139         radix = 10;
 140         break;
 141       case 'x':
 142       case 'X':
 143         if (rx_p++)
 144           return SCM_BOOL_F;
 145         radix = 16;
 146         break;
 147       case 'i':
 148       case 'I':
 149         if (ex_p++)
 150           return SCM_BOOL_F;
 151         ex = 2;
 152         break;
 153       case 'e':
 154       case 'E':
 155         if (ex_p++)
 156           return SCM_BOOL_F;
 157         ex = 1;
 158         break;
 159       default:
 160         return SCM_BOOL_F;
 161       }
 162
 163   switch (ex)
 164     {
 165     case 1:
 166       return scm_istr2int (&str[i], len - i, radix);
 167     case 0:
 168       return scm_istr2int (&str[i], len - i, radix);
 169 #if 0
 170       if NFALSEP
 171         (res) return res;
 172 #ifdef FLOATS
 173     case 2:
 174       return scm_istr2flo (&str[i], len - i, radix);
 175 #endif
 176 #endif
 177     }
 178   return SCM_BOOL_F;
 179 }
 180
 181 static void
 182 scm_read_token (int c, int weird)
 183 {
 184   while (1)
 185     {
 186       c = *lexptr++;
 187       switch (c)
 188         {
 189         case '[':
 190         case ']':
 191         case '(':
 192         case ')':
 193         case '\"':
 194         case ';':
 195         case ' ':
 196         case '\t':
 197         case '\r':
 198         case '\f':
 199         case '\n':
 200           if (weird)
 201             goto default_case;
 202         case '\0':              /* End of line */
 203         eof_case:
 204           --lexptr;
 205           return;
 206         case '\\':
 207           if (!weird)
 208             goto default_case;
 209           else
 210             {
 211               c = *lexptr++;
 212               if (c == '\0')
 213                 goto eof_case;
 214               else
 215                 goto default_case;
 216             }
 217         case '}':
 218           if (!weird)
 219             goto default_case;
 220
 221           c = *lexptr++;
 222           if (c == '#')
 223             return;
 224           else
 225             {
 226               --lexptr;
 227               c = '}';
 228               goto default_case;
 229             }
 230
 231         default:
 232         default_case:
 233           ;
 234         }
 235     }
 236 }
 237
 238 static int
 239 scm_skip_ws (void)
 240 {
 241   int c;
 242
 243   while (1)
 244     switch ((c = *lexptr++))
 245       {
 246       case '\0':
 247       goteof:
 248         return c;
 249       case ';':
 250       lp:
 251         switch ((c = *lexptr++))
 252           {
 253           case '\0':
 254             goto goteof;
 255           default:
 256             goto lp;
 257           case '\n':
 258             break;
 259           }
 260       case ' ':
 261       case '\t':
 262       case '\r':
 263       case '\f':
 264       case '\n':
 265         break;
 266       default:
 267         return c;
 268       }
 269 }
 270
 271 static void
 272 scm_lreadparen (int skipping)
 273 {
 274   for (;;)
 275     {
 276       int c = scm_skip_ws ();
 277
 278       if (')' == c || ']' == c)
 279         return;
 280       --lexptr;
 281       if (c == '\0')
 282         error ("missing close paren");
 283       scm_lreadr (skipping);
 284     }
 285 }
 286
 287 static void
 288 scm_lreadr (int skipping)
 289 {
 290   int c, j;
 291   struct stoken str;
 292   LONGEST svalue = 0;
 293
 294 tryagain:
 295   c = *lexptr++;
 296   switch (c)
 297     {
 298     case '\0':
 299       lexptr--;
 300       return;
 301     case '[':
 302     case '(':
 303       scm_lreadparen (skipping);
 304       return;
 305     case ']':
 306     case ')':
 307       error ("unexpected #\\%c", c);
 308       goto tryagain;
 309     case '\'':
 310     case '`':
 311       str.ptr = lexptr - 1;
 312       scm_lreadr (skipping);
 313       if (!skipping)
 314         {
 315           struct value *val = scm_evaluate_string (str.ptr, lexptr - str.ptr);
 316
 317           if (!is_scmvalue_type (value_type (val)))
 318             error ("quoted scm form yields non-SCM value");
 319           svalue = extract_signed_integer (value_contents (val),
 320                                            TYPE_LENGTH (value_type (val)),
 321                                            gdbarch_byte_order (parse_gdbarch));
 322           goto handle_immediate;
 323         }
 324       return;
 325     case ',':
 326       c = *lexptr++;
 327       if ('@' != c)
 328         lexptr--;
 329       scm_lreadr (skipping);
 330       return;
 331     case '#':
 332       c = *lexptr++;
 333       switch (c)
 334         {
 335         case '[':
 336         case '(':
 337           scm_lreadparen (skipping);
 338           return;
 339         case 't':
 340         case 'T':
 341           svalue = SCM_BOOL_T;
 342           goto handle_immediate;
 343         case 'f':
 344         case 'F':
 345           svalue = SCM_BOOL_F;
 346           goto handle_immediate;
 347         case 'b':
 348         case 'B':
 349         case 'o':
 350         case 'O':
 351         case 'd':
 352         case 'D':
 353         case 'x':
 354         case 'X':
 355         case 'i':
 356         case 'I':
 357         case 'e':
 358         case 'E':
 359           lexptr--;
 360           c = '#';
 361           goto num;
 362         case '*':               /* bitvector */
 363           scm_read_token (c, 0);
 364           return;
 365         case '{':
 366           scm_read_token (c, 1);
 367           return;
 368         case '\\':              /* character */
 369           c = *lexptr++;
 370           scm_read_token (c, 0);
 371           return;
 372         case '|':
 373           j = 1;                /* here j is the comment nesting depth */
 374         lp:
 375           c = *lexptr++;
 376         lpc:
 377           switch (c)
 378             {
 379             case '\0':
 380               error ("unbalanced comment");
 381             default:
 382               goto lp;
 383             case '|':
 384               if ('#' != (c = *lexptr++))
 385                 goto lpc;
 386               if (--j)
 387                 goto lp;
 388               break;
 389             case '#':
 390               if ('|' != (c = *lexptr++))
 391                 goto lpc;
 392               ++j;
 393               goto lp;
 394             }
 395           goto tryagain;
 396         case '.':
 397         default:
 398 #if 0
 399         callshrp:
 400 #endif
 401           scm_lreadr (skipping);
 402           return;
 403         }
 404     case '\"':
 405       while ('\"' != (c = *lexptr++))
 406         {
 407           if (c == '\\')
 408             switch (c = *lexptr++)
 409               {
 410               case '\0':
 411                 error ("non-terminated string literal");
 412               case '\n':
 413                 continue;
 414               case '0':
 415               case 'f':
 416               case 'n':
 417               case 'r':
 418               case 't':
 419               case 'a':
 420               case 'v':
 421                 break;
 422               }
 423         }
 424       return;
 425     case '0':
 426     case '1':
 427     case '2':
 428     case '3':
 429     case '4':
 430     case '5':
 431     case '6':
 432     case '7':
 433     case '8':
 434     case '9':
 435     case '.':
 436     case '-':
 437     case '+':
 438     num:
 439       {
 440         str.ptr = lexptr - 1;
 441         scm_read_token (c, 0);
 442         if (!skipping)
 443           {
 444             svalue = scm_istring2number (str.ptr, lexptr - str.ptr, 10);
 445             if (svalue != SCM_BOOL_F)
 446               goto handle_immediate;
 447             goto tok;
 448           }
 449       }
 450       return;
 451     case ':':
 452       scm_read_token ('-', 0);
 453       return;
 454 #if 0
 455     do_symbol:
 456 #endif
 457     default:
 458       str.ptr = lexptr - 1;
 459       scm_read_token (c, 0);
 460     tok:
 461       if (!skipping)
 462         {
 463           str.length = lexptr - str.ptr;
 464           if (str.ptr[0] == '$')
 465             {
 466               write_dollar_variable (str);
 467               return;
 468             }
 469           write_exp_elt_opcode (OP_NAME);
 470           write_exp_string (str);
 471           write_exp_elt_opcode (OP_NAME);
 472         }
 473       return;
 474     }
 475 handle_immediate:
 476   if (!skipping)
 477     {
 478       write_exp_elt_opcode (OP_LONG);
 479       write_exp_elt_type (builtin_scm_type (parse_gdbarch)->builtin_scm);
 480       write_exp_elt_longcst (svalue);
 481       write_exp_elt_opcode (OP_LONG);
 482     }
 483 }
 484
 485 int
 486 scm_parse (void)
 487 {
 488   char *start;
 489
 490   while (*lexptr == ' ')
 491     lexptr++;
 492   start = lexptr;
 493   scm_lreadr (USE_EXPRSTRING);
 494 #if USE_EXPRSTRING
 495   str.length = lexptr - start;
 496   str.ptr = start;
 497   write_exp_elt_opcode (OP_EXPRSTRING);
 498   write_exp_string (str);
 499   write_exp_elt_opcode (OP_EXPRSTRING);
 500 #endif
 501   return 0;
 502 }