gdb/ch-exp.y

   1 /* YACC grammar for Chill expressions, for GDB.
   2    Copyright 1992, 1993, 1994 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., 675 Mass Ave, Cambridge, MA 02139, USA.  */
  19
  20 /* Parse a Chill expression from text in a string,
  21    and return the result as a  struct expression  pointer.
  22    That structure contains arithmetic operations in reverse polish,
  23    with constants represented by operations that are followed by special data.
  24    See expression.h for the details of the format.
  25    What is important here is that it can be built up sequentially
  26    during the process of parsing; the lower levels of the tree always
  27    come first in the result.
  28
  29    Note that malloc's and realloc's in this file are transformed to
  30    xmalloc and xrealloc respectively by the same sed command in the
  31    makefile that remaps any other malloc/realloc inserted by the parser
  32    generator.  Doing this with #defines and trying to control the interaction
  33    with include files (<malloc.h> and <stdlib.h> for example) just became
  34    too messy, particularly when such includes can be inserted at random
  35    times by the parser generator.
  36
  37    Also note that the language accepted by this parser is more liberal
  38    than the one accepted by an actual Chill compiler.  For example, the
  39    language rule that a simple name string can not be one of the reserved
  40    simple name strings is not enforced (e.g "case" is not treated as a
  41    reserved name).  Another example is that Chill is a strongly typed
  42    language, and certain expressions that violate the type constraints
  43    may still be evaluated if gdb can do so in a meaningful manner, while
  44    such expressions would be rejected by the compiler.  The reason for
  45    this more liberal behavior is the philosophy that the debugger
  46    is intended to be a tool that is used by the programmer when things
  47    go wrong, and as such, it should provide as few artificial barriers
  48    to it's use as possible.  If it can do something meaningful, even
  49    something that violates language contraints that are enforced by the
  50    compiler, it should do so without complaint.
  51
  52  */
  53
  54 %{
  55
  56 #include "defs.h"
  57 #include <string.h>
  58 #include <ctype.h>
  59 #include "expression.h"
  60 #include "language.h"
  61 #include "value.h"
  62 #include "parser-defs.h"
  63 #include "ch-lang.h"
  64 #include "bfd.h" /* Required by objfiles.h.  */
  65 #include "symfile.h" /* Required by objfiles.h.  */
  66 #include "objfiles.h" /* For have_full_symbols and have_partial_symbols */
  67
  68 /* Remap normal yacc parser interface names (yyparse, yylex, yyerror, etc),
  69    as well as gratuitiously global symbol names, so we can have multiple
  70    yacc generated parsers in gdb.  Note that these are only the variables
  71    produced by yacc.  If other parser generators (bison, byacc, etc) produce
  72    additional global names that conflict at link time, then those parser
  73    generators need to be fixed instead of adding those names to this list. */
  74
  75 #define yymaxdepth chill_maxdepth
  76 #define yyparse chill_parse
  77 #define yylex   chill_lex
  78 #define yyerror chill_error
  79 #define yylval  chill_lval
  80 #define yychar  chill_char
  81 #define yydebug chill_debug
  82 #define yypact  chill_pact
  83 #define yyr1    chill_r1
  84 #define yyr2    chill_r2
  85 #define yydef   chill_def
  86 #define yychk   chill_chk
  87 #define yypgo   chill_pgo
  88 #define yyact   chill_act
  89 #define yyexca  chill_exca
  90 #define yyerrflag chill_errflag
  91 #define yynerrs chill_nerrs
  92 #define yyps    chill_ps
  93 #define yypv    chill_pv
  94 #define yys     chill_s
  95 #define yy_yys  chill_yys
  96 #define yystate chill_state
  97 #define yytmp   chill_tmp
  98 #define yyv     chill_v
  99 #define yy_yyv  chill_yyv
 100 #define yyval   chill_val
 101 #define yylloc  chill_lloc
 102 #define yyreds  chill_reds              /* With YYDEBUG defined */
 103 #define yytoks  chill_toks              /* With YYDEBUG defined */
 104 #define yylhs   chill_yylhs
 105 #define yylen   chill_yylen
 106 #define yydefred chill_yydefred
 107 #define yydgoto chill_yydgoto
 108 #define yysindex chill_yysindex
 109 #define yyrindex chill_yyrindex
 110 #define yygindex chill_yygindex
 111 #define yytable  chill_yytable
 112 #define yycheck  chill_yycheck
 113
 114 #ifndef YYDEBUG
 115 #define YYDEBUG 0               /* Default to no yydebug support */
 116 #endif
 117
 118 int
 119 yyparse PARAMS ((void));
 120
 121 static int
 122 yylex PARAMS ((void));
 123
 124 void
 125 yyerror PARAMS ((char *));
 126
 127 %}
 128
 129 /* Although the yacc "value" of an expression is not used,
 130    since the result is stored in the structure being created,
 131    other node types do have values.  */
 132
 133 %union
 134   {
 135     LONGEST lval;
 136     unsigned LONGEST ulval;
 137     struct {
 138       LONGEST val;
 139       struct type *type;
 140     } typed_val;
 141     double dval;
 142     struct symbol *sym;
 143     struct type *tval;
 144     struct stoken sval;
 145     struct ttype tsym;
 146     struct symtoken ssym;
 147     int voidval;
 148     struct block *bval;
 149     enum exp_opcode opcode;
 150     struct internalvar *ivar;
 151
 152     struct type **tvec;
 153     int *ivec;
 154   }
 155
 156 %token <voidval> FIXME_01
 157 %token <voidval> FIXME_02
 158 %token <voidval> FIXME_03
 159 %token <voidval> FIXME_04
 160 %token <voidval> FIXME_05
 161 %token <voidval> FIXME_06
 162 %token <voidval> FIXME_07
 163 %token <voidval> FIXME_08
 164 %token <voidval> FIXME_09
 165 %token <voidval> FIXME_10
 166 %token <voidval> FIXME_11
 167 %token <voidval> FIXME_12
 168 %token <voidval> FIXME_13
 169 %token <voidval> FIXME_14
 170 %token <voidval> FIXME_15
 171 %token <voidval> FIXME_16
 172 %token <voidval> FIXME_17
 173 %token <voidval> FIXME_18
 174 %token <voidval> FIXME_19
 175 %token <voidval> FIXME_20
 176 %token <voidval> FIXME_21
 177 %token <voidval> FIXME_22
 178 %token <voidval> FIXME_24
 179 %token <voidval> FIXME_25
 180 %token <voidval> FIXME_26
 181 %token <voidval> FIXME_27
 182 %token <voidval> FIXME_28
 183 %token <voidval> FIXME_29
 184 %token <voidval> FIXME_30
 185
 186 %token <typed_val>      INTEGER_LITERAL
 187 %token <ulval>          BOOLEAN_LITERAL
 188 %token <typed_val>      CHARACTER_LITERAL
 189 %token <dval>           FLOAT_LITERAL
 190 %token <ssym>           GENERAL_PROCEDURE_NAME
 191 %token <ssym>           LOCATION_NAME
 192 %token <voidval>        SET_LITERAL
 193 %token <voidval>        EMPTINESS_LITERAL
 194 %token <sval>           CHARACTER_STRING_LITERAL
 195 %token <sval>           BIT_STRING_LITERAL
 196 %token <tsym>           TYPENAME
 197 %token <sval>           FIELD_NAME
 198
 199 %token <voidval>        '.'
 200 %token <voidval>        ';'
 201 %token <voidval>        ':'
 202 %token <voidval>        CASE
 203 %token <voidval>        OF
 204 %token <voidval>        ESAC
 205 %token <voidval>        LOGIOR
 206 %token <voidval>        ORIF
 207 %token <voidval>        LOGXOR
 208 %token <voidval>        LOGAND
 209 %token <voidval>        ANDIF
 210 %token <voidval>        '='
 211 %token <voidval>        NOTEQUAL
 212 %token <voidval>        '>'
 213 %token <voidval>        GTR
 214 %token <voidval>        '<'
 215 %token <voidval>        LEQ
 216 %token <voidval>        IN
 217 %token <voidval>        '+'
 218 %token <voidval>        '-'
 219 %token <voidval>        '*'
 220 %token <voidval>        '/'
 221 %token <voidval>        SLASH_SLASH
 222 %token <voidval>        MOD
 223 %token <voidval>        REM
 224 %token <voidval>        NOT
 225 %token <voidval>        POINTER
 226 %token <voidval>        RECEIVE
 227 %token <voidval>        '['
 228 %token <voidval>        ']'
 229 %token <voidval>        '('
 230 %token <voidval>        ')'
 231 %token <voidval>        UP
 232 %token <voidval>        IF
 233 %token <voidval>        THEN
 234 %token <voidval>        ELSE
 235 %token <voidval>        FI
 236 %token <voidval>        ELSIF
 237 %token <voidval>        ILLEGAL_TOKEN
 238 %token <voidval>        NUM
 239 %token <voidval>        PRED
 240 %token <voidval>        SUCC
 241 %token <voidval>        ABS
 242 %token <voidval>        CARD
 243 %token <voidval>        MAX_TOKEN
 244 %token <voidval>        MIN_TOKEN
 245 %token <voidval>        SIZE
 246 %token <voidval>        UPPER
 247 %token <voidval>        LOWER
 248 %token <voidval>        LENGTH
 249 %token <voidval>        ARRAY
 250
 251 /* Tokens which are not Chill tokens used in expressions, but rather GDB
 252    specific things that we recognize in the same context as Chill tokens
 253    (register names for example). */
 254
 255 %token <lval>           GDB_REGNAME     /* Machine register name */
 256 %token <lval>           GDB_LAST        /* Value history */
 257 %token <ivar>           GDB_VARIABLE    /* Convenience variable */
 258 %token <voidval>        GDB_ASSIGNMENT  /* Assign value to somewhere */
 259
 260 %type <voidval>         access_name
 261 %type <voidval>         primitive_value
 262 %type <voidval>         value_name
 263 %type <voidval>         literal
 264 %type <voidval>         tuple
 265 %type <voidval>         slice
 266 %type <voidval>         expression_conversion
 267 %type <voidval>         value_procedure_call
 268 %type <voidval>         value_built_in_routine_call
 269 %type <voidval>         chill_value_built_in_routine_call
 270 %type <voidval>         start_expression
 271 %type <voidval>         zero_adic_operator
 272 %type <voidval>         parenthesised_expression
 273 %type <voidval>         value
 274 %type <voidval>         undefined_value
 275 %type <voidval>         expression
 276 %type <voidval>         conditional_expression
 277 %type <voidval>         then_alternative
 278 %type <voidval>         else_alternative
 279 %type <voidval>         sub_expression
 280 %type <voidval>         value_case_alternative
 281 %type <voidval>         operand_0
 282 %type <voidval>         operand_1
 283 %type <voidval>         operand_2
 284 %type <voidval>         operand_3
 285 %type <voidval>         operand_4
 286 %type <voidval>         operand_5
 287 %type <voidval>         operand_6
 288 %type <voidval>         synonym_name
 289 %type <voidval>         value_enumeration_name
 290 %type <voidval>         value_do_with_name
 291 %type <voidval>         value_receive_name
 292 %type <voidval>         expression_list
 293 %type <tval>            mode_argument
 294 %type <voidval>         upper_lower_argument
 295 %type <voidval>         length_argument
 296 %type <voidval>         array_mode_name
 297 %type <voidval>         string_mode_name
 298 %type <voidval>         variant_structure_mode_name
 299 %type <voidval>         boolean_expression
 300 %type <voidval>         case_selector_list
 301 %type <voidval>         subexpression
 302 %type <voidval>         case_label_specification
 303 %type <voidval>         buffer_location
 304 %type <voidval>         single_assignment_action
 305 %type <tsym>            mode_name
 306 %type <lval>            rparen
 307
 308 %%
 309
 310 /* Z.200, 5.3.1 */
 311
 312 start   :       value { }
 313         |       mode_name
 314                         { write_exp_elt_opcode(OP_TYPE);
 315                           write_exp_elt_type($1.type);
 316                           write_exp_elt_opcode(OP_TYPE);}
 317         ;
 318
 319 value           :       expression
 320                         {
 321                           $$ = 0;       /* FIXME */
 322                         }
 323                 |       undefined_value
 324                         {
 325                           $$ = 0;       /* FIXME */
 326                         }
 327                 ;
 328
 329 undefined_value :       FIXME_01
 330                         {
 331                           $$ = 0;       /* FIXME */
 332                         }
 333                 ;
 334
 335 /* Z.200, 4.2.2 */
 336
 337 access_name     :       LOCATION_NAME
 338                         {
 339                           write_exp_elt_opcode (OP_VAR_VALUE);
 340                           write_exp_elt_block (NULL);
 341                           write_exp_elt_sym ($1.sym);
 342                           write_exp_elt_opcode (OP_VAR_VALUE);
 343                         }
 344                 |       GDB_LAST                /* gdb specific */
 345                         {
 346                           write_exp_elt_opcode (OP_LAST);
 347                           write_exp_elt_longcst ($1);
 348                           write_exp_elt_opcode (OP_LAST);
 349                         }
 350                 |       GDB_REGNAME             /* gdb specific */
 351                         {
 352                           write_exp_elt_opcode (OP_REGISTER);
 353                           write_exp_elt_longcst ($1);
 354                           write_exp_elt_opcode (OP_REGISTER);
 355                         }
 356                 |       GDB_VARIABLE    /* gdb specific */
 357                         {
 358                           write_exp_elt_opcode (OP_INTERNALVAR);
 359                           write_exp_elt_intern ($1);
 360                           write_exp_elt_opcode (OP_INTERNALVAR);
 361                         }
 362                 |       FIXME_03
 363                         {
 364                           $$ = 0;       /* FIXME */
 365                         }
 366                 ;
 367
 368 /* Z.200, 4.2.8 */
 369
 370 expression_list :       expression
 371                         {
 372                           arglist_len = 1;
 373                         }
 374                 |       expression_list ',' expression
 375                         {
 376                           arglist_len++;
 377                         }
 378                 ;
 379
 380 maybe_expression_list:  /* EMPTY */
 381                         {
 382                           arglist_len = 0;
 383                         }
 384                 |       expression_list
 385                 ;
 386
 387
 388 /* Z.200, 5.2.1 */
 389
 390 primitive_value_lparen: primitive_value '('
 391                                 /* This is to save the value of arglist_len
 392                                    being accumulated for each dimension. */
 393                                 { start_arglist (); }
 394                 ;
 395
 396 rparen          :       ')'
 397                                 { $$ = end_arglist (); }
 398                 ;
 399
 400 primitive_value :
 401                         access_name
 402                 |       primitive_value_lparen maybe_expression_list rparen
 403                         {
 404                           write_exp_elt_opcode (MULTI_SUBSCRIPT);
 405                           write_exp_elt_longcst ($3);
 406                           write_exp_elt_opcode (MULTI_SUBSCRIPT);
 407                         }
 408                 |       primitive_value FIELD_NAME
 409                         { write_exp_elt_opcode (STRUCTOP_STRUCT);
 410                           write_exp_string ($2);
 411                           write_exp_elt_opcode (STRUCTOP_STRUCT);
 412                         }
 413                 |       primitive_value POINTER
 414                         {
 415                           write_exp_elt_opcode (UNOP_IND);
 416                         }
 417                 |       primitive_value POINTER mode_name
 418                         {
 419                           write_exp_elt_opcode (UNOP_CAST);
 420                           write_exp_elt_type (lookup_pointer_type ($3.type));
 421                           write_exp_elt_opcode (UNOP_CAST);
 422                           write_exp_elt_opcode (UNOP_IND);
 423                         }
 424                 |       value_name
 425                         {
 426                           $$ = 0;       /* FIXME */
 427                         }
 428                 |       literal
 429                         {
 430                           $$ = 0;       /* FIXME */
 431                         }
 432                 |       tuple
 433                         {
 434                           $$ = 0;       /* FIXME */
 435                         }
 436                 |       slice
 437                         {
 438                           $$ = 0;       /* FIXME */
 439                         }
 440                 |       expression_conversion
 441                         {
 442                           $$ = 0;       /* FIXME */
 443                         }
 444                 |       value_procedure_call
 445                         {
 446                           $$ = 0;       /* FIXME */
 447                         }
 448                 |       value_built_in_routine_call
 449                         {
 450                           $$ = 0;       /* FIXME */
 451                         }
 452                 |       start_expression
 453                         {
 454                           $$ = 0;       /* FIXME */
 455                         }
 456                 |       zero_adic_operator
 457                         {
 458                           $$ = 0;       /* FIXME */
 459                         }
 460                 |       parenthesised_expression
 461                         {
 462                           $$ = 0;       /* FIXME */
 463                         }
 464                 ;
 465
 466 /* Z.200, 5.2.3 */
 467
 468 value_name      :       synonym_name
 469                         {
 470                           $$ = 0;       /* FIXME */
 471                         }
 472                 |       value_enumeration_name
 473                         {
 474                           $$ = 0;       /* FIXME */
 475                         }
 476                 |       value_do_with_name
 477                         {
 478                           $$ = 0;       /* FIXME */
 479                         }
 480                 |       value_receive_name
 481                         {
 482                           $$ = 0;       /* FIXME */
 483                         }
 484                 |       GENERAL_PROCEDURE_NAME
 485                         {
 486                           write_exp_elt_opcode (OP_VAR_VALUE);
 487                           write_exp_elt_block (NULL);
 488                           write_exp_elt_sym ($1.sym);
 489                           write_exp_elt_opcode (OP_VAR_VALUE);
 490                         }
 491                 ;
 492
 493 /* Z.200, 5.2.4.1 */
 494
 495 literal         :       INTEGER_LITERAL
 496                         {
 497                           write_exp_elt_opcode (OP_LONG);
 498                           write_exp_elt_type ($1.type);
 499                           write_exp_elt_longcst ((LONGEST) ($1.val));
 500                           write_exp_elt_opcode (OP_LONG);
 501                         }
 502                 |       BOOLEAN_LITERAL
 503                         {
 504                           write_exp_elt_opcode (OP_BOOL);
 505                           write_exp_elt_longcst ((LONGEST) $1);
 506                           write_exp_elt_opcode (OP_BOOL);
 507                         }
 508                 |       CHARACTER_LITERAL
 509                         {
 510                           write_exp_elt_opcode (OP_LONG);
 511                           write_exp_elt_type ($1.type);
 512                           write_exp_elt_longcst ((LONGEST) ($1.val));
 513                           write_exp_elt_opcode (OP_LONG);
 514                         }
 515                 |       FLOAT_LITERAL
 516                         {
 517                           write_exp_elt_opcode (OP_DOUBLE);
 518                           write_exp_elt_type (builtin_type_double);
 519                           write_exp_elt_dblcst ($1);
 520                           write_exp_elt_opcode (OP_DOUBLE);
 521                         }
 522                 |       SET_LITERAL
 523                         {
 524                           $$ = 0;       /* FIXME */
 525                         }
 526                 |       EMPTINESS_LITERAL
 527                         {
 528                           struct type *void_ptr_type
 529                             = lookup_pointer_type (builtin_type_void);
 530                           write_exp_elt_opcode (OP_LONG);
 531                           write_exp_elt_type (void_ptr_type);
 532                           write_exp_elt_longcst (0);
 533                           write_exp_elt_opcode (OP_LONG);
 534                         }
 535                 |       CHARACTER_STRING_LITERAL
 536                         {
 537                           write_exp_elt_opcode (OP_STRING);
 538                           write_exp_string ($1);
 539                           write_exp_elt_opcode (OP_STRING);
 540                         }
 541                 |       BIT_STRING_LITERAL
 542                         {
 543                           write_exp_elt_opcode (OP_BITSTRING);
 544                           write_exp_bitstring ($1);
 545                           write_exp_elt_opcode (OP_BITSTRING);
 546                         }
 547                 ;
 548
 549 /* Z.200, 5.2.5 */
 550
 551 tuple_element   :       expression
 552                 |       named_record_element
 553                 ;
 554
 555 named_record_element:   FIELD_NAME ',' named_record_element
 556                         { write_exp_elt_opcode (OP_LABELED);
 557                           write_exp_string ($1);
 558                           write_exp_elt_opcode (OP_LABELED);
 559                         }
 560                 |       FIELD_NAME ':' expression
 561                         { write_exp_elt_opcode (OP_LABELED);
 562                           write_exp_string ($1);
 563                           write_exp_elt_opcode (OP_LABELED);
 564                         }
 565                 ;
 566
 567 tuple_elements  :       tuple_element
 568                         {
 569                           arglist_len = 1;
 570                         }
 571                 |       tuple_elements ',' tuple_element
 572                         {
 573                           arglist_len++;
 574                         }
 575                 ;
 576
 577 maybe_tuple_elements :  tuple_elements
 578                 | /* EMPTY */
 579                 ;
 580
 581 tuple   :       '['
 582                         { start_arglist (); }
 583                 maybe_tuple_elements ']'
 584                         {
 585                           write_exp_elt_opcode (OP_ARRAY);
 586                           write_exp_elt_longcst ((LONGEST) 0);
 587                           write_exp_elt_longcst ((LONGEST) end_arglist () - 1);
 588                           write_exp_elt_opcode (OP_ARRAY);
 589                         }
 590                 |
 591                 mode_name '['
 592                         { start_arglist (); }
 593                 maybe_tuple_elements ']'
 594                         {
 595                           write_exp_elt_opcode (OP_ARRAY);
 596                           write_exp_elt_longcst ((LONGEST) 0);
 597                           write_exp_elt_longcst ((LONGEST) end_arglist () - 1);
 598                           write_exp_elt_opcode (OP_ARRAY);
 599
 600                           write_exp_elt_opcode (UNOP_CAST);
 601                           write_exp_elt_type ($1.type);
 602                           write_exp_elt_opcode (UNOP_CAST);
 603                         }
 604                 ;
 605
 606
 607 /* Z.200, 5.2.6 */
 608
 609
 610 slice:  primitive_value_lparen expression ':' expression rparen
 611                         {
 612                           write_exp_elt_opcode (TERNOP_SLICE);
 613                         }
 614                 |       primitive_value_lparen expression UP expression rparen
 615                         {
 616                           write_exp_elt_opcode (TERNOP_SLICE_COUNT);
 617                         }
 618                 ;
 619
 620 /* Z.200, 5.2.11 */
 621
 622 expression_conversion:  mode_name parenthesised_expression
 623                         {
 624                           write_exp_elt_opcode (UNOP_CAST);
 625                           write_exp_elt_type ($1.type);
 626                           write_exp_elt_opcode (UNOP_CAST);
 627                         }
 628                 |       ARRAY '(' ')' mode_name parenthesised_expression
 629                         /* This is pseudo-Chill, similar to C's '(TYPE[])EXPR'
 630                            which casts to an artificial array. */
 631                         {
 632                           struct type *range_type
 633                             = create_range_type ((struct type *) NULL,
 634                                                  builtin_type_int, 0, 0);
 635                           struct type *array_type
 636                             = create_array_type ((struct type *) NULL,
 637                                                  $4.type, range_type);
 638                           TYPE_ARRAY_UPPER_BOUND_TYPE(array_type)
 639                             = BOUND_CANNOT_BE_DETERMINED;
 640                           write_exp_elt_opcode (UNOP_CAST);
 641                           write_exp_elt_type (array_type);
 642                           write_exp_elt_opcode (UNOP_CAST);
 643                         }
 644                 ;
 645
 646 /* Z.200, 5.2.12 */
 647
 648 value_procedure_call:   FIXME_05
 649                         {
 650                           $$ = 0;       /* FIXME */
 651                         }
 652                 ;
 653
 654 /* Z.200, 5.2.13 */
 655
 656 value_built_in_routine_call:    chill_value_built_in_routine_call
 657                         {
 658                           $$ = 0;       /* FIXME */
 659                         }
 660                 ;
 661
 662 /* Z.200, 5.2.14 */
 663
 664 start_expression:       FIXME_06
 665                         {
 666                           $$ = 0;       /* FIXME */
 667                         }       /* Not in GNU-Chill */
 668                 ;
 669
 670 /* Z.200, 5.2.15 */
 671
 672 zero_adic_operator:     FIXME_07
 673                         {
 674                           $$ = 0;       /* FIXME */
 675                         }
 676                 ;
 677
 678 /* Z.200, 5.2.16 */
 679
 680 parenthesised_expression:       '(' expression ')'
 681                         {
 682                           $$ = 0;       /* FIXME */
 683                         }
 684                 ;
 685
 686 /* Z.200, 5.3.2 */
 687
 688 expression      :       operand_0
 689                         {
 690                           $$ = 0;       /* FIXME */
 691                         }
 692                 |       single_assignment_action
 693                         {
 694                           $$ = 0;       /* FIXME */
 695                         }
 696                 |       conditional_expression
 697                         {
 698                           $$ = 0;       /* FIXME */
 699                         }
 700                 ;
 701
 702 conditional_expression : IF boolean_expression then_alternative else_alternative FI
 703                         {
 704                           $$ = 0;       /* FIXME */
 705                         }
 706                 |       CASE case_selector_list OF value_case_alternative ELSE sub_expression ESAC
 707                         {
 708                           $$ = 0;       /* FIXME */
 709                         }
 710                 ;
 711
 712 then_alternative:       THEN subexpression
 713                         {
 714                           $$ = 0;       /* FIXME */
 715                         }
 716                 ;
 717
 718 else_alternative:       ELSE subexpression
 719                         {
 720                           $$ = 0;       /* FIXME */
 721                         }
 722                 |       ELSIF boolean_expression then_alternative else_alternative
 723                         {
 724                           $$ = 0;       /* FIXME */
 725                         }
 726                 ;
 727
 728 sub_expression  :       expression
 729                         {
 730                           $$ = 0;       /* FIXME */
 731                         }
 732                 ;
 733
 734 value_case_alternative: case_label_specification ':' sub_expression ';'
 735                         {
 736                           $$ = 0;       /* FIXME */
 737                         }
 738                 ;
 739
 740 /* Z.200, 5.3.3 */
 741
 742 operand_0       :       operand_1
 743                         {
 744                           $$ = 0;       /* FIXME */
 745                         }
 746                 |       operand_0 LOGIOR operand_1
 747                         {
 748                           write_exp_elt_opcode (BINOP_BITWISE_IOR);
 749                         }
 750                 |       operand_0 ORIF operand_1
 751                         {
 752                           $$ = 0;       /* FIXME */
 753                         }
 754                 |       operand_0 LOGXOR operand_1
 755                         {
 756                           write_exp_elt_opcode (BINOP_BITWISE_XOR);
 757                         }
 758                 ;
 759
 760 /* Z.200, 5.3.4 */
 761
 762 operand_1       :       operand_2
 763                         {
 764                           $$ = 0;       /* FIXME */
 765                         }
 766                 |       operand_1 LOGAND operand_2
 767                         {
 768                           write_exp_elt_opcode (BINOP_BITWISE_AND);
 769                         }
 770                 |       operand_1 ANDIF operand_2
 771                         {
 772                           $$ = 0;       /* FIXME */
 773                         }
 774                 ;
 775
 776 /* Z.200, 5.3.5 */
 777
 778 operand_2       :       operand_3
 779                         {
 780                           $$ = 0;       /* FIXME */
 781                         }
 782                 |       operand_2 '=' operand_3
 783                         {
 784                           write_exp_elt_opcode (BINOP_EQUAL);
 785                         }
 786                 |       operand_2 NOTEQUAL operand_3
 787                         {
 788                           write_exp_elt_opcode (BINOP_NOTEQUAL);
 789                         }
 790                 |       operand_2 '>' operand_3
 791                         {
 792                           write_exp_elt_opcode (BINOP_GTR);
 793                         }
 794                 |       operand_2 GTR operand_3
 795                         {
 796                           write_exp_elt_opcode (BINOP_GEQ);
 797                         }
 798                 |       operand_2 '<' operand_3
 799                         {
 800                           write_exp_elt_opcode (BINOP_LESS);
 801                         }
 802                 |       operand_2 LEQ operand_3
 803                         {
 804                           write_exp_elt_opcode (BINOP_LEQ);
 805                         }
 806                 |       operand_2 IN operand_3
 807                         {
 808                           write_exp_elt_opcode (BINOP_IN);
 809                         }
 810                 ;
 811
 812
 813 /* Z.200, 5.3.6 */
 814
 815 operand_3       :       operand_4
 816                         {
 817                           $$ = 0;       /* FIXME */
 818                         }
 819                 |       operand_3 '+' operand_4
 820                         {
 821                           write_exp_elt_opcode (BINOP_ADD);
 822                         }
 823                 |       operand_3 '-' operand_4
 824                         {
 825                           write_exp_elt_opcode (BINOP_SUB);
 826                         }
 827                 |       operand_3 SLASH_SLASH operand_4
 828                         {
 829                           write_exp_elt_opcode (BINOP_CONCAT);
 830                         }
 831                 ;
 832
 833 /* Z.200, 5.3.7 */
 834
 835 operand_4       :       operand_5
 836                         {
 837                           $$ = 0;       /* FIXME */
 838                         }
 839                 |       operand_4 '*' operand_5
 840                         {
 841                           write_exp_elt_opcode (BINOP_MUL);
 842                         }
 843                 |       operand_4 '/' operand_5
 844                         {
 845                           write_exp_elt_opcode (BINOP_DIV);
 846                         }
 847                 |       operand_4 MOD operand_5
 848                         {
 849                           write_exp_elt_opcode (BINOP_MOD);
 850                         }
 851                 |       operand_4 REM operand_5
 852                         {
 853                           write_exp_elt_opcode (BINOP_REM);
 854                         }
 855                 ;
 856
 857 /* Z.200, 5.3.8 */
 858
 859 operand_5       :       operand_6
 860                         {
 861                           $$ = 0;       /* FIXME */
 862                         }
 863                 |       '-' operand_6
 864                         {
 865                           write_exp_elt_opcode (UNOP_NEG);
 866                         }
 867                 |       NOT operand_6
 868                         {
 869                           write_exp_elt_opcode (UNOP_LOGICAL_NOT);
 870                         }
 871                 |       parenthesised_expression literal
 872 /* We require the string operand to be a literal, to avoid some
 873    nasty parsing ambiguities. */
 874                         {
 875                           write_exp_elt_opcode (BINOP_CONCAT);
 876                         }
 877                 ;
 878
 879 /* Z.200, 5.3.9 */
 880
 881 operand_6       :       POINTER primitive_value
 882                         {
 883                           write_exp_elt_opcode (UNOP_ADDR);
 884                         }
 885                 |       RECEIVE buffer_location
 886                         {
 887                           $$ = 0;       /* FIXME */
 888                         }
 889                 |       primitive_value
 890                         {
 891                           $$ = 0;       /* FIXME */
 892                         }
 893                 ;
 894
 895
 896 /* Z.200, 6.2 */
 897
 898 single_assignment_action :
 899                         primitive_value GDB_ASSIGNMENT value
 900                         {
 901                           write_exp_elt_opcode (BINOP_ASSIGN);
 902                         }
 903                 ;
 904
 905 /* Z.200, 6.20.3 */
 906
 907 chill_value_built_in_routine_call :
 908                         NUM '(' expression ')'
 909                         {
 910                           $$ = 0;       /* FIXME */
 911                         }
 912                 |       PRED '(' expression ')'
 913                         {
 914                           $$ = 0;       /* FIXME */
 915                         }
 916                 |       SUCC '(' expression ')'
 917                         {
 918                           $$ = 0;       /* FIXME */
 919                         }
 920                 |       ABS '(' expression ')'
 921                         {
 922                           $$ = 0;       /* FIXME */
 923                         }
 924                 |       CARD '(' expression ')'
 925                         {
 926                           $$ = 0;       /* FIXME */
 927                         }
 928                 |       MAX_TOKEN '(' expression ')'
 929                         {
 930                           $$ = 0;       /* FIXME */
 931                         }
 932                 |       MIN_TOKEN '(' expression ')'
 933                         {
 934                           $$ = 0;       /* FIXME */
 935                         }
 936                 |       SIZE '(' expression ')'
 937                         { write_exp_elt_opcode (UNOP_SIZEOF); }
 938                 |       SIZE '(' mode_argument ')'
 939                         { write_exp_elt_opcode (OP_LONG);
 940                           write_exp_elt_type (builtin_type_int);
 941                           write_exp_elt_longcst ((LONGEST) TYPE_LENGTH ($3));
 942                           write_exp_elt_opcode (OP_LONG); }
 943                 |       UPPER '(' upper_lower_argument ')'
 944                         {
 945                           $$ = 0;       /* FIXME */
 946                         }
 947                 |       LOWER '(' upper_lower_argument ')'
 948                         {
 949                           $$ = 0;       /* FIXME */
 950                         }
 951                 |       LENGTH '(' length_argument ')'
 952                         {
 953                           $$ = 0;       /* FIXME */
 954                         }
 955                 ;
 956
 957 mode_argument :         mode_name
 958                         {
 959                           $$ = $1.type;
 960                         }
 961                 |       array_mode_name '(' expression ')'
 962                         {
 963                           $$ = 0;       /* FIXME */
 964                         }
 965                 |       string_mode_name '(' expression ')'
 966                         {
 967                           $$ = 0;       /* FIXME */
 968                         }
 969                 |       variant_structure_mode_name '(' expression_list ')'
 970                         {
 971                           $$ = 0;       /* FIXME */
 972                         }
 973                 ;
 974
 975 mode_name :             TYPENAME
 976                 ;
 977
 978 upper_lower_argument :  expression
 979                         {
 980                           $$ = 0;       /* FIXME */
 981                         }
 982                 |       mode_name
 983                         {
 984                           $$ = 0;       /* FIXME */
 985                         }
 986                 ;
 987
 988 length_argument :       expression
 989                         {
 990                           $$ = 0;       /* FIXME */
 991                         }
 992                 ;
 993
 994 /* Things which still need productions... */
 995
 996 array_mode_name         :       FIXME_08 { $$ = 0; }
 997 string_mode_name        :       FIXME_09 { $$ = 0; }
 998 variant_structure_mode_name:    FIXME_10 { $$ = 0; }
 999 synonym_name            :       FIXME_11 { $$ = 0; }
