gdb/m2-exp.y

   1 /* YACC grammar for Modula-2 expressions, for GDB.
   2    Copyright (C) 1986, 1989, 1990, 1991 Free Software Foundation, Inc.
   3    Generated from expread.y (now c-exp.y) and contributed by the Department
   4    of Computer Science at the State University of New York at Buffalo, 1991.
   5
   6 This file is part of GDB.
   7
   8 This program is free software; you can redistribute it and/or modify
   9 it under the terms of the GNU General Public License as published by
  10 the Free Software Foundation; either version 2 of the License, or
  11 (at your option) any later version.
  12
  13 This program is distributed in the hope that it will be useful,
  14 but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 GNU General Public License for more details.
  17
  18 You should have received a copy of the GNU General Public License
  19 along with this program; if not, write to the Free Software
  20 Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.  */
  21
  22 /* Parse a Modula-2 expression from text in a string,
  23    and return the result as a  struct expression  pointer.
  24    That structure contains arithmetic operations in reverse polish,
  25    with constants represented by operations that are followed by special data.
  26    See expression.h for the details of the format.
  27    What is important here is that it can be built up sequentially
  28    during the process of parsing; the lower levels of the tree always
  29    come first in the result.
  30
  31    Note that malloc's and realloc's in this file are transformed to
  32    xmalloc and xrealloc respectively by the same sed command in the
  33    makefile that remaps any other malloc/realloc inserted by the parser
  34    generator.  Doing this with #defines and trying to control the interaction
  35    with include files (<malloc.h> and <stdlib.h> for example) just became
  36    too messy, particularly when such includes can be inserted at random
  37    times by the parser generator. */
  38
  39 %{
  40
  41 #include <stdio.h>
  42 #include <string.h>
  43 #include "defs.h"
  44 #include "symtab.h"
  45 #include "gdbtypes.h"
  46 #include "frame.h"
  47 #include "expression.h"
  48 #include "language.h"
  49 #include "value.h"
  50 #include "parser-defs.h"
  51 #include "bfd.h"
  52 #include "symfile.h"
  53 #include "objfiles.h"
  54
  55 /* These MUST be included in any grammar file!!!! Please choose unique names!
  56    Note that this are a combined list of variables that can be produced
  57    by any one of bison, byacc, or yacc. */
  58 #define yymaxdepth m2_maxdepth
  59 #define yyparse m2_parse
  60 #define yylex   m2_lex
  61 #define yyerror m2_error
  62 #define yylval  m2_lval
  63 #define yychar  m2_char
  64 #define yydebug m2_debug
  65 #define yypact  m2_pact
  66 #define yyr1    m2_r1
  67 #define yyr2    m2_r2
  68 #define yydef   m2_def
  69 #define yychk   m2_chk
  70 #define yypgo   m2_pgo
  71 #define yyact   m2_act
  72 #define yyexca  m2_exca
  73 #define yyerrflag m2_errflag
  74 #define yynerrs m2_nerrs
  75 #define yyps    m2_ps
  76 #define yypv    m2_pv
  77 #define yys     m2_s
  78 #define yy_yys  m2_yys
  79 #define yystate m2_state
  80 #define yytmp   m2_tmp
  81 #define yyv     m2_v
  82 #define yy_yyv  m2_yyv
  83 #define yyval   m2_val
  84 #define yylloc  m2_lloc
  85 #define yyss    m2_yyss         /* byacc */
  86 #define yyssp   m2_yysp         /* byacc */
  87 #define yyvs    m2_yyvs         /* byacc */
  88 #define yyvsp   m2_yyvsp        /* byacc */
  89
  90 #if 0
  91 static char *
  92 make_qualname PARAMS ((char *, char *));
  93 #endif
  94
  95 static int
  96 parse_number PARAMS ((int));
  97
  98 static int
  99 yylex PARAMS ((void));
 100
 101 static void
 102 yyerror PARAMS ((char *));
 103
 104 int
 105 yyparse PARAMS ((void));
 106
 107 /* The sign of the number being parsed. */
 108 int number_sign = 1;
 109
 110 /* The block that the module specified by the qualifer on an identifer is
 111    contained in, */
 112 struct block *modblock=0;
 113
 114 /* #define      YYDEBUG 1 */
 115 %}
 116
 117 /* Although the yacc "value" of an expression is not used,
 118    since the result is stored in the structure being created,
 119    other node types do have values.  */
 120
 121 %union
 122   {
 123     LONGEST lval;
 124     unsigned LONGEST ulval;
 125     double dval;
 126     struct symbol *sym;
 127     struct type *tval;
 128     struct stoken sval;
 129     int voidval;
 130     struct block *bval;
 131     enum exp_opcode opcode;
 132     struct internalvar *ivar;
 133
 134     struct type **tvec;
 135     int *ivec;
 136   }
 137
 138 %type <voidval> exp type_exp start set
 139 %type <voidval> variable
 140 %type <tval> type
 141 %type <bval> block
 142 %type <sym> fblock
 143
 144 %token <lval> INT HEX ERROR
 145 %token <ulval> UINT M2_TRUE M2_FALSE CHAR
 146 %token <dval> FLOAT
 147
 148 /* Both NAME and TYPENAME tokens represent symbols in the input,
 149    and both convey their data as strings.
 150    But a TYPENAME is a string that happens to be defined as a typedef
 151    or builtin type name (such as int or char)
 152    and a NAME is any other symbol.
 153
 154    Contexts where this distinction is not important can use the
 155    nonterminal "name", which matches either NAME or TYPENAME.  */
 156
 157 %token <sval> STRING
 158 %token <sval> NAME BLOCKNAME IDENT VARNAME
 159 %token <sval> TYPENAME
 160
 161 %token SIZE CAP ORD HIGH ABS MIN_FUNC MAX_FUNC FLOAT_FUNC VAL CHR ODD TRUNC
 162 %token INC DEC INCL EXCL
 163
 164 /* The GDB scope operator */
 165 %token COLONCOLON
 166
 167 %token <lval> LAST REGNAME
 168
 169 %token <ivar> INTERNAL_VAR
 170
 171 /* M2 tokens */
 172 %left ','
 173 %left ABOVE_COMMA
 174 %nonassoc ASSIGN
 175 %left '<' '>' LEQ GEQ '=' NOTEQUAL '#' IN
 176 %left OROR
 177 %left ANDAND '&'
 178 %left '@'
 179 %left '+' '-'
 180 %left '*' '/' DIV MOD
 181 %right UNARY
 182 %right '^' DOT '[' '('
 183 %right NOT '~'
 184 %left COLONCOLON QID
 185 /* This is not an actual token ; it is used for precedence.
 186 %right QID
 187 */
 188
 189 \f
 190 %%
 191
 192 start   :       exp
 193         |       type_exp
 194         ;
 195
 196 type_exp:       type
 197                 { write_exp_elt_opcode(OP_TYPE);
 198                   write_exp_elt_type($1);
 199                   write_exp_elt_opcode(OP_TYPE);
 200                 }
 201         ;
 202
 203 /* Expressions */
 204
 205 exp     :       exp '^'   %prec UNARY
 206                         { write_exp_elt_opcode (UNOP_IND); }
 207
 208 exp     :       '-'
 209                         { number_sign = -1; }
 210                 exp    %prec UNARY
 211                         { number_sign = 1;
 212                           write_exp_elt_opcode (UNOP_NEG); }
 213         ;
 214
 215 exp     :       '+' exp    %prec UNARY
 216                 { write_exp_elt_opcode(UNOP_PLUS); }
 217         ;
 218
 219 exp     :       not_exp exp %prec UNARY
 220                         { write_exp_elt_opcode (UNOP_ZEROP); }
 221         ;
 222
 223 not_exp :       NOT
 224         |       '~'
 225         ;
 226
 227 exp     :       CAP '(' exp ')'
 228                         { write_exp_elt_opcode (UNOP_CAP); }
 229         ;
 230
 231 exp     :       ORD '(' exp ')'
 232                         { write_exp_elt_opcode (UNOP_ORD); }
 233         ;
 234
 235 exp     :       ABS '(' exp ')'
 236                         { write_exp_elt_opcode (UNOP_ABS); }
 237         ;
 238
 239 exp     :       HIGH '(' exp ')'
 240                         { write_exp_elt_opcode (UNOP_HIGH); }
 241         ;
 242
 243 exp     :       MIN_FUNC '(' type ')'
 244                         { write_exp_elt_opcode (UNOP_MIN);
 245                           write_exp_elt_type ($3);
 246                           write_exp_elt_opcode (UNOP_MIN); }
 247         ;
 248
 249 exp     :       MAX_FUNC '(' type ')'
 250                         { write_exp_elt_opcode (UNOP_MAX);
 251                           write_exp_elt_type ($3);
 252                           write_exp_elt_opcode (UNOP_MIN); }
 253         ;
 254
 255 exp     :       FLOAT_FUNC '(' exp ')'
 256                         { write_exp_elt_opcode (UNOP_FLOAT); }
 257         ;
 258
 259 exp     :       VAL '(' type ',' exp ')'
 260                         { write_exp_elt_opcode (BINOP_VAL);
 261                           write_exp_elt_type ($3);
 262                           write_exp_elt_opcode (BINOP_VAL); }
 263         ;
 264
 265 exp     :       CHR '(' exp ')'
 266                         { write_exp_elt_opcode (UNOP_CHR); }
 267         ;
 268
 269 exp     :       ODD '(' exp ')'
 270                         { write_exp_elt_opcode (UNOP_ODD); }
 271         ;
 272
 273 exp     :       TRUNC '(' exp ')'
 274                         { write_exp_elt_opcode (UNOP_TRUNC); }
 275         ;
 276
 277 exp     :       SIZE exp       %prec UNARY
 278                         { write_exp_elt_opcode (UNOP_SIZEOF); }
 279         ;
 280
 281
 282 exp     :       INC '(' exp ')'
 283                         { write_exp_elt_opcode(UNOP_PREINCREMENT); }
 284         ;
 285
 286 exp     :       INC '(' exp ',' exp ')'
 287                         { write_exp_elt_opcode(BINOP_ASSIGN_MODIFY);
 288                           write_exp_elt_opcode(BINOP_ADD);
 289                           write_exp_elt_opcode(BINOP_ASSIGN_MODIFY); }
 290         ;
 291
 292 exp     :       DEC '(' exp ')'
 293                         { write_exp_elt_opcode(UNOP_PREDECREMENT);}
 294         ;
 295
 296 exp     :       DEC '(' exp ',' exp ')'
 297                         { write_exp_elt_opcode(BINOP_ASSIGN_MODIFY);
 298                           write_exp_elt_opcode(BINOP_SUB);
 299                           write_exp_elt_opcode(BINOP_ASSIGN_MODIFY); }
 300         ;
 301
 302 exp     :       exp DOT NAME
 303                         { write_exp_elt_opcode (STRUCTOP_STRUCT);
 304                           write_exp_string ($3);
 305                           write_exp_elt_opcode (STRUCTOP_STRUCT); }
 306         ;
 307
 308 exp     :       set
 309         ;
 310
 311 exp     :       exp IN set
 312                         { error("Sets are not implemented.");}
 313         ;
 314
 315 exp     :       INCL '(' exp ',' exp ')'
 316                         { error("Sets are not implemented.");}
 317         ;
 318
 319 exp     :       EXCL '(' exp ',' exp ')'
 320                         { error("Sets are not implemented.");}
 321
 322 set     :       '{' arglist '}'
 323                         { error("Sets are not implemented.");}
 324         |       type '{' arglist '}'
 325                         { error("Sets are not implemented.");}
 326         ;
 327
 328
 329 /* Modula-2 array subscript notation [a,b,c...] */
 330 exp     :       exp '['
 331                         /* This function just saves the number of arguments
 332                            that follow in the list.  It is *not* specific to
 333                            function types */
 334                         { start_arglist(); }
 335                 non_empty_arglist ']'  %prec DOT
 336                         { write_exp_elt_opcode (BINOP_MULTI_SUBSCRIPT);
 337                           write_exp_elt_longcst ((LONGEST) end_arglist());
 338                           write_exp_elt_opcode (BINOP_MULTI_SUBSCRIPT); }
 339         ;
 340
 341 exp     :       exp '('
 342                         /* This is to save the value of arglist_len
 343                            being accumulated by an outer function call.  */
 344                         { start_arglist (); }
 345                 arglist ')'     %prec DOT
 346                         { write_exp_elt_opcode (OP_FUNCALL);
 347                           write_exp_elt_longcst ((LONGEST) end_arglist ());
 348                           write_exp_elt_opcode (OP_FUNCALL); }
 349         ;
 350
 351 arglist :
 352         ;
 353
 354 arglist :       exp
 355                         { arglist_len = 1; }
 356         ;
 357
 358 arglist :       arglist ',' exp   %prec ABOVE_COMMA
 359                         { arglist_len++; }
 360         ;
 361
 362 non_empty_arglist
 363         :       exp
 364                         { arglist_len = 1; }
 365         ;
 366
 367 non_empty_arglist
 368         :       non_empty_arglist ',' exp %prec ABOVE_COMMA
 369                         { arglist_len++; }
 370         ;
 371
 372 /* GDB construct */
 373 exp     :       '{' type '}' exp  %prec UNARY
 374                         { write_exp_elt_opcode (UNOP_MEMVAL);
 375                           write_exp_elt_type ($2);
 376                           write_exp_elt_opcode (UNOP_MEMVAL); }
 377         ;
 378
 379 exp     :       type '(' exp ')' %prec UNARY
 380                         { write_exp_elt_opcode (UNOP_CAST);
 381                           write_exp_elt_type ($1);
 382                           write_exp_elt_opcode (UNOP_CAST); }
 383         ;
 384
 385 exp     :       '(' exp ')'
 386                         { }
 387         ;
 388
 389 /* Binary operators in order of decreasing precedence.  Note that some
 390    of these operators are overloaded!  (ie. sets) */
 391
 392 /* GDB construct */
 393 exp     :       exp '@' exp
 394                         { write_exp_elt_opcode (BINOP_REPEAT); }
 395         ;
 396
 397 exp     :       exp '*' exp
 398                         { write_exp_elt_opcode (BINOP_MUL); }
 399         ;
 400
 401 exp     :       exp '/' exp
 402                         { write_exp_elt_opcode (BINOP_DIV); }
 403         ;
 404
 405 exp     :       exp DIV exp
 406                         { write_exp_elt_opcode (BINOP_INTDIV); }
 407         ;
 408
 409 exp     :       exp MOD exp
 410                         { write_exp_elt_opcode (BINOP_REM); }
 411         ;
 412
 413 exp     :       exp '+' exp
 414                         { write_exp_elt_opcode (BINOP_ADD); }
 415         ;
 416
 417 exp     :       exp '-' exp
 418                         { write_exp_elt_opcode (BINOP_SUB); }
 419         ;
 420
 421 exp     :       exp '=' exp
 422                         { write_exp_elt_opcode (BINOP_EQUAL); }
 423         ;
 424
 425 exp     :       exp NOTEQUAL exp
 426                         { write_exp_elt_opcode (BINOP_NOTEQUAL); }
 427         |       exp '#' exp
 428                         { write_exp_elt_opcode (BINOP_NOTEQUAL); }
 429         ;
 430
 431 exp     :       exp LEQ exp
 432                         { write_exp_elt_opcode (BINOP_LEQ); }
 433         ;
 434
 435 exp     :       exp GEQ exp
 436                         { write_exp_elt_opcode (BINOP_GEQ); }
 437         ;
 438
 439 exp     :       exp '<' exp
 440                         { write_exp_elt_opcode (BINOP_LESS); }
 441         ;
 442
 443 exp     :       exp '>' exp
 444                         { write_exp_elt_opcode (BINOP_GTR); }
 445         ;
 446
 447 exp     :       exp ANDAND exp
 448                         { write_exp_elt_opcode (BINOP_AND); }
 449         ;
 450
 451 exp     :       exp '&' exp
 452                         { write_exp_elt_opcode (BINOP_AND); }
 453         ;
 454
 455 exp     :       exp OROR exp
 456                         { write_exp_elt_opcode (BINOP_OR); }
 457         ;
 458
 459 exp     :       exp ASSIGN exp
 460                         { write_exp_elt_opcode (BINOP_ASSIGN); }
 461         ;
 462
 463
 464 /* Constants */
 465
 466 exp     :       M2_TRUE
 467                         { write_exp_elt_opcode (OP_BOOL);
 468                           write_exp_elt_longcst ((LONGEST) $1);
 469                           write_exp_elt_opcode (OP_BOOL); }
 470         ;
 471
 472 exp     :       M2_FALSE
 473                         { write_exp_elt_opcode (OP_BOOL);
 474                           write_exp_elt_longcst ((LONGEST) $1);
 475                           write_exp_elt_opcode (OP_BOOL); }
 476         ;
 477
 478 exp     :       INT
 479                         { write_exp_elt_opcode (OP_LONG);
 480                           write_exp_elt_type (builtin_type_m2_int);
 481                           write_exp_elt_longcst ((LONGEST) $1);
 482                           write_exp_elt_opcode (OP_LONG); }
 483         ;
 484
 485 exp     :       UINT
 486                         {
 487                           write_exp_elt_opcode (OP_LONG);
 488                           write_exp_elt_type (builtin_type_m2_card);
 489                           write_exp_elt_longcst ((LONGEST) $1);
 490                           write_exp_elt_opcode (OP_LONG);
 491                         }
 492         ;
 493
 494 exp     :       CHAR
 495                         { write_exp_elt_opcode (OP_LONG);
 496                           write_exp_elt_type (builtin_type_m2_char);
 497                           write_exp_elt_longcst ((LONGEST) $1);
 498                           write_exp_elt_opcode (OP_LONG); }
 499         ;
 500
 501
 502 exp     :       FLOAT
 503                         { write_exp_elt_opcode (OP_DOUBLE);
 504                           write_exp_elt_type (builtin_type_m2_real);
 505                           write_exp_elt_dblcst ($1);
 506                           write_exp_elt_opcode (OP_DOUBLE); }
 507         ;
 508
 509 exp     :       variable
 510         ;
 511
 512 /* The GDB internal variable $$, et al. */
 513 exp     :       LAST
 514                         { write_exp_elt_opcode (OP_LAST);
 515                           write_exp_elt_longcst ((LONGEST) $1);
 516                           write_exp_elt_opcode (OP_LAST); }
 517         ;
 518
 519 exp     :       REGNAME
 520                         { write_exp_elt_opcode (OP_REGISTER);
 521                           write_exp_elt_longcst ((LONGEST) $1);
 522                           write_exp_elt_opcode (OP_REGISTER); }
 523         ;
 524
 525 exp     :       SIZE '(' type ')'       %prec UNARY
 526                         { write_exp_elt_opcode (OP_LONG);
 527                           write_exp_elt_type (builtin_type_int);
 528                           write_exp_elt_longcst ((LONGEST) TYPE_LENGTH ($3));
 529                           write_exp_elt_opcode (OP_LONG); }
 530         ;
 531
 532 exp     :       STRING
 533                         { write_exp_elt_opcode (OP_M2_STRING);
 534                           write_exp_string ($1);
 535                           write_exp_elt_opcode (OP_M2_STRING); }
 536         ;
 537
 538 /* This will be used for extensions later.  Like adding modules. */
 539 block   :       fblock
 540                         { $$ = SYMBOL_BLOCK_VALUE($1); }
 541         ;
 542
 543 fblock  :       BLOCKNAME
 544                         { struct symbol *sym
 545                             = lookup_symbol (copy_name ($1), expression_context_block,
 546                                              VAR_NAMESPACE, 0, NULL);
 547                           $$ = sym;}
 548         ;
 549
 550
 551 /* GDB scope operator */
 552 fblock  :       block COLONCOLON BLOCKNAME
 553                         { struct symbol *tem
 554                             = lookup_symbol (copy_name ($3), $1,
 555                                              VAR_NAMESPACE, 0, NULL);
 556                           if (!tem || SYMBOL_CLASS (tem) != LOC_BLOCK)
 557                             error ("No function \"%s\" in specified context.",
 558                                    copy_name ($3));
 559                           $$ = tem;
 560                         }
 561         ;
 562
 563 /* Useful for assigning to PROCEDURE variables */
 564 variable:       fblock
 565                         { write_exp_elt_opcode(OP_VAR_VALUE);
 566                           write_exp_elt_sym ($1);
 567                           write_exp_elt_opcode (OP_VAR_VALUE); }
 568         ;
 569
 570 /* GDB internal ($foo) variable */
 571 variable:       INTERNAL_VAR
 572                         { write_exp_elt_opcode (OP_INTERNALVAR);
 573                           write_exp_elt_intern ($1);
 574                           write_exp_elt_opcode (OP_INTERNALVAR); }
 575         ;
 576
 577 /* GDB scope operator */
 578 variable:       block COLONCOLON NAME
 579                         { struct symbol *sym;
 580                           sym = lookup_symbol (copy_name ($3), $1,
 581                                                VAR_NAMESPACE, 0, NULL);
 582                           if (sym == 0)
 583                             error ("No symbol \"%s\" in specified context.",
 584                                    copy_name ($3));
 585
 586                           write_exp_elt_opcode (OP_VAR_VALUE);
 587                           write_exp_elt_sym (sym);
 588                           write_exp_elt_opcode (OP_VAR_VALUE); }
 589         ;
 590
 591 /* Base case for variables. */
 592 variable:       NAME
 593                         { struct symbol *sym;
 594                           int is_a_field_of_this;
 595
 596                           sym = lookup_symbol (copy_name ($1),
 597                                                expression_context_block,
 598                                                VAR_NAMESPACE,
 599                                                &is_a_field_of_this,
 600                                                NULL);
 601                           if (sym)
 602                             {
 603                               switch (sym->class)
 604                                 {
 605                                 case LOC_REGISTER:
 606                                 case LOC_ARG:
 607                                 case LOC_LOCAL:
 608                                 case LOC_REF_ARG:
 609                                 case LOC_REGPARM:
 610                                 case LOC_LOCAL_ARG:
 611                                   if (innermost_block == 0 ||
 612                                       contained_in (block_found,
 613                                                     innermost_block))
 614                                     innermost_block = block_found;
 615                                   break;
 616
 617                                 case LOC_UNDEF:
 618                                 case LOC_CONST:
 619                                 case LOC_STATIC:
 620                                 case LOC_TYPEDEF:
 621                                 case LOC_LABEL: /* maybe should go above? */
 622                                 case LOC_BLOCK:
 623                                 case LOC_CONST_BYTES:
 624                                   /* These are listed so gcc -Wall will reveal
 625                                      un-handled cases.  */
 626                                   break;
 627                                 }
 628                               write_exp_elt_opcode (OP_VAR_VALUE);
 629                               write_exp_elt_sym (sym);
 630                               write_exp_elt_opcode (OP_VAR_VALUE);
 631                             }
 632                           else
 633                             {
 634                               struct minimal_symbol *msymbol;
 635                               register char *arg = copy_name ($1);
 636
 637                               msymbol = lookup_minimal_symbol (arg,
 638                                           (struct objfile *) NULL);
 639                               if (msymbol != NULL)
 640                                 {
 641                                   write_exp_elt_opcode (OP_LONG);
 642                                   write_exp_elt_type (builtin_type_int);
 643                                   write_exp_elt_longcst ((LONGEST) msymbol -> address);
 644                                   write_exp_elt_opcode (OP_LONG);
 645                                   write_exp_elt_opcode (UNOP_MEMVAL);
 646                                   if (msymbol -> type == mst_data ||
 647                                       msymbol -> type == mst_bss)
 648                                     write_exp_elt_type (builtin_type_int);
 649                                   else if (msymbol -> type == mst_text)
 650                                     write_exp_elt_type (lookup_function_type (builtin_type_int));
 651                                   else
 652                                     write_exp_elt_type (builtin_type_char);
 653                                   write_exp_elt_opcode (UNOP_MEMVAL);
 654                                 }
 655                               else if (!have_full_symbols () && !have_partial_symbols ())
 656                                 error ("No symbol table is loaded.  Use the \"symbol-file\" command.");
 657                               else
 658                                 error ("No symbol \"%s\" in current context.",
 659                                        copy_name ($1));
 660                             }
 661                         }
 662         ;
 663
 664 type
 665         :       TYPENAME
 666                         { $$ = lookup_typename (copy_name ($1),
 667                                                 expression_context_block, 0); }
 668
 669         ;
 670
 671 %%
 672
 673 #if 0  /* FIXME! */
 674 int
 675 overflow(a,b)
 676    long a,b;
 677 {
 678    return (MAX_OF_TYPE(builtin_type_m2_int) - b) < a;
 679 }
 680
 681 int
 682 uoverflow(a,b)
 683    unsigned long a,b;
 684 {
 685    return (MAX_OF_TYPE(builtin_type_m2_card) - b) < a;
 686 }
 687 #endif /* FIXME */
 688
 689 /* Take care of parsing a number (anything that starts with a digit).
 690    Set yylval and return the token type; update lexptr.
 691    LEN is the number of characters in it.  */
 692
 693 /*** Needs some error checking for the float case ***/
 694
 695 static int
 696 parse_number (olen)
 697      int olen;
 698 {
 699   register char *p = lexptr;
 700   register LONGEST n = 0;
 701   register LONGEST prevn = 0;
 702   register int c,i,ischar=0;
 703   register int base = input_radix;
 704   register int len = olen;
 705   int unsigned_p = number_sign == 1 ? 1 : 0;
 706
 707   if(p[len-1] == 'H')
 708   {
 709      base = 16;
 710      len--;
 711   }
 712   else if(p[len-1] == 'C' || p[len-1] == 'B')
 713   {
 714      base = 8;
 715      ischar = p[len-1] == 'C';
 716      len--;
 717   }
 718
 719   /* Scan the number */
 720   for (c = 0; c < len; c++)
 721   {
 722     if (p[c] == '.' && base == 10)
 723       {
 724         /* It's a float since it contains a point.  */
 725         yylval.dval = atof (p);
 726         lexptr += len;
 727         return FLOAT;
 728       }
 729     if (p[c] == '.' && base != 10)
 730        error("Floating point numbers must be base 10.");
 731     if (base == 10 && (p[c] < '0' || p[c] > '9'))
 732        error("Invalid digit \'%c\' in number.",p[c]);
 733  }
 734
 735   while (len-- > 0)
 736     {
 737       c = *p++;
 738       n *= base;
 739       if( base == 8 && (c == '8' || c == '9'))
 740          error("Invalid digit \'%c\' in octal number.",c);
 741       if (c >= '0' && c <= '9')
 742         i = c - '0';
 743       else
 744         {
 745           if (base == 16 && c >= 'A' && c <= 'F')
 746             i = c - 'A' + 10;
 747           else
 748              return ERROR;
 749         }
 750       n+=i;
 751       if(i >= base)
 752          return ERROR;
 753       if(!unsigned_p && number_sign == 1 && (prevn >= n))
 754          unsigned_p=1;          /* Try something unsigned */
 755       /* Don't do the range check if n==i and i==0, since that special
 756          case will give an overflow error. */
 757       if(RANGE_CHECK && n!=i && i)
 758       {
 759          if((unsigned_p && (unsigned)prevn >= (unsigned)n) ||
 760             ((!unsigned_p && number_sign==-1) && -prevn <= -n))
 761             range_error("Overflow on numeric constant.");
 762       }
 763          prevn=n;
 764     }
 765
 766   lexptr = p;
 767   if(*p == 'B' || *p == 'C' || *p == 'H')
 768      lexptr++;                  /* Advance past B,C or H */
 769
 770   if (ischar)
 771   {
 772      yylval.ulval = n;
 773      return CHAR;
 774   }
 775   else if ( unsigned_p && number_sign == 1)
 776   {
 777      yylval.ulval = n;
 778      return UINT;
 779   }
 780   else if((unsigned_p && (n<0))) {
 781      range_error("Overflow on numeric constant -- number too large.");
 782      /* But, this can return if range_check == range_warn.  */
 783   }
 784   yylval.lval = n;
 785   return INT;
 786 }
 787
 788
 789 /* Some tokens */
 790
 791 static struct
 792 {
 793    char name[2];
 794    int token;
 795 } tokentab2[] =
 796 {
 797     { {'<', '>'},    NOTEQUAL   },
 798     { {':', '='},    ASSIGN     },
 799     { {'<', '='},    LEQ        },
 800     { {'>', '='},    GEQ        },
 801     { {':', ':'},    COLONCOLON },
 802
 803 };
 804
 805 /* Some specific keywords */
 806
 807 struct keyword {
 808    char keyw[10];
 809    int token;
 810 };
 811
 812 static struct keyword keytab[] =
 813 {
 814     {"OR" ,   OROR       },
 815     {"IN",    IN         },/* Note space after IN */
 816     {"AND",   ANDAND     },
 817     {"ABS",   ABS        },
 818     {"CHR",   CHR        },
 819     {"DEC",   DEC        },
 820     {"NOT",   NOT        },
 821     {"DIV",   DIV        },
 822     {"INC",   INC        },
 823     {"MAX",   MAX_FUNC   },
 824     {"MIN",   MIN_FUNC   },
 825     {"MOD",   MOD        },
 826     {"ODD",   ODD        },
 827     {"CAP",   CAP        },
 828     {"ORD",   ORD        },
 829     {"VAL",   VAL        },
 830     {"EXCL",  EXCL       },
 831     {"HIGH",  HIGH       },
 832     {"INCL",  INCL       },
 833     {"SIZE",  SIZE       },
 834     {"FLOAT", FLOAT_FUNC },
 835     {"TRUNC", TRUNC      },
 836 };
 837
 838
 839 /* Read one token, getting characters through lexptr.  */
 840
 841 /* This is where we will check to make sure that the language and the operators used are
 842    compatible  */
 843
 844 static int
 845 yylex ()
 846 {
 847   register int c;
 848   register int namelen;
 849   register int i;
 850   register char *tokstart;
 851   register char quote;
 852
 853  retry:
 854
 855   tokstart = lexptr;
 856
 857
 858   /* See if it is a special token of length 2 */
 859   for( i = 0 ; i < sizeof tokentab2 / sizeof tokentab2[0] ; i++)
 860      if(!strncmp(tokentab2[i].name, tokstart, 2))
 861      {
 862         lexptr += 2;
 863         return tokentab2[i].token;
 864      }
 865
 866   switch (c = *tokstart)
 867     {
 868     case 0:
 869       return 0;
 870
 871     case ' ':
 872     case '\t':
 873     case '\n':
 874       lexptr++;
 875       goto retry;
 876
 877     case '(':
 878       paren_depth++;
 879       lexptr++;
 880       return c;
 881
 882     case ')':
 883       if (paren_depth == 0)
 884         return 0;
 885       paren_depth--;
 886       lexptr++;
 887       return c;
 888
 889     case ',':
 890       if (comma_terminates && paren_depth == 0)
 891         return 0;
 892       lexptr++;
 893       return c;
 894
 895     case '.':
 896       /* Might be a floating point number.  */
 897       if (lexptr[1] >= '0' && lexptr[1] <= '9')
 898         break;                  /* Falls into number code.  */
 899       else
 900       {
 901          lexptr++;
 902          return DOT;
 903       }
 904
 905 /* These are character tokens that appear as-is in the YACC grammar */
 906     case '+':
 907     case '-':
 908     case '*':
 909     case '/':
 910     case '^':
 911     case '<':
 912     case '>':
 913     case '[':
 914     case ']':
 915     case '=':
 916     case '{':
 917     case '}':
 918     case '#':
 919     case '@':
 920     case '~':
 921     case '&':
 922       lexptr++;
 923       return c;
 924
 925     case '\'' :
 926     case '"':
 927       quote = c;
 928       for (namelen = 1; (c = tokstart[namelen]) != quote && c != '\0'; namelen++)
 929         if (c == '\\')
 930           {
 931             c = tokstart[++namelen];
 932             if (c >= '0' && c <= '9')
 933               {
 934                 c = tokstart[++namelen];
 935                 if (c >= '0' && c <= '9')
 936                   c = tokstart[++namelen];
 937               }
 938           }
 939       if(c != quote)
 940          error("Unterminated string or character constant.");
 941       yylval.sval.ptr = tokstart + 1;
 942       yylval.sval.length = namelen - 1;
 943       lexptr += namelen + 1;
 944
 945       if(namelen == 2)          /* Single character */
 946       {
 947            yylval.ulval = tokstart[1];
 948            return CHAR;
 949       }
 950       else
 951          return STRING;
 952     }
 953
 954   /* Is it a number?  */
 955   /* Note:  We have already dealt with the case of the token '.'.
 956      See case '.' above.  */
 957   if ((c >= '0' && c <= '9'))
 958     {
 959       /* It's a number.  */
 960       int got_dot = 0, got_e = 0;
 961       register char *p = tokstart;
 962       int toktype;
 963
 964       for (++p ;; ++p)
 965         {
 966           if (!got_e && (*p == 'e' || *p == 'E'))
 967             got_dot = got_e = 1;
 968           else if (!got_dot && *p == '.')
 969             got_dot = 1;
 970           else if (got_e && (p[-1] == 'e' || p[-1] == 'E')
 971                    && (*p == '-' || *p == '+'))
 972             /* This is the sign of the exponent, not the end of the
 973                number.  */
 974             continue;
 975           else if ((*p < '0' || *p > '9') &&
 976                    (*p < 'A' || *p > 'F') &&
 977                    (*p != 'H'))  /* Modula-2 hexadecimal number */
 978             break;
 979         }
 980         toktype = parse_number (p - tokstart);
 981         if (toktype == ERROR)
 982           {
 983             char *err_copy = (char *) alloca (p - tokstart + 1);
 984
 985             memcpy (err_copy, tokstart, p - tokstart);
 986             err_copy[p - tokstart] = 0;
 987             error ("Invalid number \"%s\".", err_copy);
 988           }
 989         lexptr = p;
 990         return toktype;
 991     }
 992
 993   if (!(c == '_' || c == '$'
 994         || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')))
 995     /* We must have come across a bad character (e.g. ';').  */
 996     error ("Invalid character '%c' in expression.", c);
 997
 998   /* It's a name.  See how long it is.  */
 999   namelen = 0;
1000   for (c = tokstart[namelen];
1001        (c == '_' || c == '$' || (c >= '0' && c <= '9')
1002         || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z'));
1003        c = tokstart[++namelen])
1004     ;
1005
1006   /* The token "if" terminates the expression and is NOT
1007      removed from the input stream.  */
1008   if (namelen == 2 && tokstart[0] == 'i' && tokstart[1] == 'f')
1009     {
1010       return 0;
1011     }
1012
1013   lexptr += namelen;
1014
1015   /* Handle the tokens $digits; also $ (short for $0) and $$ (short for $$1)
1016      and $$digits (equivalent to $<-digits> if you could type that).
1017      Make token type LAST, and put the number (the digits) in yylval.  */
1018
1019   if (*tokstart == '$')
1020     {
1021       register int negate = 0;
1022       c = 1;
1023       /* Double dollar means negate the number and add -1 as well.
1024          Thus $$ alone means -1.  */
1025       if (namelen >= 2 && tokstart[1] == '$')
1026         {
1027           negate = 1;
1028           c = 2;
1029         }
1030       if (c == namelen)
1031         {
1032           /* Just dollars (one or two) */
1033           yylval.lval = - negate;
1034           return LAST;
1035         }
1036       /* Is the rest of the token digits?  */
1037       for (; c < namelen; c++)
1038         if (!(tokstart[c] >= '0' && tokstart[c] <= '9'))
1039           break;
1040       if (c == namelen)
1041         {
1042           yylval.lval = atoi (tokstart + 1 + negate);
1043           if (negate)
1044             yylval.lval = - yylval.lval;
1045           return LAST;
1046         }
1047     }
1048
1049   /* Handle tokens that refer to machine registers:
1050      $ followed by a register name.  */
1051
1052   if (*tokstart == '$') {
1053     for (c = 0; c < NUM_REGS; c++)
1054       if (namelen - 1 == strlen (reg_names[c])
1055           && !strncmp (tokstart + 1, reg_names[c], namelen - 1))
1056         {
1057           yylval.lval = c;
1058           return REGNAME;
1059         }
1060     for (c = 0; c < num_std_regs; c++)
1061      if (namelen - 1 == strlen (std_regs[c].name)
1062          && !strncmp (tokstart + 1, std_regs[c].name, namelen - 1))
1063        {
1064          yylval.lval = std_regs[c].regnum;
1065          return REGNAME;
1066        }
1067   }
1068
1069
1070   /*  Lookup special keywords */
1071   for(i = 0 ; i < sizeof(keytab) / sizeof(keytab[0]) ; i++)
1072      if(namelen == strlen(keytab[i].keyw) && !strncmp(tokstart,keytab[i].keyw,namelen))
1073            return keytab[i].token;
1074
1075   yylval.sval.ptr = tokstart;
1076   yylval.sval.length = namelen;
1077
1078   /* Any other names starting in $ are debugger internal variables.  */
1079
1080   if (*tokstart == '$')
1081     {
1082       yylval.ivar = (struct internalvar *) lookup_internalvar (copy_name (yylval.sval) + 1);
1083       return INTERNAL_VAR;
1084     }
1085
1086
1087   /* Use token-type BLOCKNAME for symbols that happen to be defined as
1088      functions.  If this is not so, then ...
1089      Use token-type TYPENAME for symbols that happen to be defined
1090      currently as names of types; NAME for other symbols.
1091      The caller is not constrained to care about the distinction.  */
1092  {
1093
1094
1095     char *tmp = copy_name (yylval.sval);
1096     struct symbol *sym;
1097
1098     if (lookup_partial_symtab (tmp))
1099       return BLOCKNAME;
1100     sym = lookup_symbol (tmp, expression_context_block,
1101                          VAR_NAMESPACE, 0, NULL);
1102     if (sym && SYMBOL_CLASS (sym) == LOC_BLOCK)
1103       return BLOCKNAME;
1104     if (lookup_typename (copy_name (yylval.sval), expression_context_block, 1))
1105       return TYPENAME;
1106
1107     if(sym)
1108     {
1109        switch(sym->class)
1110        {
1111        case LOC_STATIC:
1112        case LOC_REGISTER:
1113        case LOC_ARG:
1114        case LOC_REF_ARG:
1115        case LOC_REGPARM:
1116        case LOC_LOCAL:
1117        case LOC_LOCAL_ARG:
1118        case LOC_CONST:
1119        case LOC_CONST_BYTES:
1120           return NAME;
1121
1122        case LOC_TYPEDEF:
1123           return TYPENAME;
1124
1125        case LOC_BLOCK:
1126           return BLOCKNAME;
1127
1128        case LOC_UNDEF:
1129           error("internal:  Undefined class in m2lex()");
1130
1131        case LOC_LABEL:
1132           error("internal:  Unforseen case in m2lex()");
1133        }
1134     }
1135     else
1136     {
1137        /* Built-in BOOLEAN type.  This is sort of a hack. */
1138        if(!strncmp(tokstart,"TRUE",4))
1139        {
1140           yylval.ulval = 1;
1141           return M2_TRUE;
1142        }
1143        else if(!strncmp(tokstart,"FALSE",5))
1144        {
1145           yylval.ulval = 0;
1146           return M2_FALSE;
1147        }
1148     }
1149
1150     /* Must be another type of name... */
1151     return NAME;
1152  }
1153 }
1154
1155 #if 0           /* Unused */
1156 static char *
1157 make_qualname(mod,ident)
1158    char *mod, *ident;
1159 {
1160    char *new = malloc(strlen(mod)+strlen(ident)+2);
1161
1162    strcpy(new,mod);
1163    strcat(new,".");
1164    strcat(new,ident);
1165    return new;
1166 }
1167 #endif  /* 0 */
1168
1169 static void
1170 yyerror(msg)
1171      char *msg; /* unused */
1172 {
1173    printf("Parsing:  %s\n",lexptr);
1174    if (yychar < 256)
1175      error("Invalid syntax in expression near character '%c'.",yychar);
1176    else
1177      error("Invalid syntax in expression");
1178 }
1179 \f
1180 /* Table of operators and their precedences for printing expressions.  */
1181
1182 const static struct op_print m2_op_print_tab[] = {
1183     {"+",   BINOP_ADD, PREC_ADD, 0},
1184     {"+",   UNOP_PLUS, PREC_PREFIX, 0},
1185     {"-",   BINOP_SUB, PREC_ADD, 0},
1186     {"-",   UNOP_NEG, PREC_PREFIX, 0},
1187     {"*",   BINOP_MUL, PREC_MUL, 0},
1188     {"/",   BINOP_DIV, PREC_MUL, 0},
1189     {"DIV", BINOP_INTDIV, PREC_MUL, 0},
1190     {"MOD", BINOP_REM, PREC_MUL, 0},
1191     {":=",  BINOP_ASSIGN, PREC_ASSIGN, 1},
1192     {"OR",  BINOP_OR, PREC_OR, 0},
1193     {"AND", BINOP_AND, PREC_AND, 0},
1194     {"NOT", UNOP_ZEROP, PREC_PREFIX, 0},
1195     {"=",   BINOP_EQUAL, PREC_EQUAL, 0},
1196     {"<>",  BINOP_NOTEQUAL, PREC_EQUAL, 0},
1197     {"<=",  BINOP_LEQ, PREC_ORDER, 0},
1198     {">=",  BINOP_GEQ, PREC_ORDER, 0},
1199     {">",   BINOP_GTR, PREC_ORDER, 0},
1200     {"<",   BINOP_LESS, PREC_ORDER, 0},
1201     {"^",   UNOP_IND, PREC_PREFIX, 0},
1202     {"@",   BINOP_REPEAT, PREC_REPEAT, 0},
1203 };
1204 \f
1205 /* The built-in types of Modula-2.  */
1206
1207 struct type *builtin_type_m2_char;
1208 struct type *builtin_type_m2_int;
1209 struct type *builtin_type_m2_card;
1210 struct type *builtin_type_m2_real;
1211 struct type *builtin_type_m2_bool;
1212
1213 struct type ** const (m2_builtin_types[]) =
1214 {
1215   &builtin_type_m2_char,
1216   &builtin_type_m2_int,
1217   &builtin_type_m2_card,
1218   &builtin_type_m2_real,
1219   &builtin_type_m2_bool,
1220   0
1221 };
1222
1223 const struct language_defn m2_language_defn = {
1224   "modula-2",
1225   language_m2,
1226   m2_builtin_types,
1227   range_check_on,
1228   type_check_on,
1229   m2_parse,                     /* parser */
1230   m2_error,                     /* parser error function */
1231   &builtin_type_m2_int,         /* longest signed   integral type */
1232   &builtin_type_m2_card,                /* longest unsigned integral type */
1233   &builtin_type_m2_real,                /* longest floating point type */
1234   "0%XH", "0%", "XH",           /* Hex   format string, prefix, suffix */
1235   "%oB",  "%",  "oB",           /* Octal format string, prefix, suffix */
1236   m2_op_print_tab,              /* expression operators for printing */
1237   LANG_MAGIC
1238 };
1239
1240 /* Initialization for Modula-2 */
1241
1242 void
1243 _initialize_m2_exp ()
1244 {
1245   /* Modula-2 "pervasive" types.  NOTE:  these can be redefined!!! */
1246   builtin_type_m2_int =
1247     init_type (TYPE_CODE_INT, TARGET_INT_BIT / TARGET_CHAR_BIT,
1248                0,
1249                "INTEGER", (struct objfile *) NULL);
1250   builtin_type_m2_card =
1251     init_type (TYPE_CODE_INT, TARGET_INT_BIT / TARGET_CHAR_BIT,
1252                TYPE_FLAG_UNSIGNED,
1253                "CARDINAL", (struct objfile *) NULL);
1254   builtin_type_m2_real =
1255     init_type (TYPE_CODE_FLT, TARGET_FLOAT_BIT / TARGET_CHAR_BIT,
1256                0,
1257                "REAL", (struct objfile *) NULL);
1258   builtin_type_m2_char =
1259     init_type (TYPE_CODE_CHAR, TARGET_CHAR_BIT / TARGET_CHAR_BIT,
1260                TYPE_FLAG_UNSIGNED,
1261                "CHAR", (struct objfile *) NULL);
1262   builtin_type_m2_bool =
1263     init_type (TYPE_CODE_BOOL, TARGET_INT_BIT / TARGET_CHAR_BIT,
1264                TYPE_FLAG_UNSIGNED,
1265                "BOOLEAN", (struct objfile *) NULL);
1266
1267   TYPE_NFIELDS(builtin_type_m2_bool) = 2;
1268   TYPE_FIELDS(builtin_type_m2_bool) =
1269      (struct field *) malloc (sizeof (struct field) * 2);
1270   TYPE_FIELD_BITPOS(builtin_type_m2_bool,0) = 0;
1271   TYPE_FIELD_NAME(builtin_type_m2_bool,0) = (char *)malloc(6);
1272   strcpy(TYPE_FIELD_NAME(builtin_type_m2_bool,0),"FALSE");
1273   TYPE_FIELD_BITPOS(builtin_type_m2_bool,1) = 1;
1274   TYPE_FIELD_NAME(builtin_type_m2_bool,1) = (char *)malloc(5);
1275   strcpy(TYPE_FIELD_NAME(builtin_type_m2_bool,1),"TRUE");
1276
1277   add_language (&m2_language_defn);
1278 }