gdb/ch-exp.c

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