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