gdb/ch-exp.c

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