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