Replace the block_found global with explicit data-flow
[deliverable/binutils-gdb.git] / gdb / f-exp.y
1
2 /* YACC parser for Fortran expressions, for GDB.
3 Copyright (C) 1986-2015 Free Software Foundation, Inc.
4
5 Contributed by Motorola. Adapted from the C parser by Farooq Butt
6 (fmbutt@engage.sps.mot.com).
7
8 This file is part of GDB.
9
10 This program is free software; you can redistribute it and/or modify
11 it under the terms of the GNU General Public License as published by
12 the Free Software Foundation; either version 3 of the License, or
13 (at your option) any later version.
14
15 This program is distributed in the hope that it will be useful,
16 but WITHOUT ANY WARRANTY; without even the implied warranty of
17 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 GNU General Public License for more details.
19
20 You should have received a copy of the GNU General Public License
21 along with this program. If not, see <http://www.gnu.org/licenses/>. */
22
23 /* This was blantantly ripped off the C expression parser, please
24 be aware of that as you look at its basic structure -FMB */
25
26 /* Parse a F77 expression from text in a string,
27 and return the result as a struct expression pointer.
28 That structure contains arithmetic operations in reverse polish,
29 with constants represented by operations that are followed by special data.
30 See expression.h for the details of the format.
31 What is important here is that it can be built up sequentially
32 during the process of parsing; the lower levels of the tree always
33 come first in the result.
34
35 Note that malloc's and realloc's in this file are transformed to
36 xmalloc and xrealloc respectively by the same sed command in the
37 makefile that remaps any other malloc/realloc inserted by the parser
38 generator. Doing this with #defines and trying to control the interaction
39 with include files (<malloc.h> and <stdlib.h> for example) just became
40 too messy, particularly when such includes can be inserted at random
41 times by the parser generator. */
42
43 %{
44
45 #include "defs.h"
46 #include "expression.h"
47 #include "value.h"
48 #include "parser-defs.h"
49 #include "language.h"
50 #include "f-lang.h"
51 #include "bfd.h" /* Required by objfiles.h. */
52 #include "symfile.h" /* Required by objfiles.h. */
53 #include "objfiles.h" /* For have_full_symbols and have_partial_symbols */
54 #include "block.h"
55 #include <ctype.h>
56
57 #define parse_type(ps) builtin_type (parse_gdbarch (ps))
58 #define parse_f_type(ps) builtin_f_type (parse_gdbarch (ps))
59
60 /* Remap normal yacc parser interface names (yyparse, yylex, yyerror, etc),
61 as well as gratuitiously global symbol names, so we can have multiple
62 yacc generated parsers in gdb. Note that these are only the variables
63 produced by yacc. If other parser generators (bison, byacc, etc) produce
64 additional global names that conflict at link time, then those parser
65 generators need to be fixed instead of adding those names to this list. */
66
67 #define yymaxdepth f_maxdepth
68 #define yyparse f_parse_internal
69 #define yylex f_lex
70 #define yyerror f_error
71 #define yylval f_lval
72 #define yychar f_char
73 #define yydebug f_debug
74 #define yypact f_pact
75 #define yyr1 f_r1
76 #define yyr2 f_r2
77 #define yydef f_def
78 #define yychk f_chk
79 #define yypgo f_pgo
80 #define yyact f_act
81 #define yyexca f_exca
82 #define yyerrflag f_errflag
83 #define yynerrs f_nerrs
84 #define yyps f_ps
85 #define yypv f_pv
86 #define yys f_s
87 #define yy_yys f_yys
88 #define yystate f_state
89 #define yytmp f_tmp
90 #define yyv f_v
91 #define yy_yyv f_yyv
92 #define yyval f_val
93 #define yylloc f_lloc
94 #define yyreds f_reds /* With YYDEBUG defined */
95 #define yytoks f_toks /* With YYDEBUG defined */
96 #define yyname f_name /* With YYDEBUG defined */
97 #define yyrule f_rule /* With YYDEBUG defined */
98 #define yylhs f_yylhs
99 #define yylen f_yylen
100 #define yydefred f_yydefred
101 #define yydgoto f_yydgoto
102 #define yysindex f_yysindex
103 #define yyrindex f_yyrindex
104 #define yygindex f_yygindex
105 #define yytable f_yytable
106 #define yycheck f_yycheck
107 #define yyss f_yyss
108 #define yysslim f_yysslim
109 #define yyssp f_yyssp
110 #define yystacksize f_yystacksize
111 #define yyvs f_yyvs
112 #define yyvsp f_yyvsp
113
114 #ifndef YYDEBUG
115 #define YYDEBUG 1 /* Default to yydebug support */
116 #endif
117
118 #define YYFPRINTF parser_fprintf
119
120 /* The state of the parser, used internally when we are parsing the
121 expression. */
122
123 static struct parser_state *pstate = NULL;
124
125 int yyparse (void);
126
127 static int yylex (void);
128
129 void yyerror (char *);
130
131 static void growbuf_by_size (int);
132
133 static int match_string_literal (void);
134
135 %}
136
137 /* Although the yacc "value" of an expression is not used,
138 since the result is stored in the structure being created,
139 other node types do have values. */
140
141 %union
142 {
143 LONGEST lval;
144 struct {
145 LONGEST val;
146 struct type *type;
147 } typed_val;
148 DOUBLEST dval;
149 struct symbol *sym;
150 struct type *tval;
151 struct stoken sval;
152 struct ttype tsym;
153 struct symtoken ssym;
154 int voidval;
155 struct block *bval;
156 enum exp_opcode opcode;
157 struct internalvar *ivar;
158
159 struct type **tvec;
160 int *ivec;
161 }
162
163 %{
164 /* YYSTYPE gets defined by %union */
165 static int parse_number (struct parser_state *, const char *, int,
166 int, YYSTYPE *);
167 %}
168
169 %type <voidval> exp type_exp start variable
170 %type <tval> type typebase
171 %type <tvec> nonempty_typelist
172 /* %type <bval> block */
173
174 /* Fancy type parsing. */
175 %type <voidval> func_mod direct_abs_decl abs_decl
176 %type <tval> ptype
177
178 %token <typed_val> INT
179 %token <dval> FLOAT
180
181 /* Both NAME and TYPENAME tokens represent symbols in the input,
182 and both convey their data as strings.
183 But a TYPENAME is a string that happens to be defined as a typedef
184 or builtin type name (such as int or char)
185 and a NAME is any other symbol.
186 Contexts where this distinction is not important can use the
187 nonterminal "name", which matches either NAME or TYPENAME. */
188
189 %token <sval> STRING_LITERAL
190 %token <lval> BOOLEAN_LITERAL
191 %token <ssym> NAME
192 %token <tsym> TYPENAME
193 %type <sval> name
194 %type <ssym> name_not_typename
195
196 /* A NAME_OR_INT is a symbol which is not known in the symbol table,
197 but which would parse as a valid number in the current input radix.
198 E.g. "c" when input_radix==16. Depending on the parse, it will be
199 turned into a name or into a number. */
200
201 %token <ssym> NAME_OR_INT
202
203 %token SIZEOF
204 %token ERROR
205
206 /* Special type cases, put in to allow the parser to distinguish different
207 legal basetypes. */
208 %token INT_KEYWORD INT_S2_KEYWORD LOGICAL_S1_KEYWORD LOGICAL_S2_KEYWORD
209 %token LOGICAL_S8_KEYWORD
210 %token LOGICAL_KEYWORD REAL_KEYWORD REAL_S8_KEYWORD REAL_S16_KEYWORD
211 %token COMPLEX_S8_KEYWORD COMPLEX_S16_KEYWORD COMPLEX_S32_KEYWORD
212 %token BOOL_AND BOOL_OR BOOL_NOT
213 %token <lval> CHARACTER
214
215 %token <voidval> VARIABLE
216
217 %token <opcode> ASSIGN_MODIFY
218
219 %left ','
220 %left ABOVE_COMMA
221 %right '=' ASSIGN_MODIFY
222 %right '?'
223 %left BOOL_OR
224 %right BOOL_NOT
225 %left BOOL_AND
226 %left '|'
227 %left '^'
228 %left '&'
229 %left EQUAL NOTEQUAL
230 %left LESSTHAN GREATERTHAN LEQ GEQ
231 %left LSH RSH
232 %left '@'
233 %left '+' '-'
234 %left '*' '/'
235 %right STARSTAR
236 %right '%'
237 %right UNARY
238 %right '('
239
240 \f
241 %%
242
243 start : exp
244 | type_exp
245 ;
246
247 type_exp: type
248 { write_exp_elt_opcode (pstate, OP_TYPE);
249 write_exp_elt_type (pstate, $1);
250 write_exp_elt_opcode (pstate, OP_TYPE); }
251 ;
252
253 exp : '(' exp ')'
254 { }
255 ;
256
257 /* Expressions, not including the comma operator. */
258 exp : '*' exp %prec UNARY
259 { write_exp_elt_opcode (pstate, UNOP_IND); }
260 ;
261
262 exp : '&' exp %prec UNARY
263 { write_exp_elt_opcode (pstate, UNOP_ADDR); }
264 ;
265
266 exp : '-' exp %prec UNARY
267 { write_exp_elt_opcode (pstate, UNOP_NEG); }
268 ;
269
270 exp : BOOL_NOT exp %prec UNARY
271 { write_exp_elt_opcode (pstate, UNOP_LOGICAL_NOT); }
272 ;
273
274 exp : '~' exp %prec UNARY
275 { write_exp_elt_opcode (pstate, UNOP_COMPLEMENT); }
276 ;
277
278 exp : SIZEOF exp %prec UNARY
279 { write_exp_elt_opcode (pstate, UNOP_SIZEOF); }
280 ;
281
282 /* No more explicit array operators, we treat everything in F77 as
283 a function call. The disambiguation as to whether we are
284 doing a subscript operation or a function call is done
285 later in eval.c. */
286
287 exp : exp '('
288 { start_arglist (); }
289 arglist ')'
290 { write_exp_elt_opcode (pstate,
291 OP_F77_UNDETERMINED_ARGLIST);
292 write_exp_elt_longcst (pstate,
293 (LONGEST) end_arglist ());
294 write_exp_elt_opcode (pstate,
295 OP_F77_UNDETERMINED_ARGLIST); }
296 ;
297
298 arglist :
299 ;
300
301 arglist : exp
302 { arglist_len = 1; }
303 ;
304
305 arglist : subrange
306 { arglist_len = 1; }
307 ;
308
309 arglist : arglist ',' exp %prec ABOVE_COMMA
310 { arglist_len++; }
311 ;
312
313 /* There are four sorts of subrange types in F90. */
314
315 subrange: exp ':' exp %prec ABOVE_COMMA
316 { write_exp_elt_opcode (pstate, OP_F90_RANGE);
317 write_exp_elt_longcst (pstate, NONE_BOUND_DEFAULT);
318 write_exp_elt_opcode (pstate, OP_F90_RANGE); }
319 ;
320
321 subrange: exp ':' %prec ABOVE_COMMA
322 { write_exp_elt_opcode (pstate, OP_F90_RANGE);
323 write_exp_elt_longcst (pstate, HIGH_BOUND_DEFAULT);
324 write_exp_elt_opcode (pstate, OP_F90_RANGE); }
325 ;
326
327 subrange: ':' exp %prec ABOVE_COMMA
328 { write_exp_elt_opcode (pstate, OP_F90_RANGE);
329 write_exp_elt_longcst (pstate, LOW_BOUND_DEFAULT);
330 write_exp_elt_opcode (pstate, OP_F90_RANGE); }
331 ;
332
333 subrange: ':' %prec ABOVE_COMMA
334 { write_exp_elt_opcode (pstate, OP_F90_RANGE);
335 write_exp_elt_longcst (pstate, BOTH_BOUND_DEFAULT);
336 write_exp_elt_opcode (pstate, OP_F90_RANGE); }
337 ;
338
339 complexnum: exp ',' exp
340 { }
341 ;
342
343 exp : '(' complexnum ')'
344 { write_exp_elt_opcode (pstate, OP_COMPLEX);
345 write_exp_elt_type (pstate,
346 parse_f_type (pstate)
347 ->builtin_complex_s16);
348 write_exp_elt_opcode (pstate, OP_COMPLEX); }
349 ;
350
351 exp : '(' type ')' exp %prec UNARY
352 { write_exp_elt_opcode (pstate, UNOP_CAST);
353 write_exp_elt_type (pstate, $2);
354 write_exp_elt_opcode (pstate, UNOP_CAST); }
355 ;
356
357 exp : exp '%' name
358 { write_exp_elt_opcode (pstate, STRUCTOP_STRUCT);
359 write_exp_string (pstate, $3);
360 write_exp_elt_opcode (pstate, STRUCTOP_STRUCT); }
361 ;
362
363 /* Binary operators in order of decreasing precedence. */
364
365 exp : exp '@' exp
366 { write_exp_elt_opcode (pstate, BINOP_REPEAT); }
367 ;
368
369 exp : exp STARSTAR exp
370 { write_exp_elt_opcode (pstate, BINOP_EXP); }
371 ;
372
373 exp : exp '*' exp
374 { write_exp_elt_opcode (pstate, BINOP_MUL); }
375 ;
376
377 exp : exp '/' exp
378 { write_exp_elt_opcode (pstate, BINOP_DIV); }
379 ;
380
381 exp : exp '+' exp
382 { write_exp_elt_opcode (pstate, BINOP_ADD); }
383 ;
384
385 exp : exp '-' exp
386 { write_exp_elt_opcode (pstate, BINOP_SUB); }
387 ;
388
389 exp : exp LSH exp
390 { write_exp_elt_opcode (pstate, BINOP_LSH); }
391 ;
392
393 exp : exp RSH exp
394 { write_exp_elt_opcode (pstate, BINOP_RSH); }
395 ;
396
397 exp : exp EQUAL exp
398 { write_exp_elt_opcode (pstate, BINOP_EQUAL); }
399 ;
400
401 exp : exp NOTEQUAL exp
402 { write_exp_elt_opcode (pstate, BINOP_NOTEQUAL); }
403 ;
404
405 exp : exp LEQ exp
406 { write_exp_elt_opcode (pstate, BINOP_LEQ); }
407 ;
408
409 exp : exp GEQ exp
410 { write_exp_elt_opcode (pstate, BINOP_GEQ); }
411 ;
412
413 exp : exp LESSTHAN exp
414 { write_exp_elt_opcode (pstate, BINOP_LESS); }
415 ;
416
417 exp : exp GREATERTHAN exp
418 { write_exp_elt_opcode (pstate, BINOP_GTR); }
419 ;
420
421 exp : exp '&' exp
422 { write_exp_elt_opcode (pstate, BINOP_BITWISE_AND); }
423 ;
424
425 exp : exp '^' exp
426 { write_exp_elt_opcode (pstate, BINOP_BITWISE_XOR); }
427 ;
428
429 exp : exp '|' exp
430 { write_exp_elt_opcode (pstate, BINOP_BITWISE_IOR); }
431 ;
432
433 exp : exp BOOL_AND exp
434 { write_exp_elt_opcode (pstate, BINOP_LOGICAL_AND); }
435 ;
436
437
438 exp : exp BOOL_OR exp
439 { write_exp_elt_opcode (pstate, BINOP_LOGICAL_OR); }
440 ;
441
442 exp : exp '=' exp
443 { write_exp_elt_opcode (pstate, BINOP_ASSIGN); }
444 ;
445
446 exp : exp ASSIGN_MODIFY exp
447 { write_exp_elt_opcode (pstate, BINOP_ASSIGN_MODIFY);
448 write_exp_elt_opcode (pstate, $2);
449 write_exp_elt_opcode (pstate, BINOP_ASSIGN_MODIFY); }
450 ;
451
452 exp : INT
453 { write_exp_elt_opcode (pstate, OP_LONG);
454 write_exp_elt_type (pstate, $1.type);
455 write_exp_elt_longcst (pstate, (LONGEST) ($1.val));
456 write_exp_elt_opcode (pstate, OP_LONG); }
457 ;
458
459 exp : NAME_OR_INT
460 { YYSTYPE val;
461 parse_number (pstate, $1.stoken.ptr,
462 $1.stoken.length, 0, &val);
463 write_exp_elt_opcode (pstate, OP_LONG);
464 write_exp_elt_type (pstate, val.typed_val.type);
465 write_exp_elt_longcst (pstate,
466 (LONGEST)val.typed_val.val);
467 write_exp_elt_opcode (pstate, OP_LONG); }
468 ;
469
470 exp : FLOAT
471 { write_exp_elt_opcode (pstate, OP_DOUBLE);
472 write_exp_elt_type (pstate,
473 parse_f_type (pstate)
474 ->builtin_real_s8);
475 write_exp_elt_dblcst (pstate, $1);
476 write_exp_elt_opcode (pstate, OP_DOUBLE); }
477 ;
478
479 exp : variable
480 ;
481
482 exp : VARIABLE
483 ;
484
485 exp : SIZEOF '(' type ')' %prec UNARY
486 { write_exp_elt_opcode (pstate, OP_LONG);
487 write_exp_elt_type (pstate,
488 parse_f_type (pstate)
489 ->builtin_integer);
490 $3 = check_typedef ($3);
491 write_exp_elt_longcst (pstate,
492 (LONGEST) TYPE_LENGTH ($3));
493 write_exp_elt_opcode (pstate, OP_LONG); }
494 ;
495
496 exp : BOOLEAN_LITERAL
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
503 exp : STRING_LITERAL
504 {
505 write_exp_elt_opcode (pstate, OP_STRING);
506 write_exp_string (pstate, $1);
507 write_exp_elt_opcode (pstate, OP_STRING);
508 }
509 ;
510
511 variable: name_not_typename
512 { struct block_symbol sym = $1.sym;
513
514 if (sym.symbol)
515 {
516 if (symbol_read_needs_frame (sym.symbol))
517 {
518 if (innermost_block == 0
519 || contained_in (sym.block,
520 innermost_block))
521 innermost_block = sym.block;
522 }
523 write_exp_elt_opcode (pstate, OP_VAR_VALUE);
524 /* We want to use the selected frame, not
525 another more inner frame which happens to
526 be in the same block. */
527 write_exp_elt_block (pstate, NULL);
528 write_exp_elt_sym (pstate, sym.symbol);
529 write_exp_elt_opcode (pstate, OP_VAR_VALUE);
530 break;
531 }
532 else
533 {
534 struct bound_minimal_symbol msymbol;
535 char *arg = copy_name ($1.stoken);
536
537 msymbol =
538 lookup_bound_minimal_symbol (arg);
539 if (msymbol.minsym != NULL)
540 write_exp_msymbol (pstate, msymbol);
541 else if (!have_full_symbols () && !have_partial_symbols ())
542 error (_("No symbol table is loaded. Use the \"file\" command."));
543 else
544 error (_("No symbol \"%s\" in current context."),
545 copy_name ($1.stoken));
546 }
547 }
548 ;
549
550
551 type : ptype
552 ;
553
554 ptype : typebase
555 | typebase abs_decl
556 {
557 /* This is where the interesting stuff happens. */
558 int done = 0;
559 int array_size;
560 struct type *follow_type = $1;
561 struct type *range_type;
562
563 while (!done)
564 switch (pop_type ())
565 {
566 case tp_end:
567 done = 1;
568 break;
569 case tp_pointer:
570 follow_type = lookup_pointer_type (follow_type);
571 break;
572 case tp_reference:
573 follow_type = lookup_reference_type (follow_type);
574 break;
575 case tp_array:
576 array_size = pop_type_int ();
577 if (array_size != -1)
578 {
579 range_type =
580 create_static_range_type ((struct type *) NULL,
581 parse_f_type (pstate)
582 ->builtin_integer,
583 0, array_size - 1);
584 follow_type =
585 create_array_type ((struct type *) NULL,
586 follow_type, range_type);
587 }
588 else
589 follow_type = lookup_pointer_type (follow_type);
590 break;
591 case tp_function:
592 follow_type = lookup_function_type (follow_type);
593 break;
594 }
595 $$ = follow_type;
596 }
597 ;
598
599 abs_decl: '*'
600 { push_type (tp_pointer); $$ = 0; }
601 | '*' abs_decl
602 { push_type (tp_pointer); $$ = $2; }
603 | '&'
604 { push_type (tp_reference); $$ = 0; }
605 | '&' abs_decl
606 { push_type (tp_reference); $$ = $2; }
607 | direct_abs_decl
608 ;
609
610 direct_abs_decl: '(' abs_decl ')'
611 { $$ = $2; }
612 | direct_abs_decl func_mod
613 { push_type (tp_function); }
614 | func_mod
615 { push_type (tp_function); }
616 ;
617
618 func_mod: '(' ')'
619 { $$ = 0; }
620 | '(' nonempty_typelist ')'
621 { free ($2); $$ = 0; }
622 ;
623
624 typebase /* Implements (approximately): (type-qualifier)* type-specifier */
625 : TYPENAME
626 { $$ = $1.type; }
627 | INT_KEYWORD
628 { $$ = parse_f_type (pstate)->builtin_integer; }
629 | INT_S2_KEYWORD
630 { $$ = parse_f_type (pstate)->builtin_integer_s2; }
631 | CHARACTER
632 { $$ = parse_f_type (pstate)->builtin_character; }
633 | LOGICAL_S8_KEYWORD
634 { $$ = parse_f_type (pstate)->builtin_logical_s8; }
635 | LOGICAL_KEYWORD
636 { $$ = parse_f_type (pstate)->builtin_logical; }
637 | LOGICAL_S2_KEYWORD
638 { $$ = parse_f_type (pstate)->builtin_logical_s2; }
639 | LOGICAL_S1_KEYWORD
640 { $$ = parse_f_type (pstate)->builtin_logical_s1; }
641 | REAL_KEYWORD
642 { $$ = parse_f_type (pstate)->builtin_real; }
643 | REAL_S8_KEYWORD
644 { $$ = parse_f_type (pstate)->builtin_real_s8; }
645 | REAL_S16_KEYWORD
646 { $$ = parse_f_type (pstate)->builtin_real_s16; }
647 | COMPLEX_S8_KEYWORD
648 { $$ = parse_f_type (pstate)->builtin_complex_s8; }
649 | COMPLEX_S16_KEYWORD
650 { $$ = parse_f_type (pstate)->builtin_complex_s16; }
651 | COMPLEX_S32_KEYWORD
652 { $$ = parse_f_type (pstate)->builtin_complex_s32; }
653 ;
654
655 nonempty_typelist
656 : type
657 { $$ = (struct type **) malloc (sizeof (struct type *) * 2);
658 $<ivec>$[0] = 1; /* Number of types in vector */
659 $$[1] = $1;
660 }
661 | nonempty_typelist ',' type
662 { int len = sizeof (struct type *) * (++($<ivec>1[0]) + 1);
663 $$ = (struct type **) realloc ((char *) $1, len);
664 $$[$<ivec>$[0]] = $3;
665 }
666 ;
667
668 name : NAME
669 { $$ = $1.stoken; }
670 ;
671
672 name_not_typename : NAME
673 /* These would be useful if name_not_typename was useful, but it is just
674 a fake for "variable", so these cause reduce/reduce conflicts because
675 the parser can't tell whether NAME_OR_INT is a name_not_typename (=variable,
676 =exp) or just an exp. If name_not_typename was ever used in an lvalue
677 context where only a name could occur, this might be useful.
678 | NAME_OR_INT
679 */
680 ;
681
682 %%
683
684 /* Take care of parsing a number (anything that starts with a digit).
685 Set yylval and return the token type; update lexptr.
686 LEN is the number of characters in it. */
687
688 /*** Needs some error checking for the float case ***/
689
690 static int
691 parse_number (struct parser_state *par_state,
692 const char *p, int len, int parsed_float, YYSTYPE *putithere)
693 {
694 LONGEST n = 0;
695 LONGEST prevn = 0;
696 int c;
697 int base = input_radix;
698 int unsigned_p = 0;
699 int long_p = 0;
700 ULONGEST high_bit;
701 struct type *signed_type;
702 struct type *unsigned_type;
703
704 if (parsed_float)
705 {
706 /* It's a float since it contains a point or an exponent. */
707 /* [dD] is not understood as an exponent by atof, change it to 'e'. */
708 char *tmp, *tmp2;
709
710 tmp = xstrdup (p);
711 for (tmp2 = tmp; *tmp2; ++tmp2)
712 if (*tmp2 == 'd' || *tmp2 == 'D')
713 *tmp2 = 'e';
714 putithere->dval = atof (tmp);
715 free (tmp);
716 return FLOAT;
717 }
718
719 /* Handle base-switching prefixes 0x, 0t, 0d, 0 */
720 if (p[0] == '0')
721 switch (p[1])
722 {
723 case 'x':
724 case 'X':
725 if (len >= 3)
726 {
727 p += 2;
728 base = 16;
729 len -= 2;
730 }
731 break;
732
733 case 't':
734 case 'T':
735 case 'd':
736 case 'D':
737 if (len >= 3)
738 {
739 p += 2;
740 base = 10;
741 len -= 2;
742 }
743 break;
744
745 default:
746 base = 8;
747 break;
748 }
749
750 while (len-- > 0)
751 {
752 c = *p++;
753 if (isupper (c))
754 c = tolower (c);
755 if (len == 0 && c == 'l')
756 long_p = 1;
757 else if (len == 0 && c == 'u')
758 unsigned_p = 1;
759 else
760 {
761 int i;
762 if (c >= '0' && c <= '9')
763 i = c - '0';
764 else if (c >= 'a' && c <= 'f')
765 i = c - 'a' + 10;
766 else
767 return ERROR; /* Char not a digit */
768 if (i >= base)
769 return ERROR; /* Invalid digit in this base */
770 n *= base;
771 n += i;
772 }
773 /* Portably test for overflow (only works for nonzero values, so make
774 a second check for zero). */
775 if ((prevn >= n) && n != 0)
776 unsigned_p=1; /* Try something unsigned */
777 /* If range checking enabled, portably test for unsigned overflow. */
778 if (RANGE_CHECK && n != 0)
779 {
780 if ((unsigned_p && (unsigned)prevn >= (unsigned)n))
781 range_error (_("Overflow on numeric constant."));
782 }
783 prevn = n;
784 }
785
786 /* If the number is too big to be an int, or it's got an l suffix
787 then it's a long. Work out if this has to be a long by
788 shifting right and seeing if anything remains, and the
789 target int size is different to the target long size.
790
791 In the expression below, we could have tested
792 (n >> gdbarch_int_bit (parse_gdbarch))
793 to see if it was zero,
794 but too many compilers warn about that, when ints and longs
795 are the same size. So we shift it twice, with fewer bits
796 each time, for the same result. */
797
798 if ((gdbarch_int_bit (parse_gdbarch (par_state))
799 != gdbarch_long_bit (parse_gdbarch (par_state))
800 && ((n >> 2)
801 >> (gdbarch_int_bit (parse_gdbarch (par_state))-2))) /* Avoid
802 shift warning */
803 || long_p)
804 {
805 high_bit = ((ULONGEST)1)
806 << (gdbarch_long_bit (parse_gdbarch (par_state))-1);
807 unsigned_type = parse_type (par_state)->builtin_unsigned_long;
808 signed_type = parse_type (par_state)->builtin_long;
809 }
810 else
811 {
812 high_bit =
813 ((ULONGEST)1) << (gdbarch_int_bit (parse_gdbarch (par_state)) - 1);
814 unsigned_type = parse_type (par_state)->builtin_unsigned_int;
815 signed_type = parse_type (par_state)->builtin_int;
816 }
817
818 putithere->typed_val.val = n;
819
820 /* If the high bit of the worked out type is set then this number
821 has to be unsigned. */
822
823 if (unsigned_p || (n & high_bit))
824 putithere->typed_val.type = unsigned_type;
825 else
826 putithere->typed_val.type = signed_type;
827
828 return INT;
829 }
830
831 struct token
832 {
833 char *oper;
834 int token;
835 enum exp_opcode opcode;
836 };
837
838 static const struct token dot_ops[] =
839 {
840 { ".and.", BOOL_AND, BINOP_END },
841 { ".AND.", BOOL_AND, BINOP_END },
842 { ".or.", BOOL_OR, BINOP_END },
843 { ".OR.", BOOL_OR, BINOP_END },
844 { ".not.", BOOL_NOT, BINOP_END },
845 { ".NOT.", BOOL_NOT, BINOP_END },
846 { ".eq.", EQUAL, BINOP_END },
847 { ".EQ.", EQUAL, BINOP_END },
848 { ".eqv.", EQUAL, BINOP_END },
849 { ".NEQV.", NOTEQUAL, BINOP_END },
850 { ".neqv.", NOTEQUAL, BINOP_END },
851 { ".EQV.", EQUAL, BINOP_END },
852 { ".ne.", NOTEQUAL, BINOP_END },
853 { ".NE.", NOTEQUAL, BINOP_END },
854 { ".le.", LEQ, BINOP_END },
855 { ".LE.", LEQ, BINOP_END },
856 { ".ge.", GEQ, BINOP_END },
857 { ".GE.", GEQ, BINOP_END },
858 { ".gt.", GREATERTHAN, BINOP_END },
859 { ".GT.", GREATERTHAN, BINOP_END },
860 { ".lt.", LESSTHAN, BINOP_END },
861 { ".LT.", LESSTHAN, BINOP_END },
862 { NULL, 0, BINOP_END }
863 };
864
865 struct f77_boolean_val
866 {
867 char *name;
868 int value;
869 };
870
871 static const struct f77_boolean_val boolean_values[] =
872 {
873 { ".true.", 1 },
874 { ".TRUE.", 1 },
875 { ".false.", 0 },
876 { ".FALSE.", 0 },
877 { NULL, 0 }
878 };
879
880 static const struct token f77_keywords[] =
881 {
882 { "complex_16", COMPLEX_S16_KEYWORD, BINOP_END },
883 { "complex_32", COMPLEX_S32_KEYWORD, BINOP_END },
884 { "character", CHARACTER, BINOP_END },
885 { "integer_2", INT_S2_KEYWORD, BINOP_END },
886 { "logical_1", LOGICAL_S1_KEYWORD, BINOP_END },
887 { "logical_2", LOGICAL_S2_KEYWORD, BINOP_END },
888 { "logical_8", LOGICAL_S8_KEYWORD, BINOP_END },
889 { "complex_8", COMPLEX_S8_KEYWORD, BINOP_END },
890 { "integer", INT_KEYWORD, BINOP_END },
891 { "logical", LOGICAL_KEYWORD, BINOP_END },
892 { "real_16", REAL_S16_KEYWORD, BINOP_END },
893 { "complex", COMPLEX_S8_KEYWORD, BINOP_END },
894 { "sizeof", SIZEOF, BINOP_END },
895 { "real_8", REAL_S8_KEYWORD, BINOP_END },
896 { "real", REAL_KEYWORD, BINOP_END },
897 { NULL, 0, BINOP_END }
898 };
899
900 /* Implementation of a dynamically expandable buffer for processing input
901 characters acquired through lexptr and building a value to return in
902 yylval. Ripped off from ch-exp.y */
903
904 static char *tempbuf; /* Current buffer contents */
905 static int tempbufsize; /* Size of allocated buffer */
906 static int tempbufindex; /* Current index into buffer */
907
908 #define GROWBY_MIN_SIZE 64 /* Minimum amount to grow buffer by */
909
910 #define CHECKBUF(size) \
911 do { \
912 if (tempbufindex + (size) >= tempbufsize) \
913 { \
914 growbuf_by_size (size); \
915 } \
916 } while (0);
917
918
919 /* Grow the static temp buffer if necessary, including allocating the
920 first one on demand. */
921
922 static void
923 growbuf_by_size (int count)
924 {
925 int growby;
926
927 growby = max (count, GROWBY_MIN_SIZE);
928 tempbufsize += growby;
929 if (tempbuf == NULL)
930 tempbuf = (char *) malloc (tempbufsize);
931 else
932 tempbuf = (char *) realloc (tempbuf, tempbufsize);
933 }
934
935 /* Blatantly ripped off from ch-exp.y. This routine recognizes F77
936 string-literals.
937
938 Recognize a string literal. A string literal is a nonzero sequence
939 of characters enclosed in matching single quotes, except that
940 a single character inside single quotes is a character literal, which
941 we reject as a string literal. To embed the terminator character inside
942 a string, it is simply doubled (I.E. 'this''is''one''string') */
943
944 static int
945 match_string_literal (void)
946 {
947 const char *tokptr = lexptr;
948
949 for (tempbufindex = 0, tokptr++; *tokptr != '\0'; tokptr++)
950 {
951 CHECKBUF (1);
952 if (*tokptr == *lexptr)
953 {
954 if (*(tokptr + 1) == *lexptr)
955 tokptr++;
956 else
957 break;
958 }
959 tempbuf[tempbufindex++] = *tokptr;
960 }
961 if (*tokptr == '\0' /* no terminator */
962 || tempbufindex == 0) /* no string */
963 return 0;
964 else
965 {
966 tempbuf[tempbufindex] = '\0';
967 yylval.sval.ptr = tempbuf;
968 yylval.sval.length = tempbufindex;
969 lexptr = ++tokptr;
970 return STRING_LITERAL;
971 }
972 }
973
974 /* Read one token, getting characters through lexptr. */
975
976 static int
977 yylex (void)
978 {
979 int c;
980 int namelen;
981 unsigned int i,token;
982 const char *tokstart;
983
984 retry:
985
986 prev_lexptr = lexptr;
987
988 tokstart = lexptr;
989
990 /* First of all, let us make sure we are not dealing with the
991 special tokens .true. and .false. which evaluate to 1 and 0. */
992
993 if (*lexptr == '.')
994 {
995 for (i = 0; boolean_values[i].name != NULL; i++)
996 {
997 if (strncmp (tokstart, boolean_values[i].name,
998 strlen (boolean_values[i].name)) == 0)
999 {
1000 lexptr += strlen (boolean_values[i].name);
1001 yylval.lval = boolean_values[i].value;
1002 return BOOLEAN_LITERAL;
1003 }
1004 }
1005 }
1006
1007 /* See if it is a special .foo. operator. */
1008
1009 for (i = 0; dot_ops[i].oper != NULL; i++)
1010 if (strncmp (tokstart, dot_ops[i].oper,
1011 strlen (dot_ops[i].oper)) == 0)
1012 {
1013 lexptr += strlen (dot_ops[i].oper);
1014 yylval.opcode = dot_ops[i].opcode;
1015 return dot_ops[i].token;
1016 }
1017
1018 /* See if it is an exponentiation operator. */
1019
1020 if (strncmp (tokstart, "**", 2) == 0)
1021 {
1022 lexptr += 2;
1023 yylval.opcode = BINOP_EXP;
1024 return STARSTAR;
1025 }
1026
1027 switch (c = *tokstart)
1028 {
1029 case 0:
1030 return 0;
1031
1032 case ' ':
1033 case '\t':
1034 case '\n':
1035 lexptr++;
1036 goto retry;
1037
1038 case '\'':
1039 token = match_string_literal ();
1040 if (token != 0)
1041 return (token);
1042 break;
1043
1044 case '(':
1045 paren_depth++;
1046 lexptr++;
1047 return c;
1048
1049 case ')':
1050 if (paren_depth == 0)
1051 return 0;
1052 paren_depth--;
1053 lexptr++;
1054 return c;
1055
1056 case ',':
1057 if (comma_terminates && paren_depth == 0)
1058 return 0;
1059 lexptr++;
1060 return c;
1061
1062 case '.':
1063 /* Might be a floating point number. */
1064 if (lexptr[1] < '0' || lexptr[1] > '9')
1065 goto symbol; /* Nope, must be a symbol. */
1066 /* FALL THRU into number case. */
1067
1068 case '0':
1069 case '1':
1070 case '2':
1071 case '3':
1072 case '4':
1073 case '5':
1074 case '6':
1075 case '7':
1076 case '8':
1077 case '9':
1078 {
1079 /* It's a number. */
1080 int got_dot = 0, got_e = 0, got_d = 0, toktype;
1081 const char *p = tokstart;
1082 int hex = input_radix > 10;
1083
1084 if (c == '0' && (p[1] == 'x' || p[1] == 'X'))
1085 {
1086 p += 2;
1087 hex = 1;
1088 }
1089 else if (c == '0' && (p[1]=='t' || p[1]=='T'
1090 || p[1]=='d' || p[1]=='D'))
1091 {
1092 p += 2;
1093 hex = 0;
1094 }
1095
1096 for (;; ++p)
1097 {
1098 if (!hex && !got_e && (*p == 'e' || *p == 'E'))
1099 got_dot = got_e = 1;
1100 else if (!hex && !got_d && (*p == 'd' || *p == 'D'))
1101 got_dot = got_d = 1;
1102 else if (!hex && !got_dot && *p == '.')
1103 got_dot = 1;
1104 else if (((got_e && (p[-1] == 'e' || p[-1] == 'E'))
1105 || (got_d && (p[-1] == 'd' || p[-1] == 'D')))
1106 && (*p == '-' || *p == '+'))
1107 /* This is the sign of the exponent, not the end of the
1108 number. */
1109 continue;
1110 /* We will take any letters or digits. parse_number will
1111 complain if past the radix, or if L or U are not final. */
1112 else if ((*p < '0' || *p > '9')
1113 && ((*p < 'a' || *p > 'z')
1114 && (*p < 'A' || *p > 'Z')))
1115 break;
1116 }
1117 toktype = parse_number (pstate, tokstart, p - tokstart,
1118 got_dot|got_e|got_d,
1119 &yylval);
1120 if (toktype == ERROR)
1121 {
1122 char *err_copy = (char *) alloca (p - tokstart + 1);
1123
1124 memcpy (err_copy, tokstart, p - tokstart);
1125 err_copy[p - tokstart] = 0;
1126 error (_("Invalid number \"%s\"."), err_copy);
1127 }
1128 lexptr = p;
1129 return toktype;
1130 }
1131
1132 case '+':
1133 case '-':
1134 case '*':
1135 case '/':
1136 case '%':
1137 case '|':
1138 case '&':
1139 case '^':
1140 case '~':
1141 case '!':
1142 case '@':
1143 case '<':
1144 case '>':
1145 case '[':
1146 case ']':
1147 case '?':
1148 case ':':
1149 case '=':
1150 case '{':
1151 case '}':
1152 symbol:
1153 lexptr++;
1154 return c;
1155 }
1156
1157 if (!(c == '_' || c == '$' || c ==':'
1158 || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')))
1159 /* We must have come across a bad character (e.g. ';'). */
1160 error (_("Invalid character '%c' in expression."), c);
1161
1162 namelen = 0;
1163 for (c = tokstart[namelen];
1164 (c == '_' || c == '$' || c == ':' || (c >= '0' && c <= '9')
1165 || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z'));
1166 c = tokstart[++namelen]);
1167
1168 /* The token "if" terminates the expression and is NOT
1169 removed from the input stream. */
1170
1171 if (namelen == 2 && tokstart[0] == 'i' && tokstart[1] == 'f')
1172 return 0;
1173
1174 lexptr += namelen;
1175
1176 /* Catch specific keywords. */
1177
1178 for (i = 0; f77_keywords[i].oper != NULL; i++)
1179 if (strlen (f77_keywords[i].oper) == namelen
1180 && strncmp (tokstart, f77_keywords[i].oper, namelen) == 0)
1181 {
1182 /* lexptr += strlen(f77_keywords[i].operator); */
1183 yylval.opcode = f77_keywords[i].opcode;
1184 return f77_keywords[i].token;
1185 }
1186
1187 yylval.sval.ptr = tokstart;
1188 yylval.sval.length = namelen;
1189
1190 if (*tokstart == '$')
1191 {
1192 write_dollar_variable (pstate, yylval.sval);
1193 return VARIABLE;
1194 }
1195
1196 /* Use token-type TYPENAME for symbols that happen to be defined
1197 currently as names of types; NAME for other symbols.
1198 The caller is not constrained to care about the distinction. */
1199 {
1200 char *tmp = copy_name (yylval.sval);
1201 struct block_symbol result;
1202 struct field_of_this_result is_a_field_of_this;
1203 enum domain_enum_tag lookup_domains[] =
1204 {
1205 STRUCT_DOMAIN,
1206 VAR_DOMAIN,
1207 MODULE_DOMAIN
1208 };
1209 int i;
1210 int hextype;
1211
1212 for (i = 0; i < ARRAY_SIZE (lookup_domains); ++i)
1213 {
1214 /* Initialize this in case we *don't* use it in this call; that
1215 way we can refer to it unconditionally below. */
1216 memset (&is_a_field_of_this, 0, sizeof (is_a_field_of_this));
1217
1218 result = lookup_symbol (tmp, expression_context_block,
1219 lookup_domains[i],
1220 parse_language (pstate)->la_language
1221 == language_cplus
1222 ? &is_a_field_of_this : NULL);
1223 if (result.symbol && SYMBOL_CLASS (result.symbol) == LOC_TYPEDEF)
1224 {
1225 yylval.tsym.type = SYMBOL_TYPE (result.symbol);
1226 return TYPENAME;
1227 }
1228
1229 if (result.symbol)
1230 break;
1231 }
1232
1233 yylval.tsym.type
1234 = language_lookup_primitive_type (parse_language (pstate),
1235 parse_gdbarch (pstate), tmp);
1236 if (yylval.tsym.type != NULL)
1237 return TYPENAME;
1238
1239 /* Input names that aren't symbols but ARE valid hex numbers,
1240 when the input radix permits them, can be names or numbers
1241 depending on the parse. Note we support radixes > 16 here. */
1242 if (!result.symbol
1243 && ((tokstart[0] >= 'a' && tokstart[0] < 'a' + input_radix - 10)
1244 || (tokstart[0] >= 'A' && tokstart[0] < 'A' + input_radix - 10)))
1245 {
1246 YYSTYPE newlval; /* Its value is ignored. */
1247 hextype = parse_number (pstate, tokstart, namelen, 0, &newlval);
1248 if (hextype == INT)
1249 {
1250 yylval.ssym.sym = result;
1251 yylval.ssym.is_a_field_of_this = is_a_field_of_this.type != NULL;
1252 return NAME_OR_INT;
1253 }
1254 }
1255
1256 /* Any other kind of symbol */
1257 yylval.ssym.sym = result;
1258 yylval.ssym.is_a_field_of_this = is_a_field_of_this.type != NULL;
1259 return NAME;
1260 }
1261 }
1262
1263 int
1264 f_parse (struct parser_state *par_state)
1265 {
1266 int result;
1267 struct cleanup *c = make_cleanup_clear_parser_state (&pstate);
1268
1269 /* Setting up the parser state. */
1270 gdb_assert (par_state != NULL);
1271 pstate = par_state;
1272
1273 result = yyparse ();
1274 do_cleanups (c);
1275 return result;
1276 }
1277
1278 void
1279 yyerror (char *msg)
1280 {
1281 if (prev_lexptr)
1282 lexptr = prev_lexptr;
1283
1284 error (_("A %s in expression, near `%s'."), (msg ? msg : "error"), lexptr);
1285 }
This page took 0.072507 seconds and 4 git commands to generate.