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