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, Boston, MA 02111-1307, USA.  */
  19
  20 #include "defs.h"
  21 #include "symtab.h"
  22 #include "gdbtypes.h"
  23 #include "expression.h"
  24 #include "parser-defs.h"
  25 #include "language.h"
  26 #include "value.h"
  27 #include "c-lang.h"
  28 #include "scm-lang.h"
  29 #include "scm-tags.h"
  30
  31 #define USE_EXPRSTRING 0
  32
  33 static void scm_lreadr PARAMS ((int));
  34
  35 LONGEST
  36 scm_istr2int(str, len, radix)
  37      char *str;
  38      int len;
  39      int radix;
  40 {
  41   int j;
  42   int i = 0;
  43   LONGEST inum = 0;
  44   int c;
  45   int sign = 0;
  46
  47   if (0 >= len) return SCM_BOOL_F;      /* zero scm_length */
  48   switch (str[0])
  49     {           /* leading sign */
  50     case '-':
  51     case '+':
  52       sign = str[0];
  53       if (++i==len)
  54         return SCM_BOOL_F; /* bad if lone `+' or `-' */
  55     }
  56   do {
  57     switch (c = str[i++]) {
  58     case '0': case '1': case '2': case '3': case '4':
  59     case '5': case '6': case '7': case '8': case '9':
  60       c = c - '0';
  61       goto accumulate;
  62     case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
  63       c = c-'A'+10;
  64       goto accumulate;
  65     case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
  66       c = c-'a'+10;
  67     accumulate:
  68       if (c >= radix) return SCM_BOOL_F; /* bad digit for radix */
  69       inum *= radix;
  70       inum += c;
  71       break;
  72     default:
  73       return SCM_BOOL_F;                /* not a digit */
  74     }
  75   } while (i < len);
  76   if (sign == '-')
  77     inum = -inum;
  78   return SCM_MAKINUM (inum);
  79 }
  80
  81 LONGEST
  82 scm_istring2number(str, len, radix)
  83      char *str;
  84      int len;
  85      int radix;
  86 {
  87   int i = 0;
  88   char ex = 0;
  89   char ex_p = 0, rx_p = 0;      /* Only allow 1 exactness and 1 radix prefix */
  90   SCM res;
  91   if (len==1)
  92     if (*str=='+' || *str=='-') /* Catches lone `+' and `-' for speed */
  93       return SCM_BOOL_F;
  94
  95   while ((len-i) >= 2  &&  str[i]=='#' && ++i)
  96     switch (str[i++]) {
  97     case 'b': case 'B':  if (rx_p++) return SCM_BOOL_F; radix = 2;  break;
  98     case 'o': case 'O':  if (rx_p++) return SCM_BOOL_F; radix = 8;  break;
  99     case 'd': case 'D':  if (rx_p++) return SCM_BOOL_F; radix = 10; break;
 100     case 'x': case 'X':  if (rx_p++) return SCM_BOOL_F; radix = 16; break;
 101     case 'i': case 'I':  if (ex_p++) return SCM_BOOL_F; ex = 2;     break;
 102     case 'e': case 'E':  if (ex_p++) return SCM_BOOL_F; ex = 1;     break;
 103     default:  return SCM_BOOL_F;
 104     }
 105
 106   switch (ex) {
 107   case 1:
 108     return scm_istr2int(&str[i], len-i, radix);
 109   case 0:
 110     return scm_istr2int(&str[i], len-i, radix);
 111 #if 0
 112     if NFALSEP(res) return res;
 113 #ifdef FLOATS
 114   case 2: return scm_istr2flo(&str[i], len-i, radix);
 115 #endif
 116 #endif
 117   }
 118   return SCM_BOOL_F;
 119 }
 120
 121 static void
 122 scm_read_token (c, weird)
 123      int c;
 124      int weird;
 125 {
 126   while (1)
 127     {
 128       c = *lexptr++;
 129       switch (c)
 130         {
 131         case '[':
 132         case ']':
 133         case '(':
 134         case ')':
 135         case '\"':
 136         case ';':
 137         case ' ':  case '\t':  case '\r':  case '\f':
 138         case '\n':
 139           if (weird)
 140             goto default_case;
 141         case '\0':  /* End of line */
 142         eof_case:
 143           --lexptr;
 144           return;
 145         case '\\':
 146           if (!weird)
 147             goto default_case;
 148           else
 149             {
 150               c = *lexptr++;
 151               if (c == '\0')
 152                 goto eof_case;
 153               else
 154                 goto default_case;
 155             }
 156         case '}':
 157           if (!weird)
 158             goto default_case;
 159
 160           c = *lexptr++;
 161           if (c == '#')
 162             return;
 163           else
 164             {
 165               --lexptr;
 166               c = '}';
 167               goto default_case;
 168             }
 169
 170         default:
 171         default_case:
 172           ;
 173         }
 174     }
 175 }
 176
 177 static int
 178 scm_skip_ws ()
 179 {
 180   register int c;
 181   while (1)
 182     switch ((c = *lexptr++))
 183       {
 184       case '\0':
 185       goteof:
 186         return c;
 187       case ';':
 188       lp:
 189         switch ((c = *lexptr++))
 190           {
 191           case '\0':
 192             goto goteof;
 193           default:
 194             goto lp;
 195           case '\n':
 196             break;
 197           }
 198       case ' ':  case '\t':  case '\r':  case '\f':  case '\n':
 199         break;
 200       default:
 201         return c;
 202       }
 203 }
 204
 205 static void
 206 scm_lreadparen (skipping)
 207      int skipping;
 208 {
 209   for (;;)
 210     {
 211       int c = scm_skip_ws ();
 212       if (')' == c || ']' == c)
 213         return;
 214       --lexptr;
 215       if (c == '\0')
 216         error ("missing close paren");
 217       scm_lreadr (skipping);
 218     }
 219 }
 220
 221 static void
 222 scm_lreadr (skipping)
 223      int skipping;
 224 {
 225   int c, j;
 226   struct stoken str;
 227   LONGEST svalue;
 228  tryagain:
 229   c = *lexptr++;
 230   switch (c)
 231     {
 232     case '\0':
 233       lexptr--;
 234       return;
 235     case '[':
 236     case '(':
 237       scm_lreadparen (skipping);
 238       return;
 239     case ']':
 240     case ')':
 241       error ("unexpected #\\%c", c);
 242       goto tryagain;
 243     case '\'':
 244     case '`':
 245       str.ptr = lexptr - 1;
 246       scm_lreadr (skipping);
 247       if (!skipping)
 248         {
 249           value_ptr val = scm_evaluate_string (str.ptr, lexptr - str.ptr);
 250           if (!is_scmvalue_type (VALUE_TYPE (val)))
 251             error ("quoted scm form yields non-SCM value");
 252           svalue = extract_signed_integer (VALUE_CONTENTS (val),
 253                                            TYPE_LENGTH (VALUE_TYPE (val)));
 254           goto handle_immediate;
 255         }
 256       return;
 257     case ',':
 258       c = *lexptr++;
 259       if ('@' != c)
 260         lexptr--;
 261       scm_lreadr (skipping);
 262       return;
 263     case '#':
 264       c = *lexptr++;
 265       switch (c)
 266         {
 267         case '[':
 268         case '(':
 269           scm_lreadparen (skipping);
 270           return;
 271         case 't':  case 'T':
 272           svalue = SCM_BOOL_T;
 273           goto handle_immediate;
 274         case 'f':  case 'F':
 275           svalue = SCM_BOOL_F;
 276           goto handle_immediate;
 277         case 'b':  case 'B':
 278         case 'o':  case 'O':
 279         case 'd':  case 'D':
 280         case 'x':  case 'X':
 281         case 'i':  case 'I':
 282         case 'e':  case 'E':
 283           lexptr--;
 284           c = '#';
 285           goto num;
 286         case '*': /* bitvector */
 287           scm_read_token (c, 0);
 288           return;
 289         case '{':
 290           scm_read_token (c, 1);
 291           return;
 292         case '\\': /* character */
 293           c = *lexptr++;
 294           scm_read_token (c, 0);
 295           return;
 296         case '|':
 297           j = 1;                /* here j is the comment nesting depth */
 298         lp:
 299           c = *lexptr++;
 300         lpc:
 301           switch (c)
 302             {
 303             case '\0':
 304               error ("unbalanced comment");
 305             default:
 306               goto lp;
 307             case '|':
 308               if ('#' != (c = *lexptr++))
 309                 goto lpc;
 310               if (--j)
 311                 goto lp;
 312               break;
 313             case '#':
 314               if ('|' != (c = *lexptr++))
 315                 goto lpc;
 316               ++j;
 317               goto lp;
 318             }
 319           goto tryagain;
 320         case '.':
 321         default:
 322         callshrp:
 323           scm_lreadr (skipping);
 324           return;
 325         }
 326     case '\"':
 327       while ('\"' != (c = *lexptr++))
 328         {
 329           if (c == '\\')
 330             switch (c = *lexptr++)
 331               {
 332               case '\0':
 333                 error ("non-terminated string literal");
 334               case '\n':
 335                 continue;
 336               case '0':
 337               case 'f':
 338               case 'n':
 339               case 'r':
 340               case 't':
 341               case 'a':
 342               case 'v':
 343                 break;
 344               }
 345         }
 346       return;
 347     case '0': case '1': case '2': case '3': case '4':
 348     case '5': case '6': case '7': case '8': case '9':
 349     case '.':
 350     case '-':
 351     case '+':
 352     num:
 353       {
 354         str.ptr = lexptr-1;
 355         scm_read_token (c, 0);
 356         if (!skipping)
 357           {
 358             svalue = scm_istring2number (str.ptr, lexptr - str.ptr, 10);
 359             if (svalue != SCM_BOOL_F)
 360               goto handle_immediate;
 361             goto tok;
 362           }
 363       }
 364       return;
 365     case ':':
 366       scm_read_token ('-', 0);
 367       return;
 368     do_symbol:
 369     default:
 370       str.ptr = lexptr-1;
 371       scm_read_token (c, 0);
 372     tok:
 373       if (!skipping)
 374         {
 375           str.length = lexptr - str.ptr;
 376           if (str.ptr[0] == '$')
 377             {
 378               write_dollar_variable (str);
 379               return;
 380             }
 381           write_exp_elt_opcode (OP_NAME);
 382           write_exp_string (str);
 383           write_exp_elt_opcode (OP_NAME);
 384         }
 385       return;
 386     }
 387  handle_immediate:
 388   if (!skipping)
 389     {
 390       write_exp_elt_opcode (OP_LONG);
 391       write_exp_elt_type (builtin_type_scm);
 392       write_exp_elt_longcst (svalue);
 393       write_exp_elt_opcode (OP_LONG);
 394     }
 395 }
 396
 397 int
 398 scm_parse ()
 399 {
 400   char* start;
 401   struct stoken str;
 402   while (*lexptr == ' ')
 403     lexptr++;
 404   start = lexptr;
 405   scm_lreadr (USE_EXPRSTRING);
 406 #if USE_EXPRSTRING
 407   str.length = lexptr - start;
 408   str.ptr = start;
 409   write_exp_elt_opcode (OP_EXPRSTRING);
 410   write_exp_string (str);
 411   write_exp_elt_opcode (OP_EXPRSTRING);
 412 #endif
 413   return 0;
 414 }