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