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       FORWARD_TOKEN ();
 646       expect ('(', NULL);
 647       parse_expr ();
 648       expect (')', "missing right parenthesis");
 649       type = create_array_type ((struct type *) NULL, type,
 650                                 create_range_type ((struct type *) NULL,
 651                                                    builtin_type_int, 0, 0));
 652       TYPE_ARRAY_UPPER_BOUND_TYPE(type) = BOUND_CANNOT_BE_DETERMINED;
 653       write_exp_elt_opcode (UNOP_CAST);
 654       write_exp_elt_type (type);
 655       write_exp_elt_opcode (UNOP_CAST);
 656       break;
 657 #if 0
 658     case CONST:
 659     case EXPR:
 660       val = PEEK_LVAL();
 661       FORWARD_TOKEN ();
 662       break;
 663 #endif
 664     case '(':
 665       FORWARD_TOKEN ();
 666       parse_expr ();
 667       expect (')', "missing right parenthesis");
 668       break;
 669     case '[':
 670       parse_tuple (NULL);
 671       break;
 672     case GENERAL_PROCEDURE_NAME:
 673     case LOCATION_NAME:
 674       write_exp_elt_opcode (OP_VAR_VALUE);
 675       write_exp_elt_block (NULL);
 676       write_exp_elt_sym (PEEK_LVAL ().ssym.sym);
 677       write_exp_elt_opcode (OP_VAR_VALUE);
 678       FORWARD_TOKEN ();
 679       break;
 680     case GDB_VARIABLE:  /* gdb specific */
 681       FORWARD_TOKEN ();
 682       break;
 683     case NUM:
 684       parse_unary_call ();
 685       write_exp_elt_opcode (UNOP_CAST);
 686       write_exp_elt_type (builtin_type_int);
 687       write_exp_elt_opcode (UNOP_CAST);
 688       break;
 689     case PRED:      op_name = "PRED"; goto unimplemented_unary_builtin;
 690     case SUCC:      op_name = "SUCC"; goto unimplemented_unary_builtin;
 691     case ABS:       op_name = "ABS";  goto unimplemented_unary_builtin;
 692     case CARD:      op_name = "CARD"; goto unimplemented_unary_builtin;
 693     case MAX_TOKEN: op_name = "MAX";  goto unimplemented_unary_builtin;
 694     case MIN_TOKEN: op_name = "MIN";  goto unimplemented_unary_builtin;
 695     unimplemented_unary_builtin:
 696       parse_unary_call ();
 697       error ("not implemented:  %s builtin function", op_name);
 698       break;
 699     case ADDR_TOKEN:
 700       parse_unary_call ();
 701       write_exp_elt_opcode (UNOP_ADDR);
 702       break;
 703     case SIZE:
 704       type = parse_mode_or_normal_call ();
 705       if (type)
 706         { write_exp_elt_opcode (OP_LONG);
 707           write_exp_elt_type (builtin_type_int);
 708           CHECK_TYPEDEF (type);
 709           write_exp_elt_longcst ((LONGEST) TYPE_LENGTH (type));
 710           write_exp_elt_opcode (OP_LONG);
 711         }
 712       else
 713         write_exp_elt_opcode (UNOP_SIZEOF);
 714       break;
 715     case LOWER:
 716       op = UNOP_LOWER;
 717       goto lower_upper;
 718     case UPPER:
 719       op = UNOP_UPPER;
 720       goto lower_upper;
 721     lower_upper:
 722       type = parse_mode_or_normal_call ();
 723       write_lower_upper_value (op, type);
 724       break;
 725     case LENGTH:
 726       parse_unary_call ();
 727       write_exp_elt_opcode (UNOP_LENGTH);
 728       break;
 729     case TYPENAME:
 730       type = PEEK_LVAL ().tsym.type;
 731       FORWARD_TOKEN ();
 732       switch (PEEK_TOKEN())
 733         {
 734         case '[':
 735           parse_tuple (type);
 736           break;
 737         case '(':
 738           FORWARD_TOKEN ();
 739           parse_expr ();
 740           expect (')', "missing right parenthesis");
 741           write_exp_elt_opcode (UNOP_CAST);
 742           write_exp_elt_type (type);
 743           write_exp_elt_opcode (UNOP_CAST);
 744           break;
 745         default:
 746           error ("typename in invalid context");
 747         }
 748       break;
 749
 750     default:
 751       error ("invalid expression syntax at `%s'", lexptr);
 752     }
 753   for (;;)
 754     {
 755       switch (PEEK_TOKEN ())
 756         {
 757         case FIELD_NAME:
 758           write_exp_elt_opcode (STRUCTOP_STRUCT);
 759           write_exp_string (PEEK_LVAL ().sval);
 760           write_exp_elt_opcode (STRUCTOP_STRUCT);
 761           FORWARD_TOKEN ();
 762           continue;
 763         case POINTER:
 764           FORWARD_TOKEN ();
 765           if (PEEK_TOKEN () == TYPENAME)
 766             {
 767               type = PEEK_LVAL ().tsym.type;
 768               write_exp_elt_opcode (UNOP_CAST);
 769               write_exp_elt_type (lookup_pointer_type (type));
 770               write_exp_elt_opcode (UNOP_CAST);
 771               FORWARD_TOKEN ();
 772             }
 773           write_exp_elt_opcode (UNOP_IND);
 774           continue;
 775         case '(':
 776           parse_call ();
 777           continue;
 778         case CHARACTER_STRING_LITERAL:
 779         case CHARACTER_LITERAL:
 780         case BIT_STRING_LITERAL:
 781           /* Handle string repetition. (See comment in parse_operand5.) */
 782           parse_primval ();
 783           write_exp_elt_opcode (MULTI_SUBSCRIPT);
 784           write_exp_elt_longcst (1);
 785           write_exp_elt_opcode (MULTI_SUBSCRIPT);
 786           continue;
 787         }
 788       break;
 789     }
 790   return;
 791 }
 792
 793 static void
 794 parse_operand6 ()
 795 {
 796   if (check_token (RECEIVE))
 797     {
 798       parse_primval ();
 799       error ("not implemented:  RECEIVE expression");
 800     }
 801   else if (check_token (POINTER))
 802     {
 803       parse_primval ();
 804       write_exp_elt_opcode (UNOP_ADDR);
 805     }
 806   else
 807     parse_primval();
 808 }
 809
 810 static void
 811 parse_operand5()
 812 {
 813   enum exp_opcode op;
 814   /* We are supposed to be looking for a <string repetition operator>,
 815      but in general we can't distinguish that from a parenthesized
 816      expression.  This is especially difficult if we allow the
 817      string operand to be a constant expression (as requested by
 818      some users), and not just a string literal.
 819      Consider:  LPRN expr RPRN LPRN expr RPRN
 820      Is that a function call or string repetition?
 821      Instead, we handle string repetition in parse_primval,
 822      and build_generalized_call. */
 823   switch (PEEK_TOKEN())
 824     {
 825     case NOT:  op = UNOP_LOGICAL_NOT; break;
 826     case '-':  op = UNOP_NEG; break;
 827     default:
 828       op = OP_NULL;
 829     }
 830   if (op != OP_NULL)
 831     FORWARD_TOKEN();
 832   parse_operand6();
 833   if (op != OP_NULL)
 834     write_exp_elt_opcode (op);
 835 }
 836
 837 static void
 838 parse_operand4 ()
 839 {
 840   enum exp_opcode op;
 841   parse_operand5();
 842   for (;;)
 843     {
 844       switch (PEEK_TOKEN())
 845         {
 846         case '*':  op = BINOP_MUL; break;
 847         case '/':  op = BINOP_DIV; break;
 848         case MOD:  op = BINOP_MOD; break;
 849         case REM:  op = BINOP_REM; break;
 850         default:
 851           return;
 852         }
 853       FORWARD_TOKEN();
 854       parse_operand5();
 855       write_exp_elt_opcode (op);
 856     }
 857 }
 858
 859 static void
 860 parse_operand3 ()
 861 {
 862   enum exp_opcode op;
 863   parse_operand4 ();
 864   for (;;)
 865     {
 866       switch (PEEK_TOKEN())
 867         {
 868         case '+':    op = BINOP_ADD; break;
 869         case '-':    op = BINOP_SUB; break;
 870         case SLASH_SLASH: op = BINOP_CONCAT; break;
 871         default:
 872           return;
 873         }
 874       FORWARD_TOKEN();
 875       parse_operand4();
 876       write_exp_elt_opcode (op);
 877     }
 878 }
 879
 880 static void
 881 parse_operand2 ()
 882 {
 883   enum exp_opcode op;
 884   parse_operand3 ();
 885   for (;;)
 886     {
 887       if (check_token (IN))
 888         {
 889           parse_operand3();
 890           write_exp_elt_opcode (BINOP_IN);
 891         }
 892       else
 893         {
 894           switch (PEEK_TOKEN())
 895             {
 896             case '>':      op = BINOP_GTR; break;
 897             case GEQ:      op = BINOP_GEQ; break;
 898             case '<':      op = BINOP_LESS; break;
 899             case LEQ:      op = BINOP_LEQ; break;
 900             case '=':      op = BINOP_EQUAL; break;
 901             case NOTEQUAL: op = BINOP_NOTEQUAL; break;
 902             default:
 903               return;
 904             }
 905           FORWARD_TOKEN();
 906           parse_operand3();
 907           write_exp_elt_opcode (op);
 908         }
 909     }
 910 }
 911
 912 static void
 913 parse_operand1 ()
 914 {
 915   enum exp_opcode op;
 916   parse_operand2 ();
 917   for (;;)
 918     {
 919       switch (PEEK_TOKEN())
 920         {
 921         case LOGAND: op = BINOP_BITWISE_AND; break;
 922         case ANDIF:  op = BINOP_LOGICAL_AND; break;
 923         default:
 924           return;
 925         }
 926       FORWARD_TOKEN();
 927       parse_operand2();
 928       write_exp_elt_opcode (op);
 929     }
 930 }
 931
 932 static void
 933 parse_operand0 ()
 934 {
 935   enum exp_opcode op;
 936   parse_operand1();
 937   for (;;)
 938     {
 939       switch (PEEK_TOKEN())
 940         {
 941         case LOGIOR:  op = BINOP_BITWISE_IOR; break;
 942         case LOGXOR:  op = BINOP_BITWISE_XOR; break;
 943         case ORIF:    op = BINOP_LOGICAL_OR; break;
 944         default:
 945           return;
 946         }
 947       FORWARD_TOKEN();
 948       parse_operand1();
 949       write_exp_elt_opcode (op);
 950     }
 951 }
 952
 953 static void
 954 parse_expr ()
 955 {
 956   parse_operand0 ();
 957   if (check_token (GDB_ASSIGNMENT))
 958     {
 959       parse_expr ();
 960       write_exp_elt_opcode (BINOP_ASSIGN);
 961     }
 962 }
 963
 964 static void
 965 parse_then_alternative ()
 966 {
 967   expect (THEN, "missing 'THEN' in 'IF' expression");
 968   parse_expr ();
 969 }
 970
 971 static void
 972 parse_else_alternative ()
 973 {
 974   if (check_token (ELSIF))
 975     parse_if_expression_body ();
 976   else if (check_token (ELSE))
 977     parse_expr ();
 978   else
 979     error ("missing ELSE/ELSIF in IF expression");
 980 }
 981
 982 /* Matches: <boolean expression> <then alternative> <else alternative> */
 983
 984 static void
 985 parse_if_expression_body ()
 986 {
 987   parse_expr ();
 988   parse_then_alternative ();
 989   parse_else_alternative ();
 990   write_exp_elt_opcode (TERNOP_COND);
 991 }
 992
 993 static void
 994 parse_if_expression ()
 995 {
 996   require (IF);
 997   parse_if_expression_body ();
 998   expect (FI, "missing 'FI' at end of conditional expression");
 999 }
