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

   1 /* Scheme/Guile language support routines for GDB, the GNU debugger.
   2
   3    Copyright 1995, 1996, 2000, 2003 Free Software Foundation, Inc.
   4
   5    This file is part of GDB.
   6
   7    This program is free software; you can redistribute it and/or modify
   8    it under the terms of the GNU General Public License as published by
   9    the Free Software Foundation; either version 2 of the License, or
  10    (at your option) any later version.
  11
  12    This program is distributed in the hope that it will be useful,
  13    but WITHOUT ANY WARRANTY; without even the implied warranty of
  14    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15    GNU General Public License for more details.
  16
  17    You should have received a copy of the GNU General Public License
  18    along with this program; if not, write to the Free Software
  19    Foundation, Inc., 59 Temple Place - Suite 330,
  20    Boston, MA 02111-1307, USA.  */
  21
  22 #include "defs.h"
  23 #include "symtab.h"
  24 #include "gdbtypes.h"
  25 #include "expression.h"
  26 #include "parser-defs.h"
  27 #include "language.h"
  28 #include "value.h"
  29 #include "c-lang.h"
  30 #include "scm-lang.h"
  31 #include "scm-tags.h"
  32
  33 #define USE_EXPRSTRING 0
  34
  35 static void scm_lreadparen (int);
  36 static int scm_skip_ws (void);
  37 static void scm_read_token (int, int);
  38 static LONGEST scm_istring2number (char *, int, int);
  39 static LONGEST scm_istr2int (char *, int, int);
  40 static void scm_lreadr (int);
  41
  42 static LONGEST
  43 scm_istr2int (char *str, int len, int radix)
  44 {
  45   int i = 0;
  46   LONGEST inum = 0;
  47   int c;
  48   int sign = 0;
  49
  50   if (0 >= len)
  51     return SCM_BOOL_F;          /* zero scm_length */
  52   switch (str[0])
  53     {                           /* leading sign */
  54     case '-':
  55     case '+':
  56       sign = str[0];
  57       if (++i == len)
  58         return SCM_BOOL_F;      /* bad if lone `+' or `-' */
  59     }
  60   do
  61     {
  62       switch (c = str[i++])
  63         {
  64         case '0':
  65         case '1':
  66         case '2':
  67         case '3':
  68         case '4':
  69         case '5':
  70         case '6':
  71         case '7':
  72         case '8':
  73         case '9':
  74           c = c - '0';
  75           goto accumulate;
  76         case 'A':
  77         case 'B':
  78         case 'C':
  79         case 'D':
  80         case 'E':
  81         case 'F':
  82           c = c - 'A' + 10;
  83           goto accumulate;
  84         case 'a':
  85         case 'b':
  86         case 'c':
  87         case 'd':
  88         case 'e':
  89         case 'f':
  90           c = c - 'a' + 10;
  91         accumulate:
  92           if (c >= radix)
  93             return SCM_BOOL_F;  /* bad digit for radix */
  94           inum *= radix;
  95           inum += c;
  96           break;
  97         default:
  98           return SCM_BOOL_F;    /* not a digit */
  99         }
 100     }
 101   while (i < len);
 102   if (sign == '-')
 103     inum = -inum;
 104   return SCM_MAKINUM (inum);
 105 }
 106
 107 static LONGEST
 108 scm_istring2number (char *str, int len, int radix)
 109 {
 110   int i = 0;
 111   char ex = 0;
 112   char ex_p = 0, rx_p = 0;      /* Only allow 1 exactness and 1 radix prefix */
 113 #if 0
 114   SCM res;
 115 #endif
 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   while (1)
 243     switch ((c = *lexptr++))
 244       {
 245       case '\0':
 246       goteof:
 247         return c;
 248       case ';':
 249       lp:
 250         switch ((c = *lexptr++))
 251           {
 252           case '\0':
 253             goto goteof;
 254           default:
 255             goto lp;
 256           case '\n':
 257             break;
 258           }
 259       case ' ':
 260       case '\t':
 261       case '\r':
 262       case '\f':
 263       case '\n':
 264         break;
 265       default:
 266         return c;
 267       }
 268 }
 269
 270 static void
 271 scm_lreadparen (int skipping)
 272 {
 273   for (;;)
 274     {
 275       int c = scm_skip_ws ();
 276       if (')' == c || ']' == c)
 277         return;
 278       --lexptr;
 279       if (c == '\0')
 280         error ("missing close paren");
 281       scm_lreadr (skipping);
 282     }
 283 }
 284
 285 static void
 286 scm_lreadr (int skipping)
 287 {
 288   int c, j;
 289   struct stoken str;
 290   LONGEST svalue = 0;
 291 tryagain:
 292   c = *lexptr++;
 293   switch (c)
 294     {
 295     case '\0':
 296       lexptr--;
 297       return;
 298     case '[':
 299     case '(':
 300       scm_lreadparen (skipping);
 301       return;
 302     case ']':
 303     case ')':
 304       error ("unexpected #\\%c", c);
 305       goto tryagain;
 306     case '\'':
 307     case '`':
 308       str.ptr = lexptr - 1;
 309       scm_lreadr (skipping);
 310       if (!skipping)
 311         {
 312           struct value *val = scm_evaluate_string (str.ptr, lexptr - str.ptr);
 313           if (!is_scmvalue_type (VALUE_TYPE (val)))
 314             error ("quoted scm form yields non-SCM value");
 315           svalue = extract_signed_integer (VALUE_CONTENTS (val),
 316                                            TYPE_LENGTH (VALUE_TYPE (val)));
 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_type_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 }