gdb/scm-exp.c

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