1000
1001 /* An <untyped_expr> is a superset of <expr>.  It also includes
1002    <conditional expressions> and untyped <tuples>, whose types
1003    are not given by their constituents.  Hence, these are only
1004    allowed in certain contexts that expect a certain type.
1005    You should call convert() to fix up the <untyped_expr>. */
1006
1007 static void
1008 parse_untyped_expr ()
1009 {
1010   switch (PEEK_TOKEN())
1011     {
1012     case IF:
1013       parse_if_expression ();
1014       return;
1015     case CASE:
1016       error ("not implemented:  CASE expression");
1017     case '(':
1018       switch (PEEK_TOKEN1())
1019         {
1020         case IF:
1021         case CASE:
1022           goto skip_lprn;
1023         case '[':
1024         skip_lprn:
1025           FORWARD_TOKEN ();
1026           parse_untyped_expr ();
1027           expect (')', "missing ')'");
1028           return;
1029         default: ;
1030           /* fall through */
1031         }
1032     default:
1033       parse_operand0 ();
1034     }
1035 }
1036
1037 int
1038 chill_parse ()
1039 {
1040   terminal_buffer[0] = TOKEN_NOT_READ;
1041   if (PEEK_TOKEN () == TYPENAME && PEEK_TOKEN1 () == END_TOKEN)
1042     {
1043       write_exp_elt_opcode(OP_TYPE);
1044       write_exp_elt_type(PEEK_LVAL ().tsym.type);
1045       write_exp_elt_opcode(OP_TYPE);
1046       FORWARD_TOKEN ();
1047     }
1048   else
1049     parse_expr ();
1050   if (terminal_buffer[0] != END_TOKEN)
1051     {
1052       if (comma_terminates && terminal_buffer[0] == ',')
1053         lexptr--;  /* Put the comma back.  */
1054       else
1055         error ("Junk after end of expression.");
1056     }
1057   return 0;
1058 }
1059
1060
1061 /* Implementation of a dynamically expandable buffer for processing input
1062    characters acquired through lexptr and building a value to return in
1063    yylval. */
1064
1065 static char *tempbuf;           /* Current buffer contents */
1066 static int tempbufsize;         /* Size of allocated buffer */
1067 static int tempbufindex;        /* Current index into buffer */
1068
1069 #define GROWBY_MIN_SIZE 64      /* Minimum amount to grow buffer by */
1070
1071 #define CHECKBUF(size) \
1072   do { \
1073     if (tempbufindex + (size) >= tempbufsize) \
1074       { \
1075         growbuf_by_size (size); \
1076       } \
1077   } while (0);
1078
1079 /* Grow the static temp buffer if necessary, including allocating the first one
1080    on demand. */
1081
1082 static void
1083 growbuf_by_size (count)
1084      int count;
1085 {
1086   int growby;
1087
1088   growby = max (count, GROWBY_MIN_SIZE);
1089   tempbufsize += growby;
1090   if (tempbuf == NULL)
1091     {
1092       tempbuf = (char *) malloc (tempbufsize);
1093     }
1094   else
1095     {
1096       tempbuf = (char *) realloc (tempbuf, tempbufsize);
1097     }
1098 }
1099
1100 /* Try to consume a simple name string token.  If successful, returns
1101    a pointer to a nullbyte terminated copy of the name that can be used
1102    in symbol table lookups.  If not successful, returns NULL. */
1103
1104 static char *
1105 match_simple_name_string ()
1106 {
1107   char *tokptr = lexptr;
1108
1109   if (isalpha (*tokptr) || *tokptr == '_')
1110     {
1111       char *result;
1112       do {
1113         tokptr++;
1114       } while (isalnum (*tokptr) || (*tokptr == '_'));
1115       yylval.sval.ptr = lexptr;
1116       yylval.sval.length = tokptr - lexptr;
1117       lexptr = tokptr;
1118       result = copy_name (yylval.sval);
1119       return result;
1120     }
1121   return (NULL);
1122 }
1123
1124 /* Start looking for a value composed of valid digits as set by the base
1125    in use.  Note that '_' characters are valid anywhere, in any quantity,
1126    and are simply ignored.  Since we must find at least one valid digit,
1127    or reject this token as an integer literal, we keep track of how many
1128    digits we have encountered. */
1129
1130 static int
1131 decode_integer_value (base, tokptrptr, ivalptr)
1132   int base;
1133   char **tokptrptr;
1134   LONGEST *ivalptr;
1135 {
1136   char *tokptr = *tokptrptr;
1137   int temp;
1138   int digits = 0;
1139
1140   while (*tokptr != '\0')
1141     {
1142       temp = *tokptr;
1143       if (isupper (temp))
1144         temp = tolower (temp);
1145       tokptr++;
1146       switch (temp)
1147         {
1148         case '_':
1149           continue;
1150         case '0':  case '1':  case '2':  case '3':  case '4':
1151         case '5':  case '6':  case '7':  case '8':  case '9':
1152           temp -= '0';
1153           break;
1154         case 'a':  case 'b':  case 'c':  case 'd':  case 'e': case 'f':
1155           temp -= 'a';
1156           temp += 10;
1157           break;
1158         default:
1159           temp = base;
1160           break;
1161         }
1162       if (temp < base)
1163         {
1164           digits++;
1165           *ivalptr *= base;
1166           *ivalptr += temp;
1167         }
1168       else
1169         {
1170           /* Found something not in domain for current base. */
1171           tokptr--;     /* Unconsume what gave us indigestion. */
1172           break;
1173         }
1174     }
1175
1176   /* If we didn't find any digits, then we don't have a valid integer
1177      value, so reject the entire token.  Otherwise, update the lexical
1178      scan pointer, and return non-zero for success. */
1179
1180   if (digits == 0)
1181     {
1182       return (0);
1183     }
1184   else
1185     {
1186       *tokptrptr = tokptr;
1187       return (1);
1188     }
1189 }
1190
1191 static int
1192 decode_integer_literal (valptr, tokptrptr)
1193   LONGEST *valptr;
1194   char **tokptrptr;
1195 {
1196   char *tokptr = *tokptrptr;
1197   int base = 0;
1198   LONGEST ival = 0;
1199   int explicit_base = 0;
1200
1201   /* Look for an explicit base specifier, which is optional. */
1202
1203   switch (*tokptr)
1204     {
1205     case 'd':
1206     case 'D':
1207       explicit_base++;
1208       base = 10;
1209       tokptr++;
1210       break;
1211     case 'b':
1212     case 'B':
1213       explicit_base++;
1214       base = 2;
1215       tokptr++;
1216       break;
1217     case 'h':
1218     case 'H':
1219       explicit_base++;
1220       base = 16;
1221       tokptr++;
1222       break;
1223     case 'o':
1224     case 'O':
1225       explicit_base++;
1226       base = 8;
1227       tokptr++;
1228       break;
1229     default:
1230       base = 10;
1231       break;
1232     }
1233
1234   /* If we found an explicit base ensure that the character after the
1235      explicit base is a single quote. */
1236
1237   if (explicit_base && (*tokptr++ != '\''))
1238     {
1239       return (0);
1240     }
1241
1242   /* Attempt to decode whatever follows as an integer value in the
1243      indicated base, updating the token pointer in the process and
1244      computing the value into ival.  Also, if we have an explicit
1245      base, then the next character must not be a single quote, or we
1246      have a bitstring literal, so reject the entire token in this case.
1247      Otherwise, update the lexical scan pointer, and return non-zero
1248      for success. */
1249
1250   if (!decode_integer_value (base, &tokptr, &ival))
1251     {
1252       return (0);
1253     }
1254   else if (explicit_base && (*tokptr == '\''))
1255     {
1256       return (0);
1257     }
1258   else
1259     {
1260       *valptr = ival;
1261       *tokptrptr = tokptr;
1262       return (1);
1263     }
1264 }
1265
1266 /*  If it wasn't for the fact that floating point values can contain '_'
1267     characters, we could just let strtod do all the hard work by letting it
1268     try to consume as much of the current token buffer as possible and
1269     find a legal conversion.  Unfortunately we need to filter out the '_'
1270     characters before calling strtod, which we do by copying the other
1271     legal chars to a local buffer to be converted.  However since we also
1272     need to keep track of where the last unconsumed character in the input
1273     buffer is, we have transfer only as many characters as may compose a
1274     legal floating point value. */
1275
1276 static enum ch_terminal
1277 match_float_literal ()
1278 {
1279   char *tokptr = lexptr;
1280   char *buf;
1281   char *copy;
1282   double dval;
1283   extern double strtod ();
1284
1285   /* Make local buffer in which to build the string to convert.  This is
1286      required because underscores are valid in chill floating point numbers
1287      but not in the string passed to strtod to convert.  The string will be
1288      no longer than our input string. */
1289
1290   copy = buf = (char *) alloca (strlen (tokptr) + 1);
1291
1292   /* Transfer all leading digits to the conversion buffer, discarding any
1293      underscores. */
1294
1295   while (isdigit (*tokptr) || *tokptr == '_')
1296     {
1297       if (*tokptr != '_')
1298         {
1299           *copy++ = *tokptr;
1300         }
1301       tokptr++;
1302     }
1303
1304   /* Now accept either a '.', or one of [eEdD].  Dot is legal regardless
1305      of whether we found any leading digits, and we simply accept it and
1306      continue on to look for the fractional part and/or exponent.  One of
1307      [eEdD] is legal only if we have seen digits, and means that there
1308      is no fractional part.  If we find neither of these, then this is
1309      not a floating point number, so return failure. */
1310
1311   switch (*tokptr++)
1312     {
1313       case '.':
1314         /* Accept and then look for fractional part and/or exponent. */
1315         *copy++ = '.';
1316         break;
1317
1318       case 'e':
1319       case 'E':
1320       case 'd':
1321       case 'D':
1322         if (copy == buf)
1323           {
1324             return (0);
1325           }
1326         *copy++ = 'e';
1327         goto collect_exponent;
1328         break;
1329
1330       default:
1331         return (0);
1332         break;
1333     }
1334
1335   /* We found a '.', copy any fractional digits to the conversion buffer, up
1336      to the first nondigit, non-underscore character. */
1337
1338   while (isdigit (*tokptr) || *tokptr == '_')
1339     {
1340       if (*tokptr != '_')
1341         {
1342           *copy++ = *tokptr;
1343         }
1344       tokptr++;
1345     }
1346
1347   /* Look for an exponent, which must start with one of [eEdD].  If none
1348      is found, jump directly to trying to convert what we have collected
1349      so far. */
1350
1351   switch (*tokptr)
1352     {
1353       case 'e':
1354       case 'E':
1355       case 'd':
1356       case 'D':
1357         *copy++ = 'e';
1358         tokptr++;
1359         break;
1360       default:
1361         goto convert_float;
1362         break;
1363     }
1364
1365   /* Accept an optional '-' or '+' following one of [eEdD]. */
1366
1367   collect_exponent:
1368   if (*tokptr == '+' || *tokptr == '-')
1369     {
1370       *copy++ = *tokptr++;
1371     }
1372
1373   /* Now copy an exponent into the conversion buffer.  Note that at the
1374      moment underscores are *not* allowed in exponents. */
1375
1376   while (isdigit (*tokptr))
1377     {
1378       *copy++ = *tokptr++;
1379     }
1380
1381   /* If we transfered any chars to the conversion buffer, try to interpret its
1382      contents as a floating point value.  If any characters remain, then we
1383      must not have a valid floating point string. */
1384
1385   convert_float:
1386   *copy = '\0';
1387   if (copy != buf)
1388       {
1389         dval = strtod (buf, &copy);
1390         if (*copy == '\0')
1391           {
1392             yylval.dval = dval;
1393             lexptr = tokptr;
1394             return (FLOAT_LITERAL);
1395           }
1396       }
1397   return (0);
1398 }
1399
1400 /* Recognize a string literal.  A string literal is a sequence
1401    of characters enclosed in matching single or double quotes, except that
1402    a single character inside single quotes is a character literal, which
1403    we reject as a string literal.  To embed the terminator character inside
1404    a string, it is simply doubled (I.E. "this""is""one""string") */
1405
1406 static enum ch_terminal
1407 match_string_literal ()
1408 {
1409   char *tokptr = lexptr;
1410
1411   for (tempbufindex = 0, tokptr++; *tokptr != '\0'; tokptr++)
1412     {
1413       CHECKBUF (1);
1414       if (*tokptr == *lexptr)
1415         {
1416           if (*(tokptr + 1) == *lexptr)
1417             {
1418               tokptr++;
1419             }
1420           else
1421             {
1422               break;
1423             }
1424         }
1425       tempbuf[tempbufindex++] = *tokptr;
1426     }
1427   if (*tokptr == '\0'                                   /* no terminator */
1428       || (tempbufindex == 1 && *tokptr == '\''))        /* char literal */
1429     {
1430       return (0);
1431     }
1432   else
1433     {
1434       tempbuf[tempbufindex] = '\0';
1435       yylval.sval.ptr = tempbuf;
1436       yylval.sval.length = tempbufindex;
1437       lexptr = ++tokptr;
1438       return (CHARACTER_STRING_LITERAL);
1439     }
1440 }
1441
1442 /* Recognize a character literal.  A character literal is single character
1443    or a control sequence, enclosed in single quotes.  A control sequence
1444    is a comma separated list of one or more integer literals, enclosed
1445    in parenthesis and introduced with a circumflex character.
1446
1447    EX:  'a'  '^(7)'  '^(7,8)'
1448
1449    As a GNU chill extension, the syntax C'xx' is also recognized as a
1450    character literal, where xx is a hex value for the character.
1451
1452    Note that more than a single character, enclosed in single quotes, is
1453    a string literal.
1454
1455    Also note that the control sequence form is not in GNU Chill since it
1456    is ambiguous with the string literal form using single quotes.  I.E.
1457    is '^(7)' a character literal or a string literal.  In theory it it
1458    possible to tell by context, but GNU Chill doesn't accept the control
1459    sequence form, so neither do we (for now the code is disabled).
1460
1461    Returns CHARACTER_LITERAL if a match is found.
1462    */
1463
1464 static enum ch_terminal
1465 match_character_literal ()
1466 {
1467   char *tokptr = lexptr;
1468   LONGEST ival = 0;
1469
1470   if ((*tokptr == 'c' || *tokptr == 'C') && (*(tokptr + 1) == '\''))
1471     {
1472       /* We have a GNU chill extension form, so skip the leading "C'",
1473          decode the hex value, and then ensure that we have a trailing
1474          single quote character. */
1475       tokptr += 2;
1476       if (!decode_integer_value (16, &tokptr, &ival) || (*tokptr != '\''))
1477         {
1478           return (0);
1479         }
1480       tokptr++;
1481     }
1482   else if (*tokptr == '\'')
1483     {
1484       tokptr++;
1485
1486       /* Determine which form we have, either a control sequence or the
1487          single character form. */
1488
1489       if ((*tokptr == '^') && (*(tokptr + 1) == '('))
1490         {
1491 #if 0     /* Disable, see note above. -fnf */
1492           /* Match and decode a control sequence.  Return zero if we don't
1493              find a valid integer literal, or if the next unconsumed character
1494              after the integer literal is not the trailing ')'.
1495              FIXME:  We currently don't handle the multiple integer literal
1496              form. */
1497           tokptr += 2;
1498           if (!decode_integer_literal (&ival, &tokptr) || (*tokptr++ != ')'))
1499             {
1500               return (0);
1501             }
1502 #else
1503           return (0);
1504 #endif
1505         }
1506       else
1507         {
1508           ival = *tokptr++;
1509         }
1510
1511       /* The trailing quote has not yet been consumed.  If we don't find
1512          it, then we have no match. */
1513
1514       if (*tokptr++ != '\'')
1515         {
1516           return (0);
1517         }
1518     }
1519   else
1520     {
1521       /* Not a character literal. */
1522       return (0);
1523     }
1524   yylval.typed_val.val = ival;
1525   yylval.typed_val.type = builtin_type_chill_char;
1526   lexptr = tokptr;
1527   return (CHARACTER_LITERAL);
1528 }
1529
1530 /* Recognize an integer literal, as specified in Z.200 sec 5.2.4.2.
1531    Note that according to 5.2.4.2, a single "_" is also a valid integer
1532    literal, however GNU-chill requires there to be at least one "digit"
1533    in any integer literal. */
1534
1535 static enum ch_terminal
1536 match_integer_literal ()
1537 {
1538   char *tokptr = lexptr;
1539   LONGEST ival;
1540
1541   if (!decode_integer_literal (&ival, &tokptr))
1542     {
1543       return (0);
1544     }
1545   else
1546     {
1547       yylval.typed_val.val = ival;
1548 #if defined(CC_HAS_LONG_LONG) && defined(__STDC__)
1549       if (ival > (LONGEST)2147483647U || ival < -(LONGEST)2147483648U)
1550         yylval.typed_val.type = builtin_type_long_long;
1551       else
1552 #endif
1553         yylval.typed_val.type = builtin_type_int;
1554       lexptr = tokptr;
1555       return (INTEGER_LITERAL);
1556     }
1557 }
1558
1559 /* Recognize a bit-string literal, as specified in Z.200 sec 5.2.4.8
1560    Note that according to 5.2.4.8, a single "_" is also a valid bit-string
1561    literal, however GNU-chill requires there to be at least one "digit"
1562    in any bit-string literal. */
1563
1564 static enum ch_terminal
1565 match_bitstring_literal ()
1566 {
1567   register char *tokptr = lexptr;
1568   int bitoffset = 0;
1569   int bitcount = 0;
1570   int bits_per_char;
1571   int digit;
1572
1573   tempbufindex = 0;
1574   CHECKBUF (1);
1575   tempbuf[0] = 0;
1576
1577   /* Look for the required explicit base specifier. */
1578
1579   switch (*tokptr++)
1580     {
1581     case 'b':
1582     case 'B':
1583       bits_per_char = 1;
1584       break;
1585     case 'o':
1586     case 'O':
1587       bits_per_char = 3;
1588       break;
1589     case 'h':
1590     case 'H':
1591       bits_per_char = 4;
1592       break;
1593     default:
1594       return (0);
1595       break;
1596     }
1597
1598   /* Ensure that the character after the explicit base is a single quote. */
1599
1600   if (*tokptr++ != '\'')
1601     {
1602       return (0);
1603     }
1604
1605   while (*tokptr != '\0' && *tokptr != '\'')
1606     {
1607       digit = *tokptr;
1608       if (isupper (digit))
1609         digit = tolower (digit);
1610       tokptr++;
1611       switch (digit)
1612         {
1613           case '_':
1614             continue;
1615           case '0':  case '1':  case '2':  case '3':  case '4':
1616           case '5':  case '6':  case '7':  case '8':  case '9':
1617             digit -= '0';
1618             break;
1619           case 'a':  case 'b':  case 'c':  case 'd':  case 'e': case 'f':
1620             digit -= 'a';
1621             digit += 10;
1622             break;
1623           default:
1624             error ("Invalid character in bitstring or integer.");
1625         }
1626       if (digit >= 1 << bits_per_char)
1627         {
1628           /* Found something not in domain for current base. */
1629           error ("Too-large digit in bitstring or integer.");
1630         }
1631       else
1632         {
1633           /* Extract bits from digit, packing them into the bitstring byte. */
1634           int k = TARGET_BYTE_ORDER == BIG_ENDIAN ? bits_per_char - 1 : 0;
1635           for (; TARGET_BYTE_ORDER == BIG_ENDIAN ? k >= 0 : k < bits_per_char;
1636                TARGET_BYTE_ORDER == BIG_ENDIAN ? k-- : k++)
1637             {
1638               bitcount++;
1639               if (digit & (1 << k))
1640                 {
1641                   tempbuf[tempbufindex] |=
1642                     (TARGET_BYTE_ORDER == BIG_ENDIAN)
1643                       ? (1 << (HOST_CHAR_BIT - 1 - bitoffset))
1644                         : (1 << bitoffset);
1645                 }
1646               bitoffset++;
1647               if (bitoffset == HOST_CHAR_BIT)
1648                 {
1649                   bitoffset = 0;
1650                   tempbufindex++;
1651                   CHECKBUF(1);
1652                   tempbuf[tempbufindex] = 0;
1653                 }
1654             }
1655         }
1656     }
1657
1658   /* Verify that we consumed everything up to the trailing single quote,
1659      and that we found some bits (IE not just underbars). */
1660
1661   if (*tokptr++ != '\'')
1662     {
1663       return (0);
1664     }
1665   else
1666     {
1667       yylval.sval.ptr = tempbuf;
1668       yylval.sval.length = bitcount;
1669       lexptr = tokptr;
1670       return (BIT_STRING_LITERAL);
1671     }
1672 }
1673
1674 struct token
1675 {
1676   char *operator;
1677   int token;
1678 };
1679
1680 static const struct token idtokentab[] =
1681 {
1682     { "array", ARRAY },
1683     { "length", LENGTH },
1684     { "lower", LOWER },
1685     { "upper", UPPER },
1686     { "andif", ANDIF },
1687     { "pred", PRED },
1688     { "succ", SUCC },
1689     { "card", CARD },
1690     { "size", SIZE },
1691     { "orif", ORIF },
1692     { "num", NUM },
1693     { "abs", ABS },
1694     { "max", MAX_TOKEN },
1695     { "min", MIN_TOKEN },
1696     { "mod", MOD },
1697     { "rem", REM },
1698     { "not", NOT },
1699     { "xor", LOGXOR },
1700     { "and", LOGAND },
1701     { "in", IN },
1702     { "or", LOGIOR },
1703     { "up", UP },
1704     { "addr", ADDR_TOKEN },
1705     { "null", EMPTINESS_LITERAL }
1706 };
1707
1708 static const struct token tokentab2[] =
1709 {
1710     { ":=", GDB_ASSIGNMENT },
1711     { "//", SLASH_SLASH },
1712     { "->", POINTER },
1713     { "/=", NOTEQUAL },
1714     { "<=", LEQ },
1715     { ">=", GEQ }
1716 };
1717
1718 /* Read one token, getting characters through lexptr.  */
1719 /* This is where we will check to make sure that the language and the
1720    operators used are compatible.  */
1721
1722 static enum ch_terminal
1723 ch_lex ()
1724 {
1725     unsigned int i;
1726     enum ch_terminal token;
1727     char *inputname;
1728     struct symbol *sym;
1729
1730     /* Skip over any leading whitespace. */
1731     while (isspace (*lexptr))
1732         {
1733             lexptr++;
1734         }
1735     /* Look for special single character cases which can't be the first
1736        character of some other multicharacter token. */
1737     switch (*lexptr)
1738         {
1739             case '\0':
1740                 return END_TOKEN;
1741             case ',':
1742             case '=':
1743             case ';':
1744             case '!':
1745             case '+':
1746             case '*':
1747             case '(':
1748             case ')':
1749             case '[':
1750             case ']':
1751                 return (*lexptr++);
1752         }
1753     /* Look for characters which start a particular kind of multicharacter
1754        token, such as a character literal, register name, convenience
1755        variable name, string literal, etc. */
1756     switch (*lexptr)
1757       {
1758         case '\'':
1759         case '\"':
1760           /* First try to match a string literal, which is any
1761              sequence of characters enclosed in matching single or double
1762              quotes, except that a single character inside single quotes
1763              is a character literal, so we have to catch that case also. */
1764           token = match_string_literal ();
1765           if (token != 0)
1766             {
1767               return (token);
1768             }
1769           if (*lexptr == '\'')
1770             {
1771               token = match_character_literal ();
1772               if (token != 0)
1773                 {
1774                   return (token);
1775                 }
1776             }
1777           break;
1778         case 'C':
1779         case 'c':
1780           token = match_character_literal ();
1781           if (token != 0)
1782             {
1783               return (token);
1784             }
1785           break;
1786         case '$':
1787           yylval.sval.ptr = lexptr;
1788           do {
1789             lexptr++;
1790           } while (isalnum (*lexptr) || *lexptr == '_' || *lexptr == '$');
1791           yylval.sval.length = lexptr - yylval.sval.ptr;
1792           write_dollar_variable (yylval.sval);
1793           return GDB_VARIABLE;
1794           break;
1795       }
1796     /* See if it is a special token of length 2.  */
1797     for (i = 0; i < sizeof (tokentab2) / sizeof (tokentab2[0]); i++)
1798         {
1799             if (STREQN (lexptr, tokentab2[i].operator, 2))
1800                 {
1801                     lexptr += 2;
1802                     return (tokentab2[i].token);
1803                 }
1804         }
1805     /* Look for single character cases which which could be the first
1806        character of some other multicharacter token, but aren't, or we
1807        would already have found it. */
1808     switch (*lexptr)
1809         {
1810             case '-':
1811             case ':':
1812             case '/':
1813             case '<':
1814             case '>':
1815                 return (*lexptr++);
1816         }
1817     /* Look for a float literal before looking for an integer literal, so
1818        we match as much of the input stream as possible. */
1819     token = match_float_literal ();
1820     if (token != 0)
1821         {
1822             return (token);
1823         }
1824     token = match_bitstring_literal ();
1825     if (token != 0)
1826         {
1827             return (token);
1828         }
1829     token = match_integer_literal ();
1830     if (token != 0)
1831         {
1832             return (token);
1833         }
1834
1835     /* Try to match a simple name string, and if a match is found, then
1836        further classify what sort of name it is and return an appropriate
1837        token.  Note that attempting to match a simple name string consumes
1838        the token from lexptr, so we can't back out if we later find that
1839        we can't classify what sort of name it is. */
1840
1841     inputname = match_simple_name_string ();
1842
1843     if (inputname != NULL)
1844       {
1845         char *simplename = (char*) alloca (strlen (inputname) + 1);
1846
1847         char *dptr = simplename, *sptr = inputname;
1848         for (; *sptr; sptr++)
1849           *dptr++ = isupper (*sptr) ? tolower(*sptr) : *sptr;
1850         *dptr = '\0';
1851
1852         /* See if it is a reserved identifier. */
1853         for (i = 0; i < sizeof (idtokentab) / sizeof (idtokentab[0]); i++)
1854             {
1855                 if (STREQ (simplename, idtokentab[i].operator))
1856                     {
1857                         return (idtokentab[i].token);
1858                     }
1859             }
1860
1861         /* Look for other special tokens. */
1862         if (STREQ (simplename, "true"))
1863             {
1864                 yylval.ulval = 1;
1865                 return (BOOLEAN_LITERAL);
1866             }
1867         if (STREQ (simplename, "false"))
1868             {
1869                 yylval.ulval = 0;
1870                 return (BOOLEAN_LITERAL);
1871             }
1872
1873         sym = lookup_symbol (inputname, expression_context_block,
1874                              VAR_NAMESPACE, (int *) NULL,
1875                              (struct symtab **) NULL);
1876         if (sym == NULL && strcmp (inputname, simplename) != 0)
1877           {
1878             sym = lookup_symbol (simplename, expression_context_block,
1879                                  VAR_NAMESPACE, (int *) NULL,
1880                                  (struct symtab **) NULL);
1881           }
1882         if (sym != NULL)
1883           {
1884             yylval.ssym.stoken.ptr = NULL;
1885             yylval.ssym.stoken.length = 0;
1886             yylval.ssym.sym = sym;
1887             yylval.ssym.is_a_field_of_this = 0; /* FIXME, C++'ism */
1888             switch (SYMBOL_CLASS (sym))
1889               {
1890               case LOC_BLOCK:
1891                 /* Found a procedure name. */
1892                 return (GENERAL_PROCEDURE_NAME);
1893               case LOC_STATIC:
1894                 /* Found a global or local static variable. */
1895                 return (LOCATION_NAME);
1896               case LOC_REGISTER:
1897               case LOC_ARG:
1898               case LOC_REF_ARG:
1899               case LOC_REGPARM:
1900               case LOC_REGPARM_ADDR:
1901               case LOC_LOCAL:
1902               case LOC_LOCAL_ARG:
1903               case LOC_BASEREG:
1904               case LOC_BASEREG_ARG:
1905                 if (innermost_block == NULL
1906                     || contained_in (block_found, innermost_block))
1907                   {
1908                     innermost_block = block_found;
1909                   }
1910                 return (LOCATION_NAME);
1911                 break;
1912               case LOC_CONST:
1913               case LOC_LABEL:
1914                 return (LOCATION_NAME);
1915                 break;
1916               case LOC_TYPEDEF:
1917                 yylval.tsym.type = SYMBOL_TYPE (sym);
1918                 return TYPENAME;
1919               case LOC_UNDEF:
1920               case LOC_CONST_BYTES:
1921               case LOC_OPTIMIZED_OUT:
1922                 error ("Symbol \"%s\" names no location.", inputname);
1923                 break;
1924               }
1925           }
1926         else if (!have_full_symbols () && !have_partial_symbols ())
1927           {
1928             error ("No symbol table is loaded.  Use the \"file\" command.");
1929           }
1930         else
1931           {
1932             error ("No symbol \"%s\" in current context.", inputname);
1933           }
1934       }
1935
1936     /* Catch single character tokens which are not part of some
1937        longer token. */
1938
1939     switch (*lexptr)
1940       {
1941         case '.':                       /* Not float for example. */
1942           lexptr++;
1943           while (isspace (*lexptr)) lexptr++;
1944           inputname = match_simple_name_string ();
1945           if (!inputname)
1946             return '.';
1947           return FIELD_NAME;
1948       }
1949
1950     return (ILLEGAL_TOKEN);
1951 }
1952
1953 static void
1954 write_lower_upper_value (opcode, type)
1955      enum exp_opcode opcode;  /* Either UNOP_LOWER or UNOP_UPPER */
1956      struct type *type;
1957 {
1958   if (type == NULL)
1959     write_exp_elt_opcode (opcode);
1960   else
1961     {
1962       extern LONGEST type_lower_upper ();
1963       struct type *result_type;
1964       LONGEST val = type_lower_upper (opcode, type, &result_type);
1965       write_exp_elt_opcode (OP_LONG);
1966       write_exp_elt_type (result_type);
1967       write_exp_elt_longcst (val);
1968       write_exp_elt_opcode (OP_LONG);
1969     }
1970 }
1971
1972 void
1973 chill_error (msg)
1974      char *msg;
1975 {
1976   /* Never used. */
1977 }