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