gdb/scm-lang.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 "c-lang.h"
  27 #include "value.h"
  28
  29 extern struct type ** const (c_builtin_types[]);
  30 extern value_ptr value_allocate_space_in_inferior PARAMS ((int));
  31 extern value_ptr find_function_in_inferior PARAMS ((char*));
  32
  33 static void scm_lreadr ();
  34
  35 static void
  36 scm_read_token (c, weird)
  37      int c;
  38      int weird;
  39 {
  40   while (1)
  41     {
  42       c = *lexptr++;
  43       switch (c)
  44         {
  45         case '[':
  46         case ']':
  47         case '(':
  48         case ')':
  49         case '\"':
  50         case ';':
  51         case ' ':  case '\t':  case '\r':  case '\f':
  52         case '\n':
  53           if (weird)
  54             goto default_case;
  55         case '\0':  /* End of line */
  56         eof_case:
  57           --lexptr;
  58           return;
  59         case '\\':
  60           if (!weird)
  61             goto default_case;
  62           else
  63             {
  64               c = *lexptr++;
  65               if (c == '\0')
  66                 goto eof_case;
  67               else
  68                 goto default_case;
  69             }
  70         case '}':
  71           if (!weird)
  72             goto default_case;
  73
  74           c = *lexptr++;
  75           if (c == '#')
  76             return;
  77           else
  78             {
  79               --lexptr;
  80               c = '}';
  81               goto default_case;
  82             }
  83
  84         default:
  85         default_case:
  86           ;
  87         }
  88     }
  89 }
  90
  91 static int
  92 scm_skip_ws ()
  93 {
  94   register int c;
  95   while (1)
  96     switch ((c = *lexptr++))
  97       {
  98       case '\0':
  99       goteof:
 100         return c;
 101       case ';':
 102       lp:
 103         switch ((c = *lexptr++))
 104           {
 105           case '\0':
 106             goto goteof;
 107           default:
 108             goto lp;
 109           case '\n':
 110             break;
 111           }
 112       case ' ':  case '\t':  case '\r':  case '\f':  case '\n':
 113         break;
 114       default:
 115         return c;
 116       }
 117 }
 118
 119 static void
 120 scm_lreadparen ()
 121 {
 122   for (;;)
 123     {
 124       int c = scm_skip_ws ();
 125       if (')' == c || ']' == c)
 126         return;
 127       --lexptr;
 128       if (c == '\0')
 129         error ("missing close paren");
 130       scm_lreadr ();
 131     }
 132 }
 133
 134 static void
 135 scm_lreadr ()
 136 {
 137   int c, j;
 138  tryagain:
 139   c = *lexptr++;
 140   switch (c)
 141     {
 142     case '\0':
 143       lexptr--;
 144       return;
 145     case '[':
 146     case '(':
 147       scm_lreadparen ();
 148       return;
 149     case ']':
 150     case ')':
 151       error ("unexpected #\\%c", c);
 152       goto tryagain;
 153     case '\'':
 154     case '`':
 155       scm_lreadr ();
 156       return;
 157     case ',':
 158       c = *lexptr++;
 159       if ('@' != c)
 160         lexptr--;
 161       scm_lreadr ();
 162       return;
 163     case '#':
 164       c = *lexptr++;
 165       switch (c)
 166         {
 167         case '[':
 168         case '(':
 169           scm_lreadparen ();
 170           return;
 171         case 't':  case 'T':
 172         case 'f':  case 'F':
 173           return;
 174         case 'b':  case 'B':
 175         case 'o':  case 'O':
 176         case 'd':  case 'D':
 177         case 'x':  case 'X':
 178         case 'i':  case 'I':
 179         case 'e':  case 'E':
 180           lexptr--;
 181           c = '#';
 182           goto num;
 183         case '*': /* bitvector */
 184           scm_read_token (c, 0);
 185           return;
 186         case '{':
 187           scm_read_token (c, 1);
 188           return;
 189         case '\\': /* character */
 190           c = *lexptr++;
 191           scm_read_token (c, 0);
 192           return;
 193         case '|':
 194           j = 1;                /* here j is the comment nesting depth */
 195         lp:
 196           c = *lexptr++;
 197         lpc:
 198           switch (c)
 199             {
 200             case '\0':
 201               error ("unbalanced comment");
 202             default:
 203               goto lp;
 204             case '|':
 205               if ('#' != (c = *lexptr++))
 206                 goto lpc;
 207               if (--j)
 208                 goto lp;
 209               break;
 210             case '#':
 211               if ('|' != (c = *lexptr++))
 212                 goto lpc;
 213               ++j;
 214               goto lp;
 215             }
 216           goto tryagain;
 217         case '.':
 218         default:
 219         callshrp:
 220           scm_lreadr ();
 221           return;
 222         }
 223     case '\"':
 224       while ('\"' != (c = *lexptr++))
 225         {
 226           if (c == '\\')
 227             switch (c = *lexptr++)
 228               {
 229               case '\0':
 230                 error ("non-terminated string literal");
 231               case '\n':
 232                 continue;
 233               case '0':
 234               case 'f':
 235               case 'n':
 236               case 'r':
 237               case 't':
 238               case 'a':
 239               case 'v':
 240                 break;
 241               }
 242         }
 243       return;
 244     case '0': case '1': case '2': case '3': case '4':
 245     case '5': case '6': case '7': case '8': case '9':
 246     case '.':
 247     case '-':
 248     case '+':
 249     num:
 250       scm_read_token (c, 0);
 251       return;
 252     case ':':
 253       scm_read_token ('-', 0);
 254       return;
 255     default:
 256       scm_read_token (c, 0);
 257     tok:
 258       return;
 259     }
 260 }
 261
 262 int
 263 scm_parse ()
 264 {
 265   char* start;
 266   struct stoken str;
 267   while (*lexptr == ' ')
 268     lexptr++;
 269   start = lexptr;
 270   scm_lreadr ();
 271   str.length = lexptr - start;
 272   str.ptr = start;
 273   write_exp_elt_opcode (OP_EXPRSTRING);
 274   write_exp_string (str);
 275   write_exp_elt_opcode (OP_EXPRSTRING);
 276   return 0;
 277 }
 278
 279 static void
 280 scm_printchar (c, stream)
 281      int c;
 282      GDB_FILE *stream;
 283 {
 284   fprintf_filtered (stream, "#\\%c", c);
 285 }
 286
 287 static void
 288 scm_printstr (stream, string, length, force_ellipses)
 289      GDB_FILE *stream;
 290      char *string;
 291      unsigned int length;
 292      int force_ellipses;
 293 {
 294   fprintf_filtered (stream, "\"%s\"", string);
 295 }
 296
 297 int
 298 is_object_type (type)
 299      struct type *type;
 300 {
 301   /* FIXME - this should test for the SCM type, but we can't do that ! */
 302   return TYPE_CODE (type) == TYPE_CODE_INT
 303     && TYPE_NAME (type)
 304 #if 1
 305     && strcmp (TYPE_NAME (type), "SCM") == 0;
 306 #else
 307     && TYPE_LENGTH (type) == TYPE_LENGTH (builtin_type_long)
 308     && strcmp (TYPE_NAME (type), "long int") == 0;
 309 #endif
 310 }
 311
 312 /* Prints the SCM value VALUE by invoking the inferior, if appropraite.
 313    Returns >= 0 on succes;  retunr -1 if the inferior cannot/should not
 314    print VALUE. */
 315
 316 int
 317 scm_inferior_print (value, stream, format, deref_ref, recurse, pretty)
 318      LONGEST value;
 319      GDB_FILE *stream;
 320      int format;
 321      int deref_ref;
 322      int recurse;
 323      enum val_prettyprint pretty;
 324 {
 325   return -1;
 326 }
 327
 328 #define SCM_ITAG8_DATA(X)       ((X)>>8)
 329 #define SCM_ICHR(x)     ((unsigned char)SCM_ITAG8_DATA(x))
 330 #define SCM_ICHRP(x)    (SCM_ITAG8(x) == scm_tc8_char)
 331 #define scm_tc8_char 0xf4
 332 #define SCM_IFLAGP(n)            ((0x87 & (int)(n))==4)
 333 #define SCM_ISYMNUM(n)           ((int)((n)>>9))
 334 #define SCM_ISYMCHARS(n)         (scm_isymnames[SCM_ISYMNUM(n)])
 335 #define SCM_ILOCP(n)             ((0xff & (int)(n))==0xfc)
 336 #define SCM_ITAG8(X)             ((int)(X) & 0xff)
 337
 338 /* {Names of immediate symbols}
 339  * This table must agree with the declarations in scm.h: {Immediate Symbols}.*/
 340
 341 static char *scm_isymnames[] =
 342 {
 343   /* This table must agree with the declarations */
 344   "#@and",
 345   "#@begin",
 346   "#@case",
 347   "#@cond",
 348   "#@do",
 349   "#@if",
 350   "#@lambda",
 351   "#@let",
 352   "#@let*",
 353   "#@letrec",
 354   "#@or",
 355   "#@quote",
 356   "#@set!",
 357   "#@define",
 358 #if 0
 359   "#@literal-variable-ref",
 360   "#@literal-variable-set!",
 361 #endif
 362   "#@apply",
 363   "#@call-with-current-continuation",
 364
 365  /* user visible ISYMS */
 366  /* other keywords */
 367  /* Flags */
 368
 369   "#f",
 370   "#t",
 371   "#<undefined>",
 372   "#<eof>",
 373   "()",
 374   "#<unspecified>"
 375 };
 376
 377 int
 378 scm_val_print (type, valaddr, address, stream, format, deref_ref, recurse,
 379              pretty)
 380      struct type *type;
 381      char *valaddr;
 382      CORE_ADDR address;
 383      GDB_FILE *stream;
 384      int format;
 385      int deref_ref;
 386      int recurse;
 387      enum val_prettyprint pretty;
 388 {
 389   if (is_object_type (type))
 390     {
 391       LONGEST svalue = unpack_long (type, valaddr);
 392       if (scm_inferior_print (svalue, stream, format,
 393                               deref_ref, recurse, pretty) >= 0)
 394         {
 395         }
 396       else
 397         {
 398           switch (7 & svalue)
 399             {
 400             case 2:
 401             case 6:
 402               print_longest (stream, format ? format : 'd', 1, svalue >> 2);
 403               break;
 404             case 4:
 405               if (SCM_ICHRP (svalue))
 406                 {
 407                   svalue = SCM_ICHR (svalue);
 408                   scm_printchar (svalue, stream);
 409                   break;
 410                 }
 411               else if (SCM_IFLAGP (svalue)
 412                && (SCM_ISYMNUM (svalue)
 413                    < (sizeof scm_isymnames / sizeof (char *))))
 414                 {
 415                   fputs_filtered (SCM_ISYMCHARS (svalue), stream);
 416                   break;
 417                 }
 418               else if (SCM_ILOCP (svalue))
 419                 {
 420 #if 0
 421                   fputs_filtered ("#@", stream);
 422                   scm_intprint ((long) IFRAME (exp), 10, port);
 423                   scm_putc (ICDRP (exp) ? '-' : '+', port);
 424                   scm_intprint ((long) IDIST (exp), 10, port);
 425                   break;
 426 #endif
 427                 }
 428             default:
 429               fprintf_filtered (stream, "#<%lX>", svalue);
 430             }
 431         }
 432       gdb_flush (stream);
 433       return (0);
 434     }
 435   else
 436     {
 437       return c_val_print (type, valaddr, address, stream, format,
 438                           deref_ref, recurse, pretty);
 439     }
 440 }
 441
 442 int
 443 scm_value_print (val, stream, format, pretty)
 444      value_ptr val;
 445      GDB_FILE *stream;
 446      int format;
 447      enum val_prettyprint pretty;
 448 {
 449   return (val_print (VALUE_TYPE (val), VALUE_CONTENTS (val),
 450                      VALUE_ADDRESS (val), stream, format, 1, 0, pretty));
 451 }
 452
 453 static value_ptr
 454 evaluate_subexp_scm (expect_type, exp, pos, noside)
 455      struct type *expect_type;
 456      register struct expression *exp;
 457      register int *pos;
 458      enum noside noside;
 459 {
 460   enum exp_opcode op = exp->elts[*pos].opcode;
 461   value_ptr func, addr;
 462   int len, pc;  char *str;
 463   switch (op)
 464     {
 465     case OP_EXPRSTRING:
 466       pc = (*pos)++;
 467       len = longest_to_int (exp->elts[pc + 1].longconst);
 468       (*pos) += 3 + BYTES_TO_EXP_ELEM (len + 1);
 469       if (noside == EVAL_SKIP)
 470         goto nosideret;
 471       str = &exp->elts[ + 2].string;
 472       addr = value_allocate_space_in_inferior (len);
 473       write_memory (value_as_long (addr), str, len);
 474       func = find_function_in_inferior ("scm_evstr");
 475       return call_function_by_hand (func, 1, &addr);
 476     default: ;
 477     }
 478   return evaluate_subexp_standard (expect_type, exp, pos, noside);
 479  nosideret:
 480   return value_from_longest (builtin_type_long, (LONGEST) 1);
 481 }
 482
 483 const struct language_defn scm_language_defn = {
 484   "scheme",                     /* Language name */
 485   language_scm,
 486   c_builtin_types,
 487   range_check_off,
 488   type_check_off,
 489   scm_parse,
 490   c_error,
 491   evaluate_subexp_scm,
 492   scm_printchar,                        /* Print a character constant */
 493   scm_printstr,                 /* Function to print string constant */
 494   NULL, /* Create fundamental type in this language */
 495   c_print_type,                 /* Print a type using appropriate syntax */
 496   scm_val_print,                /* Print a value using appropriate syntax */
 497   scm_value_print,              /* Print a top-level value */
 498   {"",     "",    "",  ""},     /* Binary format info */
 499   {"#o%lo",  "#o",   "o", ""},  /* Octal format info */
 500   {"%ld",   "",    "d", ""},    /* Decimal format info */
 501   {"#x%lX", "#X",  "X", ""},    /* Hex format info */
 502   NULL,                         /* expression operators for printing */
 503   1,                            /* c-style arrays */
 504   0,                            /* String lower bound */
 505   &builtin_type_char,           /* Type of string elements */
 506   LANG_MAGIC
 507 };
 508
 509 void
 510 _initialize_scheme_language ()
 511 {
 512   add_language (&scm_language_defn);
 513 }