gdb/scm-exp.c

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