gdb/ch-exp.c

   1 /* Parser for GNU CHILL (CCITT High-Level Language)  -*- C -*-
   2    Copyright (C) 1992, 1993, 1995 Free Software Foundation, Inc.
   3
   4 This file is part of GDB.
   5
   6 This program is free software; you can redistribute it and/or modify
   7 it under the terms of the GNU General Public License as published by
   8 the Free Software Foundation; either version 2 of the License, or
   9 (at your option) any later version.
  10
  11 This program is distributed in the hope that it will be useful,
  12 but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 GNU General Public License for more details.
  15
  16 You should have received a copy of the GNU General Public License
  17 along with this program; if not, write to the Free Software
  18 Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.  */
  19
  20 /* Parse a Chill expression from text in a string,
  21    and return the result as a  struct expression  pointer.
  22    That structure contains arithmetic operations in reverse polish,
  23    with constants represented by operations that are followed by special data.
  24    See expression.h for the details of the format.
  25    What is important here is that it can be built up sequentially
  26    during the process of parsing; the lower levels of the tree always
  27    come first in the result.
  28
  29    Note that the language accepted by this parser is more liberal
  30    than the one accepted by an actual Chill compiler.  For example, the
  31    language rule that a simple name string can not be one of the reserved
  32    simple name strings is not enforced (e.g "case" is not treated as a
  33    reserved name).  Another example is that Chill is a strongly typed
  34    language, and certain expressions that violate the type constraints
  35    may still be evaluated if gdb can do so in a meaningful manner, while
  36    such expressions would be rejected by the compiler.  The reason for
  37    this more liberal behavior is the philosophy that the debugger
  38    is intended to be a tool that is used by the programmer when things
  39    go wrong, and as such, it should provide as few artificial barriers
  40    to it's use as possible.  If it can do something meaningful, even
  41    something that violates language contraints that are enforced by the
  42    compiler, it should do so without complaint.
  43
  44  */
  45
  46 #include "defs.h"
  47 #include "gdb_string.h"
  48 #include <ctype.h>
  49 #include "expression.h"
  50 #include "language.h"
  51 #include "value.h"
  52 #include "parser-defs.h"
  53 #include "ch-lang.h"
  54 #include "bfd.h" /* Required by objfiles.h.  */
  55 #include "symfile.h" /* Required by objfiles.h.  */
  56 #include "objfiles.h" /* For have_full_symbols and have_partial_symbols */
  57
  58 typedef union
  59
  60   {
  61     LONGEST lval;
  62     unsigned LONGEST ulval;
  63     struct {
  64       LONGEST val;
  65       struct type *type;
  66     } typed_val;
  67     double dval;
  68     struct symbol *sym;
  69     struct type *tval;
  70     struct stoken sval;
  71     struct ttype tsym;
  72     struct symtoken ssym;
  73   }YYSTYPE;
  74
  75 enum ch_terminal {
  76   END_TOKEN = 0,
  77   /* '\001' ... '\xff' come first. */
  78   OPEN_PAREN = '(',
  79   TOKEN_NOT_READ = 999,
  80   INTEGER_LITERAL,
  81   BOOLEAN_LITERAL,
  82   CHARACTER_LITERAL,
  83   FLOAT_LITERAL,
  84   GENERAL_PROCEDURE_NAME,
  85   LOCATION_NAME,
  86   EMPTINESS_LITERAL,
  87   CHARACTER_STRING_LITERAL,
  88   BIT_STRING_LITERAL,
  89   TYPENAME,
  90   FIELD_NAME,
  91   CASE,
  92   OF,
  93   ESAC,
  94   LOGIOR,
  95   ORIF,
  96   LOGXOR,
  97   LOGAND,
  98   ANDIF,
  99   NOTEQUAL,
 100   GEQ,
 101   LEQ,
 102   IN,
 103   SLASH_SLASH,
 104   MOD,
 105   REM,
 106   NOT,
 107   POINTER,
 108   RECEIVE,
 109   UP,
 110   IF,
 111   THEN,
 112   ELSE,
 113   FI,
 114   ELSIF,
 115   ILLEGAL_TOKEN,
 116   NUM,
 117   PRED,
 118   SUCC,
 119   ABS,
 120   CARD,
 121   MAX_TOKEN,
 122   MIN_TOKEN,
 123   ADDR_TOKEN,
 124   SIZE,
 125   UPPER,
 126   LOWER,
 127   LENGTH,
 128   ARRAY,
 129   GDB_VARIABLE,
 130   GDB_ASSIGNMENT
 131 };
 132
 133 /* Forward declarations. */
 134 static void parse_expr ();
 135 static void parse_primval ();
 136 static void parse_untyped_expr ();
 137 static int parse_opt_untyped_expr ();
 138 static void parse_if_expression_body PARAMS((void));
 139 static void write_lower_upper_value PARAMS ((enum exp_opcode, struct type *));
 140 static enum ch_terminal ch_lex ();
 141 static void calculate_array_length (struct type *);
 142
 143 #define MAX_LOOK_AHEAD 2
 144 static enum ch_terminal terminal_buffer[MAX_LOOK_AHEAD+1] = {
 145   TOKEN_NOT_READ, TOKEN_NOT_READ, TOKEN_NOT_READ};
 146 static YYSTYPE yylval;
 147 static YYSTYPE val_buffer[MAX_LOOK_AHEAD+1];
 148
 149 /*int current_token, lookahead_token;*/
 150
 151 #ifdef __GNUC__
 152 __inline__
 153 #endif
 154 static enum ch_terminal
 155 PEEK_TOKEN()
 156 {
 157   if (terminal_buffer[0] == TOKEN_NOT_READ)
 158     {
 159       terminal_buffer[0] = ch_lex ();
 160       val_buffer[0] = yylval;
 161     }
 162   return terminal_buffer[0];
 163 }
 164 #define PEEK_LVAL() val_buffer[0]
 165 #define PEEK_TOKEN1() peek_token_(1)
 166 #define PEEK_TOKEN2() peek_token_(2)
 167 static enum ch_terminal
 168 peek_token_ (i)
 169      int i;
 170 {
 171   if (i > MAX_LOOK_AHEAD)
 172     fatal ("internal error - too much lookahead");
 173   if (terminal_buffer[i] == TOKEN_NOT_READ)
 174     {
 175       terminal_buffer[i] = ch_lex ();
 176       val_buffer[i] = yylval;
 177     }
 178   return terminal_buffer[i];
 179 }
 180
 181 #if 0
 182
 183 static void
 184 pushback_token (code, node)
 185      enum ch_terminal code;
 186      YYSTYPE node;
 187 {
 188   int i;
 189   if (terminal_buffer[MAX_LOOK_AHEAD] != TOKEN_NOT_READ)
 190     fatal ("internal error - cannot pushback token");
 191   for (i = MAX_LOOK_AHEAD; i > 0; i--)
 192     {
 193       terminal_buffer[i] = terminal_buffer[i - 1];
 194       val_buffer[i] = val_buffer[i - 1];
 195   }
 196   terminal_buffer[0] = code;
 197   val_buffer[0] = node;
 198 }
 199
 200 #endif
 201
 202 static void
 203 forward_token_()
 204 {
 205   int i;
 206   for (i = 0; i < MAX_LOOK_AHEAD; i++)
 207     {
 208       terminal_buffer[i] = terminal_buffer[i+1];
 209       val_buffer[i] = val_buffer[i+1];
 210     }
 211   terminal_buffer[MAX_LOOK_AHEAD] = TOKEN_NOT_READ;
 212 }
 213 #define FORWARD_TOKEN() forward_token_()
 214
 215 /* Skip the next token.
 216    if it isn't TOKEN, the parser is broken. */
 217
 218 void
 219 require(token)
 220      enum ch_terminal token;
 221 {
 222   if (PEEK_TOKEN() != token)
 223     {
 224       char buf[80];
 225       sprintf (buf, "internal parser error - expected token %d", (int)token);
 226       fatal(buf);
 227     }
 228   FORWARD_TOKEN();
 229 }
 230
 231 int
 232 check_token (token)
 233      enum ch_terminal token;
 234 {
 235   if (PEEK_TOKEN() != token)
 236     return 0;
 237   FORWARD_TOKEN ();
 238   return 1;
 239 }
 240
 241 /* return 0 if expected token was not found,
 242    else return 1.
 243 */
 244 int
 245 expect(token, message)
 246      enum ch_terminal token;
 247      char *message;
 248 {
 249   if (PEEK_TOKEN() != token)
 250     {
 251       if (message)
 252         error (message);
 253       else if (token < 256)
 254         error ("syntax error - expected a '%c' here \"%s\"", token, lexptr);
 255       else
 256         error ("syntax error");
 257       return 0;
 258     }
 259   else
 260     FORWARD_TOKEN();
 261   return 1;
 262 }
 263
 264 #if 0
 265 static tree
 266 parse_opt_name_string (allow_all)
 267      int allow_all; /* 1 if ALL is allowed as a postfix */
 268 {
 269   int token = PEEK_TOKEN();
 270   tree name;
 271   if (token != NAME)
 272     {
 273       if (token == ALL && allow_all)
 274         {
 275           FORWARD_TOKEN ();
 276           return ALL_POSTFIX;
 277         }
 278       return NULL_TREE;
 279     }
 280   name = PEEK_LVAL();
 281   for (;;)
 282     {
 283       FORWARD_TOKEN ();
 284       token = PEEK_TOKEN();
 285       if (token != '!')
 286         return name;
 287       FORWARD_TOKEN();
 288       token = PEEK_TOKEN();
 289       if (token == ALL && allow_all)
 290         return get_identifier3(IDENTIFIER_POINTER (name), "!", "*");
 291       if (token != NAME)
 292         {
 293           if (pass == 1)
 294             error ("'%s!' is not followed by an identifier",
 295                    IDENTIFIER_POINTER (name));
 296           return name;
 297         }
 298       name = get_identifier3(IDENTIFIER_POINTER(name),
 299                              "!", IDENTIFIER_POINTER(PEEK_LVAL()));
 300     }
 301 }
 302
 303 static tree
 304 parse_simple_name_string ()
 305 {
 306   int token = PEEK_TOKEN();
 307   tree name;
 308   if (token != NAME)
 309     {
 310       error ("expected a name here");
 311       return error_mark_node;
 312     }
 313   name = PEEK_LVAL ();
 314   FORWARD_TOKEN ();
 315   return name;
 316 }
 317
 318 static tree
 319 parse_name_string ()
 320 {
 321   tree name = parse_opt_name_string (0);
 322   if (name)
 323     return name;
 324   if (pass == 1)
 325     error ("expected a name string here");
 326   return error_mark_node;
 327 }
 328
 329 /* Matches: <name_string>
 330    Returns if pass 1: the identifier.
 331    Returns if pass 2: a decl or value for identifier. */
 332
 333 static tree
 334 parse_name ()
 335 {
 336   tree name = parse_name_string ();
 337   if (pass == 1 || ignoring)
 338     return name;
 339   else
 340     {
 341       tree decl = lookup_name (name);
 342       if (decl == NULL_TREE)
 343         {
 344           error ("`%s' undeclared", IDENTIFIER_POINTER (name));
 345           return error_mark_node;
 346         }
 347       else if (TREE_CODE (TREE_TYPE (decl)) == ERROR_MARK)
 348         return error_mark_node;
 349       else if (TREE_CODE (decl) == CONST_DECL)
 350         return DECL_INITIAL (decl);
 351       else if (TREE_CODE (TREE_TYPE (decl)) == REFERENCE_TYPE)
 352         return convert_from_reference (decl);
 353       else
 354         return decl;
 355     }
 356 }
 357 #endif
 358
 359 #if 0
 360 static void
 361 pushback_paren_expr (expr)
 362      tree expr;
 363 {
 364   if (pass == 1 && !ignoring)
 365     expr = build1 (PAREN_EXPR, NULL_TREE, expr);
 366   pushback_token (EXPR, expr);
 367 }
 368 #endif
 369
 370 /* Matches: <case label> */
 371
 372 static void
 373 parse_case_label ()
 374 {
 375   if (check_token (ELSE))
 376     error ("ELSE in tuples labels not implemented");
 377   /* Does not handle the case of a mode name.  FIXME */
 378   parse_expr ();
 379   if (check_token (':'))
 380     {
 381       parse_expr ();
 382       write_exp_elt_opcode (BINOP_RANGE);
 383     }
 384 }
 385
 386 static int
 387 parse_opt_untyped_expr ()
 388 {
 389   switch (PEEK_TOKEN ())
 390     {
 391     case ',':
 392     case ':':
 393     case ')':
 394       return 0;
 395     default:
 396       parse_untyped_expr ();
 397       return 1;
 398     }
 399 }
 400
 401 static void
 402 parse_unary_call ()
 403 {
 404   FORWARD_TOKEN ();
 405   expect ('(', NULL);
 406   parse_expr ();
 407   expect (')', NULL);
 408 }
 409
 410 /* Parse NAME '(' MODENAME ')'. */
 411
 412 struct type *
 413 parse_mode_call ()
 414 {
 415   struct type *type;
 416   FORWARD_TOKEN ();
 417   expect ('(', NULL);
 418   if (PEEK_TOKEN () != TYPENAME)
 419     error ("expect MODENAME here `%s'", lexptr);
 420   type = PEEK_LVAL().tsym.type;
 421   FORWARD_TOKEN ();
 422   expect (')', NULL);
 423   return type;
 424 }
 425
 426 struct type *
 427 parse_mode_or_normal_call ()
 428 {
 429   struct type *type;
 430   FORWARD_TOKEN ();
 431   expect ('(', NULL);
 432   if (PEEK_TOKEN () == TYPENAME)
 433     {
 434       type = PEEK_LVAL().tsym.type;
 435       FORWARD_TOKEN ();
 436     }
 437   else
 438     {
 439       parse_expr ();
 440       type = NULL;
 441     }
 442   expect (')', NULL);
 443   return type;
 444 }
 445
 446 /* Parse something that looks like a function call.
 447    Assume we have parsed the function, and are at the '('. */
 448
 449 static void
 450 parse_call ()
 451 {
 452   int arg_count;
 453   require ('(');
 454   /* This is to save the value of arglist_len
 455      being accumulated for each dimension. */
 456   start_arglist ();
 457   if (parse_opt_untyped_expr ())
 458     {
 459       int tok = PEEK_TOKEN ();
 460       arglist_len = 1;
 461       if (tok == UP || tok == ':')
 462         {
 463           FORWARD_TOKEN ();
 464           parse_expr ();
 465           expect (')', "expected ')' to terminate slice");
 466           end_arglist ();
 467           write_exp_elt_opcode (tok == UP ? TERNOP_SLICE_COUNT
 468                                 : TERNOP_SLICE);
 469           return;
 470         }
 471       while (check_token (','))
 472         {
 473           parse_untyped_expr ();
 474           arglist_len++;
 475         }
 476     }
 477   else
 478     arglist_len = 0;
 479   expect (')', NULL);
 480   arg_count = end_arglist ();
 481   write_exp_elt_opcode (MULTI_SUBSCRIPT);
 482   write_exp_elt_longcst (arg_count);
 483   write_exp_elt_opcode (MULTI_SUBSCRIPT);
 484 }
 485
 486 static void
 487 parse_named_record_element ()
 488 {
 489   struct stoken label;
 490
 491   label = PEEK_LVAL ().sval;
 492   expect (FIELD_NAME, "expected a field name here `%s'", lexptr);
 493   if (check_token (','))
 494     parse_named_record_element ();
 495   else if (check_token (':'))
 496     parse_expr ();
 497   else
 498     error ("syntax error near `%s' in named record tuple element", lexptr);
 499   write_exp_elt_opcode (OP_LABELED);
 500   write_exp_string (label);
 501   write_exp_elt_opcode (OP_LABELED);
 502 }
 503
 504 /* Returns one or nore TREE_LIST nodes, in reverse order. */
 505
 506 static void
 507 parse_tuple_element ()
 508 {
 509   if (PEEK_TOKEN () == FIELD_NAME)
 510     {
 511       /* Parse a labelled structure tuple. */
 512       parse_named_record_element ();
 513       return;
 514     }
 515
 516   if (check_token ('('))
 517     {
 518       if (check_token ('*'))
 519         {
 520           expect (')', "missing ')' after '*' case label list");
 521           error ("(*) not implemented in case label list");
 522         }
 523       else
 524         {
 525           parse_case_label ();
 526           while (check_token (','))
 527             {
 528               parse_case_label ();
 529               write_exp_elt_opcode (BINOP_COMMA);
 530             }
 531           expect (')', NULL);
 532         }
 533     }
 534   else
 535     parse_untyped_expr ();
 536   if (check_token (':'))
 537     {
 538       /* A powerset range or a labeled Array. */
 539       parse_untyped_expr ();
 540       write_exp_elt_opcode (BINOP_RANGE);
 541     }
 542 }
 543
 544 /* Matches:  a COMMA-separated list of tuple elements.
 545    Returns a list (of TREE_LIST nodes). */
 546 static void
 547 parse_opt_element_list ()
 548 {
 549   arglist_len = 0;
 550   if (PEEK_TOKEN () == ']')
 551     return;
 552   for (;;)
 553     {
 554       parse_tuple_element ();
 555       arglist_len++;
 556       if (PEEK_TOKEN () == ']')
 557         break;
 558       if (!check_token (','))
 559         error ("bad syntax in tuple");
 560     }
 561 }
 562
 563 /* Parses: '[' elements ']'
 564    If modename is non-NULL it prefixed the tuple.  */
 565
 566 static void
 567 parse_tuple (mode)
 568      struct type *mode;
 569 {
 570   require ('[');
 571   start_arglist ();
 572   parse_opt_element_list ();
 573   expect (']', "missing ']' after tuple");
 574   write_exp_elt_opcode (OP_ARRAY);
 575   write_exp_elt_longcst ((LONGEST) 0);
 576   write_exp_elt_longcst ((LONGEST) end_arglist () - 1);
 577   write_exp_elt_opcode (OP_ARRAY);
 578   if (mode)
 579     {
 580       struct type *type = check_typedef (mode);
 581       if (TYPE_CODE (type) != TYPE_CODE_ARRAY
 582           && TYPE_CODE (type) != TYPE_CODE_STRUCT
 583           && TYPE_CODE (type) != TYPE_CODE_SET)
 584         error ("invalid tuple mode");
 585       write_exp_elt_opcode (UNOP_CAST);
 586       write_exp_elt_type (mode);
 587       write_exp_elt_opcode (UNOP_CAST);
 588     }
 589 }
 590
 591 static void
 592 parse_primval ()
 593 {
 594   struct type *type;
 595   enum exp_opcode op;
 596   char *op_name;
 597   switch (PEEK_TOKEN ())
 598     {
 599     case INTEGER_LITERAL:
 600     case CHARACTER_LITERAL:
 601       write_exp_elt_opcode (OP_LONG);
 602       write_exp_elt_type (PEEK_LVAL ().typed_val.type);
 603       write_exp_elt_longcst (PEEK_LVAL ().typed_val.val);
 604       write_exp_elt_opcode (OP_LONG);
 605       FORWARD_TOKEN ();
 606       break;
 607     case BOOLEAN_LITERAL:
 608       write_exp_elt_opcode (OP_BOOL);
 609       write_exp_elt_longcst ((LONGEST) PEEK_LVAL ().ulval);
 610       write_exp_elt_opcode (OP_BOOL);
 611       FORWARD_TOKEN ();
 612       break;
 613     case FLOAT_LITERAL:
 614       write_exp_elt_opcode (OP_DOUBLE);
 615       write_exp_elt_type (builtin_type_double);
 616       write_exp_elt_dblcst (PEEK_LVAL ().dval);
 617       write_exp_elt_opcode (OP_DOUBLE);
 618       FORWARD_TOKEN ();
 619       break;
 620     case EMPTINESS_LITERAL:
 621       write_exp_elt_opcode (OP_LONG);
 622       write_exp_elt_type (lookup_pointer_type (builtin_type_void));
 623       write_exp_elt_longcst (0);
 624       write_exp_elt_opcode (OP_LONG);
 625       FORWARD_TOKEN ();
 626       break;
 627     case CHARACTER_STRING_LITERAL:
 628       write_exp_elt_opcode (OP_STRING);
 629       write_exp_string (PEEK_LVAL ().sval);
 630       write_exp_elt_opcode (OP_STRING);
 631       FORWARD_TOKEN ();
 632       break;
 633     case BIT_STRING_LITERAL:
 634       write_exp_elt_opcode (OP_BITSTRING);
 635       write_exp_bitstring (PEEK_LVAL ().sval);
 636       write_exp_elt_opcode (OP_BITSTRING);
 637       FORWARD_TOKEN ();
 638       break;
 639     case ARRAY:
 640       FORWARD_TOKEN ();
 641       /* This is pseudo-Chill, similar to C's '(TYPE[])EXPR'
 642          which casts to an artificial array. */
 643       expect ('(', NULL);
 644       expect (')', NULL);
 645       if (PEEK_TOKEN () != TYPENAME)
 646         error ("missing MODENAME after ARRAY()");
 647       type = PEEK_LVAL().tsym.type;
 648       FORWARD_TOKEN ();
 649       expect ('(', NULL);
 650       parse_expr ();
 651       expect (')', "missing right parenthesis");
 652       type = create_array_type ((struct type *) NULL, type,
 653                                 create_range_type ((struct type *) NULL,
 654                                                    builtin_type_int, 0, 0));
 655       TYPE_ARRAY_UPPER_BOUND_TYPE(type) = BOUND_CANNOT_BE_DETERMINED;
 656       write_exp_elt_opcode (UNOP_CAST);
 657       write_exp_elt_type (type);
 658       write_exp_elt_opcode (UNOP_CAST);
 659       break;
 660 #if 0
 661     case CONST:
 662     case EXPR:
 663       val = PEEK_LVAL();
 664       FORWARD_TOKEN ();
 665       break;
 666 #endif
 667     case '(':
 668       FORWARD_TOKEN ();
 669       parse_expr ();
 670       expect (')', "missing right parenthesis");
 671       break;
 672     case '[':
 673       parse_tuple (NULL);
 674       break;
 675     case GENERAL_PROCEDURE_NAME:
 676     case LOCATION_NAME:
 677       {
 678         struct type *type;
 679
 680         /* FIXME: look at calculate_array_length */
 681         type = PEEK_LVAL().ssym.sym->type;
 682         if (type && TYPE_CODE (type) == TYPE_CODE_ARRAY &&
 683             TYPE_LENGTH (type) == 0)
 684           calculate_array_length (type);
 685         write_exp_elt_opcode (OP_VAR_VALUE);
 686         write_exp_elt_block (NULL);
 687         write_exp_elt_sym (PEEK_LVAL ().ssym.sym);
 688         write_exp_elt_opcode (OP_VAR_VALUE);
 689         FORWARD_TOKEN ();
 690       }
 691       break;
 692     case GDB_VARIABLE:  /* gdb specific */
 693       FORWARD_TOKEN ();
 694       break;
 695     case NUM:
 696       parse_unary_call ();
 697       write_exp_elt_opcode (UNOP_CAST);
 698       write_exp_elt_type (builtin_type_int);
 699       write_exp_elt_opcode (UNOP_CAST);
 700       break;
 701     case CARD:
 702       parse_unary_call ();
 703       write_exp_elt_opcode (UNOP_CARD);
 704       break;
 705     case MAX_TOKEN:
 706       parse_unary_call ();
 707       write_exp_elt_opcode (UNOP_CHMAX);
 708       break;
 709     case MIN_TOKEN:
 710       parse_unary_call ();
 711       write_exp_elt_opcode (UNOP_CHMIN);
 712       break;
 713     case PRED:      op_name = "PRED"; goto unimplemented_unary_builtin;
 714     case SUCC:      op_name = "SUCC"; goto unimplemented_unary_builtin;
 715     case ABS:       op_name = "ABS";  goto unimplemented_unary_builtin;
 716     unimplemented_unary_builtin:
 717       parse_unary_call ();
 718       error ("not implemented:  %s builtin function", op_name);
 719       break;
 720     case ADDR_TOKEN:
 721       parse_unary_call ();
 722       write_exp_elt_opcode (UNOP_ADDR);
 723       break;
 724     case SIZE:
 725       type = parse_mode_or_normal_call ();
 726       if (type)
 727         { write_exp_elt_opcode (OP_LONG);
 728           write_exp_elt_type (builtin_type_int);
 729           CHECK_TYPEDEF (type);
 730           write_exp_elt_longcst ((LONGEST) TYPE_LENGTH (type));
 731           write_exp_elt_opcode (OP_LONG);
 732         }
 733       else
 734         write_exp_elt_opcode (UNOP_SIZEOF);
 735       break;
 736     case LOWER:
 737       op = UNOP_LOWER;
 738       goto lower_upper;
 739     case UPPER:
 740       op = UNOP_UPPER;
 741       goto lower_upper;
 742     lower_upper:
 743       type = parse_mode_or_normal_call ();
 744       write_lower_upper_value (op, type);
 745       break;
 746     case LENGTH:
 747       parse_unary_call ();
 748       write_exp_elt_opcode (UNOP_LENGTH);
 749       break;
 750     case TYPENAME:
 751       type = PEEK_LVAL ().tsym.type;
 752       FORWARD_TOKEN ();
 753       switch (PEEK_TOKEN())
 754         {
 755         case '[':
 756           parse_tuple (type);
 757           break;
 758         case '(':
 759           FORWARD_TOKEN ();
 760           parse_expr ();
 761           expect (')', "missing right parenthesis");
 762           write_exp_elt_opcode (UNOP_CAST);
 763           write_exp_elt_type (type);
 764           write_exp_elt_opcode (UNOP_CAST);
 765           break;
 766         default:
 767           error ("typename in invalid context");
 768         }
 769       break;
 770
 771     default:
 772       error ("invalid expression syntax at `%s'", lexptr);
 773     }
 774   for (;;)
 775     {
 776       switch (PEEK_TOKEN ())
 777         {
 778         case FIELD_NAME:
 779           write_exp_elt_opcode (STRUCTOP_STRUCT);
 780           write_exp_string (PEEK_LVAL ().sval);
 781           write_exp_elt_opcode (STRUCTOP_STRUCT);
 782           FORWARD_TOKEN ();
 783           continue;
 784         case POINTER:
 785           FORWARD_TOKEN ();
 786           if (PEEK_TOKEN () == TYPENAME)
 787             {
 788               type = PEEK_LVAL ().tsym.type;
 789               write_exp_elt_opcode (UNOP_CAST);
 790               write_exp_elt_type (lookup_pointer_type (type));
 791               write_exp_elt_opcode (UNOP_CAST);
 792               FORWARD_TOKEN ();
 793             }
 794           write_exp_elt_opcode (UNOP_IND);
 795           continue;
 796         case OPEN_PAREN:
 797           parse_call ();
 798           continue;
 799         case CHARACTER_STRING_LITERAL:
 800         case CHARACTER_LITERAL:
 801         case BIT_STRING_LITERAL:
 802           /* Handle string repetition. (See comment in parse_operand5.) */
 803           parse_primval ();
 804           write_exp_elt_opcode (MULTI_SUBSCRIPT);
 805           write_exp_elt_longcst (1);
 806           write_exp_elt_opcode (MULTI_SUBSCRIPT);
 807           continue;
 808         case END_TOKEN:
 809         case TOKEN_NOT_READ:
 810         case INTEGER_LITERAL:
 811         case BOOLEAN_LITERAL:
 812         case FLOAT_LITERAL:
 813         case GENERAL_PROCEDURE_NAME:
 814         case LOCATION_NAME:
 815         case EMPTINESS_LITERAL:
 816         case TYPENAME:
 817         case CASE:
 818         case OF:
 819         case ESAC:
 820         case LOGIOR:
 821         case ORIF:
 822         case LOGXOR:
 823         case LOGAND:
 824         case ANDIF:
 825         case NOTEQUAL:
 826         case GEQ:
 827         case LEQ:
 828         case IN:
 829         case SLASH_SLASH:
 830         case MOD:
 831         case REM:
 832         case NOT:
 833         case RECEIVE:
 834         case UP:
 835         case IF:
 836         case THEN:
 837         case ELSE:
 838         case FI:
 839         case ELSIF:
 840         case ILLEGAL_TOKEN:
 841         case NUM:
 842         case PRED:
 843         case SUCC:
 844         case ABS:
 845         case CARD:
 846         case MAX_TOKEN:
 847         case MIN_TOKEN:
 848         case ADDR_TOKEN:
 849         case SIZE:
 850         case UPPER:
 851         case LOWER:
 852         case LENGTH:
 853         case ARRAY:
 854         case GDB_VARIABLE:
 855         case GDB_ASSIGNMENT:
 856           break;
 857         }
 858       break;
 859     }
 860   return;
 861 }
 862
 863 static void
 864 parse_operand6 ()
 865 {
 866   if (check_token (RECEIVE))
 867     {
 868       parse_primval ();
 869       error ("not implemented:  RECEIVE expression");
 870     }
 871   else if (check_token (POINTER))
 872     {
 873       parse_primval ();
 874       write_exp_elt_opcode (UNOP_ADDR);
 875     }
 876   else
 877     parse_primval();
 878 }
 879
 880 static void
 881 parse_operand5()
 882 {
 883   enum exp_opcode op;
 884   /* We are supposed to be looking for a <string repetition operator>,
 885      but in general we can't distinguish that from a parenthesized
 886      expression.  This is especially difficult if we allow the
 887      string operand to be a constant expression (as requested by
 888      some users), and not just a string literal.
 889      Consider:  LPRN expr RPRN LPRN expr RPRN
 890      Is that a function call or string repetition?
 891      Instead, we handle string repetition in parse_primval,
 892      and build_generalized_call. */
 893   switch (PEEK_TOKEN())
 894     {
 895     case NOT:  op = UNOP_LOGICAL_NOT; break;
 896     case '-':  op = UNOP_NEG; break;
 897     default:
 898       op = OP_NULL;
 899     }
 900   if (op != OP_NULL)
 901     FORWARD_TOKEN();
 902   parse_operand6();
 903   if (op != OP_NULL)
 904     write_exp_elt_opcode (op);
 905 }
 906
 907 static void
 908 parse_operand4 ()
 909 {
 910   enum exp_opcode op;
 911   parse_operand5();
 912   for (;;)
 913     {
 914       switch (PEEK_TOKEN())
 915         {
 916         case '*':  op = BINOP_MUL; break;
 917         case '/':  op = BINOP_DIV; break;
 918         case MOD:  op = BINOP_MOD; break;
 919         case REM:  op = BINOP_REM; break;
 920         default:
 921           return;
 922         }
 923       FORWARD_TOKEN();
 924       parse_operand5();
 925       write_exp_elt_opcode (op);
 926     }
 927 }
 928
 929 static void
 930 parse_operand3 ()
 931 {
 932   enum exp_opcode op;
 933   parse_operand4 ();
 934   for (;;)
 935     {
 936       switch (PEEK_TOKEN())
 937         {
 938         case '+':    op = BINOP_ADD; break;
 939         case '-':    op = BINOP_SUB; break;
 940         case SLASH_SLASH: op = BINOP_CONCAT; break;
 941         default:
 942           return;
 943         }
 944       FORWARD_TOKEN();
 945       parse_operand4();
 946       write_exp_elt_opcode (op);
 947     }
 948 }
 949
 950 static void
 951 parse_operand2 ()
 952 {
 953   enum exp_opcode op;
 954   parse_operand3 ();
 955   for (;;)
 956     {
 957       if (check_token (IN))
 958         {
 959           parse_operand3();
 960           write_exp_elt_opcode (BINOP_IN);
 961         }
 962       else
 963         {
 964           switch (PEEK_TOKEN())
 965             {
 966             case '>':      op = BINOP_GTR; break;
 967             case GEQ:      op = BINOP_GEQ; break;
 968             case '<':      op = BINOP_LESS; break;
 969             case LEQ:      op = BINOP_LEQ; break;
 970             case '=':      op = BINOP_EQUAL; break;
 971             case NOTEQUAL: op = BINOP_NOTEQUAL; break;
 972             default:
 973               return;
 974             }
 975           FORWARD_TOKEN();
 976           parse_operand3();
 977           write_exp_elt_opcode (op);
 978         }
 979     }
 980 }
 981
 982 static void
 983 parse_operand1 ()
 984 {
 985   enum exp_opcode op;
 986   parse_operand2 ();
 987   for (;;)
 988     {
 989       switch (PEEK_TOKEN())
 990         {
 991         case LOGAND: op = BINOP_BITWISE_AND; break;
 992         case ANDIF:  op = BINOP_LOGICAL_AND; break;
 993         default:
 994           return;
 995         }
 996       FORWARD_TOKEN();
 997       parse_operand2();
 998       write_exp_elt_opcode (op);
 999     }
1000 }
1001
1002 static void
1003 parse_operand0 ()
1004 {
1005   enum exp_opcode op;
1006   parse_operand1();
1007   for (;;)
1008     {
1009       switch (PEEK_TOKEN())
1010         {
1011         case LOGIOR:  op = BINOP_BITWISE_IOR; break;
1012         case LOGXOR:  op = BINOP_BITWISE_XOR; break;
1013         case ORIF:    op = BINOP_LOGICAL_OR; break;
1014         default:
1015           return;
1016         }
1017       FORWARD_TOKEN();
1018       parse_operand1();
1019       write_exp_elt_opcode (op);
1020     }
1021 }
1022
1023 static void
1024 parse_expr ()
1025 {
1026   parse_operand0 ();
1027   if (check_token (GDB_ASSIGNMENT))
1028     {
1029       parse_expr ();
1030       write_exp_elt_opcode (BINOP_ASSIGN);
1031     }
1032 }
1033
1034 static void
1035 parse_then_alternative ()
1036 {
1037   expect (THEN, "missing 'THEN' in 'IF' expression");
1038   parse_expr ();
1039 }
1040
1041 static void
1042 parse_else_alternative ()
1043 {
1044   if (check_token (ELSIF))
1045     parse_if_expression_body ();
1046   else if (check_token (ELSE))
1047     parse_expr ();
1048   else
1049     error ("missing ELSE/ELSIF in IF expression");
1050 }
1051
1052 /* Matches: <boolean expression> <then alternative> <else alternative> */
1053
1054 static void
1055 parse_if_expression_body ()
1056 {
1057   parse_expr ();
1058   parse_then_alternative ();
1059   parse_else_alternative ();
1060   write_exp_elt_opcode (TERNOP_COND);
1061 }
1062
1063 static void
1064 parse_if_expression ()
1065 {
1066   require (IF);
1067   parse_if_expression_body ();
1068   expect (FI, "missing 'FI' at end of conditional expression");
1069 }
1070
1071 /* An <untyped_expr> is a superset of <expr>.  It also includes
1072    <conditional expressions> and untyped <tuples>, whose types
1073    are not given by their constituents.  Hence, these are only
1074    allowed in certain contexts that expect a certain type.
1075    You should call convert() to fix up the <untyped_expr>. */
1076
1077 static void
1078 parse_untyped_expr ()
1079 {
1080   switch (PEEK_TOKEN())
1081     {
1082     case IF:
1083       parse_if_expression ();
1084       return;
1085     case CASE:
1086       error ("not implemented:  CASE expression");
1087     case '(':
1088       switch (PEEK_TOKEN1())
1089         {
1090         case IF:
1091         case CASE:
1092           goto skip_lprn;
1093         case '[':
1094         skip_lprn:
1095           FORWARD_TOKEN ();
1096           parse_untyped_expr ();
1097           expect (')', "missing ')'");
1098           return;
1099         default: ;
1100           /* fall through */
1101         }
1102     default:
1103       parse_operand0 ();
1104     }
1105 }
1106
1107 int
1108 chill_parse ()
1109 {
1110   terminal_buffer[0] = TOKEN_NOT_READ;
1111   if (PEEK_TOKEN () == TYPENAME && PEEK_TOKEN1 () == END_TOKEN)
1112     {
1113       write_exp_elt_opcode(OP_TYPE);
1114       write_exp_elt_type(PEEK_LVAL ().tsym.type);
1115       write_exp_elt_opcode(OP_TYPE);
1116       FORWARD_TOKEN ();
1117     }
1118   else
1119     parse_expr ();
1120   if (terminal_buffer[0] != END_TOKEN)
1121     {
1122       if (comma_terminates && terminal_buffer[0] == ',')
1123         lexptr--;  /* Put the comma back.  */
1124       else
1125         error ("Junk after end of expression.");
1126     }
1127   return 0;
1128 }
1129
1130
1131 /* Implementation of a dynamically expandable buffer for processing input
1132    characters acquired through lexptr and building a value to return in
1133    yylval. */
1134
1135 static char *tempbuf;           /* Current buffer contents */
1136 static int tempbufsize;         /* Size of allocated buffer */
1137 static int tempbufindex;        /* Current index into buffer */
1138
1139 #define GROWBY_MIN_SIZE 64      /* Minimum amount to grow buffer by */
1140
1141 #define CHECKBUF(size) \
1142   do { \
1143     if (tempbufindex + (size) >= tempbufsize) \
1144       { \
1145         growbuf_by_size (size); \
1146       } \
1147   } while (0);
1148
1149 /* Grow the static temp buffer if necessary, including allocating the first one
1150    on demand. */
1151
1152 static void
1153 growbuf_by_size (count)
1154      int count;
1155 {
1156   int growby;
1157
1158   growby = max (count, GROWBY_MIN_SIZE);
1159   tempbufsize += growby;
1160   if (tempbuf == NULL)
1161     {
1162       tempbuf = (char *) xmalloc (tempbufsize);
1163     }
1164   else
1165     {
1166       tempbuf = (char *) xrealloc (tempbuf, tempbufsize);
1167     }
1168 }
1169
1170 /* Try to consume a simple name string token.  If successful, returns
1171    a pointer to a nullbyte terminated copy of the name that can be used
1172    in symbol table lookups.  If not successful, returns NULL. */
1173
1174 static char *
1175 match_simple_name_string ()
1176 {
1177   char *tokptr = lexptr;
1178
1179   if (isalpha (*tokptr) || *tokptr == '_')
1180     {
1181       char *result;
1182       do {
1183         tokptr++;
1184       } while (isalnum (*tokptr) || (*tokptr == '_'));
1185       yylval.sval.ptr = lexptr;
1186       yylval.sval.length = tokptr - lexptr;
1187       lexptr = tokptr;
1188       result = copy_name (yylval.sval);
1189       return result;
1190     }
1191   return (NULL);
1192 }
1193
1194 /* Start looking for a value composed of valid digits as set by the base
1195    in use.  Note that '_' characters are valid anywhere, in any quantity,
1196    and are simply ignored.  Since we must find at least one valid digit,
1197    or reject this token as an integer literal, we keep track of how many
1198    digits we have encountered. */
1199
1200 static int
1201 decode_integer_value (base, tokptrptr, ivalptr)
1202   int base;
1203   char **tokptrptr;
1204   LONGEST *ivalptr;
1205 {
1206   char *tokptr = *tokptrptr;
1207   int temp;
1208   int digits = 0;
1209
1210   while (*tokptr != '\0')
1211     {
1212       temp = *tokptr;
1213       if (isupper (temp))
1214         temp = tolower (temp);
1215       tokptr++;
1216       switch (temp)
1217         {
1218         case '_':
1219           continue;
1220         case '0':  case '1':  case '2':  case '3':  case '4':
1221         case '5':  case '6':  case '7':  case '8':  case '9':
1222           temp -= '0';
1223           break;
1224         case 'a':  case 'b':  case 'c':  case 'd':  case 'e': case 'f':
1225           temp -= 'a';
1226           temp += 10;
1227           break;
1228         default:
1229           temp = base;
1230           break;
1231         }
1232       if (temp < base)
1233         {
1234           digits++;
1235           *ivalptr *= base;
1236           *ivalptr += temp;
1237         }
1238       else
1239         {
1240           /* Found something not in domain for current base. */
1241           tokptr--;     /* Unconsume what gave us indigestion. */
1242           break;
1243         }
1244     }
1245
1246   /* If we didn't find any digits, then we don't have a valid integer
1247      value, so reject the entire token.  Otherwise, update the lexical
1248      scan pointer, and return non-zero for success. */
1249
1250   if (digits == 0)
1251     {
1252       return (0);
1253     }
1254   else
1255     {
1256       *tokptrptr = tokptr;
1257       return (1);
1258     }
1259 }
1260
1261 static int
1262 decode_integer_literal (valptr, tokptrptr)
1263   LONGEST *valptr;
1264   char **tokptrptr;
1265 {
1266   char *tokptr = *tokptrptr;
1267   int base = 0;
1268   LONGEST ival = 0;
1269   int explicit_base = 0;
1270
1271   /* Look for an explicit base specifier, which is optional. */
1272
1273   switch (*tokptr)
1274     {
1275     case 'd':
1276     case 'D':
1277       explicit_base++;
1278       base = 10;
1279       tokptr++;
1280       break;
1281     case 'b':
1282     case 'B':
1283       explicit_base++;
1284       base = 2;
1285       tokptr++;
1286       break;
1287     case 'h':
1288     case 'H':
1289       explicit_base++;
1290       base = 16;
1291       tokptr++;
1292       break;
1293     case 'o':
1294     case 'O':
1295       explicit_base++;
1296       base = 8;
1297       tokptr++;
1298       break;
1299     default:
1300       base = 10;
1301       break;
1302     }
1303
1304   /* If we found an explicit base ensure that the character after the
1305      explicit base is a single quote. */
1306
1307   if (explicit_base && (*tokptr++ != '\''))
1308     {
1309       return (0);
1310     }
1311
1312   /* Attempt to decode whatever follows as an integer value in the
1313      indicated base, updating the token pointer in the process and
1314      computing the value into ival.  Also, if we have an explicit
1315      base, then the next character must not be a single quote, or we
1316      have a bitstring literal, so reject the entire token in this case.
1317      Otherwise, update the lexical scan pointer, and return non-zero
1318      for success. */
1319
1320   if (!decode_integer_value (base, &tokptr, &ival))
1321     {
1322       return (0);
1323     }
1324   else if (explicit_base && (*tokptr == '\''))
1325     {
1326       return (0);
1327     }
1328   else
1329     {
1330       *valptr = ival;
1331       *tokptrptr = tokptr;
1332       return (1);
1333     }
1334 }
1335
1336 /*  If it wasn't for the fact that floating point values can contain '_'
1337     characters, we could just let strtod do all the hard work by letting it
1338     try to consume as much of the current token buffer as possible and
1339     find a legal conversion.  Unfortunately we need to filter out the '_'
1340     characters before calling strtod, which we do by copying the other
1341     legal chars to a local buffer to be converted.  However since we also
1342     need to keep track of where the last unconsumed character in the input
1343     buffer is, we have transfer only as many characters as may compose a
1344     legal floating point value. */
1345
1346 static enum ch_terminal
1347 match_float_literal ()
1348 {
1349   char *tokptr = lexptr;
1350   char *buf;
1351   char *copy;
1352   double dval;
1353   extern double strtod ();
1354
1355   /* Make local buffer in which to build the string to convert.  This is
1356      required because underscores are valid in chill floating point numbers
1357      but not in the string passed to strtod to convert.  The string will be
1358      no longer than our input string. */
1359
1360   copy = buf = (char *) alloca (strlen (tokptr) + 1);
1361
1362   /* Transfer all leading digits to the conversion buffer, discarding any
1363      underscores. */
1364
1365   while (isdigit (*tokptr) || *tokptr == '_')
1366     {
1367       if (*tokptr != '_')
1368         {
1369           *copy++ = *tokptr;
1370         }
1371       tokptr++;
1372     }
1373
1374   /* Now accept either a '.', or one of [eEdD].  Dot is legal regardless
1375      of whether we found any leading digits, and we simply accept it and
1376      continue on to look for the fractional part and/or exponent.  One of
1377      [eEdD] is legal only if we have seen digits, and means that there
1378      is no fractional part.  If we find neither of these, then this is
1379      not a floating point number, so return failure. */
1380
1381   switch (*tokptr++)
1382     {
1383       case '.':
1384         /* Accept and then look for fractional part and/or exponent. */
1385         *copy++ = '.';
1386         break;
1387
1388       case 'e':
1389       case 'E':
1390       case 'd':
1391       case 'D':
1392         if (copy == buf)
1393           {
1394             return (0);
1395           }
1396         *copy++ = 'e';
1397         goto collect_exponent;
1398         break;
1399
1400       default:
1401         return (0);
1402         break;
1403     }
1404
1405   /* We found a '.', copy any fractional digits to the conversion buffer, up
1406      to the first nondigit, non-underscore character. */
1407
1408   while (isdigit (*tokptr) || *tokptr == '_')
1409     {
1410       if (*tokptr != '_')
1411         {
1412           *copy++ = *tokptr;
1413         }
1414       tokptr++;
1415     }
1416
1417   /* Look for an exponent, which must start with one of [eEdD].  If none
1418      is found, jump directly to trying to convert what we have collected
1419      so far. */
1420
1421   switch (*tokptr)
1422     {
1423       case 'e':
1424       case 'E':
1425       case 'd':
1426       case 'D':
1427         *copy++ = 'e';
1428         tokptr++;
1429         break;
1430       default:
1431         goto convert_float;
1432         break;
1433     }
1434
1435   /* Accept an optional '-' or '+' following one of [eEdD]. */
1436
1437   collect_exponent:
1438   if (*tokptr == '+' || *tokptr == '-')
1439     {
1440       *copy++ = *tokptr++;
1441     }
1442
1443   /* Now copy an exponent into the conversion buffer.  Note that at the
1444      moment underscores are *not* allowed in exponents. */
1445
1446   while (isdigit (*tokptr))
1447     {
1448       *copy++ = *tokptr++;
1449     }
1450
1451   /* If we transfered any chars to the conversion buffer, try to interpret its
1452      contents as a floating point value.  If any characters remain, then we
1453      must not have a valid floating point string. */
1454
1455   convert_float:
1456   *copy = '\0';
1457   if (copy != buf)
1458       {
1459         dval = strtod (buf, &copy);
1460         if (*copy == '\0')
1461           {
1462             yylval.dval = dval;
1463             lexptr = tokptr;
1464             return (FLOAT_LITERAL);
1465           }
1466       }
1467   return (0);
1468 }
1469
1470 /* Recognize a string literal.  A string literal is a sequence
1471    of characters enclosed in matching single or double quotes, except that
1472    a single character inside single quotes is a character literal, which
1473    we reject as a string literal.  To embed the terminator character inside
1474    a string, it is simply doubled (I.E. "this""is""one""string") */
1475
1476 static enum ch_terminal
1477 match_string_literal ()
1478 {
1479   char *tokptr = lexptr;
1480   int in_ctrlseq = 0;
1481   LONGEST ival;
1482
1483   for (tempbufindex = 0, tokptr++; *tokptr != '\0'; tokptr++)
1484     {
1485       CHECKBUF (1);
1486     tryagain: ;
1487       if (in_ctrlseq)
1488         {
1489           /* skip possible whitespaces */
1490           while ((*tokptr == ' ' || *tokptr == '\t') && *tokptr)
1491             tokptr++;
1492           if (*tokptr == ')')
1493             {
1494               in_ctrlseq = 0;
1495               tokptr++;
1496               goto tryagain;
1497             }
1498           else if (*tokptr != ',')
1499             error ("Invalid control sequence");
1500           tokptr++;
1501           /* skip possible whitespaces */
1502           while ((*tokptr == ' ' || *tokptr == '\t') && *tokptr)
1503             tokptr++;
1504           if (!decode_integer_literal (&ival, &tokptr))
1505             error ("Invalid control sequence");
1506           tokptr--;
1507         }
1508       else if (*tokptr == *lexptr)
1509         {
1510           if (*(tokptr + 1) == *lexptr)
1511             {
1512               ival = *tokptr++;
1513             }
1514           else
1515             {
1516               break;
1517             }
1518         }
1519       else if (*tokptr == '^')
1520         {
1521           if (*(tokptr + 1) == '(')
1522             {
1523               in_ctrlseq = 1;
1524               tokptr += 2;
1525               if (!decode_integer_literal (&ival, &tokptr))
1526                 error ("Invalid control sequence");
1527               tokptr--;
1528             }
1529           else if (*(tokptr + 1) == '^')
1530             ival = *tokptr++;
1531           else
1532             error ("Invalid control sequence");
1533         }
1534       else
1535         ival = *tokptr;
1536       tempbuf[tempbufindex++] = ival;
1537     }
1538   if (in_ctrlseq)
1539     error ("Invalid control sequence");
1540
1541   if (*tokptr == '\0'                                   /* no terminator */
1542       || (tempbufindex == 1 && *tokptr == '\''))        /* char literal */
1543     {
1544       return (0);
1545     }
1546   else
1547     {
1548       tempbuf[tempbufindex] = '\0';
1549       yylval.sval.ptr = tempbuf;
1550       yylval.sval.length = tempbufindex;
1551       lexptr = ++tokptr;
1552       return (CHARACTER_STRING_LITERAL);
1553     }
1554 }
1555
1556 /* Recognize a character literal.  A character literal is single character
1557    or a control sequence, enclosed in single quotes.  A control sequence
1558    is a comma separated list of one or more integer literals, enclosed
1559    in parenthesis and introduced with a circumflex character.
1560
1561    EX:  'a'  '^(7)'  '^(7,8)'
1562
1563    As a GNU chill extension, the syntax C'xx' is also recognized as a
1564    character literal, where xx is a hex value for the character.
1565
1566    Note that more than a single character, enclosed in single quotes, is
1567    a string literal.
1568
1569    Returns CHARACTER_LITERAL if a match is found.
1570    */
1571
1572 static enum ch_terminal
1573 match_character_literal ()
1574 {
1575   char *tokptr = lexptr;
1576   LONGEST ival = 0;
1577
1578   if ((*tokptr == 'c' || *tokptr == 'C') && (*(tokptr + 1) == '\''))
1579     {
1580       /* We have a GNU chill extension form, so skip the leading "C'",
1581          decode the hex value, and then ensure that we have a trailing
1582          single quote character. */
1583       tokptr += 2;
1584       if (!decode_integer_value (16, &tokptr, &ival) || (*tokptr != '\''))
1585         {
1586           return (0);
1587         }
1588       tokptr++;
1589     }
1590   else if (*tokptr == '\'')
1591     {
1592       tokptr++;
1593
1594       /* Determine which form we have, either a control sequence or the
1595          single character form. */
1596
1597       if (*tokptr == '^')
1598         {
1599           if (*(tokptr + 1) == '(')
1600             {
1601               /* Match and decode a control sequence.  Return zero if we don't
1602                  find a valid integer literal, or if the next unconsumed character
1603                  after the integer literal is not the trailing ')'. */
1604               tokptr += 2;
1605               if (!decode_integer_literal (&ival, &tokptr) || (*tokptr++ != ')'))
1606                 {
1607                   return (0);
1608                 }
1609             }
1610           else if (*(tokptr + 1) == '^')
1611             {
1612               ival = *tokptr;
1613               tokptr += 2;
1614             }
1615           else
1616             /* fail */
1617             error ("Invalid control sequence");
1618         }
1619       else if (*tokptr == '\'')
1620         {
1621           /* this must be duplicated */
1622           ival = *tokptr;
1623           tokptr += 2;
1624         }
1625       else
1626         {
1627           ival = *tokptr++;
1628         }
1629
1630       /* The trailing quote has not yet been consumed.  If we don't find
1631          it, then we have no match. */
1632
1633       if (*tokptr++ != '\'')
1634         {
1635           return (0);
1636         }
1637     }
1638   else
1639     {
1640       /* Not a character literal. */
1641       return (0);
1642     }
1643   yylval.typed_val.val = ival;
1644   yylval.typed_val.type = builtin_type_chill_char;
1645   lexptr = tokptr;
1646   return (CHARACTER_LITERAL);
1647 }
1648
1649 /* Recognize an integer literal, as specified in Z.200 sec 5.2.4.2.
1650    Note that according to 5.2.4.2, a single "_" is also a valid integer
1651    literal, however GNU-chill requires there to be at least one "digit"
1652    in any integer literal. */
1653
1654 static enum ch_terminal
1655 match_integer_literal ()
1656 {
1657   char *tokptr = lexptr;
1658   LONGEST ival;
1659
1660   if (!decode_integer_literal (&ival, &tokptr))
1661     {
1662       return (0);
1663     }
1664   else
1665     {
1666       yylval.typed_val.val = ival;
1667 #if defined(CC_HAS_LONG_LONG) && defined(__STDC__)
1668       if (ival > (LONGEST)2147483647U || ival < -(LONGEST)2147483648U)
1669         yylval.typed_val.type = builtin_type_long_long;
1670       else
1671 #endif
1672         yylval.typed_val.type = builtin_type_int;
1673       lexptr = tokptr;
1674       return (INTEGER_LITERAL);
1675     }
1676 }
1677
1678 /* Recognize a bit-string literal, as specified in Z.200 sec 5.2.4.8
1679    Note that according to 5.2.4.8, a single "_" is also a valid bit-string
1680    literal, however GNU-chill requires there to be at least one "digit"
1681    in any bit-string literal. */
1682
1683 static enum ch_terminal
1684 match_bitstring_literal ()
1685 {
1686   register char *tokptr = lexptr;
1687   int bitoffset = 0;
1688   int bitcount = 0;
1689   int bits_per_char;
1690   int digit;
1691
1692   tempbufindex = 0;
1693   CHECKBUF (1);
1694   tempbuf[0] = 0;
1695
1696   /* Look for the required explicit base specifier. */
1697
1698   switch (*tokptr++)
1699     {
1700     case 'b':
1701     case 'B':
1702       bits_per_char = 1;
1703       break;
1704     case 'o':
1705     case 'O':
1706       bits_per_char = 3;
1707       break;
1708     case 'h':
1709     case 'H':
1710       bits_per_char = 4;
1711       break;
1712     default:
1713       return (0);
1714       break;
1715     }
1716
1717   /* Ensure that the character after the explicit base is a single quote. */
1718
1719   if (*tokptr++ != '\'')
1720     {
1721       return (0);
1722     }
1723
1724   while (*tokptr != '\0' && *tokptr != '\'')
1725     {
1726       digit = *tokptr;
1727       if (isupper (digit))
1728         digit = tolower (digit);
1729       tokptr++;
1730       switch (digit)
1731         {
1732           case '_':
1733             continue;
1734           case '0':  case '1':  case '2':  case '3':  case '4':
1735           case '5':  case '6':  case '7':  case '8':  case '9':
1736             digit -= '0';
1737             break;
1738           case 'a':  case 'b':  case 'c':  case 'd':  case 'e': case 'f':
1739             digit -= 'a';
1740             digit += 10;
1741             break;
1742           default:
1743             /* this is not a bitstring literal, probably an integer */
1744             return 0;
1745         }
1746       if (digit >= 1 << bits_per_char)
1747         {
1748           /* Found something not in domain for current base. */
1749           error ("Too-large digit in bitstring or integer.");
1750         }
1751       else
1752         {
1753           /* Extract bits from digit, packing them into the bitstring byte. */
1754           int k = TARGET_BYTE_ORDER == BIG_ENDIAN ? bits_per_char - 1 : 0;
1755           for (; TARGET_BYTE_ORDER == BIG_ENDIAN ? k >= 0 : k < bits_per_char;
1756                TARGET_BYTE_ORDER == BIG_ENDIAN ? k-- : k++)
1757             {
1758               bitcount++;
1759               if (digit & (1 << k))
1760                 {
1761                   tempbuf[tempbufindex] |=
1762                     (TARGET_BYTE_ORDER == BIG_ENDIAN)
1763                       ? (1 << (HOST_CHAR_BIT - 1 - bitoffset))
1764                         : (1 << bitoffset);
1765                 }
1766               bitoffset++;
1767               if (bitoffset == HOST_CHAR_BIT)
1768                 {
1769                   bitoffset = 0;
1770                   tempbufindex++;
1771                   CHECKBUF(1);
1772                   tempbuf[tempbufindex] = 0;
1773                 }
1774             }
1775         }
1776     }
1777
1778   /* Verify that we consumed everything up to the trailing single quote,
1779      and that we found some bits (IE not just underbars). */
1780
1781   if (*tokptr++ != '\'')
1782     {
1783       return (0);
1784     }
1785   else
1786     {
1787       yylval.sval.ptr = tempbuf;
1788       yylval.sval.length = bitcount;
1789       lexptr = tokptr;
1790       return (BIT_STRING_LITERAL);
1791     }
1792 }
1793
1794 struct token
1795 {
1796   char *operator;
1797   int token;
1798 };
1799
1800 static const struct token idtokentab[] =
1801 {
1802     { "array", ARRAY },
1803     { "length", LENGTH },
1804     { "lower", LOWER },
1805     { "upper", UPPER },
1806     { "andif", ANDIF },
1807     { "pred", PRED },
1808     { "succ", SUCC },
1809     { "card", CARD },
1810     { "size", SIZE },
1811     { "orif", ORIF },
1812     { "num", NUM },
1813     { "abs", ABS },
1814     { "max", MAX_TOKEN },
1815     { "min", MIN_TOKEN },
1816     { "mod", MOD },
1817     { "rem", REM },
1818     { "not", NOT },
1819     { "xor", LOGXOR },
1820     { "and", LOGAND },
1821     { "in", IN },
1822     { "or", LOGIOR },
1823     { "up", UP },
1824     { "addr", ADDR_TOKEN },
1825     { "null", EMPTINESS_LITERAL }
1826 };
1827
1828 static const struct token tokentab2[] =
1829 {
1830     { ":=", GDB_ASSIGNMENT },
1831     { "//", SLASH_SLASH },
1832     { "->", POINTER },
1833     { "/=", NOTEQUAL },
1834     { "<=", LEQ },
1835     { ">=", GEQ }
1836 };
1837
1838 /* Read one token, getting characters through lexptr.  */
1839 /* This is where we will check to make sure that the language and the
1840    operators used are compatible.  */
1841
1842 static enum ch_terminal
1843 ch_lex ()
1844 {
1845     unsigned int i;
1846     enum ch_terminal token;
1847     char *inputname;
1848     struct symbol *sym;
1849
1850     /* Skip over any leading whitespace. */
1851     while (isspace (*lexptr))
1852         {
1853             lexptr++;
1854         }
1855     /* Look for special single character cases which can't be the first
1856        character of some other multicharacter token. */
1857     switch (*lexptr)
1858         {
1859             case '\0':
1860                 return END_TOKEN;
1861             case ',':
1862             case '=':
1863             case ';':
1864             case '!':
1865             case '+':
1866             case '*':
1867             case '(':
1868             case ')':
1869             case '[':
1870             case ']':
1871                 return (*lexptr++);
1872         }
1873     /* Look for characters which start a particular kind of multicharacter
1874        token, such as a character literal, register name, convenience
1875        variable name, string literal, etc. */
1876     switch (*lexptr)
1877       {
1878         case '\'':
1879         case '\"':
1880           /* First try to match a string literal, which is any
1881              sequence of characters enclosed in matching single or double
1882              quotes, except that a single character inside single quotes
1883              is a character literal, so we have to catch that case also. */
1884           token = match_string_literal ();
1885           if (token != 0)
1886             {
1887               return (token);
1888             }
1889           if (*lexptr == '\'')
1890             {
1891               token = match_character_literal ();
1892               if (token != 0)
1893                 {
1894                   return (token);
1895                 }
1896             }
1897           break;
1898         case 'C':
1899         case 'c':
1900           token = match_character_literal ();
1901           if (token != 0)
1902             {
1903               return (token);
1904             }
1905           break;
1906         case '$':
1907           yylval.sval.ptr = lexptr;
1908           do {
1909             lexptr++;
1910           } while (isalnum (*lexptr) || *lexptr == '_' || *lexptr == '$');
1911           yylval.sval.length = lexptr - yylval.sval.ptr;
1912           write_dollar_variable (yylval.sval);
1913           return GDB_VARIABLE;
1914           break;
1915       }
1916     /* See if it is a special token of length 2.  */
1917     for (i = 0; i < sizeof (tokentab2) / sizeof (tokentab2[0]); i++)
1918         {
1919             if (STREQN (lexptr, tokentab2[i].operator, 2))
1920                 {
1921                     lexptr += 2;
1922                     return (tokentab2[i].token);
1923                 }
1924         }
1925     /* Look for single character cases which which could be the first
1926        character of some other multicharacter token, but aren't, or we
1927        would already have found it. */
1928     switch (*lexptr)
1929         {
1930             case '-':
1931             case ':':
1932             case '/':
1933             case '<':
1934             case '>':
1935                 return (*lexptr++);
1936         }
1937     /* Look for a float literal before looking for an integer literal, so
1938        we match as much of the input stream as possible. */
1939     token = match_float_literal ();
1940     if (token != 0)
1941         {
1942             return (token);
1943         }
1944     token = match_bitstring_literal ();
1945     if (token != 0)
1946         {
1947             return (token);
1948         }
1949     token = match_integer_literal ();
1950     if (token != 0)
1951         {
1952             return (token);
1953         }
1954
1955     /* Try to match a simple name string, and if a match is found, then
1956        further classify what sort of name it is and return an appropriate
1957        token.  Note that attempting to match a simple name string consumes
1958        the token from lexptr, so we can't back out if we later find that
1959        we can't classify what sort of name it is. */
1960
1961     inputname = match_simple_name_string ();
1962
1963     if (inputname != NULL)
1964       {
1965         char *simplename = (char*) alloca (strlen (inputname) + 1);
1966
1967         char *dptr = simplename, *sptr = inputname;
1968         for (; *sptr; sptr++)
1969           *dptr++ = isupper (*sptr) ? tolower(*sptr) : *sptr;
1970         *dptr = '\0';
1971
1972         /* See if it is a reserved identifier. */
1973         for (i = 0; i < sizeof (idtokentab) / sizeof (idtokentab[0]); i++)
1974             {
1975                 if (STREQ (simplename, idtokentab[i].operator))
1976                     {
1977                         return (idtokentab[i].token);
1978                     }
1979             }
1980
1981         /* Look for other special tokens. */
1982         if (STREQ (simplename, "true"))
1983             {
1984                 yylval.ulval = 1;
1985                 return (BOOLEAN_LITERAL);
1986             }
1987         if (STREQ (simplename, "false"))
1988             {
1989                 yylval.ulval = 0;
1990                 return (BOOLEAN_LITERAL);
1991             }
1992
1993         sym = lookup_symbol (inputname, expression_context_block,
1994                              VAR_NAMESPACE, (int *) NULL,
1995                              (struct symtab **) NULL);
1996         if (sym == NULL && strcmp (inputname, simplename) != 0)
1997           {
1998             sym = lookup_symbol (simplename, expression_context_block,
1999                                  VAR_NAMESPACE, (int *) NULL,
2000                                  (struct symtab **) NULL);
2001           }
2002         if (sym != NULL)
2003           {
2004             yylval.ssym.stoken.ptr = NULL;
2005             yylval.ssym.stoken.length = 0;
2006             yylval.ssym.sym = sym;
2007             yylval.ssym.is_a_field_of_this = 0; /* FIXME, C++'ism */
2008             switch (SYMBOL_CLASS (sym))
2009               {
2010               case LOC_BLOCK:
2011                 /* Found a procedure name. */
2012                 return (GENERAL_PROCEDURE_NAME);
2013               case LOC_STATIC:
2014                 /* Found a global or local static variable. */
2015                 return (LOCATION_NAME);
2016               case LOC_REGISTER:
2017               case LOC_ARG:
2018               case LOC_REF_ARG:
2019               case LOC_REGPARM:
2020               case LOC_REGPARM_ADDR:
2021               case LOC_LOCAL:
2022               case LOC_LOCAL_ARG:
2023               case LOC_BASEREG:
2024               case LOC_BASEREG_ARG:
2025                 if (innermost_block == NULL
2026                     || contained_in (block_found, innermost_block))
2027                   {
2028                     innermost_block = block_found;
2029                   }
2030                 return (LOCATION_NAME);
2031                 break;
2032               case LOC_CONST:
2033               case LOC_LABEL:
2034                 return (LOCATION_NAME);
2035                 break;
2036               case LOC_TYPEDEF:
2037                 yylval.tsym.type = SYMBOL_TYPE (sym);
2038                 return TYPENAME;
2039               case LOC_UNDEF:
2040               case LOC_CONST_BYTES:
2041               case LOC_OPTIMIZED_OUT:
2042                 error ("Symbol \"%s\" names no location.", inputname);
2043                 break;
2044               case LOC_UNRESOLVED:
2045                 error ("unhandled SYMBOL_CLASS in ch_lex()");
2046                 break;
2047               }
2048           }
2049         else if (!have_full_symbols () && !have_partial_symbols ())
2050           {
2051             error ("No symbol table is loaded.  Use the \"file\" command.");
2052           }
2053         else
2054           {
2055             error ("No symbol \"%s\" in current context.", inputname);
2056           }
2057       }
2058
2059     /* Catch single character tokens which are not part of some
2060        longer token. */
2061
2062     switch (*lexptr)
2063       {
2064         case '.':                       /* Not float for example. */
2065           lexptr++;
2066           while (isspace (*lexptr)) lexptr++;
2067           inputname = match_simple_name_string ();
2068           if (!inputname)
2069             return '.';
2070           return FIELD_NAME;
2071       }
2072
2073     return (ILLEGAL_TOKEN);
2074 }
2075
2076 static void
2077 write_lower_upper_value (opcode, type)
2078      enum exp_opcode opcode;  /* Either UNOP_LOWER or UNOP_UPPER */
2079      struct type *type;
2080 {
2081   if (type == NULL)
2082     write_exp_elt_opcode (opcode);
2083   else
2084     {
2085       extern LONGEST type_lower_upper ();
2086       struct type *result_type;
2087       LONGEST val = type_lower_upper (opcode, type, &result_type);
2088       write_exp_elt_opcode (OP_LONG);
2089       write_exp_elt_type (result_type);
2090       write_exp_elt_longcst (val);
2091       write_exp_elt_opcode (OP_LONG);
2092     }
2093 }
2094
2095 /* In certain cases it could happen, that an array type doesn't
2096    have a length (this have to do with seizing). The reason is
2097    shown in the following stabs:
2098
2099    .stabs "m_x:Tt81=s36i:1,0,32;ar:82=ar80;0;1;83=xsm_struct:,32,256;;",128,0,25,0
2100
2101    .stabs "m_struct:Tt83=s16f1:9,0,16;f2:85=*84,32,32;f3:84,64,64;;",128,0,10,0
2102
2103    When processing t81, the array ar80 doesn't have a length, cause
2104    struct m_struct is specified extern at thse moment. Afterwards m_struct
2105    gets specified and updated, but not the surrounding type.
2106
2107    So we walk through array's till we find a type with a length and
2108    calculate the array length.
2109
2110    FIXME: Where may this happen too ?
2111    */
2112
2113 static void
2114 calculate_array_length (type)
2115      struct type *type;
2116 {
2117   struct type *target_type;
2118   struct type *range_type;
2119   LONGEST lower_bound, upper_bound;
2120
2121   if (TYPE_CODE (type) != TYPE_CODE_ARRAY)
2122     /* not an array, stop processing */
2123     return;
2124
2125   target_type = TYPE_TARGET_TYPE (type);
2126   range_type = TYPE_FIELD_TYPE (type, 0);
2127   lower_bound = TYPE_FIELD_BITPOS (range_type, 0);
2128   upper_bound = TYPE_FIELD_BITPOS (range_type, 1);
2129
2130   if (TYPE_LENGTH (target_type) == 0 &&
2131       TYPE_CODE (target_type) == TYPE_CODE_ARRAY)
2132     /* we've got another array */
2133     calculate_array_length (target_type);
2134
2135   TYPE_LENGTH (type) = (upper_bound - lower_bound + 1) * TYPE_LENGTH (target_type);
2136 }
2137
2138 void
2139 chill_error (msg)
2140      char *msg;
2141 {
2142   /* Never used. */
2143 }