contrib/gdb-6/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 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           goto handle_immediate;
 317         }
 318       return;
 319     case ',':
 320       c = *lexptr++;
 321       if ('@' != c)
 322         lexptr--;
 323       scm_lreadr (skipping);
 324       return;
 325     case '#':
 326       c = *lexptr++;
 327       switch (c)
 328         {
 329         case '[':
 330         case '(':
 331           scm_lreadparen (skipping);
 332           return;
 333         case 't':
 334         case 'T':
 335           svalue = SCM_BOOL_T;
 336           goto handle_immediate;
 337         case 'f':
 338         case 'F':
 339           svalue = SCM_BOOL_F;
 340           goto handle_immediate;
 341         case 'b':
 342         case 'B':
 343         case 'o':
 344         case 'O':
 345         case 'd':
 346         case 'D':
 347         case 'x':
 348         case 'X':
 349         case 'i':
 350         case 'I':
 351         case 'e':
 352         case 'E':
 353           lexptr--;
 354           c = '#';
 355           goto num;
 356         case '*':               /* bitvector */
 357           scm_read_token (c, 0);
 358           return;
 359         case '{':
 360           scm_read_token (c, 1);
 361           return;
 362         case '\\':              /* character */
 363           c = *lexptr++;
 364           scm_read_token (c, 0);
 365           return;
 366         case '|':
 367           j = 1;                /* here j is the comment nesting depth */
 368         lp:
 369           c = *lexptr++;
 370         lpc:
 371           switch (c)
 372             {
 373             case '\0':
 374               error ("unbalanced comment");
 375             default:
 376               goto lp;
 377             case '|':
 378               if ('#' != (c = *lexptr++))
 379                 goto lpc;
 380               if (--j)
 381                 goto lp;
 382               break;
 383             case '#':
 384               if ('|' != (c = *lexptr++))
 385                 goto lpc;
 386               ++j;
 387               goto lp;
 388             }
 389           goto tryagain;
 390         case '.':
 391         default:
 392 #if 0
 393         callshrp:
 394 #endif
 395           scm_lreadr (skipping);
 396           return;
 397         }
 398     case '\"':
 399       while ('\"' != (c = *lexptr++))
 400         {
 401           if (c == '\\')
 402             switch (c = *lexptr++)
 403               {
 404               case '\0':
 405                 error ("non-terminated string literal");
 406               case '\n':
 407                 continue;
 408               case '0':
 409               case 'f':
 410               case 'n':
 411               case 'r':
 412               case 't':
 413               case 'a':
 414               case 'v':
 415                 break;
 416               }
 417         }
 418       return;
 419     case '0':
 420     case '1':
 421     case '2':
 422     case '3':
 423     case '4':
 424     case '5':
 425     case '6':
 426     case '7':
 427     case '8':
 428     case '9':
 429     case '.':
 430     case '-':
 431     case '+':
 432     num:
 433       {
 434         str.ptr = lexptr - 1;
 435         scm_read_token (c, 0);
 436         if (!skipping)
 437           {
 438             svalue = scm_istring2number (str.ptr, lexptr - str.ptr, 10);
 439             if (svalue != SCM_BOOL_F)
 440               goto handle_immediate;
 441             goto tok;
 442           }
 443       }
 444       return;
 445     case ':':
 446       scm_read_token ('-', 0);
 447       return;
 448 #if 0
 449     do_symbol:
 450 #endif
 451     default:
 452       str.ptr = lexptr - 1;
 453       scm_read_token (c, 0);
 454     tok:
 455       if (!skipping)
 456         {
 457           str.length = lexptr - str.ptr;
 458           if (str.ptr[0] == '$')
 459             {
 460               write_dollar_variable (str);
 461               return;
 462             }
 463           write_exp_elt_opcode (OP_NAME);
 464           write_exp_string (str);
 465           write_exp_elt_opcode (OP_NAME);
 466         }
 467       return;
 468     }
 469 handle_immediate:
 470   if (!skipping)
 471     {
 472       write_exp_elt_opcode (OP_LONG);
 473       write_exp_elt_type (builtin_type_scm);
 474       write_exp_elt_longcst (svalue);
 475       write_exp_elt_opcode (OP_LONG);
 476     }
 477 }
 478
 479 int
 480 scm_parse (void)
 481 {
 482   char *start;
 483   while (*lexptr == ' ')
 484     lexptr++;
 485   start = lexptr;
 486   scm_lreadr (USE_EXPRSTRING);
 487 #if USE_EXPRSTRING
 488   str.length = lexptr - start;
 489   str.ptr = start;
 490   write_exp_elt_opcode (OP_EXPRSTRING);
 491   write_exp_string (str);
 492   write_exp_elt_opcode (OP_EXPRSTRING);
 493 #endif
 494   return 0;
 495 }