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
   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   if (len == 1)
 116     if (*str == '+' || *str == '-')     /* Catches lone `+' and `-' for speed */
 117       return SCM_BOOL_F;
 118
 119   while ((len - i) >= 2 && str[i] == '#' && ++i)
 120     switch (str[i++])
 121       {
 122       case 'b':
 123       case 'B':
 124         if (rx_p++)
 125           return SCM_BOOL_F;
 126         radix = 2;
 127         break;
 128       case 'o':
 129       case 'O':
 130         if (rx_p++)
 131           return SCM_BOOL_F;
 132         radix = 8;
 133         break;
 134       case 'd':
 135       case 'D':
 136         if (rx_p++)
 137           return SCM_BOOL_F;
 138         radix = 10;
 139         break;
 140       case 'x':
 141       case 'X':
 142         if (rx_p++)
 143           return SCM_BOOL_F;
 144         radix = 16;
 145         break;
 146       case 'i':
 147       case 'I':
 148         if (ex_p++)
 149           return SCM_BOOL_F;
 150         ex = 2;
 151         break;
 152       case 'e':
 153       case 'E':
 154         if (ex_p++)
 155           return SCM_BOOL_F;
 156         ex = 1;
 157         break;
 158       default:
 159         return SCM_BOOL_F;
 160       }
 161
 162   switch (ex)
 163     {
 164     case 1:
 165       return scm_istr2int (&str[i], len - i, radix);
 166     case 0:
 167       return scm_istr2int (&str[i], len - i, radix);
 168 #if 0
 169       if NFALSEP
 170         (res) return res;
 171 #ifdef FLOATS
 172     case 2:
 173       return scm_istr2flo (&str[i], len - i, radix);
 174 #endif
 175 #endif
 176     }
 177   return SCM_BOOL_F;
 178 }
 179
 180 static void
 181 scm_read_token (int c, int weird)
 182 {
 183   while (1)
 184     {
 185       c = *lexptr++;
 186       switch (c)
 187         {
 188         case '[':
 189         case ']':
 190         case '(':
 191         case ')':
 192         case '\"':
 193         case ';':
 194         case ' ':
 195         case '\t':
 196         case '\r':
 197         case '\f':
 198         case '\n':
 199           if (weird)
 200             goto default_case;
 201         case '\0':              /* End of line */
 202         eof_case:
 203           --lexptr;
 204           return;
 205         case '\\':
 206           if (!weird)
 207             goto default_case;
 208           else
 209             {
 210               c = *lexptr++;
 211               if (c == '\0')
 212                 goto eof_case;
 213               else
 214                 goto default_case;
 215             }
 216         case '}':
 217           if (!weird)
 218             goto default_case;
 219
 220           c = *lexptr++;
 221           if (c == '#')
 222             return;
 223           else
 224             {
 225               --lexptr;
 226               c = '}';
 227               goto default_case;
 228             }
 229
 230         default:
 231         default_case:
 232           ;
 233         }
 234     }
 235 }
 236
 237 static int
 238 scm_skip_ws (void)
 239 {
 240   int c;
 241   while (1)
 242     switch ((c = *lexptr++))
 243       {
 244       case '\0':
 245       goteof:
 246         return c;
 247       case ';':
 248       lp:
 249         switch ((c = *lexptr++))
 250           {
 251           case '\0':
 252             goto goteof;
 253           default:
 254             goto lp;
 255           case '\n':
 256             break;
 257           }
 258       case ' ':
 259       case '\t':
 260       case '\r':
 261       case '\f':
 262       case '\n':
 263         break;
 264       default:
 265         return c;
 266       }
 267 }
 268
 269 static void
 270 scm_lreadparen (int skipping)
 271 {
 272   for (;;)
 273     {
 274       int c = scm_skip_ws ();
 275       if (')' == c || ']' == c)
 276         return;
 277       --lexptr;
 278       if (c == '\0')
 279         error ("missing close paren");
 280       scm_lreadr (skipping);
 281     }
 282 }
 283
 284 static void
 285 scm_lreadr (int skipping)
 286 {
 287   int c, j;
 288   struct stoken str;
 289   LONGEST svalue = 0;
 290 tryagain:
 291   c = *lexptr++;
 292   switch (c)
 293     {
 294     case '\0':
 295       lexptr--;
 296       return;
 297     case '[':
 298     case '(':
 299       scm_lreadparen (skipping);
 300       return;
 301     case ']':
 302     case ')':
 303       error ("unexpected #\\%c", c);
 304       goto tryagain;
 305     case '\'':
 306     case '`':
 307       str.ptr = lexptr - 1;
 308       scm_lreadr (skipping);
 309       if (!skipping)
 310         {
 311           struct value *val = scm_evaluate_string (str.ptr, lexptr - str.ptr);
 312           if (!is_scmvalue_type (value_type (val)))
 313             error ("quoted scm form yields non-SCM value");
 314           svalue = extract_signed_integer (value_contents (val),
 315                                            TYPE_LENGTH (value_type (val)),
 316                                            gdbarch_byte_order (parse_gdbarch));
 317           goto handle_immediate;
 318         }
 319       return;
 320     case ',':
 321       c = *lexptr++;
 322       if ('@' != c)
 323         lexptr--;
 324       scm_lreadr (skipping);
 325       return;
 326     case '#':
 327       c = *lexptr++;
 328       switch (c)
 329         {
 330         case '[':
 331         case '(':
 332           scm_lreadparen (skipping);
 333           return;
 334         case 't':
 335         case 'T':
 336           svalue = SCM_BOOL_T;
 337           goto handle_immediate;
 338         case 'f':
 339         case 'F':
 340           svalue = SCM_BOOL_F;
 341           goto handle_immediate;
 342         case 'b':
 343         case 'B':
 344         case 'o':
 345         case 'O':
 346         case 'd':
 347         case 'D':
 348         case 'x':
 349         case 'X':
 350         case 'i':
 351         case 'I':
 352         case 'e':
 353         case 'E':
 354           lexptr--;
 355           c = '#';
 356           goto num;
 357         case '*':               /* bitvector */
 358           scm_read_token (c, 0);
 359           return;
 360         case '{':
 361           scm_read_token (c, 1);
 362           return;
 363         case '\\':              /* character */
 364           c = *lexptr++;
 365           scm_read_token (c, 0);
 366           return;
 367         case '|':
 368           j = 1;                /* here j is the comment nesting depth */
 369         lp:
 370           c = *lexptr++;
 371         lpc:
 372           switch (c)
 373             {
 374             case '\0':
 375               error ("unbalanced comment");
 376             default:
 377               goto lp;
 378             case '|':
 379               if ('#' != (c = *lexptr++))
 380                 goto lpc;
 381               if (--j)
 382                 goto lp;
 383               break;
 384             case '#':
 385               if ('|' != (c = *lexptr++))
 386                 goto lpc;
 387               ++j;
 388               goto lp;
 389             }
 390           goto tryagain;
 391         case '.':
 392         default:
 393 #if 0
 394         callshrp:
 395 #endif
 396           scm_lreadr (skipping);
 397           return;
 398         }
 399     case '\"':
 400       while ('\"' != (c = *lexptr++))
 401         {
 402           if (c == '\\')
 403             switch (c = *lexptr++)
 404               {
 405               case '\0':
 406                 error ("non-terminated string literal");
 407               case '\n':
 408                 continue;
 409               case '0':
 410               case 'f':
 411               case 'n':
 412               case 'r':
 413               case 't':
 414               case 'a':
 415               case 'v':
 416                 break;
 417               }
 418         }
 419       return;
 420     case '0':
 421     case '1':
 422     case '2':
 423     case '3':
 424     case '4':
 425     case '5':
 426     case '6':
 427     case '7':
 428     case '8':
 429     case '9':
 430     case '.':
 431     case '-':
 432     case '+':
 433     num:
 434       {
 435         str.ptr = lexptr - 1;
 436         scm_read_token (c, 0);
 437         if (!skipping)
 438           {
 439             svalue = scm_istring2number (str.ptr, lexptr - str.ptr, 10);
 440             if (svalue != SCM_BOOL_F)
 441               goto handle_immediate;
 442             goto tok;
 443           }
 444       }
 445       return;
 446     case ':':
 447       scm_read_token ('-', 0);
 448       return;
 449 #if 0
 450     do_symbol:
 451 #endif
 452     default:
 453       str.ptr = lexptr - 1;
 454       scm_read_token (c, 0);
 455     tok:
 456       if (!skipping)
 457         {
 458           str.length = lexptr - str.ptr;
 459           if (str.ptr[0] == '$')
 460             {
 461               write_dollar_variable (str);
 462               return;
 463             }
 464           write_exp_elt_opcode (OP_NAME);
 465           write_exp_string (str);
 466           write_exp_elt_opcode (OP_NAME);
 467         }
 468       return;
 469     }
 470 handle_immediate:
 471   if (!skipping)
 472     {
 473       write_exp_elt_opcode (OP_LONG);
 474       write_exp_elt_type (builtin_scm_type (parse_gdbarch)->builtin_scm);
 475       write_exp_elt_longcst (svalue);
 476       write_exp_elt_opcode (OP_LONG);
 477     }
 478 }
 479
 480 int
 481 scm_parse (void)
 482 {
 483   char *start;
 484   while (*lexptr == ' ')
 485     lexptr++;
 486   start = lexptr;
 487   scm_lreadr (USE_EXPRSTRING);
 488 #if USE_EXPRSTRING
 489   str.length = lexptr - start;
 490   str.ptr = start;
 491   write_exp_elt_opcode (OP_EXPRSTRING);
 492   write_exp_string (str);
 493   write_exp_elt_opcode (OP_EXPRSTRING);
 494 #endif
 495   return 0;
 496 }