1000 value_enumeration_name  :       FIXME_12 { $$ = 0; }
1001 value_do_with_name      :       FIXME_13 { $$ = 0; }
1002 value_receive_name      :       FIXME_14 { $$ = 0; }
1003 boolean_expression      :       FIXME_26 { $$ = 0; }
1004 case_selector_list      :       FIXME_27 { $$ = 0; }
1005 subexpression           :       FIXME_28 { $$ = 0; }
1006 case_label_specification:       FIXME_29 { $$ = 0; }
1007 buffer_location         :       FIXME_30 { $$ = 0; }
1008
1009 %%
1010
1011 /* Implementation of a dynamically expandable buffer for processing input
1012    characters acquired through lexptr and building a value to return in
1013    yylval. */
1014
1015 static char *tempbuf;           /* Current buffer contents */
1016 static int tempbufsize;         /* Size of allocated buffer */
1017 static int tempbufindex;        /* Current index into buffer */
1018
1019 #define GROWBY_MIN_SIZE 64      /* Minimum amount to grow buffer by */
1020
1021 #define CHECKBUF(size) \
1022   do { \
1023     if (tempbufindex + (size) >= tempbufsize) \
1024       { \
1025         growbuf_by_size (size); \
1026       } \
1027   } while (0);
1028
1029 /* Grow the static temp buffer if necessary, including allocating the first one
1030    on demand. */
1031
1032 static void
1033 growbuf_by_size (count)
1034      int count;
1035 {
1036   int growby;
1037
1038   growby = max (count, GROWBY_MIN_SIZE);
1039   tempbufsize += growby;
1040   if (tempbuf == NULL)
1041     {
1042       tempbuf = (char *) malloc (tempbufsize);
1043     }
1044   else
1045     {
1046       tempbuf = (char *) realloc (tempbuf, tempbufsize);
1047     }
1048 }
1049
1050 /* Try to consume a simple name string token.  If successful, returns
1051    a pointer to a nullbyte terminated copy of the name that can be used
1052    in symbol table lookups.  If not successful, returns NULL. */
1053
1054 static char *
1055 match_simple_name_string ()
1056 {
1057   char *tokptr = lexptr;
1058
1059   if (isalpha (*tokptr) || *tokptr == '_')
1060     {
1061       char *result;
1062       do {
1063         tokptr++;
1064       } while (isalnum (*tokptr) || (*tokptr == '_'));
1065       yylval.sval.ptr = lexptr;
1066       yylval.sval.length = tokptr - lexptr;
1067       lexptr = tokptr;
1068       result = copy_name (yylval.sval);
1069       return result;
1070     }
1071   return (NULL);
1072 }
1073
1074 /* Start looking for a value composed of valid digits as set by the base
1075    in use.  Note that '_' characters are valid anywhere, in any quantity,
1076    and are simply ignored.  Since we must find at least one valid digit,
1077    or reject this token as an integer literal, we keep track of how many
1078    digits we have encountered. */
1079
1080 static int
1081 decode_integer_value (base, tokptrptr, ivalptr)
1082   int base;
1083   char **tokptrptr;
1084   int *ivalptr;
1085 {
1086   char *tokptr = *tokptrptr;
1087   int temp;
1088   int digits = 0;
1089
1090   while (*tokptr != '\0')
1091     {
1092       temp = *tokptr;
1093       if (isupper (temp))
1094         temp = tolower (temp);
1095       tokptr++;
1096       switch (temp)
1097         {
1098         case '_':
1099           continue;
1100         case '0':  case '1':  case '2':  case '3':  case '4':
1101         case '5':  case '6':  case '7':  case '8':  case '9':
1102           temp -= '0';
1103           break;
1104         case 'a':  case 'b':  case 'c':  case 'd':  case 'e': case 'f':
1105           temp -= 'a';
1106           temp += 10;
1107           break;
1108         default:
1109           temp = base;
1110           break;
1111         }
1112       if (temp < base)
1113         {
1114           digits++;
1115           *ivalptr *= base;
1116           *ivalptr += temp;
1117         }
1118       else
1119         {
1120           /* Found something not in domain for current base. */
1121           tokptr--;     /* Unconsume what gave us indigestion. */
1122           break;
1123         }
1124     }
1125
1126   /* If we didn't find any digits, then we don't have a valid integer
1127      value, so reject the entire token.  Otherwise, update the lexical
1128      scan pointer, and return non-zero for success. */
1129
1130   if (digits == 0)
1131     {
1132       return (0);
1133     }
1134   else
1135     {
1136       *tokptrptr = tokptr;
1137       return (1);
1138     }
1139 }
1140
1141 static int
1142 decode_integer_literal (valptr, tokptrptr)
1143   int *valptr;
1144   char **tokptrptr;
1145 {
1146   char *tokptr = *tokptrptr;
1147   int base = 0;
1148   int ival = 0;
1149   int explicit_base = 0;
1150
1151   /* Look for an explicit base specifier, which is optional. */
1152
1153   switch (*tokptr)
1154     {
1155     case 'd':
1156     case 'D':
1157       explicit_base++;
1158       base = 10;
1159       tokptr++;
1160       break;
1161     case 'b':
1162     case 'B':
1163       explicit_base++;
1164       base = 2;
1165       tokptr++;
1166       break;
1167     case 'h':
1168     case 'H':
1169       explicit_base++;
1170       base = 16;
1171       tokptr++;
1172       break;
1173     case 'o':
1174     case 'O':
1175       explicit_base++;
1176       base = 8;
1177       tokptr++;
1178       break;
1179     default:
1180       base = 10;
1181       break;
1182     }
1183
1184   /* If we found an explicit base ensure that the character after the
1185      explicit base is a single quote. */
1186
1187   if (explicit_base && (*tokptr++ != '\''))
1188     {
1189       return (0);
1190     }
1191
1192   /* Attempt to decode whatever follows as an integer value in the
1193      indicated base, updating the token pointer in the process and
1194      computing the value into ival.  Also, if we have an explicit
1195      base, then the next character must not be a single quote, or we
1196      have a bitstring literal, so reject the entire token in this case.
1197      Otherwise, update the lexical scan pointer, and return non-zero
1198      for success. */
1199
1200   if (!decode_integer_value (base, &tokptr, &ival))
1201     {
1202       return (0);
1203     }
1204   else if (explicit_base && (*tokptr == '\''))
1205     {
1206       return (0);
1207     }
1208   else
1209     {
1210       *valptr = ival;
1211       *tokptrptr = tokptr;
1212       return (1);
1213     }
1214 }
1215
1216 /*  If it wasn't for the fact that floating point values can contain '_'
1217     characters, we could just let strtod do all the hard work by letting it
1218     try to consume as much of the current token buffer as possible and
1219     find a legal conversion.  Unfortunately we need to filter out the '_'
1220     characters before calling strtod, which we do by copying the other
1221     legal chars to a local buffer to be converted.  However since we also
1222     need to keep track of where the last unconsumed character in the input
1223     buffer is, we have transfer only as many characters as may compose a
1224     legal floating point value. */
1225
1226 static int
1227 match_float_literal ()
1228 {
1229   char *tokptr = lexptr;
1230   char *buf;
1231   char *copy;
1232   double dval;
1233   extern double strtod ();
1234
1235   /* Make local buffer in which to build the string to convert.  This is
1236      required because underscores are valid in chill floating point numbers
1237      but not in the string passed to strtod to convert.  The string will be
1238      no longer than our input string. */
1239
1240   copy = buf = (char *) alloca (strlen (tokptr) + 1);
1241
1242   /* Transfer all leading digits to the conversion buffer, discarding any
1243      underscores. */
1244
1245   while (isdigit (*tokptr) || *tokptr == '_')
1246     {
1247       if (*tokptr != '_')
1248         {
1249           *copy++ = *tokptr;
1250         }
1251       tokptr++;
1252     }
1253
1254   /* Now accept either a '.', or one of [eEdD].  Dot is legal regardless
1255      of whether we found any leading digits, and we simply accept it and
1256      continue on to look for the fractional part and/or exponent.  One of
1257      [eEdD] is legal only if we have seen digits, and means that there
1258      is no fractional part.  If we find neither of these, then this is
1259      not a floating point number, so return failure. */
1260
1261   switch (*tokptr++)
1262     {
1263       case '.':
1264         /* Accept and then look for fractional part and/or exponent. */
1265         *copy++ = '.';
1266         break;
1267
1268       case 'e':
1269       case 'E':
1270       case 'd':
1271       case 'D':
1272         if (copy == buf)
1273           {
1274             return (0);
1275           }
1276         *copy++ = 'e';
1277         goto collect_exponent;
1278         break;
1279
1280       default:
1281         return (0);
1282         break;
1283     }
1284
1285   /* We found a '.', copy any fractional digits to the conversion buffer, up
1286      to the first nondigit, non-underscore character. */
1287
1288   while (isdigit (*tokptr) || *tokptr == '_')
1289     {
1290       if (*tokptr != '_')
1291         {
1292           *copy++ = *tokptr;
1293         }
1294       tokptr++;
1295     }
1296
1297   /* Look for an exponent, which must start with one of [eEdD].  If none
1298      is found, jump directly to trying to convert what we have collected
1299      so far. */
1300
1301   switch (*tokptr)
1302     {
1303       case 'e':
1304       case 'E':
1305       case 'd':
1306       case 'D':
1307         *copy++ = 'e';
1308         tokptr++;
1309         break;
1310       default:
1311         goto convert_float;
1312         break;
1313     }
1314
1315   /* Accept an optional '-' or '+' following one of [eEdD]. */
1316
1317   collect_exponent:
1318   if (*tokptr == '+' || *tokptr == '-')
1319     {
1320       *copy++ = *tokptr++;
1321     }
1322
1323   /* Now copy an exponent into the conversion buffer.  Note that at the
1324      moment underscores are *not* allowed in exponents. */
1325
1326   while (isdigit (*tokptr))
1327     {
1328       *copy++ = *tokptr++;
1329     }
1330
1331   /* If we transfered any chars to the conversion buffer, try to interpret its
1332      contents as a floating point value.  If any characters remain, then we
1333      must not have a valid floating point string. */
1334
1335   convert_float:
1336   *copy = '\0';
1337   if (copy != buf)
1338       {
1339         dval = strtod (buf, &copy);
1340         if (*copy == '\0')
1341           {
1342             yylval.dval = dval;
1343             lexptr = tokptr;
1344             return (FLOAT_LITERAL);
1345           }
1346       }
1347   return (0);
1348 }
1349
1350 /* Recognize a string literal.  A string literal is a sequence
1351    of characters enclosed in matching single or double quotes, except that
1352    a single character inside single quotes is a character literal, which
1353    we reject as a string literal.  To embed the terminator character inside
1354    a string, it is simply doubled (I.E. "this""is""one""string") */
1355
1356 static int
1357 match_string_literal ()
1358 {
1359   char *tokptr = lexptr;
1360
1361   for (tempbufindex = 0, tokptr++; *tokptr != '\0'; tokptr++)
1362     {
1363       CHECKBUF (1);
1364       if (*tokptr == *lexptr)
1365         {
1366           if (*(tokptr + 1) == *lexptr)
1367             {
1368               tokptr++;
1369             }
1370           else
1371             {
1372               break;
1373             }
1374         }
1375       tempbuf[tempbufindex++] = *tokptr;
1376     }
1377   if (*tokptr == '\0'                                   /* no terminator */
1378       || (tempbufindex == 1 && *tokptr == '\''))        /* char literal */
1379     {
1380       return (0);
1381     }
1382   else
1383     {
1384       tempbuf[tempbufindex] = '\0';
1385       yylval.sval.ptr = tempbuf;
1386       yylval.sval.length = tempbufindex;
1387       lexptr = ++tokptr;
1388       return (CHARACTER_STRING_LITERAL);
1389     }
1390 }
1391
1392 /* Recognize a character literal.  A character literal is single character
1393    or a control sequence, enclosed in single quotes.  A control sequence
1394    is a comma separated list of one or more integer literals, enclosed
1395    in parenthesis and introduced with a circumflex character.
1396
1397    EX:  'a'  '^(7)'  '^(7,8)'
1398
1399    As a GNU chill extension, the syntax C'xx' is also recognized as a
1400    character literal, where xx is a hex value for the character.
1401
1402    Note that more than a single character, enclosed in single quotes, is
1403    a string literal.
1404
1405    Also note that the control sequence form is not in GNU Chill since it
1406    is ambiguous with the string literal form using single quotes.  I.E.
1407    is '^(7)' a character literal or a string literal.  In theory it it
1408    possible to tell by context, but GNU Chill doesn't accept the control
1409    sequence form, so neither do we (for now the code is disabled).
1410
1411    Returns CHARACTER_LITERAL if a match is found.
1412    */
1413
1414 static int
1415 match_character_literal ()
1416 {
1417   char *tokptr = lexptr;
1418   int ival = 0;
1419
1420   if ((*tokptr == 'c' || *tokptr == 'C') && (*(tokptr + 1) == '\''))
1421     {
1422       /* We have a GNU chill extension form, so skip the leading "C'",
1423          decode the hex value, and then ensure that we have a trailing
1424          single quote character. */
1425       tokptr += 2;
1426       if (!decode_integer_value (16, &tokptr, &ival) || (*tokptr != '\''))
1427         {
1428           return (0);
1429         }
1430       tokptr++;
1431     }
1432   else if (*tokptr == '\'')
1433     {
1434       tokptr++;
1435
1436       /* Determine which form we have, either a control sequence or the
1437          single character form. */
1438
1439       if ((*tokptr == '^') && (*(tokptr + 1) == '('))
1440         {
1441 #if 0     /* Disable, see note above. -fnf */
1442           /* Match and decode a control sequence.  Return zero if we don't
1443              find a valid integer literal, or if the next unconsumed character
1444              after the integer literal is not the trailing ')'.
1445              FIXME:  We currently don't handle the multiple integer literal
1446              form. */
1447           tokptr += 2;
1448           if (!decode_integer_literal (&ival, &tokptr) || (*tokptr++ != ')'))
1449             {
1450               return (0);
1451             }
1452 #else
1453           return (0);
1454 #endif
1455         }
1456       else
1457         {
1458           ival = *tokptr++;
1459         }
1460
1461       /* The trailing quote has not yet been consumed.  If we don't find
1462          it, then we have no match. */
1463
1464       if (*tokptr++ != '\'')
1465         {
1466           return (0);
1467         }
1468     }
1469   else
1470     {
1471       /* Not a character literal. */
1472       return (0);
1473     }
1474   yylval.typed_val.val = ival;
1475   yylval.typed_val.type = builtin_type_chill_char;
1476   lexptr = tokptr;
1477   return (CHARACTER_LITERAL);
1478 }
1479
1480 /* Recognize an integer literal, as specified in Z.200 sec 5.2.4.2.
1481    Note that according to 5.2.4.2, a single "_" is also a valid integer
1482    literal, however GNU-chill requires there to be at least one "digit"
1483    in any integer literal. */
1484
1485 static int
1486 match_integer_literal ()
1487 {
1488   char *tokptr = lexptr;
1489   int ival;
1490
1491   if (!decode_integer_literal (&ival, &tokptr))
1492     {
1493       return (0);
1494     }
1495   else
1496     {
1497       yylval.typed_val.val = ival;
1498       yylval.typed_val.type = builtin_type_int;
1499       lexptr = tokptr;
1500       return (INTEGER_LITERAL);
1501     }
1502 }
1503
1504 /* Recognize a bit-string literal, as specified in Z.200 sec 5.2.4.8
1505    Note that according to 5.2.4.8, a single "_" is also a valid bit-string
1506    literal, however GNU-chill requires there to be at least one "digit"
1507    in any bit-string literal. */
1508
1509 static int
1510 match_bitstring_literal ()
1511 {
1512   register char *tokptr = lexptr;
1513   int bitoffset = 0;
1514   int bitcount = 0;
1515   int bits_per_char;
1516   int digit;
1517
1518   tempbufindex = 0;
1519   CHECKBUF (1);
1520   tempbuf[0] = 0;
1521
1522   /* Look for the required explicit base specifier. */
1523
1524   switch (*tokptr++)
1525     {
1526     case 'b':
1527     case 'B':
1528       bits_per_char = 1;
1529       break;
1530     case 'o':
1531     case 'O':
1532       bits_per_char = 3;
1533       break;
1534     case 'h':
1535     case 'H':
1536       bits_per_char = 4;
1537       break;
1538     default:
1539       return (0);
1540       break;
1541     }
1542
1543   /* Ensure that the character after the explicit base is a single quote. */
1544
1545   if (*tokptr++ != '\'')
1546     {
1547       return (0);
1548     }
1549
1550   while (*tokptr != '\0' && *tokptr != '\'')
1551     {
1552       digit = *tokptr;
1553       if (isupper (digit))
1554         digit = tolower (digit);
1555       tokptr++;
1556       switch (digit)
1557         {
1558           case '_':
1559             continue;
1560           case '0':  case '1':  case '2':  case '3':  case '4':
1561           case '5':  case '6':  case '7':  case '8':  case '9':
1562             digit -= '0';
1563             break;
1564           case 'a':  case 'b':  case 'c':  case 'd':  case 'e': case 'f':
1565             digit -= 'a';
1566             digit += 10;
1567             break;
1568           default:
1569             return (0);
1570             break;
1571         }
1572       if (digit >= 1 << bits_per_char)
1573         {
1574           /* Found something not in domain for current base. */
1575           return (0);
1576         }
1577       else
1578         {
1579           /* Extract bits from digit, packing them into the bitstring byte. */
1580           int k = TARGET_BYTE_ORDER == BIG_ENDIAN ? bits_per_char - 1 : 0;
1581           for (; TARGET_BYTE_ORDER == BIG_ENDIAN ? k >= 0 : k < bits_per_char;
1582                TARGET_BYTE_ORDER == BIG_ENDIAN ? k-- : k++)
1583             {
1584               bitcount++;
1585               if (digit & (1 << k))
1586                 {
1587                   tempbuf[tempbufindex] |=
1588                     (TARGET_BYTE_ORDER == BIG_ENDIAN)
1589                       ? (1 << (HOST_CHAR_BIT - 1 - bitoffset))
1590                         : (1 << bitoffset);
1591                 }
1592               bitoffset++;
1593               if (bitoffset == HOST_CHAR_BIT)
1594                 {
1595                   bitoffset = 0;
1596                   tempbufindex++;
1597                   CHECKBUF(1);
1598                   tempbuf[tempbufindex] = 0;
1599                 }
1600             }
1601         }
1602     }
1603
1604   /* Verify that we consumed everything up to the trailing single quote,
1605      and that we found some bits (IE not just underbars). */
1606
1607   if (*tokptr++ != '\'')
1608     {
1609       return (0);
1610     }
1611   else
1612     {
1613       yylval.sval.ptr = tempbuf;
1614       yylval.sval.length = bitcount;
1615       lexptr = tokptr;
1616       return (BIT_STRING_LITERAL);
1617     }
1618 }
1619
1620 /* Recognize tokens that start with '$'.  These include:
1621
1622         $regname        A native register name or a "standard
1623                         register name".
1624                         Return token GDB_REGNAME.
1625
1626         $variable       A convenience variable with a name chosen
1627                         by the user.
1628                         Return token GDB_VARIABLE.
1629
1630         $digits         Value history with index <digits>, starting
1631                         from the first value which has index 1.
1632                         Return GDB_LAST.
1633
1634         $$digits        Value history with index <digits> relative
1635                         to the last value.  I.E. $$0 is the last
1636                         value, $$1 is the one previous to that, $$2
1637                         is the one previous to $$1, etc.
1638                         Return token GDB_LAST.
1639
1640         $ | $0 | $$0    The last value in the value history.
1641                         Return token GDB_LAST.
1642
1643         $$              An abbreviation for the second to the last
1644                         value in the value history, I.E. $$1
1645                         Return token GDB_LAST.
1646
1647     Note that we currently assume that register names and convenience
1648     variables follow the convention of starting with a letter or '_'.
1649
1650    */
1651
1652 static int
1653 match_dollar_tokens ()
1654 {
1655   char *tokptr;
1656   int regno;
1657   int namelength;
1658   int negate;
1659   int ival;
1660
1661   /* We will always have a successful match, even if it is just for
1662      a single '$', the abbreviation for $$0.  So advance lexptr. */
1663
1664   tokptr = ++lexptr;
1665
1666   if (*tokptr == '_' || isalpha (*tokptr))
1667     {
1668       /* Look for a match with a native register name, usually something
1669          like "r0" for example. */
1670
1671       for (regno = 0; regno < NUM_REGS; regno++)
1672         {
1673           namelength = strlen (reg_names[regno]);
1674           if (STREQN (tokptr, reg_names[regno], namelength)
1675               && !isalnum (tokptr[namelength]))
1676             {
1677               yylval.lval = regno;
1678               lexptr += namelength;
1679               return (GDB_REGNAME);
1680             }
1681         }
1682
1683       /* Look for a match with a standard register name, usually something
1684          like "pc", which gdb always recognizes as the program counter
1685          regardless of what the native register name is. */
1686
1687       for (regno = 0; regno < num_std_regs; regno++)
1688         {
1689           namelength = strlen (std_regs[regno].name);
1690           if (STREQN (tokptr, std_regs[regno].name, namelength)
1691               && !isalnum (tokptr[namelength]))
1692             {
1693               yylval.lval = std_regs[regno].regnum;
1694               lexptr += namelength;
1695               return (GDB_REGNAME);
1696             }
1697         }
1698
1699       /* Attempt to match against a convenience variable.  Note that
1700          this will always succeed, because if no variable of that name
1701          already exists, the lookup_internalvar will create one for us.
1702          Also note that both lexptr and tokptr currently point to the
1703          start of the input string we are trying to match, and that we
1704          have already tested the first character for non-numeric, so we
1705          don't have to treat it specially. */
1706
1707       while (*tokptr == '_' || isalnum (*tokptr))
1708         {
1709           tokptr++;
1710         }
1711       yylval.sval.ptr = lexptr;
1712       yylval.sval.length = tokptr - lexptr;
1713       yylval.ivar = lookup_internalvar (copy_name (yylval.sval));
1714       lexptr = tokptr;
1715       return (GDB_VARIABLE);
1716     }
1717
1718   /* Since we didn't match against a register name or convenience
1719      variable, our only choice left is a history value. */
1720
1721   if (*tokptr == '$')
1722     {
1723       negate = 1;
1724       ival = 1;
1725       tokptr++;
1726     }
1727   else
1728     {
1729       negate = 0;
1730       ival = 0;
1731     }
1732
1733   /* Attempt to decode more characters as an integer value giving
1734      the index in the history list.  If successful, the value will
1735      overwrite ival (currently 0 or 1), and if not, ival will be
1736      left alone, which is good since it is currently correct for
1737      the '$' or '$$' case. */
1738
1739   decode_integer_literal (&ival, &tokptr);
1740   yylval.lval = negate ? -ival : ival;
1741   lexptr = tokptr;
1742   return (GDB_LAST);
1743 }
1744
1745 struct token
1746 {
1747   char *operator;
1748   int token;
1749 };
1750
1751 static const struct token idtokentab[] =
1752 {
1753     { "array", ARRAY },
1754     { "length", LENGTH },
1755     { "lower", LOWER },
1756     { "upper", UPPER },
1757     { "andif", ANDIF },
1758     { "pred", PRED },
1759     { "succ", SUCC },
1760     { "card", CARD },
1761     { "size", SIZE },
1762     { "orif", ORIF },
1763     { "num", NUM },
1764     { "abs", ABS },
1765     { "max", MAX_TOKEN },
1766     { "min", MIN_TOKEN },
1767     { "mod", MOD },
1768     { "rem", REM },
1769     { "not", NOT },
1770     { "xor", LOGXOR },
1771     { "and", LOGAND },
1772     { "in", IN },
1773     { "or", LOGIOR },
1774     { "up", UP },
1775     { "null", EMPTINESS_LITERAL }
1776 };
1777
1778 static const struct token tokentab2[] =
1779 {
1780     { ":=", GDB_ASSIGNMENT },
1781     { "//", SLASH_SLASH },
1782     { "->", POINTER },
1783     { "/=", NOTEQUAL },
1784     { "<=", LEQ },
1785     { ">=", GTR }
1786 };
1787
1788 /* Read one token, getting characters through lexptr.  */
1789 /* This is where we will check to make sure that the language and the
1790    operators used are compatible.  */
1791
1792 static int
1793 yylex ()
1794 {
1795     unsigned int i;
1796     int token;
1797     char *inputname;
1798     struct symbol *sym;
1799
1800     /* Skip over any leading whitespace. */
1801     while (isspace (*lexptr))
1802         {
1803             lexptr++;
1804         }
1805     /* Look for special single character cases which can't be the first
1806        character of some other multicharacter token. */
1807     switch (*lexptr)
1808         {
1809             case '\0':
1810                 return (0);
1811             case ',':
1812             case '=':
1813             case ';':
1814             case '!':
1815             case '+':
1816             case '*':
1817             case '(':
1818             case ')':
1819             case '[':
1820             case ']':
1821                 return (*lexptr++);
1822         }
1823     /* Look for characters which start a particular kind of multicharacter
1824        token, such as a character literal, register name, convenience
1825        variable name, string literal, etc. */
1826     switch (*lexptr)
1827       {
1828         case '\'':
1829         case '\"':
1830           /* First try to match a string literal, which is any
1831              sequence of characters enclosed in matching single or double
1832              quotes, except that a single character inside single quotes
1833              is a character literal, so we have to catch that case also. */
1834           token = match_string_literal ();
1835           if (token != 0)
1836             {
1837               return (token);
1838             }
1839           if (*lexptr == '\'')
1840             {
1841               token = match_character_literal ();
1842               if (token != 0)
1843                 {
1844                   return (token);
1845                 }
1846             }
1847           break;
1848         case 'C':
1849         case 'c':
1850           token = match_character_literal ();
1851           if (token != 0)
1852             {
1853               return (token);
1854             }
1855           break;
1856         case '$':
1857           token = match_dollar_tokens ();
1858           if (token != 0)
1859             {
1860               return (token);
1861             }
1862           break;
1863       }
1864     /* See if it is a special token of length 2.  */
1865     for (i = 0; i < sizeof (tokentab2) / sizeof (tokentab2[0]); i++)
1866         {
1867             if (STREQN (lexptr, tokentab2[i].operator, 2))
1868                 {
1869                     lexptr += 2;
1870                     return (tokentab2[i].token);
1871                 }
1872         }
1873     /* Look for single character cases which which could be the first
1874        character of some other multicharacter token, but aren't, or we
1875        would already have found it. */
1876     switch (*lexptr)
1877         {
1878             case '-':
1879             case ':':
1880             case '/':
1881             case '<':
1882             case '>':
1883                 return (*lexptr++);
1884         }
1885     /* Look for a float literal before looking for an integer literal, so
1886        we match as much of the input stream as possible. */
1887     token = match_float_literal ();
1888     if (token != 0)
1889         {
1890             return (token);
1891         }
1892     token = match_bitstring_literal ();
1893     if (token != 0)
1894         {
1895             return (token);
1896         }
1897     token = match_integer_literal ();
1898     if (token != 0)
1899         {
1900             return (token);
1901         }
1902
1903     /* Try to match a simple name string, and if a match is found, then
1904        further classify what sort of name it is and return an appropriate
1905        token.  Note that attempting to match a simple name string consumes
1906        the token from lexptr, so we can't back out if we later find that
1907        we can't classify what sort of name it is. */
1908
1909     inputname = match_simple_name_string ();
1910
1911     if (inputname != NULL)
1912       {
1913         char *simplename = (char*) alloca (strlen (inputname) + 1);
1914
1915         char *dptr = simplename, *sptr = inputname;
1916         for (; *sptr; sptr++)
1917           *dptr++ = isupper (*sptr) ? tolower(*sptr) : *sptr;
1918         *dptr = '\0';
1919
1920         /* See if it is a reserved identifier. */
1921         for (i = 0; i < sizeof (idtokentab) / sizeof (idtokentab[0]); i++)
1922             {
1923                 if (STREQ (simplename, idtokentab[i].operator))
1924                     {
1925                         return (idtokentab[i].token);
1926                     }
1927             }
1928
1929         /* Look for other special tokens. */
1930         if (STREQ (simplename, "true"))
1931             {
1932                 yylval.ulval = 1;
1933                 return (BOOLEAN_LITERAL);
1934             }
1935         if (STREQ (simplename, "false"))
1936             {
1937                 yylval.ulval = 0;
1938                 return (BOOLEAN_LITERAL);
1939             }
1940
1941         sym = lookup_symbol (inputname, expression_context_block,
1942                              VAR_NAMESPACE, (int *) NULL,
1943                              (struct symtab **) NULL);
1944         if (sym == NULL && strcmp (inputname, simplename) != 0)
1945           {
1946             sym = lookup_symbol (simplename, expression_context_block,
1947                                  VAR_NAMESPACE, (int *) NULL,
1948                                  (struct symtab **) NULL);
1949           }
1950         if (sym != NULL)
1951           {
1952             yylval.ssym.stoken.ptr = NULL;
1953             yylval.ssym.stoken.length = 0;
1954             yylval.ssym.sym = sym;
1955             yylval.ssym.is_a_field_of_this = 0; /* FIXME, C++'ism */
1956             switch (SYMBOL_CLASS (sym))
1957               {
1958               case LOC_BLOCK:
1959                 /* Found a procedure name. */
1960                 return (GENERAL_PROCEDURE_NAME);
1961               case LOC_STATIC:
1962                 /* Found a global or local static variable. */
1963                 return (LOCATION_NAME);
1964               case LOC_REGISTER:
1965               case LOC_ARG:
1966               case LOC_REF_ARG:
1967               case LOC_REGPARM:
1968               case LOC_REGPARM_ADDR:
1969               case LOC_LOCAL:
1970               case LOC_LOCAL_ARG:
1971               case LOC_BASEREG:
1972               case LOC_BASEREG_ARG:
1973                 if (innermost_block == NULL
1974                     || contained_in (block_found, innermost_block))
1975                   {
1976                     innermost_block = block_found;
1977                   }
1978                 return (LOCATION_NAME);
1979                 break;
1980               case LOC_CONST:
1981               case LOC_LABEL:
1982                 return (LOCATION_NAME);
1983                 break;
1984               case LOC_TYPEDEF:
1985                 yylval.tsym.type = SYMBOL_TYPE (sym);
1986                 return TYPENAME;
1987               case LOC_UNDEF:
1988               case LOC_CONST_BYTES:
1989               case LOC_OPTIMIZED_OUT:
1990                 error ("Symbol \"%s\" names no location.", inputname);
1991                 break;
1992               }
1993           }
1994         else if (!have_full_symbols () && !have_partial_symbols ())
1995           {
1996             error ("No symbol table is loaded.  Use the \"file\" command.");
1997           }
1998         else
1999           {
2000             error ("No symbol \"%s\" in current context.", inputname);
2001           }
2002       }
2003
2004     /* Catch single character tokens which are not part of some
2005        longer token. */
2006
2007     switch (*lexptr)
2008       {
2009         case '.':                       /* Not float for example. */
2010           lexptr++;
2011           while (isspace (*lexptr)) lexptr++;
2012           inputname = match_simple_name_string ();
2013           if (!inputname)
2014             return '.';
2015           return FIELD_NAME;
2016       }
2017
2018     return (ILLEGAL_TOKEN);
2019 }
2020
2021 void
2022 yyerror (msg)
2023      char *msg;
2024 {
2025   error ("A %s in expression, near `%s'.", (msg ? msg : "error"), lexptr);
2026 }