gdb/eval.c

   1 /* Evaluate expressions for GDB.
   2    Copyright 1986, 1987, 1989, 1991, 1992, 1993, 1994
   3    Free Software Foundation, Inc.
   4
   5 This file is part of GDB.
   6
   7 This program is free software; you can redistribute it and/or modify
   8 it under the terms of the GNU General Public License as published by
   9 the Free Software Foundation; either version 2 of the License, or
  10 (at your option) any later version.
  11
  12 This program is distributed in the hope that it will be useful,
  13 but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 GNU General Public License for more details.
  16
  17 You should have received a copy of the GNU General Public License
  18 along with this program; if not, write to the Free Software
  19 Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.  */
  20
  21 #include "defs.h"
  22 #include <string.h>
  23 #include "symtab.h"
  24 #include "gdbtypes.h"
  25 #include "value.h"
  26 #include "expression.h"
  27 #include "target.h"
  28 #include "frame.h"
  29 #include "demangle.h"
  30 #include "language.h"   /* For CAST_IS_CONVERSION */
  31 #include "f-lang.h" /* for array bound stuff */
  32
  33 /* Values of NOSIDE argument to eval_subexp.  */
  34
  35 enum noside
  36 {
  37   EVAL_NORMAL,
  38   EVAL_SKIP,                    /* Only effect is to increment pos.  */
  39   EVAL_AVOID_SIDE_EFFECTS       /* Don't modify any variables or
  40                                    call any functions.  The value
  41                                    returned will have the correct
  42                                    type, and will have an
  43                                    approximately correct lvalue
  44                                    type (inaccuracy: anything that is
  45                                    listed as being in a register in
  46                                    the function in which it was
  47                                    declared will be lval_register).  */
  48 };
  49
  50 /* Prototypes for local functions. */
  51
  52 static value_ptr evaluate_subexp_for_sizeof PARAMS ((struct expression *,
  53                                                      int *));
  54
  55 static value_ptr evaluate_subexp_with_coercion PARAMS ((struct expression *,
  56                                                         int *, enum noside));
  57
  58 static value_ptr evaluate_subexp_for_address PARAMS ((struct expression *,
  59                                                       int *, enum noside));
  60
  61 static value_ptr evaluate_subexp PARAMS ((struct type *, struct expression *,
  62                                           int *, enum noside));
  63
  64 \f
  65 /* Parse the string EXP as a C expression, evaluate it,
  66    and return the result as a number.  */
  67
  68 CORE_ADDR
  69 parse_and_eval_address (exp)
  70      char *exp;
  71 {
  72   struct expression *expr = parse_expression (exp);
  73   register CORE_ADDR addr;
  74   register struct cleanup *old_chain =
  75       make_cleanup (free_current_contents, &expr);
  76
  77   addr = value_as_pointer (evaluate_expression (expr));
  78   do_cleanups (old_chain);
  79   return addr;
  80 }
  81
  82 /* Like parse_and_eval_address but takes a pointer to a char * variable
  83    and advanced that variable across the characters parsed.  */
  84
  85 CORE_ADDR
  86 parse_and_eval_address_1 (expptr)
  87      char **expptr;
  88 {
  89   struct expression *expr = parse_exp_1 (expptr, (struct block *)0, 0);
  90   register CORE_ADDR addr;
  91   register struct cleanup *old_chain =
  92       make_cleanup (free_current_contents, &expr);
  93
  94   addr = value_as_pointer (evaluate_expression (expr));
  95   do_cleanups (old_chain);
  96   return addr;
  97 }
  98
  99 value_ptr
 100 parse_and_eval (exp)
 101      char *exp;
 102 {
 103   struct expression *expr = parse_expression (exp);
 104   register value_ptr val;
 105   register struct cleanup *old_chain
 106     = make_cleanup (free_current_contents, &expr);
 107
 108   val = evaluate_expression (expr);
 109   do_cleanups (old_chain);
 110   return val;
 111 }
 112
 113 /* Parse up to a comma (or to a closeparen)
 114    in the string EXPP as an expression, evaluate it, and return the value.
 115    EXPP is advanced to point to the comma.  */
 116
 117 value_ptr
 118 parse_to_comma_and_eval (expp)
 119      char **expp;
 120 {
 121   struct expression *expr = parse_exp_1 (expp, (struct block *) 0, 1);
 122   register value_ptr val;
 123   register struct cleanup *old_chain
 124     = make_cleanup (free_current_contents, &expr);
 125
 126   val = evaluate_expression (expr);
 127   do_cleanups (old_chain);
 128   return val;
 129 }
 130 \f
 131 /* Evaluate an expression in internal prefix form
 132    such as is constructed by parse.y.
 133
 134    See expression.h for info on the format of an expression.  */
 135
 136 value_ptr
 137 evaluate_expression (exp)
 138      struct expression *exp;
 139 {
 140   int pc = 0;
 141   return evaluate_subexp (NULL_TYPE, exp, &pc, EVAL_NORMAL);
 142 }
 143
 144 /* Evaluate an expression, avoiding all memory references
 145    and getting a value whose type alone is correct.  */
 146
 147 value_ptr
 148 evaluate_type (exp)
 149      struct expression *exp;
 150 {
 151   int pc = 0;
 152   return evaluate_subexp (NULL_TYPE, exp, &pc, EVAL_AVOID_SIDE_EFFECTS);
 153 }
 154
 155 static value_ptr
 156 evaluate_subexp (expect_type, exp, pos, noside)
 157      struct type *expect_type;
 158      register struct expression *exp;
 159      register int *pos;
 160      enum noside noside;
 161 {
 162   enum exp_opcode op;
 163   int tem, tem2, tem3;
 164   register int pc, pc2 = 0, oldpos;
 165   register value_ptr arg1 = NULL, arg2 = NULL, arg3;
 166   struct type *type;
 167   int nargs;
 168   value_ptr *argvec;
 169   int tmp_pos, tmp1_pos;
 170   struct symbol *tmp_symbol;
 171   int upper, lower, retcode;
 172   int code;
 173   struct internalvar *var;
 174
 175   /* This expect_type crap should not be used for C.  C expressions do
 176      not have any notion of expected types, never has and (goddess
 177      willing) never will.  The C++ code uses it for some twisted
 178      purpose (I haven't investigated but I suspect it just the usual
 179      combination of Stroustrup figuring out some crazy language
 180      feature and Tiemann figuring out some crazier way to try to
 181      implement it).  CHILL has the tuple stuff; I don't know enough
 182      about CHILL to know whether expected types is the way to do it.
 183      FORTRAN I don't know.  */
 184   if (current_language->la_language != language_cplus
 185       && current_language->la_language != language_chill)
 186     expect_type = NULL_TYPE;
 187
 188   pc = (*pos)++;
 189   op = exp->elts[pc].opcode;
 190
 191   switch (op)
 192     {
 193     case OP_SCOPE:
 194       tem = longest_to_int (exp->elts[pc + 2].longconst);
 195       (*pos) += 4 + BYTES_TO_EXP_ELEM (tem + 1);
 196       arg1 = value_struct_elt_for_reference (exp->elts[pc + 1].type,
 197                                              0,
 198                                              exp->elts[pc + 1].type,
 199                                              &exp->elts[pc + 3].string,
 200                                              expect_type);
 201       if (arg1 == NULL)
 202         error ("There is no field named %s", &exp->elts[pc + 3].string);
 203       return arg1;
 204
 205     case OP_LONG:
 206       (*pos) += 3;
 207       return value_from_longest (exp->elts[pc + 1].type,
 208                                  exp->elts[pc + 2].longconst);
 209
 210     case OP_DOUBLE:
 211       (*pos) += 3;
 212       return value_from_double (exp->elts[pc + 1].type,
 213                                 exp->elts[pc + 2].doubleconst);
 214
 215     case OP_VAR_VALUE:
 216       (*pos) += 3;
 217       if (noside == EVAL_SKIP)
 218         goto nosideret;
 219       if (noside == EVAL_AVOID_SIDE_EFFECTS)
 220         {
 221           struct symbol * sym = exp->elts[pc + 2].symbol;
 222           enum lval_type lv;
 223
 224           switch (SYMBOL_CLASS (sym))
 225             {
 226             case LOC_CONST:
 227             case LOC_LABEL:
 228             case LOC_CONST_BYTES:
 229               lv = not_lval;
 230               break;
 231
 232             case LOC_REGISTER:
 233             case LOC_REGPARM:
 234               lv = lval_register;
 235               break;
 236
 237             default:
 238               lv = lval_memory;
 239               break;
 240             }
 241
 242           return value_zero (SYMBOL_TYPE (sym), lv);
 243         }
 244       else
 245         return value_of_variable (exp->elts[pc + 2].symbol,
 246                                   exp->elts[pc + 1].block);
 247
 248     case OP_LAST:
 249       (*pos) += 2;
 250       return
 251         access_value_history (longest_to_int (exp->elts[pc + 1].longconst));
 252
 253     case OP_REGISTER:
 254       (*pos) += 2;
 255       return value_of_register (longest_to_int (exp->elts[pc + 1].longconst));
 256
 257     case OP_BOOL:
 258       (*pos) += 2;
 259       if (current_language->la_language == language_fortran)
 260         return value_from_longest (builtin_type_f_logical_s2,
 261                                    exp->elts[pc + 1].longconst);
 262       else
 263         return value_from_longest (builtin_type_chill_bool,
 264                                    exp->elts[pc + 1].longconst);
 265
 266     case OP_INTERNALVAR:
 267       (*pos) += 2;
 268       return value_of_internalvar (exp->elts[pc + 1].internalvar);
 269
 270     case OP_STRING:
 271       tem = longest_to_int (exp->elts[pc + 1].longconst);
 272       (*pos) += 3 + BYTES_TO_EXP_ELEM (tem + 1);
 273       if (noside == EVAL_SKIP)
 274         goto nosideret;
 275       return value_string (&exp->elts[pc + 2].string, tem);
 276
 277     case OP_BITSTRING:
 278       error ("support for OP_BITSTRING unimplemented");
 279       break;
 280
 281     case OP_ARRAY:
 282       (*pos) += 3;
 283       tem2 = longest_to_int (exp->elts[pc + 1].longconst);
 284       tem3 = longest_to_int (exp->elts[pc + 2].longconst);
 285       nargs = tem3 - tem2 + 1;
 286
 287       if (expect_type != NULL_TYPE && noside != EVAL_SKIP
 288           && TYPE_CODE (expect_type) == TYPE_CODE_STRUCT)
 289         {
 290           value_ptr rec = allocate_value (expect_type);
 291           if (TYPE_NFIELDS (expect_type) != nargs)
 292             error ("wrong number of initialiers for structure type");
 293           for (tem = 0; tem < nargs; tem++)
 294             {
 295               struct type *field_type = TYPE_FIELD_TYPE (expect_type, tem);
 296               value_ptr field_val = evaluate_subexp (field_type,
 297                                                      exp, pos, noside);
 298               int bitsize, bitpos;
 299               char *addr;
 300               if (VALUE_TYPE (field_val) != field_type)
 301                 field_val = value_cast (field_type, field_val);
 302 #if 1
 303               bitsize = TYPE_FIELD_BITSIZE (expect_type, tem);
 304               bitpos = TYPE_FIELD_BITPOS (expect_type, tem);
 305               addr = VALUE_CONTENTS (rec);
 306               addr += bitpos / 8;
 307               if (bitsize)
 308                 modify_field (addr, value_as_long (field_val),
 309                               bitpos % 8, bitsize);
 310               else
 311                 memcpy (addr, VALUE_CONTENTS (field_val),
 312                         TYPE_LENGTH (VALUE_TYPE (field_val)));
 313 #else
 314               value_assign (value_primitive_field (rec, 0, tem, expect_type),
 315                             field_val);
 316 #endif
 317             }
 318           return rec;
 319         }
 320
 321       if (expect_type != NULL_TYPE && noside != EVAL_SKIP
 322           && TYPE_CODE (expect_type) == TYPE_CODE_ARRAY)
 323         {
 324           struct type *range_type = TYPE_FIELD_TYPE (expect_type, 0);
 325           struct type *element_type = TYPE_TARGET_TYPE (expect_type);
 326           LONGEST low_bound =  TYPE_FIELD_BITPOS (range_type, 0);
 327           LONGEST high_bound = TYPE_FIELD_BITPOS (range_type, 1);
 328           int element_size = TYPE_LENGTH (element_type);
 329           value_ptr rec = allocate_value (expect_type);
 330           if (nargs != (high_bound - low_bound + 1))
 331             error ("wrong number of initialiers for array type");
 332           for (tem = low_bound;  tem <= high_bound;  tem++)
 333             {
 334               value_ptr element = evaluate_subexp (element_type,
 335                                                    exp, pos, noside);
 336               memcpy (VALUE_CONTENTS_RAW (rec)
 337                       + (tem - low_bound) * element_size,
 338                       VALUE_CONTENTS (element),
 339                       element_size);
 340             }
 341           return rec;
 342         }
 343
 344       argvec = (value_ptr *) alloca (sizeof (value_ptr) * nargs);
 345       for (tem = 0; tem < nargs; tem++)
 346         {
 347           /* Ensure that array expressions are coerced into pointer objects. */
 348           argvec[tem] = evaluate_subexp_with_coercion (exp, pos, noside);
 349         }
 350       if (noside == EVAL_SKIP)
 351         goto nosideret;
 352       if (current_language->la_language == language_fortran)
 353          /* For F77, we need to do special things to literal strings */
 354          return (f77_value_literal_string (tem2, tem3, argvec));
 355       return value_array (tem2, tem3, argvec);
 356       break;
 357
 358     case TERNOP_COND:
 359       /* Skip third and second args to evaluate the first one.  */
 360       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
 361       if (value_logical_not (arg1))
 362         {
 363           evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
 364           return evaluate_subexp (NULL_TYPE, exp, pos, noside);
 365         }
 366       else
 367         {
 368           arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
 369           evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
 370           return arg2;
 371         }
 372
 373     case OP_FUNCALL:
 374       (*pos) += 2;
 375       op = exp->elts[*pos].opcode;
 376       if (op == STRUCTOP_MEMBER || op == STRUCTOP_MPTR)
 377         {
 378           LONGEST fnptr;
 379
 380           nargs = longest_to_int (exp->elts[pc + 1].longconst) + 1;
 381           /* First, evaluate the structure into arg2 */
 382           pc2 = (*pos)++;
 383
 384           if (noside == EVAL_SKIP)
 385             goto nosideret;
 386
 387           if (op == STRUCTOP_MEMBER)
 388             {
 389               arg2 = evaluate_subexp_for_address (exp, pos, noside);
 390             }
 391           else
 392             {
 393               arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
 394             }
 395
 396           /* If the function is a virtual function, then the
 397              aggregate value (providing the structure) plays
 398              its part by providing the vtable.  Otherwise,
 399              it is just along for the ride: call the function
 400              directly.  */
 401
 402           arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
 403
 404           fnptr = value_as_long (arg1);
 405
 406           if (METHOD_PTR_IS_VIRTUAL(fnptr))
 407             {
 408               int fnoffset = METHOD_PTR_TO_VOFFSET(fnptr);
 409               struct type *basetype;
 410               struct type *domain_type =
 411                   TYPE_DOMAIN_TYPE (TYPE_TARGET_TYPE (VALUE_TYPE (arg1)));
 412               int i, j;
 413               basetype = TYPE_TARGET_TYPE (VALUE_TYPE (arg2));
 414               if (domain_type != basetype)
 415                   arg2 = value_cast(lookup_pointer_type (domain_type), arg2);
 416               basetype = TYPE_VPTR_BASETYPE (domain_type);
 417               for (i = TYPE_NFN_FIELDS (basetype) - 1; i >= 0; i--)
 418                 {
 419                   struct fn_field *f = TYPE_FN_FIELDLIST1 (basetype, i);
 420                   /* If one is virtual, then all are virtual.  */
 421                   if (TYPE_FN_FIELD_VIRTUAL_P (f, 0))
 422                     for (j = TYPE_FN_FIELDLIST_LENGTH (basetype, i) - 1; j >= 0; --j)
 423                       if (TYPE_FN_FIELD_VOFFSET (f, j) == fnoffset)
 424                         {
 425                           value_ptr temp = value_ind (arg2);
 426                           arg1 = value_virtual_fn_field (&temp, f, j, domain_type, 0);
 427                           arg2 = value_addr (temp);
 428                           goto got_it;
 429                         }
 430                 }
 431               if (i < 0)
 432                 error ("virtual function at index %d not found", fnoffset);
 433             }
 434           else
 435             {
 436               VALUE_TYPE (arg1) = lookup_pointer_type (TYPE_TARGET_TYPE (VALUE_TYPE (arg1)));
 437             }
 438         got_it:
 439
 440           /* Now, say which argument to start evaluating from */
 441           tem = 2;
 442         }
 443       else if (op == STRUCTOP_STRUCT || op == STRUCTOP_PTR)
 444         {
 445           /* Hair for method invocations */
 446           int tem2;
 447
 448           nargs = longest_to_int (exp->elts[pc + 1].longconst) + 1;
 449           /* First, evaluate the structure into arg2 */
 450           pc2 = (*pos)++;
 451           tem2 = longest_to_int (exp->elts[pc2 + 1].longconst);
 452           *pos += 3 + BYTES_TO_EXP_ELEM (tem2 + 1);
 453           if (noside == EVAL_SKIP)
 454             goto nosideret;
 455
 456           if (op == STRUCTOP_STRUCT)
 457             {
 458               /* If v is a variable in a register, and the user types
 459                  v.method (), this will produce an error, because v has
 460                  no address.
 461
 462                  A possible way around this would be to allocate a
 463                  copy of the variable on the stack, copy in the
 464                  contents, call the function, and copy out the
 465                  contents.  I.e. convert this from call by reference
 466                  to call by copy-return (or whatever it's called).
 467                  However, this does not work because it is not the
 468                  same: the method being called could stash a copy of
 469                  the address, and then future uses through that address
 470                  (after the method returns) would be expected to
 471                  use the variable itself, not some copy of it.  */
 472               arg2 = evaluate_subexp_for_address (exp, pos, noside);
 473             }
 474           else
 475             {
 476               arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
 477             }
 478           /* Now, say which argument to start evaluating from */
 479           tem = 2;
 480         }
 481       else
 482         {
 483           nargs = longest_to_int (exp->elts[pc + 1].longconst);
 484           tem = 0;
 485         }
 486       /* Allocate arg vector, including space for the function to be
 487          called in argvec[0] and a terminating NULL */
 488       argvec = (value_ptr *) alloca (sizeof (value_ptr) * (nargs + 2));
 489       for (; tem <= nargs; tem++)
 490         /* Ensure that array expressions are coerced into pointer objects. */
 491         argvec[tem] = evaluate_subexp_with_coercion (exp, pos, noside);
 492
 493       /* signal end of arglist */
 494       argvec[tem] = 0;
 495
 496       if (op == STRUCTOP_STRUCT || op == STRUCTOP_PTR)
 497         {
 498           int static_memfuncp;
 499           value_ptr temp = arg2;
 500           char tstr[64];
 501
 502           argvec[1] = arg2;
 503           argvec[0] = 0;
 504           strcpy(tstr, &exp->elts[pc2+2].string);
 505           if (!argvec[0])
 506             {
 507               temp = arg2;
 508               argvec[0] =
 509               value_struct_elt (&temp, argvec+1, tstr,
 510                               &static_memfuncp,
 511                               op == STRUCTOP_STRUCT
 512                               ? "structure" : "structure pointer");
 513             }
 514           arg2 = value_from_longest (lookup_pointer_type(VALUE_TYPE (temp)),
 515                          VALUE_ADDRESS (temp)+VALUE_OFFSET (temp));
 516           argvec[1] = arg2;
 517
 518           if (static_memfuncp)
 519             {
 520               argvec[1] = argvec[0];
 521               nargs--;
 522               argvec++;
 523             }
 524         }
 525       else if (op == STRUCTOP_MEMBER || op == STRUCTOP_MPTR)
 526         {
 527           argvec[1] = arg2;
 528           argvec[0] = arg1;
 529         }
 530
 531       if (noside == EVAL_SKIP)
 532         goto nosideret;
 533       if (noside == EVAL_AVOID_SIDE_EFFECTS)
 534         {
 535           /* If the return type doesn't look like a function type, call an
 536              error.  This can happen if somebody tries to turn a variable into
 537              a function call. This is here because people often want to
 538              call, eg, strcmp, which gdb doesn't know is a function.  If
 539              gdb isn't asked for it's opinion (ie. through "whatis"),
 540              it won't offer it. */
 541
 542           struct type *ftype =
 543             TYPE_TARGET_TYPE (VALUE_TYPE (argvec[0]));
 544
 545           if (ftype)
 546             return allocate_value (TYPE_TARGET_TYPE (VALUE_TYPE (argvec[0])));
 547           else
 548             error ("Expression of type other than \"Function returning ...\" used as function");
 549         }
 550       return call_function_by_hand (argvec[0], nargs, argvec + 1);
 551
 552     case OP_F77_UNDETERMINED_ARGLIST:
 553
 554       tmp_pos = pc; /* Point to this instr */
 555
 556       /* Remember that in F77, functions, substring ops and
 557          array subscript operations cannot be disambiguated
 558          at parse time.  We have made all array subscript operations,
 559          substring operations as well as function calls  come here
 560          and we now have to discover what the heck this thing actually was.
 561          If it is an array, we massage it into a form that the
 562          MULTI_F77_SUBSCRIPT operator can deal with. If it is
 563          a function, we process just as if we got an OP_FUNCALL and
 564          for a subscring operation, we perform the appropriate
 565          substring operation.  */
 566
 567       /* First get the nargs and then jump all the way over the:
 568
 569          OP_UNDETERMINED_ARGLIST
 570          nargs
 571          OP_UNDETERMINED_ARGLIST
 572
 573          instruction sequence */
 574
 575       nargs = longest_to_int (exp->elts[tmp_pos+1].longconst);
 576       tmp_pos += 3; /* size(op_funcall) == 3 elts */
 577
 578       /* We will always have an OP_VAR_VALUE as the next opcode.
 579          The data stored after the OP_VAR_VALUE is the a pointer
 580          to the function/array/string symbol.  We should now check and
 581          make sure that the symbols is an array and not a function.
 582          If it is an array type, we have hit a F77 subscript operation and
 583          we have to do some magic. If it is not an array, we check
 584          to see if we found a string here. If there is a string,
 585          we recursively evaluate and let OP_f77_SUBSTR deal with
 586          things.  If there is no string, we know there is a function
 587          call at hand and change OP_FUNCALL_OR_SUBSCRIPT -> OP_FUNCALL.
 588          In all cases, we recursively evaluate.  */
 589
 590       /* First determine the type code we are dealing with.  */
 591
 592       switch (exp->elts[tmp_pos].opcode)
 593         {
 594         case OP_VAR_VALUE:
 595           tmp_pos += 1; /* To get to the symbol ptr */
 596           tmp_symbol = exp->elts[tmp_pos].symbol;
 597           code = TYPE_CODE (SYMBOL_TYPE (tmp_symbol));
 598           break;
 599
 600         case OP_INTERNALVAR:
 601           tmp_pos += 1;
 602           var = exp->elts[tmp_pos].internalvar;
 603           code = TYPE_CODE(VALUE_TYPE(var->value));
 604           break;
 605
 606         case OP_F77_UNDETERMINED_ARGLIST:
 607           /* Special case when you do stuff like print ARRAY(1,1)(3:4) */
 608           tmp1_pos = tmp_pos ;
 609           arg2 = evaluate_subexp (NULL_TYPE, exp, &tmp1_pos, noside);
 610           code =TYPE_CODE (VALUE_TYPE (arg2));
 611           break;
 612
 613         default:
 614           error ("Cannot perform substring on this type");
 615         }
 616
 617       switch (code)
 618         {
 619         case TYPE_CODE_ARRAY:
 620           /* Transform this into what it really is: a MULTI_F77_SUBSCRIPT */
 621           tmp_pos = pc;
 622           exp->elts[tmp_pos].opcode = MULTI_F77_SUBSCRIPT;
 623           exp->elts[tmp_pos+2].opcode = MULTI_F77_SUBSCRIPT;
 624           break;
 625
 626         case TYPE_CODE_LITERAL_STRING:  /* When substring'ing internalvars */
 627         case TYPE_CODE_STRING:
 628           tmp_pos = pc;
 629           exp->elts[tmp_pos].opcode = OP_F77_SUBSTR;
 630           exp->elts[tmp_pos+2].opcode = OP_F77_SUBSTR;
 631           break;
 632
 633         case TYPE_CODE_PTR:
 634         case TYPE_CODE_FUNC:
 635           /* This is just a regular OP_FUNCALL, transform it
 636              and recursively evaluate */
 637           tmp_pos = pc; /* Point to OP_FUNCALL_OR_SUBSCRIPT */
 638           exp->elts[tmp_pos].opcode = OP_FUNCALL;
 639           exp->elts[tmp_pos+2].opcode = OP_FUNCALL;
 640           break;
 641
 642         default:
 643               error ("Cannot perform substring on this type");
 644         }
 645
 646       /* Pretend like you never saw this expression */
 647       *pos -= 1;
 648       arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
 649       return arg2;
 650
 651     case OP_F77_SUBSTR:
 652       /* We have a substring operation on our hands here,
 653          let us get the string we will be dealing with */
 654
 655       (*pos) += 2;
 656       arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
 657
 658       /* Now evaluate the 'from' and 'to' */
 659
 660       arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
 661
 662       if (TYPE_CODE (VALUE_TYPE (arg2)) != TYPE_CODE_INT)
 663          error ("Substring arguments must be of type integer");
 664
 665       arg3 = evaluate_subexp_with_coercion (exp, pos, noside);
 666
 667       if (TYPE_CODE (VALUE_TYPE (arg3)) != TYPE_CODE_INT)
 668          error ("Substring arguments must be of type integer");
 669
 670       tem2 = *((int *) VALUE_CONTENTS_RAW (arg2));
 671       tem3 = *((int *) VALUE_CONTENTS_RAW (arg3));
 672
 673       if ((tem2 < 1) || (tem2 > tem3))
 674          error ("Bad 'from' value %d on substring operation", tem2);
 675
 676       if ((tem3 < tem2) || (tem3 > (TYPE_LENGTH (VALUE_TYPE (arg1)))))
 677          error ("Bad 'to' value %d on substring operation", tem3);
 678
 679       if (noside == EVAL_SKIP)
 680         goto nosideret;
 681
 682       return f77_value_substring (arg1, tem2, tem3);
 683
 684     case OP_F77_LITERAL_COMPLEX:
 685       /* We have a complex number, There should be 2 floating
 686          point numbers that compose it */
 687       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
 688       arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
 689
 690       /* Complex*16 is the default size to create */
 691       return f77_value_literal_complex (arg1, arg2, 16);
 692
 693     case STRUCTOP_STRUCT:
 694       tem = longest_to_int (exp->elts[pc + 1].longconst);
 695       (*pos) += 3 + BYTES_TO_EXP_ELEM (tem + 1);
 696       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
 697       if (noside == EVAL_SKIP)
 698         goto nosideret;
 699       if (noside == EVAL_AVOID_SIDE_EFFECTS)
 700         return value_zero (lookup_struct_elt_type (VALUE_TYPE (arg1),
 701                                                    &exp->elts[pc + 2].string,
 702                                                    0),
 703                            lval_memory);
 704       else
 705         {
 706           value_ptr temp = arg1;
 707           return value_struct_elt (&temp, NULL, &exp->elts[pc + 2].string,
 708                                    NULL, "structure");
 709         }
 710
 711     case STRUCTOP_PTR:
 712       tem = longest_to_int (exp->elts[pc + 1].longconst);
 713       (*pos) += 3 + BYTES_TO_EXP_ELEM (tem + 1);
 714       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
 715       if (noside == EVAL_SKIP)
 716         goto nosideret;
 717       if (noside == EVAL_AVOID_SIDE_EFFECTS)
 718         return value_zero (lookup_struct_elt_type (VALUE_TYPE (arg1),
 719                                                    &exp->elts[pc + 2].string,
 720                                                    0),
 721                            lval_memory);
 722       else
 723         {
 724           value_ptr temp = arg1;
 725           return value_struct_elt (&temp, NULL, &exp->elts[pc + 2].string,
 726                                    NULL, "structure pointer");
 727         }
 728
 729     case STRUCTOP_MEMBER:
 730       arg1 = evaluate_subexp_for_address (exp, pos, noside);
 731       goto handle_pointer_to_member;
 732     case STRUCTOP_MPTR:
 733       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
 734     handle_pointer_to_member:
 735       arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
 736       if (noside == EVAL_SKIP)
 737         goto nosideret;
 738       if (TYPE_CODE (VALUE_TYPE (arg2)) != TYPE_CODE_PTR)
 739         goto bad_pointer_to_member;
 740       type = TYPE_TARGET_TYPE (VALUE_TYPE (arg2));
 741       if (TYPE_CODE (type) == TYPE_CODE_METHOD)
 742         error ("not implemented: pointer-to-method in pointer-to-member construct");
 743       if (TYPE_CODE (type) != TYPE_CODE_MEMBER)
 744         goto bad_pointer_to_member;
 745       /* Now, convert these values to an address.  */
 746       arg1 = value_cast (lookup_pointer_type (TYPE_DOMAIN_TYPE (type)),
 747                          arg1);
 748       arg3 = value_from_longest (lookup_pointer_type (TYPE_TARGET_TYPE (type)),
 749                                  value_as_long (arg1) + value_as_long (arg2));
 750       return value_ind (arg3);
 751     bad_pointer_to_member:
 752       error("non-pointer-to-member value used in pointer-to-member construct");
 753
 754     case BINOP_CONCAT:
 755       arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
 756       arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
 757       if (noside == EVAL_SKIP)
 758         goto nosideret;
 759       if (binop_user_defined_p (op, arg1, arg2))
 760         return value_x_binop (arg1, arg2, op, OP_NULL);
 761       else
 762         return value_concat (arg1, arg2);
 763
 764     case BINOP_ASSIGN:
 765       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
 766       arg2 = evaluate_subexp (VALUE_TYPE (arg1), exp, pos, noside);
 767       if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
 768         return arg1;
 769       if (binop_user_defined_p (op, arg1, arg2))
 770         return value_x_binop (arg1, arg2, op, OP_NULL);
 771       else
 772         return value_assign (arg1, arg2);
 773
 774     case BINOP_ASSIGN_MODIFY:
 775       (*pos) += 2;
 776       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
 777       arg2 = evaluate_subexp (VALUE_TYPE (arg1), exp, pos, noside);
 778       if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
 779         return arg1;
 780       op = exp->elts[pc + 1].opcode;
 781       if (binop_user_defined_p (op, arg1, arg2))
 782         return value_x_binop (arg1, arg2, BINOP_ASSIGN_MODIFY, op);
 783       else if (op == BINOP_ADD)
 784         arg2 = value_add (arg1, arg2);
 785       else if (op == BINOP_SUB)
 786         arg2 = value_sub (arg1, arg2);
 787       else
 788         arg2 = value_binop (arg1, arg2, op);
 789       return value_assign (arg1, arg2);
 790
 791     case BINOP_ADD:
 792       arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
 793       arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
 794       if (noside == EVAL_SKIP)
 795         goto nosideret;
 796       if (binop_user_defined_p (op, arg1, arg2))
 797         return value_x_binop (arg1, arg2, op, OP_NULL);
 798       else
 799         return value_add (arg1, arg2);
 800
 801     case BINOP_SUB:
 802       arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
 803       arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
 804       if (noside == EVAL_SKIP)
 805         goto nosideret;
 806       if (binop_user_defined_p (op, arg1, arg2))
 807         return value_x_binop (arg1, arg2, op, OP_NULL);
 808       else
 809         return value_sub (arg1, arg2);
 810
 811     case BINOP_MUL:
 812     case BINOP_DIV:
 813     case BINOP_REM:
 814     case BINOP_MOD:
 815     case BINOP_LSH:
 816     case BINOP_RSH:
 817     case BINOP_BITWISE_AND:
 818     case BINOP_BITWISE_IOR:
 819     case BINOP_BITWISE_XOR:
 820       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
 821       arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
 822       if (noside == EVAL_SKIP)
 823         goto nosideret;
 824       if (binop_user_defined_p (op, arg1, arg2))
 825         return value_x_binop (arg1, arg2, op, OP_NULL);
 826       else
 827         if (noside == EVAL_AVOID_SIDE_EFFECTS
 828             && (op == BINOP_DIV || op == BINOP_REM || op == BINOP_MOD))
 829           return value_zero (VALUE_TYPE (arg1), not_lval);
 830       else
 831         return value_binop (arg1, arg2, op);
 832
 833     case BINOP_SUBSCRIPT:
 834       arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
 835       arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
 836       if (noside == EVAL_SKIP)
 837         goto nosideret;
 838       if (noside == EVAL_AVOID_SIDE_EFFECTS)
 839         {
 840           /* If the user attempts to subscript something that has no target
 841              type (like a plain int variable for example), then report this
 842              as an error. */
 843
 844           type = TYPE_TARGET_TYPE (VALUE_TYPE (arg1));
 845           if (type)
 846             return value_zero (type, VALUE_LVAL (arg1));
 847           else
 848             error ("cannot subscript something of type `%s'",
 849                    TYPE_NAME (VALUE_TYPE (arg1)));
 850         }
 851
 852       if (binop_user_defined_p (op, arg1, arg2))
 853         return value_x_binop (arg1, arg2, op, OP_NULL);
 854       else
 855         return value_subscript (arg1, arg2);
 856
 857     case BINOP_IN:
 858       arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
 859       arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
 860       if (noside == EVAL_SKIP)
 861         goto nosideret;
 862       return value_in (arg1, arg2);
 863
 864     case MULTI_SUBSCRIPT:
 865       (*pos) += 2;
 866       nargs = longest_to_int (exp->elts[pc + 1].longconst);
 867       arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
 868       while (nargs-- > 0)
 869         {
 870           arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
 871           /* FIXME:  EVAL_SKIP handling may not be correct. */
 872           if (noside == EVAL_SKIP)
 873             {
 874               if (nargs > 0)
 875                 {
 876                   continue;
 877                 }
 878               else
 879                 {
 880                   goto nosideret;
 881                 }
 882             }
 883           /* FIXME:  EVAL_AVOID_SIDE_EFFECTS handling may not be correct. */
 884           if (noside == EVAL_AVOID_SIDE_EFFECTS)
 885             {
 886               /* If the user attempts to subscript something that has no target
 887                  type (like a plain int variable for example), then report this
 888                  as an error. */
 889
 890               type = TYPE_TARGET_TYPE (VALUE_TYPE (arg1));
 891               if (type != NULL)
 892                 {
 893                   arg1 = value_zero (type, VALUE_LVAL (arg1));
 894                   noside = EVAL_SKIP;
 895                   continue;
 896                 }
 897               else
 898                 {
 899                   error ("cannot subscript something of type `%s'",
 900                          TYPE_NAME (VALUE_TYPE (arg1)));
 901                 }
 902             }
 903
 904           if (binop_user_defined_p (op, arg1, arg2))
 905             {
 906               arg1 = value_x_binop (arg1, arg2, op, OP_NULL);
 907             }
 908           else
 909             {
 910               arg1 = value_subscript (arg1, arg2);
 911             }
 912         }
 913       return (arg1);
 914
 915     case MULTI_F77_SUBSCRIPT:
 916       {
 917         int subscript_array[MAX_FORTRAN_DIMS+1]; /* 1-based array of
 918                                                     subscripts, max == 7 */
 919         int array_size_array[MAX_FORTRAN_DIMS+1];
 920         int ndimensions=1,i;
 921         struct type *tmp_type;
 922         int offset_item;   /* The array offset where the item lives */
 923         int fixed_subscript;
 924
 925         (*pos) += 2;
 926         nargs = longest_to_int (exp->elts[pc + 1].longconst);
 927
 928         if (nargs > MAX_FORTRAN_DIMS)
 929           error ("Too many subscripts for F77 (%d Max)", MAX_FORTRAN_DIMS);
 930
 931         arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
 932
 933         ndimensions = calc_f77_array_dims (VALUE_TYPE (arg1));
 934
 935         if (nargs != ndimensions)
 936           error ("Wrong number of subscripts");
 937
 938         /* Now that we know we have a legal array subscript expression
 939            let us actually find out where this element exists in the array. */
 940
 941         tmp_type = VALUE_TYPE (arg1);
 942         offset_item = 0;
 943         for (i = 1; i <= nargs; i++)
 944           {
 945             /* Evaluate each subscript, It must be a legal integer in F77 */
 946             arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
 947
 948             if (TYPE_CODE (VALUE_TYPE (arg2)) != TYPE_CODE_INT)
 949               error ("Array subscripts must be of type integer");
 950
 951             /* Fill in the subscript and array size arrays */
 952
 953             subscript_array[i] = (* (unsigned int *) VALUE_CONTENTS(arg2));
 954
 955             retcode = f77_get_dynamic_upperbound (tmp_type, &upper);
 956             if (retcode == BOUND_FETCH_ERROR)
 957               error ("Cannot obtain dynamic upper bound");
 958
 959             retcode = f77_get_dynamic_lowerbound (tmp_type, &lower);
 960             if (retcode == BOUND_FETCH_ERROR)
 961               error("Cannot obtain dynamic lower bound");
 962
 963             array_size_array[i] = upper - lower + 1;
 964
 965             /* Zero-normalize subscripts so that offsetting will work. */
 966
 967             subscript_array[i] -= lower;
 968
 969             /* If we are at the bottom of a multidimensional
 970                array type then keep a ptr to the last ARRAY
 971                type around for use when calling value_subscript()
 972                below. This is done because we pretend to value_subscript
 973                that we actually have a one-dimensional array
 974                of base element type that we apply a simple
 975                offset to. */
 976
 977             if (i < nargs)
 978               tmp_type = TYPE_TARGET_TYPE (tmp_type);
 979           }
 980
 981         /* Now let us calculate the offset for this item */
 982
 983         offset_item = subscript_array[ndimensions];
 984
 985         for (i = ndimensions - 1; i >= 1; i--)
 986           offset_item =
 987             array_size_array[i] * offset_item + subscript_array[i];
 988
 989         /* Construct a value node with the value of the offset */
 990
 991         arg2 = value_from_longest (builtin_type_f_integer, offset_item);
 992
 993         /* Let us now play a dirty trick: we will take arg1
 994            which is a value node pointing to the topmost level
 995            of the multidimensional array-set and pretend
 996            that it is actually a array of the final element
 997            type, this will ensure that value_subscript()
 998            returns the correct type value */
 999
1000         VALUE_TYPE (arg1) = tmp_type;
1001
1002         arg1 = value_subscript (arg1, arg2);
1003         return arg1;
1004       }
1005
1006     case BINOP_LOGICAL_AND:
1007       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
1008       if (noside == EVAL_SKIP)
1009         {
1010           arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
1011           goto nosideret;
1012         }
1013
1014       oldpos = *pos;
1015       arg2 = evaluate_subexp (NULL_TYPE, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
1016       *pos = oldpos;
1017
1018       if (binop_user_defined_p (op, arg1, arg2))
1019         {
1020           arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
1021           return value_x_binop (arg1, arg2, op, OP_NULL);
1022         }
1023       else
1024         {
1025           tem = value_logical_not (arg1);
1026           arg2 = evaluate_subexp (NULL_TYPE, exp, pos,
1027                                   (tem ? EVAL_SKIP : noside));
1028           return value_from_longest (builtin_type_int,
1029                                   (LONGEST) (!tem && !value_logical_not (arg2)));
1030         }
1031
1032     case BINOP_LOGICAL_OR:
1033       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
1034       if (noside == EVAL_SKIP)
1035         {
1036           arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
1037           goto nosideret;
1038         }
1039
1040       oldpos = *pos;
1041       arg2 = evaluate_subexp (NULL_TYPE, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
1042       *pos = oldpos;
1043
1044       if (binop_user_defined_p (op, arg1, arg2))
1045         {
1046           arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
1047           return value_x_binop (arg1, arg2, op, OP_NULL);
1048         }
1049       else
1050         {
1051           tem = value_logical_not (arg1);
1052           arg2 = evaluate_subexp (NULL_TYPE, exp, pos,
1053                                   (!tem ? EVAL_SKIP : noside));
1054           return value_from_longest (builtin_type_int,
1055                                   (LONGEST) (!tem || !value_logical_not (arg2)));
1056         }
1057
1058     case BINOP_EQUAL:
1059       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
1060       arg2 = evaluate_subexp (VALUE_TYPE (arg1), exp, pos, noside);
1061       if (noside == EVAL_SKIP)
1062         goto nosideret;
1063       if (binop_user_defined_p (op, arg1, arg2))
1064         {
1065           return value_x_binop (arg1, arg2, op, OP_NULL);
1066         }
1067       else
1068         {
1069           tem = value_equal (arg1, arg2);
1070           return value_from_longest (builtin_type_int, (LONGEST) tem);
1071         }
1072
1073     case BINOP_NOTEQUAL:
1074       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
1075       arg2 = evaluate_subexp (VALUE_TYPE (arg1), exp, pos, noside);
1076       if (noside == EVAL_SKIP)
1077         goto nosideret;
1078       if (binop_user_defined_p (op, arg1, arg2))
1079         {
1080           return value_x_binop (arg1, arg2, op, OP_NULL);
1081         }
1082       else
1083         {
1084           tem = value_equal (arg1, arg2);
1085           return value_from_longest (builtin_type_int, (LONGEST) ! tem);
1086         }
1087
1088     case BINOP_LESS:
1089       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
1090       arg2 = evaluate_subexp (VALUE_TYPE (arg1), exp, pos, noside);
1091       if (noside == EVAL_SKIP)
1092         goto nosideret;
1093       if (binop_user_defined_p (op, arg1, arg2))
1094         {
1095           return value_x_binop (arg1, arg2, op, OP_NULL);
1096         }
1097       else
1098         {
1099           tem = value_less (arg1, arg2);
1100           return value_from_longest (builtin_type_int, (LONGEST) tem);
1101         }
1102
1103     case BINOP_GTR:
1104       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
1105       arg2 = evaluate_subexp (VALUE_TYPE (arg1), exp, pos, noside);
1106       if (noside == EVAL_SKIP)
1107         goto nosideret;
1108       if (binop_user_defined_p (op, arg1, arg2))
1109         {
1110           return value_x_binop (arg1, arg2, op, OP_NULL);
1111         }
1112       else
1113         {
1114           tem = value_less (arg2, arg1);
1115           return value_from_longest (builtin_type_int, (LONGEST) tem);
1116         }
1117
1118     case BINOP_GEQ:
1119       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
1120       arg2 = evaluate_subexp (VALUE_TYPE (arg1), exp, pos, noside);
1121       if (noside == EVAL_SKIP)
1122         goto nosideret;
1123       if (binop_user_defined_p (op, arg1, arg2))
1124         {
1125           return value_x_binop (arg1, arg2, op, OP_NULL);
1126         }
1127       else
1128         {
1129           tem = value_less (arg2, arg1) || value_equal (arg1, arg2);
1130           return value_from_longest (builtin_type_int, (LONGEST) tem);
1131         }
1132
1133     case BINOP_LEQ:
1134       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
1135       arg2 = evaluate_subexp (VALUE_TYPE (arg1), exp, pos, noside);
1136       if (noside == EVAL_SKIP)
1137         goto nosideret;
1138       if (binop_user_defined_p (op, arg1, arg2))
1139         {
1140           return value_x_binop (arg1, arg2, op, OP_NULL);
1141         }
1142       else
1143         {
1144           tem = value_less (arg1, arg2) || value_equal (arg1, arg2);
1145           return value_from_longest (builtin_type_int, (LONGEST) tem);
1146         }
1147
1148     case BINOP_REPEAT:
1149       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
1150       arg2 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
1151       if (noside == EVAL_SKIP)
1152         goto nosideret;
1153       if (TYPE_CODE (VALUE_TYPE (arg2)) != TYPE_CODE_INT)
1154         error ("Non-integral right operand for \"@\" operator.");
1155       if (noside == EVAL_AVOID_SIDE_EFFECTS)
1156         return allocate_repeat_value (VALUE_TYPE (arg1),
1157                                       longest_to_int (value_as_long (arg2)));
1158       else
1159         return value_repeat (arg1, longest_to_int (value_as_long (arg2)));
1160
1161     case BINOP_COMMA:
1162       evaluate_subexp (NULL_TYPE, exp, pos, noside);
1163       return evaluate_subexp (NULL_TYPE, exp, pos, noside);
1164
1165     case UNOP_NEG:
1166       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
1167       if (noside == EVAL_SKIP)
1168         goto nosideret;
1169       if (unop_user_defined_p (op, arg1))
1170         return value_x_unop (arg1, op);
1171       else
1172         return value_neg (arg1);
1173
1174     case UNOP_COMPLEMENT:
1175       /* C++: check for and handle destructor names.  */
1176       op = exp->elts[*pos].opcode;
1177
1178       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
1179       if (noside == EVAL_SKIP)
1180         goto nosideret;
1181       if (unop_user_defined_p (UNOP_COMPLEMENT, arg1))
1182         return value_x_unop (arg1, UNOP_COMPLEMENT);
1183       else
1184         return value_complement (arg1);
1185
1186     case UNOP_LOGICAL_NOT:
1187       arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
1188       if (noside == EVAL_SKIP)
1189         goto nosideret;
1190       if (unop_user_defined_p (op, arg1))
1191         return value_x_unop (arg1, op);
1192       else
1193         return value_from_longest (builtin_type_int,
1194                                    (LONGEST) value_logical_not (arg1));
1195
1196     case UNOP_IND:
1197       if (expect_type && TYPE_CODE (expect_type) == TYPE_CODE_PTR)
1198         expect_type = TYPE_TARGET_TYPE (expect_type);
1199       arg1 = evaluate_subexp (expect_type, exp, pos, noside);
1200       if (noside == EVAL_SKIP)
1201         goto nosideret;
1202       if (noside == EVAL_AVOID_SIDE_EFFECTS)
1203         {
1204           if (TYPE_CODE (VALUE_TYPE (arg1)) == TYPE_CODE_PTR
1205               || TYPE_CODE (VALUE_TYPE (arg1)) == TYPE_CODE_REF
1206               /* In C you can dereference an array to get the 1st elt.  */
1207               || TYPE_CODE (VALUE_TYPE (arg1)) == TYPE_CODE_ARRAY
1208               )
1209             return value_zero (TYPE_TARGET_TYPE (VALUE_TYPE (arg1)),
1210                                lval_memory);
1211           else if (TYPE_CODE (VALUE_TYPE (arg1)) == TYPE_CODE_INT)
1212             /* GDB allows dereferencing an int.  */
1213             return value_zero (builtin_type_int, lval_memory);
1214           else
1215             error ("Attempt to take contents of a non-pointer value.");
1216         }
1217       return value_ind (arg1);
1218
1219     case UNOP_ADDR:
1220       /* C++: check for and handle pointer to members.  */
1221
1222       op = exp->elts[*pos].opcode;
1223
1224       if (noside == EVAL_SKIP)
1225         {
1226           if (op == OP_SCOPE)
1227             {
1228               int temm = longest_to_int (exp->elts[pc+3].longconst);
1229               (*pos) += 3 + BYTES_TO_EXP_ELEM (temm + 1);
1230             }
1231           else
1232             evaluate_subexp (expect_type, exp, pos, EVAL_SKIP);
1233           goto nosideret;
1234         }
1235
1236       return evaluate_subexp_for_address (exp, pos, noside);
1237
1238     case UNOP_SIZEOF:
1239       if (noside == EVAL_SKIP)
1240         {
1241           evaluate_subexp (NULL_TYPE, exp, pos, EVAL_SKIP);
1242           goto nosideret;
1243         }
1244       return evaluate_subexp_for_sizeof (exp, pos);
1245
1246     case UNOP_CAST:
1247       (*pos) += 2;
1248       type = exp->elts[pc + 1].type;
1249       arg1 = evaluate_subexp (type, exp, pos, noside);
1250       if (noside == EVAL_SKIP)
1251         goto nosideret;
1252       if (type != VALUE_TYPE (arg1))
1253         arg1 = value_cast (type, arg1);
1254       return arg1;
1255
1256     case UNOP_MEMVAL:
1257       (*pos) += 2;
1258       arg1 = evaluate_subexp (expect_type, exp, pos, noside);
1259       if (noside == EVAL_SKIP)
1260         goto nosideret;
1261       if (noside == EVAL_AVOID_SIDE_EFFECTS)
1262         return value_zero (exp->elts[pc + 1].type, lval_memory);
1263       else
1264         return value_at_lazy (exp->elts[pc + 1].type,
1265                               value_as_pointer (arg1));
1266
1267     case UNOP_PREINCREMENT:
1268       arg1 = evaluate_subexp (expect_type, exp, pos, noside);
1269       if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
1270         return arg1;
1271       else if (unop_user_defined_p (op, arg1))
1272         {
1273           return value_x_unop (arg1, op);
1274         }
1275       else
1276         {
1277           arg2 = value_add (arg1, value_from_longest (builtin_type_char,
1278                                                    (LONGEST) 1));
1279           return value_assign (arg1, arg2);
1280         }
1281
1282     case UNOP_PREDECREMENT:
1283       arg1 = evaluate_subexp (expect_type, exp, pos, noside);
1284       if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
1285         return arg1;
1286       else if (unop_user_defined_p (op, arg1))
1287         {
1288           return value_x_unop (arg1, op);
1289         }
1290       else
1291         {
1292           arg2 = value_sub (arg1, value_from_longest (builtin_type_char,
1293                                                    (LONGEST) 1));
1294           return value_assign (arg1, arg2);
1295         }
1296
1297     case UNOP_POSTINCREMENT:
1298       arg1 = evaluate_subexp (expect_type, exp, pos, noside);
1299       if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
1300         return arg1;
1301       else if (unop_user_defined_p (op, arg1))
1302         {
1303           return value_x_unop (arg1, op);
1304         }
1305       else
1306         {
1307           arg2 = value_add (arg1, value_from_longest (builtin_type_char,
1308                                                    (LONGEST) 1));
1309           value_assign (arg1, arg2);
1310           return arg1;
1311         }
1312
1313     case UNOP_POSTDECREMENT:
1314       arg1 = evaluate_subexp (expect_type, exp, pos, noside);
1315       if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
1316         return arg1;
1317       else if (unop_user_defined_p (op, arg1))
1318         {
1319           return value_x_unop (arg1, op);
1320         }
1321       else
1322         {
1323           arg2 = value_sub (arg1, value_from_longest (builtin_type_char,
1324                                                    (LONGEST) 1));
1325           value_assign (arg1, arg2);
1326           return arg1;
1327         }
1328
1329     case OP_THIS:
1330       (*pos) += 1;
1331       return value_of_this (1);
1332
1333     case OP_TYPE:
1334       error ("Attempt to use a type name as an expression");
1335
1336     default:
1337       /* Removing this case and compiling with gcc -Wall reveals that
1338          a lot of cases are hitting this case.  Some of these should
1339          probably be removed from expression.h (e.g. do we need a BINOP_SCOPE
1340          and an OP_SCOPE?); others are legitimate expressions which are
1341          (apparently) not fully implemented.
1342
1343          If there are any cases landing here which mean a user error,
1344          then they should be separate cases, with more descriptive
1345          error messages.  */
1346
1347       error ("\
1348 GDB does not (yet) know how to evaluate that kind of expression");
1349     }
1350
1351  nosideret:
1352   return value_from_longest (builtin_type_long, (LONGEST) 1);
1353 }
1354 \f
1355 /* Evaluate a subexpression of EXP, at index *POS,
1356    and return the address of that subexpression.
1357    Advance *POS over the subexpression.
1358    If the subexpression isn't an lvalue, get an error.
1359    NOSIDE may be EVAL_AVOID_SIDE_EFFECTS;
1360    then only the type of the result need be correct.  */
1361
1362 static value_ptr
1363 evaluate_subexp_for_address (exp, pos, noside)
1364      register struct expression *exp;
1365      register int *pos;
1366      enum noside noside;
1367 {
1368   enum exp_opcode op;
1369   register int pc;
1370   struct symbol *var;
1371
1372   pc = (*pos);
1373   op = exp->elts[pc].opcode;
1374
1375   switch (op)
1376     {
1377     case UNOP_IND:
1378       (*pos)++;
1379       return evaluate_subexp (NULL_TYPE, exp, pos, noside);
1380
1381     case UNOP_MEMVAL:
1382       (*pos) += 3;
1383       return value_cast (lookup_pointer_type (exp->elts[pc + 1].type),
1384                          evaluate_subexp (NULL_TYPE, exp, pos, noside));
1385
1386     case OP_VAR_VALUE:
1387       var = exp->elts[pc + 2].symbol;
1388
1389       /* C++: The "address" of a reference should yield the address
1390        * of the object pointed to. Let value_addr() deal with it. */
1391       if (TYPE_CODE (SYMBOL_TYPE (var)) == TYPE_CODE_REF)
1392         goto default_case;
1393
1394       (*pos) += 4;
1395       if (noside == EVAL_AVOID_SIDE_EFFECTS)
1396         {
1397           struct type *type =
1398             lookup_pointer_type (SYMBOL_TYPE (var));
1399           enum address_class sym_class = SYMBOL_CLASS (var);
1400
1401           if (sym_class == LOC_CONST
1402               || sym_class == LOC_CONST_BYTES
1403               || sym_class == LOC_REGISTER
1404               || sym_class == LOC_REGPARM)
1405             error ("Attempt to take address of register or constant.");
1406
1407         return
1408           value_zero (type, not_lval);
1409         }
1410       else
1411         return
1412           locate_var_value
1413             (var,
1414              block_innermost_frame (exp->elts[pc + 1].block));
1415
1416     default:
1417     default_case:
1418       if (noside == EVAL_AVOID_SIDE_EFFECTS)
1419         {
1420           value_ptr x = evaluate_subexp (NULL_TYPE, exp, pos, noside);
1421           if (VALUE_LVAL (x) == lval_memory)
1422             return value_zero (lookup_pointer_type (VALUE_TYPE (x)),
1423                                not_lval);
1424           else
1425             error ("Attempt to take address of non-lval");
1426         }
1427       return value_addr (evaluate_subexp (NULL_TYPE, exp, pos, noside));
1428     }
1429 }
1430
1431 /* Evaluate like `evaluate_subexp' except coercing arrays to pointers.
1432    When used in contexts where arrays will be coerced anyway, this is
1433    equivalent to `evaluate_subexp' but much faster because it avoids
1434    actually fetching array contents (perhaps obsolete now that we have
1435    VALUE_LAZY).
1436
1437    Note that we currently only do the coercion for C expressions, where
1438    arrays are zero based and the coercion is correct.  For other languages,
1439    with nonzero based arrays, coercion loses.  Use CAST_IS_CONVERSION
1440    to decide if coercion is appropriate.
1441
1442    */
1443
1444 static value_ptr
1445 evaluate_subexp_with_coercion (exp, pos, noside)
1446      register struct expression *exp;
1447      register int *pos;
1448      enum noside noside;
1449 {
1450   register enum exp_opcode op;
1451   register int pc;
1452   register value_ptr val;
1453   struct symbol *var;
1454
1455   pc = (*pos);
1456   op = exp->elts[pc].opcode;
1457
1458   switch (op)
1459     {
1460     case OP_VAR_VALUE:
1461       var = exp->elts[pc + 2].symbol;
1462       if (TYPE_CODE (SYMBOL_TYPE (var)) == TYPE_CODE_ARRAY
1463           && CAST_IS_CONVERSION)
1464         {
1465           (*pos) += 4;
1466           val =
1467             locate_var_value
1468               (var, block_innermost_frame (exp->elts[pc + 1].block));
1469           return value_cast (lookup_pointer_type (TYPE_TARGET_TYPE (SYMBOL_TYPE (var))),
1470                              val);
1471         }
1472       /* FALLTHROUGH */
1473
1474     default:
1475       return evaluate_subexp (NULL_TYPE, exp, pos, noside);
1476     }
1477 }
1478
1479 /* Evaluate a subexpression of EXP, at index *POS,
1480    and return a value for the size of that subexpression.
1481    Advance *POS over the subexpression.  */
1482
1483 static value_ptr
1484 evaluate_subexp_for_sizeof (exp, pos)
1485      register struct expression *exp;
1486      register int *pos;
1487 {
1488   enum exp_opcode op;
1489   register int pc;
1490   value_ptr val;
1491
1492   pc = (*pos);
1493   op = exp->elts[pc].opcode;
1494
1495   switch (op)
1496     {
1497       /* This case is handled specially
1498          so that we avoid creating a value for the result type.
1499          If the result type is very big, it's desirable not to
1500          create a value unnecessarily.  */
1501     case UNOP_IND:
1502       (*pos)++;
1503       val = evaluate_subexp (NULL_TYPE, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
1504       return value_from_longest (builtin_type_int, (LONGEST)
1505                       TYPE_LENGTH (TYPE_TARGET_TYPE (VALUE_TYPE (val))));
1506
1507     case UNOP_MEMVAL:
1508       (*pos) += 3;
1509       return value_from_longest (builtin_type_int,
1510                               (LONGEST) TYPE_LENGTH (exp->elts[pc + 1].type));
1511
1512     case OP_VAR_VALUE:
1513       (*pos) += 4;
1514       return
1515         value_from_longest
1516           (builtin_type_int,
1517            (LONGEST) TYPE_LENGTH (SYMBOL_TYPE (exp->elts[pc + 2].symbol)));
1518
1519     default:
1520       val = evaluate_subexp (NULL_TYPE, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
1521       return value_from_longest (builtin_type_int,
1522                               (LONGEST) TYPE_LENGTH (VALUE_TYPE (val)));
1523     }
1524 }
1525
1526 /* Parse a type expression in the string [P..P+LENGTH). */
1527
1528 struct type *
1529 parse_and_eval_type (p, length)
1530      char *p;
1531      int length;
1532 {
1533     char *tmp = (char *)alloca (length + 4);
1534     struct expression *expr;
1535     tmp[0] = '(';
1536     memcpy (tmp+1, p, length);
1537     tmp[length+1] = ')';
1538     tmp[length+2] = '0';
1539     tmp[length+3] = '\0';
1540     expr = parse_expression (tmp);
1541     if (expr->elts[0].opcode != UNOP_CAST)
1542         error ("Internal error in eval_type.");
1543     return expr->elts[1].type;
1544 }
1545
1546 int
1547 calc_f77_array_dims (array_type)
1548      struct type *array_type;
1549 {
1550   int ndimen = 1;
1551   struct type *tmp_type;
1552
1553   if ((TYPE_CODE(array_type) != TYPE_CODE_ARRAY))
1554     error ("Can't get dimensions for a non-array type");
1555
1556   tmp_type = array_type;
1557
1558   while (tmp_type = TYPE_TARGET_TYPE (tmp_type))
1559     {
1560       if (TYPE_CODE (tmp_type) == TYPE_CODE_ARRAY)
1561         ++ndimen;
1562     }
1563   return ndimen;
1564 }