gdb/ch-lang.c

   1 /* Chill language support routines for GDB, the GNU debugger.
   2    Copyright 1992 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 "value.h"
  24 #include "expression.h"
  25 #include "parser-defs.h"
  26 #include "language.h"
  27 #include "ch-lang.h"
  28
  29
  30 /* For now, Chill uses a simple mangling algorithm whereby you simply
  31    discard everything after the occurance of two successive CPLUS_MARKER
  32    characters to derive the demangled form. */
  33
  34 char *
  35 chill_demangle (mangled)
  36      const char *mangled;
  37 {
  38   char *joiner;
  39   char *demangled;
  40
  41   joiner = strchr (mangled, CPLUS_MARKER);
  42   if (joiner != NULL && *(joiner + 1) == CPLUS_MARKER)
  43     {
  44       demangled = savestring (mangled, joiner - mangled);
  45     }
  46   else
  47     {
  48       demangled = NULL;
  49     }
  50   return (demangled);
  51 }
  52
  53 static void
  54 chill_printchar (c, stream)
  55      register int c;
  56      GDB_FILE *stream;
  57 {
  58   c &= 0xFF;                    /* Avoid sign bit follies */
  59
  60   if (PRINT_LITERAL_FORM (c))
  61     {
  62       fprintf_filtered (stream, "'%c'", c);
  63     }
  64   else
  65     {
  66       fprintf_filtered (stream, "C'%.2x'", (unsigned int) c);
  67     }
  68 }
  69
  70 /* Print the character string STRING, printing at most LENGTH characters.
  71    Printing stops early if the number hits print_max; repeat counts
  72    are printed as appropriate.  Print ellipses at the end if we
  73    had to stop before printing LENGTH characters, or if FORCE_ELLIPSES.
  74    Note that gdb maintains the length of strings without counting the
  75    terminating null byte, while chill strings are typically written with
  76    an explicit null byte.  So we always assume an implied null byte
  77    until gdb is able to maintain non-null terminated strings as well
  78    as null terminated strings (FIXME).
  79   */
  80
  81 static void
  82 chill_printstr (stream, string, length, force_ellipses)
  83      GDB_FILE *stream;
  84      char *string;
  85      unsigned int length;
  86      int force_ellipses;
  87 {
  88   register unsigned int i;
  89   unsigned int things_printed = 0;
  90   int in_literal_form = 0;
  91   int in_control_form = 0;
  92   int need_slashslash = 0;
  93   unsigned int c;
  94   extern int repeat_count_threshold;
  95   extern int print_max;
  96
  97   if (length == 0)
  98     {
  99       fputs_filtered ("\"\"", stream);
 100       return;
 101     }
 102
 103   for (i = 0; i < length && things_printed < print_max; ++i)
 104     {
 105       /* Position of the character we are examining
 106          to see whether it is repeated.  */
 107       unsigned int rep1;
 108       /* Number of repetitions we have detected so far.  */
 109       unsigned int reps;
 110
 111       QUIT;
 112
 113       if (need_slashslash)
 114         {
 115           fputs_filtered ("//", stream);
 116           need_slashslash = 0;
 117         }
 118
 119       rep1 = i + 1;
 120       reps = 1;
 121       while (rep1 < length && string[rep1] == string[i])
 122         {
 123           ++rep1;
 124           ++reps;
 125         }
 126
 127       c = string[i];
 128       if (reps > repeat_count_threshold)
 129         {
 130           if (in_control_form || in_literal_form)
 131             {
 132               fputs_filtered ("\"//", stream);
 133               in_control_form = in_literal_form = 0;
 134             }
 135           chill_printchar (c, stream);
 136           fprintf_filtered (stream, "<repeats %u times>", reps);
 137           i = rep1 - 1;
 138           things_printed += repeat_count_threshold;
 139           need_slashslash = 1;
 140         }
 141       else
 142         {
 143           if (PRINT_LITERAL_FORM (c))
 144             {
 145               if (!in_literal_form)
 146                 {
 147                   if (in_control_form)
 148                     {
 149                       fputs_filtered ("\"//", stream);
 150                       in_control_form = 0;
 151                     }
 152                   fputs_filtered ("\"", stream);
 153                   in_literal_form = 1;
 154                 }
 155               fprintf_filtered (stream, "%c", c);
 156             }
 157           else
 158             {
 159               if (!in_control_form)
 160                 {
 161                   if (in_literal_form)
 162                     {
 163                       fputs_filtered ("\"//", stream);
 164                       in_literal_form = 0;
 165                     }
 166                   fputs_filtered ("c\"", stream);
 167                   in_control_form = 1;
 168                 }
 169               fprintf_filtered (stream, "%.2x", c);
 170             }
 171           ++things_printed;
 172         }
 173     }
 174
 175   /* Terminate the quotes if necessary.  */
 176   if (in_literal_form || in_control_form)
 177     {
 178       fputs_filtered ("\"", stream);
 179     }
 180   if (force_ellipses || (i < length))
 181     {
 182       fputs_filtered ("...", stream);
 183     }
 184 }
 185
 186 static struct type *
 187 chill_create_fundamental_type (objfile, typeid)
 188      struct objfile *objfile;
 189      int typeid;
 190 {
 191   register struct type *type = NULL;
 192
 193   switch (typeid)
 194     {
 195       default:
 196         /* FIXME:  For now, if we are asked to produce a type not in this
 197            language, create the equivalent of a C integer type with the
 198            name "<?type?>".  When all the dust settles from the type
 199            reconstruction work, this should probably become an error. */
 200         type = init_type (TYPE_CODE_INT, 2, 0, "<?type?>", objfile);
 201         warning ("internal error: no chill fundamental type %d", typeid);
 202         break;
 203       case FT_VOID:
 204         /* FIXME:  Currently the GNU Chill compiler emits some DWARF entries for
 205            typedefs, unrelated to anything directly in the code being compiled,
 206            that have some FT_VOID types.  Just fake it for now. */
 207         type = init_type (TYPE_CODE_VOID, 0, 0, "<?VOID?>", objfile);
 208         break;
 209       case FT_BOOLEAN:
 210         type = init_type (TYPE_CODE_BOOL, 1, TYPE_FLAG_UNSIGNED, "BOOL", objfile);
 211         break;
 212       case FT_CHAR:
 213         type = init_type (TYPE_CODE_CHAR, 1, TYPE_FLAG_UNSIGNED, "CHAR", objfile);
 214         break;
 215       case FT_SIGNED_CHAR:
 216         type = init_type (TYPE_CODE_INT, 1, 0, "BYTE", objfile);
 217         break;
 218       case FT_UNSIGNED_CHAR:
 219         type = init_type (TYPE_CODE_INT, 1, TYPE_FLAG_UNSIGNED, "UBYTE", objfile);
 220         break;
 221       case FT_SHORT:                    /* Chill ints are 2 bytes */
 222         type = init_type (TYPE_CODE_INT, 2, 0, "INT", objfile);
 223         break;
 224       case FT_UNSIGNED_SHORT:           /* Chill ints are 2 bytes */
 225         type = init_type (TYPE_CODE_INT, 2, TYPE_FLAG_UNSIGNED, "UINT", objfile);
 226         break;
 227       case FT_INTEGER:                  /* FIXME? */
 228       case FT_SIGNED_INTEGER:           /* FIXME? */
 229       case FT_LONG:                     /* Chill longs are 4 bytes */
 230       case FT_SIGNED_LONG:              /* Chill longs are 4 bytes */
 231         type = init_type (TYPE_CODE_INT, 4, 0, "LONG", objfile);
 232         break;
 233       case FT_UNSIGNED_INTEGER:         /* FIXME? */
 234       case FT_UNSIGNED_LONG:            /* Chill longs are 4 bytes */
 235         type = init_type (TYPE_CODE_INT, 4, TYPE_FLAG_UNSIGNED, "ULONG", objfile);
 236         break;
 237       case FT_FLOAT:
 238         type = init_type (TYPE_CODE_FLT, 4, 0, "REAL", objfile);
 239         break;
 240       case FT_DBL_PREC_FLOAT:
 241         type = init_type (TYPE_CODE_FLT, 8, 0, "LONG_REAL", objfile);
 242         break;
 243       }
 244   return (type);
 245 }
 246
 247 \f
 248 /* Table of operators and their precedences for printing expressions.  */
 249
 250 static const struct op_print chill_op_print_tab[] = {
 251     {"AND", BINOP_LOGICAL_AND, PREC_LOGICAL_AND, 0},
 252     {"OR",  BINOP_LOGICAL_OR, PREC_LOGICAL_OR, 0},
 253     {"NOT", UNOP_LOGICAL_NOT, PREC_PREFIX, 0},
 254     {"MOD", BINOP_MOD, PREC_MUL, 0},
 255     {"REM", BINOP_REM, PREC_MUL, 0},
 256     {"SIZE",UNOP_SIZEOF, PREC_BUILTIN_FUNCTION, 0},
 257     {"LOWER",UNOP_LOWER, PREC_BUILTIN_FUNCTION, 0},
 258     {"UPPER",UNOP_UPPER, PREC_BUILTIN_FUNCTION, 0},
 259     {"LOWER",UNOP_UPPER, PREC_BUILTIN_FUNCTION, 0},
 260     {":=",  BINOP_ASSIGN, PREC_ASSIGN, 1},
 261     {"=",   BINOP_EQUAL, PREC_EQUAL, 0},
 262     {"/=",  BINOP_NOTEQUAL, PREC_EQUAL, 0},
 263     {"<=",  BINOP_LEQ, PREC_ORDER, 0},
 264     {">=",  BINOP_GEQ, PREC_ORDER, 0},
 265     {">",   BINOP_GTR, PREC_ORDER, 0},
 266     {"<",   BINOP_LESS, PREC_ORDER, 0},
 267     {"+",   BINOP_ADD, PREC_ADD, 0},
 268     {"-",   BINOP_SUB, PREC_ADD, 0},
 269     {"*",   BINOP_MUL, PREC_MUL, 0},
 270     {"/",   BINOP_DIV, PREC_MUL, 0},
 271     {"//",  BINOP_CONCAT, PREC_PREFIX, 0},      /* FIXME: precedence? */
 272     {"-",   UNOP_NEG, PREC_PREFIX, 0},
 273     {"->",  UNOP_IND, PREC_SUFFIX, 1},
 274     {"->",  UNOP_ADDR, PREC_PREFIX, 0},
 275     {":",   BINOP_RANGE, PREC_ASSIGN, 0},
 276     {NULL,  0, 0, 0}
 277 };
 278 \f
 279 /* The built-in types of Chill.  */
 280
 281 struct type *builtin_type_chill_bool;
 282 struct type *builtin_type_chill_char;
 283 struct type *builtin_type_chill_long;
 284 struct type *builtin_type_chill_ulong;
 285 struct type *builtin_type_chill_real;
 286
 287 struct type ** const (chill_builtin_types[]) =
 288 {
 289   &builtin_type_chill_bool,
 290   &builtin_type_chill_char,
 291   &builtin_type_chill_long,
 292   &builtin_type_chill_ulong,
 293   &builtin_type_chill_real,
 294   0
 295 };
 296
 297 /* Calculate LOWER or UPPER of TYPE.
 298    Returns the result as an integer.
 299    *RESULT_TYPE is the appropriate type for the result. */
 300
 301 LONGEST
 302 type_lower_upper (op, type, result_type)
 303      enum exp_opcode op;  /* Either UNOP_LOWER or UNOP_UPPER */
 304      struct type *type;
 305      struct type **result_type;
 306 {
 307   LONGEST tmp;
 308   *result_type = builtin_type_int;
 309   switch (TYPE_CODE (type))
 310     {
 311     case TYPE_CODE_STRUCT:
 312       if (chill_varying_type (type))
 313         return type_lower_upper (op, TYPE_FIELD_TYPE (type, 1), result_type);
 314       break;
 315     case TYPE_CODE_ARRAY:
 316     case TYPE_CODE_BITSTRING:
 317     case TYPE_CODE_STRING:
 318       type = TYPE_FIELD_TYPE (type, 0);  /* Get index type */
 319
 320       /* ... fall through ... */
 321     case TYPE_CODE_RANGE:
 322       if (TYPE_DUMMY_RANGE (type) > 0)
 323         return type_lower_upper (op, TYPE_TARGET_TYPE (type), result_type);
 324       *result_type = TYPE_TARGET_TYPE (type);
 325       return op == UNOP_LOWER ? TYPE_LOW_BOUND (type) : TYPE_HIGH_BOUND (type);
 326
 327     case TYPE_CODE_ENUM:
 328       *result_type = type;
 329       if (TYPE_NFIELDS (type) > 0)
 330         return TYPE_FIELD_BITPOS (type,
 331                                   op == UNOP_LOWER ? 0
 332                                   : TYPE_NFIELDS (type) - 1);
 333
 334     case TYPE_CODE_BOOL:
 335       *result_type = type;
 336       return op == UNOP_LOWER ? 0 : 1;
 337     case TYPE_CODE_INT:
 338     case TYPE_CODE_CHAR:
 339       *result_type = type;
 340       tmp = (LONGEST) 1 << (TARGET_CHAR_BIT * TYPE_LENGTH (type));
 341       if (TYPE_UNSIGNED (type))
 342         return op == UNOP_LOWER ? 0 : tmp - (LONGEST) 1;
 343       tmp = tmp >> 1;
 344       return op == UNOP_LOWER ? -tmp : (tmp - 1);
 345     case TYPE_CODE_UNDEF:
 346     case TYPE_CODE_PTR:
 347     case TYPE_CODE_UNION:
 348     case TYPE_CODE_FUNC:
 349     case TYPE_CODE_FLT:
 350     case TYPE_CODE_VOID:
 351     case TYPE_CODE_SET:
 352     case TYPE_CODE_ERROR:
 353     case TYPE_CODE_MEMBER:
 354     case TYPE_CODE_METHOD:
 355     case TYPE_CODE_REF:
 356     case TYPE_CODE_COMPLEX:
 357     default:
 358       break;
 359     }
 360   error ("unknown mode for LOWER/UPPER builtin");
 361 }
 362
 363 static value_ptr
 364 value_chill_length (val)
 365      value_ptr val;
 366 {
 367   LONGEST tmp;
 368   struct type *type = VALUE_TYPE (val);
 369   struct type *ttype;
 370   switch (TYPE_CODE (type))
 371     {
 372     case TYPE_CODE_ARRAY:
 373     case TYPE_CODE_BITSTRING:
 374     case TYPE_CODE_STRING:
 375       tmp = type_lower_upper (UNOP_UPPER, type, &ttype)
 376         - type_lower_upper (UNOP_LOWER, type, &ttype) + 1;
 377       break;
 378     case TYPE_CODE_STRUCT:
 379       if (chill_varying_type (type))
 380         {
 381           tmp = unpack_long (TYPE_FIELD_TYPE (type, 0), VALUE_CONTENTS (val));
 382           break;
 383         }
 384       /* ... else fall through ... */
 385     default:
 386       error ("bad argument to LENGTH builtin");
 387     }
 388   return value_from_longest (builtin_type_int, tmp);
 389 }
 390
 391 static value_ptr
 392 evaluate_subexp_chill (expect_type, exp, pos, noside)
 393      struct type *expect_type;
 394      register struct expression *exp;
 395      register int *pos;
 396      enum noside noside;
 397 {
 398   int pc = *pos;
 399   struct type *type;
 400   int tem, nargs;
 401   value_ptr arg1;
 402   value_ptr *argvec;
 403   enum exp_opcode op = exp->elts[*pos].opcode;
 404   switch (op)
 405     {
 406     case MULTI_SUBSCRIPT:
 407       if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
 408         break;
 409       (*pos) += 3;
 410       nargs = longest_to_int (exp->elts[pc + 1].longconst);
 411       arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
 412
 413       switch (TYPE_CODE (VALUE_TYPE (arg1)))
 414         {
 415         case TYPE_CODE_PTR:
 416         case TYPE_CODE_FUNC:
 417           /* It's a function call. */
 418           /* Allocate arg vector, including space for the function to be
 419              called in argvec[0] and a terminating NULL */
 420           argvec = (value_ptr *) alloca (sizeof (value_ptr) * (nargs + 2));
 421           argvec[0] = arg1;
 422           tem = 1;
 423           for (; tem <= nargs; tem++)
 424             argvec[tem] = evaluate_subexp_with_coercion (exp, pos, noside);
 425           argvec[tem] = 0; /* signal end of arglist */
 426
 427           return call_function_by_hand (argvec[0], nargs, argvec + 1);
 428         default:
 429           break;
 430         }
 431
 432       while (nargs-- > 0)
 433         {
 434           value_ptr index = evaluate_subexp_with_coercion (exp, pos, noside);
 435           arg1 = value_subscript (arg1, index);
 436         }
 437       return (arg1);
 438
 439     case UNOP_LOWER:
 440     case UNOP_UPPER:
 441       (*pos)++;
 442       if (noside == EVAL_SKIP)
 443         {
 444           (*exp->language_defn->evaluate_exp) (NULL_TYPE, exp, pos, EVAL_SKIP);
 445           goto nosideret;
 446         }
 447       arg1 = (*exp->language_defn->evaluate_exp) (NULL_TYPE, exp, pos,
 448                                                   EVAL_AVOID_SIDE_EFFECTS);
 449       tem = type_lower_upper (op, VALUE_TYPE (arg1), &type);
 450       return value_from_longest (type, tem);
 451
 452     case UNOP_LENGTH:
 453       (*pos)++;
 454       arg1 = (*exp->language_defn->evaluate_exp) (NULL_TYPE, exp, pos, noside);
 455       return value_chill_length (arg1);
 456
 457     case BINOP_COMMA:
 458       error ("',' operator used in invalid context");
 459
 460     default:
 461       break;
 462     }
 463
 464   return evaluate_subexp_standard (expect_type, exp, pos, noside);
 465  nosideret:
 466   return value_from_longest (builtin_type_long, (LONGEST) 1);
 467 }
 468
 469 const struct language_defn chill_language_defn = {
 470   "chill",
 471   language_chill,
 472   chill_builtin_types,
 473   range_check_on,
 474   type_check_on,
 475   chill_parse,                  /* parser */
 476   chill_error,                  /* parser error function */
 477   evaluate_subexp_chill,
 478   chill_printchar,              /* print a character constant */
 479   chill_printstr,               /* function to print a string constant */
 480   chill_create_fundamental_type,/* Create fundamental type in this language */
 481   chill_print_type,             /* Print a type using appropriate syntax */
 482   chill_val_print,              /* Print a value using appropriate syntax */
 483   chill_value_print,            /* Print a top-levl value */
 484   {"",      "B'",  "",   ""},   /* Binary format info */
 485   {"O'%lo",  "O'",  "o",  ""},  /* Octal format info */
 486   {"D'%ld",  "D'",  "d",  ""},  /* Decimal format info */
 487   {"H'%lx",  "H'",  "x",  ""},  /* Hex format info */
 488   chill_op_print_tab,           /* expression operators for printing */
 489   0,                            /* arrays are first-class (not c-style) */
 490   0,                            /* String lower bound */
 491   &builtin_type_chill_char,     /* Type of string elements */
 492   LANG_MAGIC
 493 };
 494
 495 /* Initialization for Chill */
 496
 497 void
 498 _initialize_chill_language ()
 499 {
 500   builtin_type_chill_bool =
 501     init_type (TYPE_CODE_BOOL, TARGET_CHAR_BIT / TARGET_CHAR_BIT,
 502                TYPE_FLAG_UNSIGNED,
 503                "BOOL", (struct objfile *) NULL);
 504   builtin_type_chill_char =
 505     init_type (TYPE_CODE_CHAR, TARGET_CHAR_BIT / TARGET_CHAR_BIT,
 506                TYPE_FLAG_UNSIGNED,
 507                "CHAR", (struct objfile *) NULL);
 508   builtin_type_chill_long =
 509     init_type (TYPE_CODE_INT, TARGET_LONG_BIT / TARGET_CHAR_BIT,
 510                0,
 511                "LONG", (struct objfile *) NULL);
 512   builtin_type_chill_ulong =
 513     init_type (TYPE_CODE_INT, TARGET_LONG_BIT / TARGET_CHAR_BIT,
 514                TYPE_FLAG_UNSIGNED,
 515                "ULONG", (struct objfile *) NULL);
 516   builtin_type_chill_real =
 517     init_type (TYPE_CODE_FLT, TARGET_DOUBLE_BIT / TARGET_CHAR_BIT,
 518                0,
 519                "LONG_REAL", (struct objfile *) NULL);
 520
 521   add_language (&chill_language_defn);
 522 }