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