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