Automatic date update in version.in
[platform/upstream/binutils.git] / gdb / m2-exp.y
1 /* YACC grammar for Modula-2 expressions, for GDB.
2    Copyright (C) 1986-2014 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 3 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, see <http://www.gnu.org/licenses/>.  */
20
21 /* Parse a Modula-2 expression from text in a string,
22    and return the result as a  struct expression  pointer.
23    That structure contains arithmetic operations in reverse polish,
24    with constants represented by operations that are followed by special data.
25    See expression.h for the details of the format.
26    What is important here is that it can be built up sequentially
27    during the process of parsing; the lower levels of the tree always
28    come first in the result.
29
30    Note that malloc's and realloc's in this file are transformed to
31    xmalloc and xrealloc respectively by the same sed command in the
32    makefile that remaps any other malloc/realloc inserted by the parser
33    generator.  Doing this with #defines and trying to control the interaction
34    with include files (<malloc.h> and <stdlib.h> for example) just became
35    too messy, particularly when such includes can be inserted at random
36    times by the parser generator.  */
37    
38 %{
39
40 #include "defs.h"
41 #include "expression.h"
42 #include "language.h"
43 #include "value.h"
44 #include "parser-defs.h"
45 #include "m2-lang.h"
46 #include "bfd.h" /* Required by objfiles.h.  */
47 #include "symfile.h" /* Required by objfiles.h.  */
48 #include "objfiles.h" /* For have_full_symbols and have_partial_symbols */
49 #include "block.h"
50
51 #define parse_type(ps) builtin_type (parse_gdbarch (ps))
52 #define parse_m2_type(ps) builtin_m2_type (parse_gdbarch (ps))
53
54 /* Remap normal yacc parser interface names (yyparse, yylex, yyerror, etc),
55    as well as gratuitiously global symbol names, so we can have multiple
56    yacc generated parsers in gdb.  Note that these are only the variables
57    produced by yacc.  If other parser generators (bison, byacc, etc) produce
58    additional global names that conflict at link time, then those parser
59    generators need to be fixed instead of adding those names to this list.  */
60
61 #define yymaxdepth m2_maxdepth
62 #define yyparse m2_parse_internal
63 #define yylex   m2_lex
64 #define yyerror m2_error
65 #define yylval  m2_lval
66 #define yychar  m2_char
67 #define yydebug m2_debug
68 #define yypact  m2_pact
69 #define yyr1    m2_r1
70 #define yyr2    m2_r2
71 #define yydef   m2_def
72 #define yychk   m2_chk
73 #define yypgo   m2_pgo
74 #define yyact   m2_act
75 #define yyexca  m2_exca
76 #define yyerrflag m2_errflag
77 #define yynerrs m2_nerrs
78 #define yyps    m2_ps
79 #define yypv    m2_pv
80 #define yys     m2_s
81 #define yy_yys  m2_yys
82 #define yystate m2_state
83 #define yytmp   m2_tmp
84 #define yyv     m2_v
85 #define yy_yyv  m2_yyv
86 #define yyval   m2_val
87 #define yylloc  m2_lloc
88 #define yyreds  m2_reds         /* With YYDEBUG defined */
89 #define yytoks  m2_toks         /* With YYDEBUG defined */
90 #define yyname  m2_name         /* With YYDEBUG defined */
91 #define yyrule  m2_rule         /* With YYDEBUG defined */
92 #define yylhs   m2_yylhs
93 #define yylen   m2_yylen
94 #define yydefred m2_yydefred
95 #define yydgoto m2_yydgoto
96 #define yysindex m2_yysindex
97 #define yyrindex m2_yyrindex
98 #define yygindex m2_yygindex
99 #define yytable  m2_yytable
100 #define yycheck  m2_yycheck
101 #define yyss    m2_yyss
102 #define yysslim m2_yysslim
103 #define yyssp   m2_yyssp
104 #define yystacksize m2_yystacksize
105 #define yyvs    m2_yyvs
106 #define yyvsp   m2_yyvsp
107
108 #ifndef YYDEBUG
109 #define YYDEBUG 1               /* Default to yydebug support */
110 #endif
111
112 #define YYFPRINTF parser_fprintf
113
114 /* The state of the parser, used internally when we are parsing the
115    expression.  */
116
117 static struct parser_state *pstate = NULL;
118
119 int yyparse (void);
120
121 static int yylex (void);
122
123 void yyerror (char *);
124
125 static int parse_number (int);
126
127 /* The sign of the number being parsed.  */
128 static int number_sign = 1;
129
130 %}
131
132 /* Although the yacc "value" of an expression is not used,
133    since the result is stored in the structure being created,
134    other node types do have values.  */
135
136 %union
137   {
138     LONGEST lval;
139     ULONGEST ulval;
140     DOUBLEST dval;
141     struct symbol *sym;
142     struct type *tval;
143     struct stoken sval;
144     int voidval;
145     const struct block *bval;
146     enum exp_opcode opcode;
147     struct internalvar *ivar;
148
149     struct type **tvec;
150     int *ivec;
151   }
152
153 %type <voidval> exp type_exp start set
154 %type <voidval> variable
155 %type <tval> type
156 %type <bval> block 
157 %type <sym> fblock 
158
159 %token <lval> INT HEX ERROR
160 %token <ulval> UINT M2_TRUE M2_FALSE CHAR
161 %token <dval> FLOAT
162
163 /* Both NAME and TYPENAME tokens represent symbols in the input,
164    and both convey their data as strings.
165    But a TYPENAME is a string that happens to be defined as a typedef
166    or builtin type name (such as int or char)
167    and a NAME is any other symbol.
168
169    Contexts where this distinction is not important can use the
170    nonterminal "name", which matches either NAME or TYPENAME.  */
171
172 %token <sval> STRING
173 %token <sval> NAME BLOCKNAME IDENT VARNAME
174 %token <sval> TYPENAME
175
176 %token SIZE CAP ORD HIGH ABS MIN_FUNC MAX_FUNC FLOAT_FUNC VAL CHR ODD TRUNC
177 %token TSIZE
178 %token INC DEC INCL EXCL
179
180 /* The GDB scope operator */
181 %token COLONCOLON
182
183 %token <voidval> INTERNAL_VAR
184
185 /* M2 tokens */
186 %left ','
187 %left ABOVE_COMMA
188 %nonassoc ASSIGN
189 %left '<' '>' LEQ GEQ '=' NOTEQUAL '#' IN
190 %left OROR
191 %left LOGICAL_AND '&'
192 %left '@'
193 %left '+' '-'
194 %left '*' '/' DIV MOD
195 %right UNARY
196 %right '^' DOT '[' '('
197 %right NOT '~'
198 %left COLONCOLON QID
199 /* This is not an actual token ; it is used for precedence. 
200 %right QID
201 */
202
203 \f
204 %%
205
206 start   :       exp
207         |       type_exp
208         ;
209
210 type_exp:       type
211                 { write_exp_elt_opcode (pstate, OP_TYPE);
212                   write_exp_elt_type (pstate, $1);
213                   write_exp_elt_opcode (pstate, OP_TYPE);
214                 }
215         ;
216
217 /* Expressions */
218
219 exp     :       exp '^'   %prec UNARY
220                         { write_exp_elt_opcode (pstate, UNOP_IND); }
221         ;
222
223 exp     :       '-'
224                         { number_sign = -1; }
225                 exp    %prec UNARY
226                         { number_sign = 1;
227                           write_exp_elt_opcode (pstate, UNOP_NEG); }
228         ;
229
230 exp     :       '+' exp    %prec UNARY
231                 { write_exp_elt_opcode (pstate, UNOP_PLUS); }
232         ;
233
234 exp     :       not_exp exp %prec UNARY
235                         { write_exp_elt_opcode (pstate, UNOP_LOGICAL_NOT); }
236         ;
237
238 not_exp :       NOT
239         |       '~'
240         ;
241
242 exp     :       CAP '(' exp ')'
243                         { write_exp_elt_opcode (pstate, UNOP_CAP); }
244         ;
245
246 exp     :       ORD '(' exp ')'
247                         { write_exp_elt_opcode (pstate, UNOP_ORD); }
248         ;
249
250 exp     :       ABS '(' exp ')'
251                         { write_exp_elt_opcode (pstate, UNOP_ABS); }
252         ;
253
254 exp     :       HIGH '(' exp ')'
255                         { write_exp_elt_opcode (pstate, UNOP_HIGH); }
256         ;
257
258 exp     :       MIN_FUNC '(' type ')'
259                         { write_exp_elt_opcode (pstate, UNOP_MIN);
260                           write_exp_elt_type (pstate, $3);
261                           write_exp_elt_opcode (pstate, UNOP_MIN); }
262         ;
263
264 exp     :       MAX_FUNC '(' type ')'
265                         { write_exp_elt_opcode (pstate, UNOP_MAX);
266                           write_exp_elt_type (pstate, $3);
267                           write_exp_elt_opcode (pstate, UNOP_MAX); }
268         ;
269
270 exp     :       FLOAT_FUNC '(' exp ')'
271                         { write_exp_elt_opcode (pstate, UNOP_FLOAT); }
272         ;
273
274 exp     :       VAL '(' type ',' exp ')'
275                         { write_exp_elt_opcode (pstate, BINOP_VAL);
276                           write_exp_elt_type (pstate, $3);
277                           write_exp_elt_opcode (pstate, BINOP_VAL); }
278         ;
279
280 exp     :       CHR '(' exp ')'
281                         { write_exp_elt_opcode (pstate, UNOP_CHR); }
282         ;
283
284 exp     :       ODD '(' exp ')'
285                         { write_exp_elt_opcode (pstate, UNOP_ODD); }
286         ;
287
288 exp     :       TRUNC '(' exp ')'
289                         { write_exp_elt_opcode (pstate, UNOP_TRUNC); }
290         ;
291
292 exp     :       TSIZE '(' exp ')'
293                         { write_exp_elt_opcode (pstate, UNOP_SIZEOF); }
294         ;
295
296 exp     :       SIZE exp       %prec UNARY
297                         { write_exp_elt_opcode (pstate, UNOP_SIZEOF); }
298         ;
299
300
301 exp     :       INC '(' exp ')'
302                         { write_exp_elt_opcode (pstate, UNOP_PREINCREMENT); }
303         ;
304
305 exp     :       INC '(' exp ',' exp ')'
306                         { write_exp_elt_opcode (pstate, BINOP_ASSIGN_MODIFY);
307                           write_exp_elt_opcode (pstate, BINOP_ADD);
308                           write_exp_elt_opcode (pstate,
309                                                 BINOP_ASSIGN_MODIFY); }
310         ;
311
312 exp     :       DEC '(' exp ')'
313                         { write_exp_elt_opcode (pstate, UNOP_PREDECREMENT);}
314         ;
315
316 exp     :       DEC '(' exp ',' exp ')'
317                         { write_exp_elt_opcode (pstate, BINOP_ASSIGN_MODIFY);
318                           write_exp_elt_opcode (pstate, BINOP_SUB);
319                           write_exp_elt_opcode (pstate,
320                                                 BINOP_ASSIGN_MODIFY); }
321         ;
322
323 exp     :       exp DOT NAME
324                         { write_exp_elt_opcode (pstate, STRUCTOP_STRUCT);
325                           write_exp_string (pstate, $3);
326                           write_exp_elt_opcode (pstate, STRUCTOP_STRUCT); }
327         ;
328
329 exp     :       set
330         ;
331
332 exp     :       exp IN set
333                         { error (_("Sets are not implemented."));}
334         ;
335
336 exp     :       INCL '(' exp ',' exp ')'
337                         { error (_("Sets are not implemented."));}
338         ;
339
340 exp     :       EXCL '(' exp ',' exp ')'
341                         { error (_("Sets are not implemented."));}
342         ;
343
344 set     :       '{' arglist '}'
345                         { error (_("Sets are not implemented."));}
346         |       type '{' arglist '}'
347                         { error (_("Sets are not implemented."));}
348         ;
349
350
351 /* Modula-2 array subscript notation [a,b,c...] */
352 exp     :       exp '['
353                         /* This function just saves the number of arguments
354                            that follow in the list.  It is *not* specific to
355                            function types */
356                         { start_arglist(); }
357                 non_empty_arglist ']'  %prec DOT
358                         { write_exp_elt_opcode (pstate, MULTI_SUBSCRIPT);
359                           write_exp_elt_longcst (pstate,
360                                                  (LONGEST) end_arglist());
361                           write_exp_elt_opcode (pstate, MULTI_SUBSCRIPT); }
362         ;
363
364 exp     :       exp '[' exp ']'
365                         { write_exp_elt_opcode (pstate, BINOP_SUBSCRIPT); }
366         ;
367
368 exp     :       exp '('
369                         /* This is to save the value of arglist_len
370                            being accumulated by an outer function call.  */
371                         { start_arglist (); }
372                 arglist ')'     %prec DOT
373                         { write_exp_elt_opcode (pstate, OP_FUNCALL);
374                           write_exp_elt_longcst (pstate,
375                                                  (LONGEST) end_arglist ());
376                           write_exp_elt_opcode (pstate, OP_FUNCALL); }
377         ;
378
379 arglist :
380         ;
381
382 arglist :       exp
383                         { arglist_len = 1; }
384         ;
385
386 arglist :       arglist ',' exp   %prec ABOVE_COMMA
387                         { arglist_len++; }
388         ;
389
390 non_empty_arglist
391         :       exp
392                         { arglist_len = 1; }
393         ;
394
395 non_empty_arglist
396         :       non_empty_arglist ',' exp %prec ABOVE_COMMA
397                         { arglist_len++; }
398         ;
399
400 /* GDB construct */
401 exp     :       '{' type '}' exp  %prec UNARY
402                         { write_exp_elt_opcode (pstate, UNOP_MEMVAL);
403                           write_exp_elt_type (pstate, $2);
404                           write_exp_elt_opcode (pstate, UNOP_MEMVAL); }
405         ;
406
407 exp     :       type '(' exp ')' %prec UNARY
408                         { write_exp_elt_opcode (pstate, UNOP_CAST);
409                           write_exp_elt_type (pstate, $1);
410                           write_exp_elt_opcode (pstate, UNOP_CAST); }
411         ;
412
413 exp     :       '(' exp ')'
414                         { }
415         ;
416
417 /* Binary operators in order of decreasing precedence.  Note that some
418    of these operators are overloaded!  (ie. sets) */
419
420 /* GDB construct */
421 exp     :       exp '@' exp
422                         { write_exp_elt_opcode (pstate, BINOP_REPEAT); }
423         ;
424
425 exp     :       exp '*' exp
426                         { write_exp_elt_opcode (pstate, BINOP_MUL); }
427         ;
428
429 exp     :       exp '/' exp
430                         { write_exp_elt_opcode (pstate, BINOP_DIV); }
431         ;
432
433 exp     :       exp DIV exp
434                         { write_exp_elt_opcode (pstate, BINOP_INTDIV); }
435         ;
436
437 exp     :       exp MOD exp
438                         { write_exp_elt_opcode (pstate, BINOP_REM); }
439         ;
440
441 exp     :       exp '+' exp
442                         { write_exp_elt_opcode (pstate, BINOP_ADD); }
443         ;
444
445 exp     :       exp '-' exp
446                         { write_exp_elt_opcode (pstate, BINOP_SUB); }
447         ;
448
449 exp     :       exp '=' exp
450                         { write_exp_elt_opcode (pstate, BINOP_EQUAL); }
451         ;
452
453 exp     :       exp NOTEQUAL exp
454                         { write_exp_elt_opcode (pstate, BINOP_NOTEQUAL); }
455         |       exp '#' exp
456                         { write_exp_elt_opcode (pstate, BINOP_NOTEQUAL); }
457         ;
458
459 exp     :       exp LEQ exp
460                         { write_exp_elt_opcode (pstate, BINOP_LEQ); }
461         ;
462
463 exp     :       exp GEQ exp
464                         { write_exp_elt_opcode (pstate, BINOP_GEQ); }
465         ;
466
467 exp     :       exp '<' exp
468                         { write_exp_elt_opcode (pstate, BINOP_LESS); }
469         ;
470
471 exp     :       exp '>' exp
472                         { write_exp_elt_opcode (pstate, BINOP_GTR); }
473         ;
474
475 exp     :       exp LOGICAL_AND exp
476                         { write_exp_elt_opcode (pstate, BINOP_LOGICAL_AND); }
477         ;
478
479 exp     :       exp OROR exp
480                         { write_exp_elt_opcode (pstate, BINOP_LOGICAL_OR); }
481         ;
482
483 exp     :       exp ASSIGN exp
484                         { write_exp_elt_opcode (pstate, BINOP_ASSIGN); }
485         ;
486
487
488 /* Constants */
489
490 exp     :       M2_TRUE
491                         { write_exp_elt_opcode (pstate, OP_BOOL);
492                           write_exp_elt_longcst (pstate, (LONGEST) $1);
493                           write_exp_elt_opcode (pstate, OP_BOOL); }
494         ;
495
496 exp     :       M2_FALSE
497                         { write_exp_elt_opcode (pstate, OP_BOOL);
498                           write_exp_elt_longcst (pstate, (LONGEST) $1);
499                           write_exp_elt_opcode (pstate, OP_BOOL); }
500         ;
501
502 exp     :       INT
503                         { write_exp_elt_opcode (pstate, OP_LONG);
504                           write_exp_elt_type (pstate,
505                                         parse_m2_type (pstate)->builtin_int);
506                           write_exp_elt_longcst (pstate, (LONGEST) $1);
507                           write_exp_elt_opcode (pstate, OP_LONG); }
508         ;
509
510 exp     :       UINT
511                         {
512                           write_exp_elt_opcode (pstate, OP_LONG);
513                           write_exp_elt_type (pstate,
514                                               parse_m2_type (pstate)
515                                               ->builtin_card);
516                           write_exp_elt_longcst (pstate, (LONGEST) $1);
517                           write_exp_elt_opcode (pstate, OP_LONG);
518                         }
519         ;
520
521 exp     :       CHAR
522                         { write_exp_elt_opcode (pstate, OP_LONG);
523                           write_exp_elt_type (pstate,
524                                               parse_m2_type (pstate)
525                                               ->builtin_char);
526                           write_exp_elt_longcst (pstate, (LONGEST) $1);
527                           write_exp_elt_opcode (pstate, OP_LONG); }
528         ;
529
530
531 exp     :       FLOAT
532                         { write_exp_elt_opcode (pstate, OP_DOUBLE);
533                           write_exp_elt_type (pstate,
534                                               parse_m2_type (pstate)
535                                               ->builtin_real);
536                           write_exp_elt_dblcst (pstate, $1);
537                           write_exp_elt_opcode (pstate, OP_DOUBLE); }
538         ;
539
540 exp     :       variable
541         ;
542
543 exp     :       SIZE '(' type ')'       %prec UNARY
544                         { write_exp_elt_opcode (pstate, OP_LONG);
545                           write_exp_elt_type (pstate,
546                                             parse_type (pstate)->builtin_int);
547                           write_exp_elt_longcst (pstate,
548                                                  (LONGEST) TYPE_LENGTH ($3));
549                           write_exp_elt_opcode (pstate, OP_LONG); }
550         ;
551
552 exp     :       STRING
553                         { write_exp_elt_opcode (pstate, OP_M2_STRING);
554                           write_exp_string (pstate, $1);
555                           write_exp_elt_opcode (pstate, OP_M2_STRING); }
556         ;
557
558 /* This will be used for extensions later.  Like adding modules.  */
559 block   :       fblock  
560                         { $$ = SYMBOL_BLOCK_VALUE($1); }
561         ;
562
563 fblock  :       BLOCKNAME
564                         { struct symbol *sym
565                             = lookup_symbol (copy_name ($1),
566                                              expression_context_block,
567                                              VAR_DOMAIN, 0);
568                           $$ = sym;}
569         ;
570                              
571
572 /* GDB scope operator */
573 fblock  :       block COLONCOLON BLOCKNAME
574                         { struct symbol *tem
575                             = lookup_symbol (copy_name ($3), $1,
576                                              VAR_DOMAIN, 0);
577                           if (!tem || SYMBOL_CLASS (tem) != LOC_BLOCK)
578                             error (_("No function \"%s\" in specified context."),
579                                    copy_name ($3));
580                           $$ = tem;
581                         }
582         ;
583
584 /* Useful for assigning to PROCEDURE variables */
585 variable:       fblock
586                         { write_exp_elt_opcode (pstate, OP_VAR_VALUE);
587                           write_exp_elt_block (pstate, NULL);
588                           write_exp_elt_sym (pstate, $1);
589                           write_exp_elt_opcode (pstate, OP_VAR_VALUE); }
590         ;
591
592 /* GDB internal ($foo) variable */
593 variable:       INTERNAL_VAR
594         ;
595
596 /* GDB scope operator */
597 variable:       block COLONCOLON NAME
598                         { struct symbol *sym;
599                           sym = lookup_symbol (copy_name ($3), $1,
600                                                VAR_DOMAIN, 0);
601                           if (sym == 0)
602                             error (_("No symbol \"%s\" in specified context."),
603                                    copy_name ($3));
604                           if (symbol_read_needs_frame (sym))
605                             {
606                               if (innermost_block == 0
607                                   || contained_in (block_found,
608                                                    innermost_block))
609                                 innermost_block = block_found;
610                             }
611
612                           write_exp_elt_opcode (pstate, OP_VAR_VALUE);
613                           /* block_found is set by lookup_symbol.  */
614                           write_exp_elt_block (pstate, block_found);
615                           write_exp_elt_sym (pstate, sym);
616                           write_exp_elt_opcode (pstate, OP_VAR_VALUE); }
617         ;
618
619 /* Base case for variables.  */
620 variable:       NAME
621                         { struct symbol *sym;
622                           struct field_of_this_result is_a_field_of_this;
623
624                           sym = lookup_symbol (copy_name ($1),
625                                                expression_context_block,
626                                                VAR_DOMAIN,
627                                                &is_a_field_of_this);
628                           if (sym)
629                             {
630                               if (symbol_read_needs_frame (sym))
631                                 {
632                                   if (innermost_block == 0 ||
633                                       contained_in (block_found, 
634                                                     innermost_block))
635                                     innermost_block = block_found;
636                                 }
637
638                               write_exp_elt_opcode (pstate, OP_VAR_VALUE);
639                               /* We want to use the selected frame, not
640                                  another more inner frame which happens to
641                                  be in the same block.  */
642                               write_exp_elt_block (pstate, NULL);
643                               write_exp_elt_sym (pstate, sym);
644                               write_exp_elt_opcode (pstate, OP_VAR_VALUE);
645                             }
646                           else
647                             {
648                               struct bound_minimal_symbol msymbol;
649                               char *arg = copy_name ($1);
650
651                               msymbol =
652                                 lookup_bound_minimal_symbol (arg);
653                               if (msymbol.minsym != NULL)
654                                 write_exp_msymbol (pstate, msymbol);
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 (parse_language (pstate),
667                                                 parse_gdbarch (pstate),
668                                                 copy_name ($1),
669                                                 expression_context_block, 0); }
670
671         ;
672
673 %%
674
675 /* Take care of parsing a number (anything that starts with a digit).
676    Set yylval and return the token type; update lexptr.
677    LEN is the number of characters in it.  */
678
679 /*** Needs some error checking for the float case ***/
680
681 static int
682 parse_number (int olen)
683 {
684   const char *p = lexptr;
685   LONGEST n = 0;
686   LONGEST prevn = 0;
687   int c,i,ischar=0;
688   int base = input_radix;
689   int len = olen;
690   int unsigned_p = number_sign == 1 ? 1 : 0;
691
692   if(p[len-1] == 'H')
693   {
694      base = 16;
695      len--;
696   }
697   else if(p[len-1] == 'C' || p[len-1] == 'B')
698   {
699      base = 8;
700      ischar = p[len-1] == 'C';
701      len--;
702   }
703
704   /* Scan the number */
705   for (c = 0; c < len; c++)
706   {
707     if (p[c] == '.' && base == 10)
708       {
709         /* It's a float since it contains a point.  */
710         yylval.dval = atof (p);
711         lexptr += len;
712         return FLOAT;
713       }
714     if (p[c] == '.' && base != 10)
715        error (_("Floating point numbers must be base 10."));
716     if (base == 10 && (p[c] < '0' || p[c] > '9'))
717        error (_("Invalid digit \'%c\' in number."),p[c]);
718  }
719
720   while (len-- > 0)
721     {
722       c = *p++;
723       n *= base;
724       if( base == 8 && (c == '8' || c == '9'))
725          error (_("Invalid digit \'%c\' in octal number."),c);
726       if (c >= '0' && c <= '9')
727         i = c - '0';
728       else
729         {
730           if (base == 16 && c >= 'A' && c <= 'F')
731             i = c - 'A' + 10;
732           else
733              return ERROR;
734         }
735       n+=i;
736       if(i >= base)
737          return ERROR;
738       if(!unsigned_p && number_sign == 1 && (prevn >= n))
739          unsigned_p=1;          /* Try something unsigned */
740       /* Don't do the range check if n==i and i==0, since that special
741          case will give an overflow error.  */
742       if(RANGE_CHECK && n!=i && i)
743       {
744          if((unsigned_p && (unsigned)prevn >= (unsigned)n) ||
745             ((!unsigned_p && number_sign==-1) && -prevn <= -n))
746             range_error (_("Overflow on numeric constant."));
747       }
748          prevn=n;
749     }
750
751   lexptr = p;
752   if(*p == 'B' || *p == 'C' || *p == 'H')
753      lexptr++;                  /* Advance past B,C or H */
754
755   if (ischar)
756   {
757      yylval.ulval = n;
758      return CHAR;
759   }
760   else if ( unsigned_p && number_sign == 1)
761   {
762      yylval.ulval = n;
763      return UINT;
764   }
765   else if((unsigned_p && (n<0))) {
766      range_error (_("Overflow on numeric constant -- number too large."));
767      /* But, this can return if range_check == range_warn.  */
768   }
769   yylval.lval = n;
770   return INT;
771 }
772
773
774 /* Some tokens */
775
776 static struct
777 {
778    char name[2];
779    int token;
780 } tokentab2[] =
781 {
782     { {'<', '>'},    NOTEQUAL   },
783     { {':', '='},    ASSIGN     },
784     { {'<', '='},    LEQ        },
785     { {'>', '='},    GEQ        },
786     { {':', ':'},    COLONCOLON },
787
788 };
789
790 /* Some specific keywords */
791
792 struct keyword {
793    char keyw[10];
794    int token;
795 };
796
797 static struct keyword keytab[] =
798 {
799     {"OR" ,   OROR       },
800     {"IN",    IN         },/* Note space after IN */
801     {"AND",   LOGICAL_AND},
802     {"ABS",   ABS        },
803     {"CHR",   CHR        },
804     {"DEC",   DEC        },
805     {"NOT",   NOT        },
806     {"DIV",   DIV        },
807     {"INC",   INC        },
808     {"MAX",   MAX_FUNC   },
809     {"MIN",   MIN_FUNC   },
810     {"MOD",   MOD        },
811     {"ODD",   ODD        },
812     {"CAP",   CAP        },
813     {"ORD",   ORD        },
814     {"VAL",   VAL        },
815     {"EXCL",  EXCL       },
816     {"HIGH",  HIGH       },
817     {"INCL",  INCL       },
818     {"SIZE",  SIZE       },
819     {"FLOAT", FLOAT_FUNC },
820     {"TRUNC", TRUNC      },
821     {"TSIZE", SIZE       },
822 };
823
824
825 /* Read one token, getting characters through lexptr.  */
826
827 /* This is where we will check to make sure that the language and the
828    operators used are compatible  */
829
830 static int
831 yylex (void)
832 {
833   int c;
834   int namelen;
835   int i;
836   const char *tokstart;
837   char quote;
838
839  retry:
840
841   prev_lexptr = lexptr;
842
843   tokstart = lexptr;
844
845
846   /* See if it is a special token of length 2 */
847   for( i = 0 ; i < (int) (sizeof tokentab2 / sizeof tokentab2[0]) ; i++)
848      if (strncmp (tokentab2[i].name, tokstart, 2) == 0)
849      {
850         lexptr += 2;
851         return tokentab2[i].token;
852      }
853
854   switch (c = *tokstart)
855     {
856     case 0:
857       return 0;
858
859     case ' ':
860     case '\t':
861     case '\n':
862       lexptr++;
863       goto retry;
864
865     case '(':
866       paren_depth++;
867       lexptr++;
868       return c;
869
870     case ')':
871       if (paren_depth == 0)
872         return 0;
873       paren_depth--;
874       lexptr++;
875       return c;
876
877     case ',':
878       if (comma_terminates && paren_depth == 0)
879         return 0;
880       lexptr++;
881       return c;
882
883     case '.':
884       /* Might be a floating point number.  */
885       if (lexptr[1] >= '0' && lexptr[1] <= '9')
886         break;                  /* Falls into number code.  */
887       else
888       {
889          lexptr++;
890          return DOT;
891       }
892
893 /* These are character tokens that appear as-is in the YACC grammar */
894     case '+':
895     case '-':
896     case '*':
897     case '/':
898     case '^':
899     case '<':
900     case '>':
901     case '[':
902     case ']':
903     case '=':
904     case '{':
905     case '}':
906     case '#':
907     case '@':
908     case '~':
909     case '&':
910       lexptr++;
911       return c;
912
913     case '\'' :
914     case '"':
915       quote = c;
916       for (namelen = 1; (c = tokstart[namelen]) != quote && c != '\0'; namelen++)
917         if (c == '\\')
918           {
919             c = tokstart[++namelen];
920             if (c >= '0' && c <= '9')
921               {
922                 c = tokstart[++namelen];
923                 if (c >= '0' && c <= '9')
924                   c = tokstart[++namelen];
925               }
926           }
927       if(c != quote)
928          error (_("Unterminated string or character constant."));
929       yylval.sval.ptr = tokstart + 1;
930       yylval.sval.length = namelen - 1;
931       lexptr += namelen + 1;
932
933       if(namelen == 2)          /* Single character */
934       {
935            yylval.ulval = tokstart[1];
936            return CHAR;
937       }
938       else
939          return STRING;
940     }
941
942   /* Is it a number?  */
943   /* Note:  We have already dealt with the case of the token '.'.
944      See case '.' above.  */
945   if ((c >= '0' && c <= '9'))
946     {
947       /* It's a number.  */
948       int got_dot = 0, got_e = 0;
949       const char *p = tokstart;
950       int toktype;
951
952       for (++p ;; ++p)
953         {
954           if (!got_e && (*p == 'e' || *p == 'E'))
955             got_dot = got_e = 1;
956           else if (!got_dot && *p == '.')
957             got_dot = 1;
958           else if (got_e && (p[-1] == 'e' || p[-1] == 'E')
959                    && (*p == '-' || *p == '+'))
960             /* This is the sign of the exponent, not the end of the
961                number.  */
962             continue;
963           else if ((*p < '0' || *p > '9') &&
964                    (*p < 'A' || *p > 'F') &&
965                    (*p != 'H'))  /* Modula-2 hexadecimal number */
966             break;
967         }
968         toktype = parse_number (p - tokstart);
969         if (toktype == ERROR)
970           {
971             char *err_copy = (char *) alloca (p - tokstart + 1);
972
973             memcpy (err_copy, tokstart, p - tokstart);
974             err_copy[p - tokstart] = 0;
975             error (_("Invalid number \"%s\"."), err_copy);
976           }
977         lexptr = p;
978         return toktype;
979     }
980
981   if (!(c == '_' || c == '$'
982         || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')))
983     /* We must have come across a bad character (e.g. ';').  */
984     error (_("Invalid character '%c' in expression."), c);
985
986   /* It's a name.  See how long it is.  */
987   namelen = 0;
988   for (c = tokstart[namelen];
989        (c == '_' || c == '$' || (c >= '0' && c <= '9')
990         || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z'));
991        c = tokstart[++namelen])
992     ;
993
994   /* The token "if" terminates the expression and is NOT
995      removed from the input stream.  */
996   if (namelen == 2 && tokstart[0] == 'i' && tokstart[1] == 'f')
997     {
998       return 0;
999     }
1000
1001   lexptr += namelen;
1002
1003   /*  Lookup special keywords */
1004   for(i = 0 ; i < (int) (sizeof(keytab) / sizeof(keytab[0])) ; i++)
1005      if (namelen == strlen (keytab[i].keyw)
1006          && strncmp (tokstart, keytab[i].keyw, namelen) == 0)
1007            return keytab[i].token;
1008
1009   yylval.sval.ptr = tokstart;
1010   yylval.sval.length = namelen;
1011
1012   if (*tokstart == '$')
1013     {
1014       write_dollar_variable (pstate, yylval.sval);
1015       return INTERNAL_VAR;
1016     }
1017
1018   /* Use token-type BLOCKNAME for symbols that happen to be defined as
1019      functions.  If this is not so, then ...
1020      Use token-type TYPENAME for symbols that happen to be defined
1021      currently as names of types; NAME for other symbols.
1022      The caller is not constrained to care about the distinction.  */
1023  {
1024
1025
1026     char *tmp = copy_name (yylval.sval);
1027     struct symbol *sym;
1028
1029     if (lookup_symtab (tmp))
1030       return BLOCKNAME;
1031     sym = lookup_symbol (tmp, expression_context_block, VAR_DOMAIN, 0);
1032     if (sym && SYMBOL_CLASS (sym) == LOC_BLOCK)
1033       return BLOCKNAME;
1034     if (lookup_typename (parse_language (pstate), parse_gdbarch (pstate),
1035                          copy_name (yylval.sval),
1036                          expression_context_block, 1))
1037       return TYPENAME;
1038
1039     if(sym)
1040     {
1041       switch(SYMBOL_CLASS (sym))
1042        {
1043        case LOC_STATIC:
1044        case LOC_REGISTER:
1045        case LOC_ARG:
1046        case LOC_REF_ARG:
1047        case LOC_REGPARM_ADDR:
1048        case LOC_LOCAL:
1049        case LOC_CONST:
1050        case LOC_CONST_BYTES:
1051        case LOC_OPTIMIZED_OUT:
1052        case LOC_COMPUTED:
1053           return NAME;
1054
1055        case LOC_TYPEDEF:
1056           return TYPENAME;
1057
1058        case LOC_BLOCK:
1059           return BLOCKNAME;
1060
1061        case LOC_UNDEF:
1062           error (_("internal:  Undefined class in m2lex()"));
1063
1064        case LOC_LABEL:
1065        case LOC_UNRESOLVED:
1066           error (_("internal:  Unforseen case in m2lex()"));
1067
1068        default:
1069           error (_("unhandled token in m2lex()"));
1070           break;
1071        }
1072     }
1073     else
1074     {
1075        /* Built-in BOOLEAN type.  This is sort of a hack.  */
1076        if (strncmp (tokstart, "TRUE", 4) == 0)
1077        {
1078           yylval.ulval = 1;
1079           return M2_TRUE;
1080        }
1081        else if (strncmp (tokstart, "FALSE", 5) == 0)
1082        {
1083           yylval.ulval = 0;
1084           return M2_FALSE;
1085        }
1086     }
1087
1088     /* Must be another type of name...  */
1089     return NAME;
1090  }
1091 }
1092
1093 int
1094 m2_parse (struct parser_state *par_state)
1095 {
1096   int result;
1097   struct cleanup *c = make_cleanup_clear_parser_state (&pstate);
1098
1099   /* Setting up the parser state.  */
1100   gdb_assert (par_state != NULL);
1101   pstate = par_state;
1102
1103   result = yyparse ();
1104   do_cleanups (c);
1105
1106   return result;
1107 }
1108
1109 void
1110 yyerror (char *msg)
1111 {
1112   if (prev_lexptr)
1113     lexptr = prev_lexptr;
1114
1115   error (_("A %s in expression, near `%s'."), (msg ? msg : "error"), lexptr);
1116 }