gdb/eval.c

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