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