2 /* YACC parser for Fortran expressions, for GDB.
3 Copyright (C) 1986-2021 Free Software Foundation, Inc.
5 Contributed by Motorola. Adapted from the C parser by Farooq Butt
6 (fmbutt@engage.sps.mot.com).
8 This file is part of GDB.
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.
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.
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/>. */
23 /* This was blantantly ripped off the C expression parser, please
24 be aware of that as you look at its basic structure -FMB */
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.
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. */
46 #include "expression.h"
48 #include "parser-defs.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 */
57 #include "type-stack.h"
59 #define parse_type(ps) builtin_type (ps->gdbarch ())
60 #define parse_f_type(ps) builtin_f_type (ps->gdbarch ())
62 /* Remap normal yacc parser interface names (yyparse, yylex, yyerror,
64 #define GDB_YY_REMAP_PREFIX f_
67 /* The state of the parser, used internally when we are parsing the
70 static struct parser_state *pstate = NULL;
72 /* Depth of parentheses. */
73 static int paren_depth;
75 /* The current type stack. */
76 static struct type_stack *type_stack;
80 static int yylex (void);
82 static void yyerror (const char *);
84 static void growbuf_by_size (int);
86 static int match_string_literal (void);
88 static void push_kind_type (LONGEST val, struct type *type);
90 static struct type *convert_to_kind_type (struct type *basetype, int kind);
94 /* Although the yacc "value" of an expression is not used,
95 since the result is stored in the structure being created,
96 other node types do have values. */
113 struct symtoken ssym;
115 enum exp_opcode opcode;
116 struct internalvar *ivar;
123 /* YYSTYPE gets defined by %union */
124 static int parse_number (struct parser_state *, const char *, int,
128 %type <voidval> exp type_exp start variable
129 %type <tval> type typebase
130 %type <tvec> nonempty_typelist
131 /* %type <bval> block */
133 /* Fancy type parsing. */
134 %type <voidval> func_mod direct_abs_decl abs_decl
137 %token <typed_val> INT
138 %token <typed_val_float> FLOAT
140 /* Both NAME and TYPENAME tokens represent symbols in the input,
141 and both convey their data as strings.
142 But a TYPENAME is a string that happens to be defined as a typedef
143 or builtin type name (such as int or char)
144 and a NAME is any other symbol.
145 Contexts where this distinction is not important can use the
146 nonterminal "name", which matches either NAME or TYPENAME. */
148 %token <sval> STRING_LITERAL
149 %token <lval> BOOLEAN_LITERAL
151 %token <tsym> TYPENAME
152 %token <voidval> COMPLETE
154 %type <ssym> name_not_typename
156 /* A NAME_OR_INT is a symbol which is not known in the symbol table,
157 but which would parse as a valid number in the current input radix.
158 E.g. "c" when input_radix==16. Depending on the parse, it will be
159 turned into a name or into a number. */
161 %token <ssym> NAME_OR_INT
166 /* Special type cases, put in to allow the parser to distinguish different
168 %token INT_KEYWORD INT_S2_KEYWORD LOGICAL_S1_KEYWORD LOGICAL_S2_KEYWORD
169 %token LOGICAL_S8_KEYWORD
170 %token LOGICAL_KEYWORD REAL_KEYWORD REAL_S8_KEYWORD REAL_S16_KEYWORD
171 %token COMPLEX_KEYWORD
172 %token COMPLEX_S8_KEYWORD COMPLEX_S16_KEYWORD COMPLEX_S32_KEYWORD
173 %token BOOL_AND BOOL_OR BOOL_NOT
174 %token SINGLE DOUBLE PRECISION
175 %token <lval> CHARACTER
177 %token <sval> DOLLAR_VARIABLE
179 %token <opcode> ASSIGN_MODIFY
180 %token <opcode> UNOP_INTRINSIC BINOP_INTRINSIC
184 %right '=' ASSIGN_MODIFY
193 %left LESSTHAN GREATERTHAN LEQ GEQ
211 { write_exp_elt_opcode (pstate, OP_TYPE);
212 write_exp_elt_type (pstate, $1);
213 write_exp_elt_opcode (pstate, OP_TYPE); }
220 /* Expressions, not including the comma operator. */
221 exp : '*' exp %prec UNARY
222 { write_exp_elt_opcode (pstate, UNOP_IND); }
225 exp : '&' exp %prec UNARY
226 { write_exp_elt_opcode (pstate, UNOP_ADDR); }
229 exp : '-' exp %prec UNARY
230 { write_exp_elt_opcode (pstate, UNOP_NEG); }
233 exp : BOOL_NOT exp %prec UNARY
234 { write_exp_elt_opcode (pstate, UNOP_LOGICAL_NOT); }
237 exp : '~' exp %prec UNARY
238 { write_exp_elt_opcode (pstate, UNOP_COMPLEMENT); }
241 exp : SIZEOF exp %prec UNARY
242 { write_exp_elt_opcode (pstate, UNOP_SIZEOF); }
245 exp : KIND '(' exp ')' %prec UNARY
246 { write_exp_elt_opcode (pstate, UNOP_FORTRAN_KIND); }
249 /* No more explicit array operators, we treat everything in F77 as
250 a function call. The disambiguation as to whether we are
251 doing a subscript operation or a function call is done
255 { pstate->start_arglist (); }
257 { write_exp_elt_opcode (pstate,
258 OP_F77_UNDETERMINED_ARGLIST);
259 write_exp_elt_longcst (pstate,
260 pstate->end_arglist ());
261 write_exp_elt_opcode (pstate,
262 OP_F77_UNDETERMINED_ARGLIST); }
265 exp : UNOP_INTRINSIC '(' exp ')'
266 { write_exp_elt_opcode (pstate, $1); }
269 exp : BINOP_INTRINSIC '(' exp ',' exp ')'
270 { write_exp_elt_opcode (pstate, $1); }
277 { pstate->arglist_len = 1; }
281 { pstate->arglist_len = 1; }
284 arglist : arglist ',' exp %prec ABOVE_COMMA
285 { pstate->arglist_len++; }
288 arglist : arglist ',' subrange %prec ABOVE_COMMA
289 { pstate->arglist_len++; }
292 /* There are four sorts of subrange types in F90. */
294 subrange: exp ':' exp %prec ABOVE_COMMA
295 { write_exp_elt_opcode (pstate, OP_RANGE);
296 write_exp_elt_longcst (pstate, RANGE_STANDARD);
297 write_exp_elt_opcode (pstate, OP_RANGE); }
300 subrange: exp ':' %prec ABOVE_COMMA
301 { write_exp_elt_opcode (pstate, OP_RANGE);
302 write_exp_elt_longcst (pstate,
303 RANGE_HIGH_BOUND_DEFAULT);
304 write_exp_elt_opcode (pstate, OP_RANGE); }
307 subrange: ':' exp %prec ABOVE_COMMA
308 { write_exp_elt_opcode (pstate, OP_RANGE);
309 write_exp_elt_longcst (pstate,
310 RANGE_LOW_BOUND_DEFAULT);
311 write_exp_elt_opcode (pstate, OP_RANGE); }
314 subrange: ':' %prec ABOVE_COMMA
315 { write_exp_elt_opcode (pstate, OP_RANGE);
316 write_exp_elt_longcst (pstate,
317 (RANGE_LOW_BOUND_DEFAULT
318 | RANGE_HIGH_BOUND_DEFAULT));
319 write_exp_elt_opcode (pstate, OP_RANGE); }
322 /* And each of the four subrange types can also have a stride. */
323 subrange: exp ':' exp ':' exp %prec ABOVE_COMMA
324 { write_exp_elt_opcode (pstate, OP_RANGE);
325 write_exp_elt_longcst (pstate, RANGE_HAS_STRIDE);
326 write_exp_elt_opcode (pstate, OP_RANGE); }
329 subrange: exp ':' ':' exp %prec ABOVE_COMMA
330 { write_exp_elt_opcode (pstate, OP_RANGE);
331 write_exp_elt_longcst (pstate,
332 (RANGE_HIGH_BOUND_DEFAULT
333 | RANGE_HAS_STRIDE));
334 write_exp_elt_opcode (pstate, OP_RANGE); }
337 subrange: ':' exp ':' exp %prec ABOVE_COMMA
338 { write_exp_elt_opcode (pstate, OP_RANGE);
339 write_exp_elt_longcst (pstate,
340 (RANGE_LOW_BOUND_DEFAULT
341 | RANGE_HAS_STRIDE));
342 write_exp_elt_opcode (pstate, OP_RANGE); }
345 subrange: ':' ':' exp %prec ABOVE_COMMA
346 { write_exp_elt_opcode (pstate, OP_RANGE);
347 write_exp_elt_longcst (pstate,
348 (RANGE_LOW_BOUND_DEFAULT
349 | RANGE_HIGH_BOUND_DEFAULT
350 | RANGE_HAS_STRIDE));
351 write_exp_elt_opcode (pstate, OP_RANGE); }
354 complexnum: exp ',' exp
358 exp : '(' complexnum ')'
359 { write_exp_elt_opcode (pstate, OP_COMPLEX);
360 write_exp_elt_type (pstate,
361 parse_f_type (pstate)
362 ->builtin_complex_s16);
363 write_exp_elt_opcode (pstate, OP_COMPLEX); }
366 exp : '(' type ')' exp %prec UNARY
367 { write_exp_elt_opcode (pstate, UNOP_CAST);
368 write_exp_elt_type (pstate, $2);
369 write_exp_elt_opcode (pstate, UNOP_CAST); }
373 { write_exp_elt_opcode (pstate, STRUCTOP_STRUCT);
374 write_exp_string (pstate, $3);
375 write_exp_elt_opcode (pstate, STRUCTOP_STRUCT); }
378 exp : exp '%' name COMPLETE
379 { pstate->mark_struct_expression ();
380 write_exp_elt_opcode (pstate, STRUCTOP_STRUCT);
381 write_exp_string (pstate, $3);
382 write_exp_elt_opcode (pstate, STRUCTOP_STRUCT); }
385 exp : exp '%' COMPLETE
387 pstate->mark_struct_expression ();
388 write_exp_elt_opcode (pstate, STRUCTOP_PTR);
391 write_exp_string (pstate, s);
392 write_exp_elt_opcode (pstate, STRUCTOP_PTR); }
394 /* Binary operators in order of decreasing precedence. */
397 { write_exp_elt_opcode (pstate, BINOP_REPEAT); }
400 exp : exp STARSTAR exp
401 { write_exp_elt_opcode (pstate, BINOP_EXP); }
405 { write_exp_elt_opcode (pstate, BINOP_MUL); }
409 { write_exp_elt_opcode (pstate, BINOP_DIV); }
413 { write_exp_elt_opcode (pstate, BINOP_ADD); }
417 { write_exp_elt_opcode (pstate, BINOP_SUB); }
421 { write_exp_elt_opcode (pstate, BINOP_LSH); }
425 { write_exp_elt_opcode (pstate, BINOP_RSH); }
429 { write_exp_elt_opcode (pstate, BINOP_EQUAL); }
432 exp : exp NOTEQUAL exp
433 { write_exp_elt_opcode (pstate, BINOP_NOTEQUAL); }
437 { write_exp_elt_opcode (pstate, BINOP_LEQ); }
441 { write_exp_elt_opcode (pstate, BINOP_GEQ); }
444 exp : exp LESSTHAN exp
445 { write_exp_elt_opcode (pstate, BINOP_LESS); }
448 exp : exp GREATERTHAN exp
449 { write_exp_elt_opcode (pstate, BINOP_GTR); }
453 { write_exp_elt_opcode (pstate, BINOP_BITWISE_AND); }
457 { write_exp_elt_opcode (pstate, BINOP_BITWISE_XOR); }
461 { write_exp_elt_opcode (pstate, BINOP_BITWISE_IOR); }
464 exp : exp BOOL_AND exp
465 { write_exp_elt_opcode (pstate, BINOP_LOGICAL_AND); }
469 exp : exp BOOL_OR exp
470 { write_exp_elt_opcode (pstate, BINOP_LOGICAL_OR); }
474 { write_exp_elt_opcode (pstate, BINOP_ASSIGN); }
477 exp : exp ASSIGN_MODIFY exp
478 { write_exp_elt_opcode (pstate, BINOP_ASSIGN_MODIFY);
479 write_exp_elt_opcode (pstate, $2);
480 write_exp_elt_opcode (pstate, BINOP_ASSIGN_MODIFY); }
484 { write_exp_elt_opcode (pstate, OP_LONG);
485 write_exp_elt_type (pstate, $1.type);
486 write_exp_elt_longcst (pstate, (LONGEST) ($1.val));
487 write_exp_elt_opcode (pstate, OP_LONG); }
492 parse_number (pstate, $1.stoken.ptr,
493 $1.stoken.length, 0, &val);
494 write_exp_elt_opcode (pstate, OP_LONG);
495 write_exp_elt_type (pstate, val.typed_val.type);
496 write_exp_elt_longcst (pstate,
497 (LONGEST)val.typed_val.val);
498 write_exp_elt_opcode (pstate, OP_LONG); }
502 { write_exp_elt_opcode (pstate, OP_FLOAT);
503 write_exp_elt_type (pstate, $1.type);
504 write_exp_elt_floatcst (pstate, $1.val);
505 write_exp_elt_opcode (pstate, OP_FLOAT); }
511 exp : DOLLAR_VARIABLE
512 { write_dollar_variable (pstate, $1); }
515 exp : SIZEOF '(' type ')' %prec UNARY
516 { write_exp_elt_opcode (pstate, OP_LONG);
517 write_exp_elt_type (pstate,
518 parse_f_type (pstate)
520 $3 = check_typedef ($3);
521 write_exp_elt_longcst (pstate,
522 (LONGEST) TYPE_LENGTH ($3));
523 write_exp_elt_opcode (pstate, OP_LONG); }
526 exp : BOOLEAN_LITERAL
527 { write_exp_elt_opcode (pstate, OP_BOOL);
528 write_exp_elt_longcst (pstate, (LONGEST) $1);
529 write_exp_elt_opcode (pstate, OP_BOOL);
535 write_exp_elt_opcode (pstate, OP_STRING);
536 write_exp_string (pstate, $1);
537 write_exp_elt_opcode (pstate, OP_STRING);
541 variable: name_not_typename
542 { struct block_symbol sym = $1.sym;
546 if (symbol_read_needs_frame (sym.symbol))
547 pstate->block_tracker->update (sym);
548 write_exp_elt_opcode (pstate, OP_VAR_VALUE);
549 write_exp_elt_block (pstate, sym.block);
550 write_exp_elt_sym (pstate, sym.symbol);
551 write_exp_elt_opcode (pstate, OP_VAR_VALUE);
556 struct bound_minimal_symbol msymbol;
557 std::string arg = copy_name ($1.stoken);
560 lookup_bound_minimal_symbol (arg.c_str ());
561 if (msymbol.minsym != NULL)
562 write_exp_msymbol (pstate, msymbol);
563 else if (!have_full_symbols () && !have_partial_symbols ())
564 error (_("No symbol table is loaded. Use the \"file\" command."));
566 error (_("No symbol \"%s\" in current context."),
579 /* This is where the interesting stuff happens. */
582 struct type *follow_type = $1;
583 struct type *range_type;
586 switch (type_stack->pop ())
592 follow_type = lookup_pointer_type (follow_type);
595 follow_type = lookup_lvalue_reference_type (follow_type);
598 array_size = type_stack->pop_int ();
599 if (array_size != -1)
602 create_static_range_type ((struct type *) NULL,
603 parse_f_type (pstate)
607 create_array_type ((struct type *) NULL,
608 follow_type, range_type);
611 follow_type = lookup_pointer_type (follow_type);
614 follow_type = lookup_function_type (follow_type);
618 int kind_val = type_stack->pop_int ();
620 = convert_to_kind_type (follow_type, kind_val);
629 { type_stack->push (tp_pointer); $$ = 0; }
631 { type_stack->push (tp_pointer); $$ = $2; }
633 { type_stack->push (tp_reference); $$ = 0; }
635 { type_stack->push (tp_reference); $$ = $2; }
639 direct_abs_decl: '(' abs_decl ')'
641 | '(' KIND '=' INT ')'
642 { push_kind_type ($4.val, $4.type); }
644 { push_kind_type ($2.val, $2.type); }
645 | direct_abs_decl func_mod
646 { type_stack->push (tp_function); }
648 { type_stack->push (tp_function); }
653 | '(' nonempty_typelist ')'
654 { free ($2); $$ = 0; }
657 typebase /* Implements (approximately): (type-qualifier)* type-specifier */
661 { $$ = parse_f_type (pstate)->builtin_integer; }
663 { $$ = parse_f_type (pstate)->builtin_integer_s2; }
665 { $$ = parse_f_type (pstate)->builtin_character; }
667 { $$ = parse_f_type (pstate)->builtin_logical_s8; }
669 { $$ = parse_f_type (pstate)->builtin_logical; }
671 { $$ = parse_f_type (pstate)->builtin_logical_s2; }
673 { $$ = parse_f_type (pstate)->builtin_logical_s1; }
675 { $$ = parse_f_type (pstate)->builtin_real; }
677 { $$ = parse_f_type (pstate)->builtin_real_s8; }
679 { $$ = parse_f_type (pstate)->builtin_real_s16; }
681 { $$ = parse_f_type (pstate)->builtin_complex_s8; }
683 { $$ = parse_f_type (pstate)->builtin_complex_s8; }
684 | COMPLEX_S16_KEYWORD
685 { $$ = parse_f_type (pstate)->builtin_complex_s16; }
686 | COMPLEX_S32_KEYWORD
687 { $$ = parse_f_type (pstate)->builtin_complex_s32; }
689 { $$ = parse_f_type (pstate)->builtin_real;}
691 { $$ = parse_f_type (pstate)->builtin_real_s8;}
692 | SINGLE COMPLEX_KEYWORD
693 { $$ = parse_f_type (pstate)->builtin_complex_s8;}
694 | DOUBLE COMPLEX_KEYWORD
695 { $$ = parse_f_type (pstate)->builtin_complex_s16;}
700 { $$ = (struct type **) malloc (sizeof (struct type *) * 2);
701 $<ivec>$[0] = 1; /* Number of types in vector */
704 | nonempty_typelist ',' type
705 { int len = sizeof (struct type *) * (++($<ivec>1[0]) + 1);
706 $$ = (struct type **) realloc ((char *) $1, len);
707 $$[$<ivec>$[0]] = $3;
715 name_not_typename : NAME
716 /* These would be useful if name_not_typename was useful, but it is just
717 a fake for "variable", so these cause reduce/reduce conflicts because
718 the parser can't tell whether NAME_OR_INT is a name_not_typename (=variable,
719 =exp) or just an exp. If name_not_typename was ever used in an lvalue
720 context where only a name could occur, this might be useful.
727 /* Take care of parsing a number (anything that starts with a digit).
728 Set yylval and return the token type; update lexptr.
729 LEN is the number of characters in it. */
731 /*** Needs some error checking for the float case ***/
734 parse_number (struct parser_state *par_state,
735 const char *p, int len, int parsed_float, YYSTYPE *putithere)
740 int base = input_radix;
744 struct type *signed_type;
745 struct type *unsigned_type;
749 /* It's a float since it contains a point or an exponent. */
750 /* [dD] is not understood as an exponent by parse_float,
755 for (tmp2 = tmp; *tmp2; ++tmp2)
756 if (*tmp2 == 'd' || *tmp2 == 'D')
759 /* FIXME: Should this use different types? */
760 putithere->typed_val_float.type = parse_f_type (pstate)->builtin_real_s8;
761 bool parsed = parse_float (tmp, len,
762 putithere->typed_val_float.type,
763 putithere->typed_val_float.val);
765 return parsed? FLOAT : ERROR;
768 /* Handle base-switching prefixes 0x, 0t, 0d, 0 */
804 if (len == 0 && c == 'l')
806 else if (len == 0 && c == 'u')
811 if (c >= '0' && c <= '9')
813 else if (c >= 'a' && c <= 'f')
816 return ERROR; /* Char not a digit */
818 return ERROR; /* Invalid digit in this base */
822 /* Portably test for overflow (only works for nonzero values, so make
823 a second check for zero). */
824 if ((prevn >= n) && n != 0)
825 unsigned_p=1; /* Try something unsigned */
826 /* If range checking enabled, portably test for unsigned overflow. */
827 if (RANGE_CHECK && n != 0)
829 if ((unsigned_p && (unsigned)prevn >= (unsigned)n))
830 range_error (_("Overflow on numeric constant."));
835 /* If the number is too big to be an int, or it's got an l suffix
836 then it's a long. Work out if this has to be a long by
837 shifting right and seeing if anything remains, and the
838 target int size is different to the target long size.
840 In the expression below, we could have tested
841 (n >> gdbarch_int_bit (parse_gdbarch))
842 to see if it was zero,
843 but too many compilers warn about that, when ints and longs
844 are the same size. So we shift it twice, with fewer bits
845 each time, for the same result. */
847 if ((gdbarch_int_bit (par_state->gdbarch ())
848 != gdbarch_long_bit (par_state->gdbarch ())
850 >> (gdbarch_int_bit (par_state->gdbarch ())-2))) /* Avoid
854 high_bit = ((ULONGEST)1)
855 << (gdbarch_long_bit (par_state->gdbarch ())-1);
856 unsigned_type = parse_type (par_state)->builtin_unsigned_long;
857 signed_type = parse_type (par_state)->builtin_long;
862 ((ULONGEST)1) << (gdbarch_int_bit (par_state->gdbarch ()) - 1);
863 unsigned_type = parse_type (par_state)->builtin_unsigned_int;
864 signed_type = parse_type (par_state)->builtin_int;
867 putithere->typed_val.val = n;
869 /* If the high bit of the worked out type is set then this number
870 has to be unsigned. */
872 if (unsigned_p || (n & high_bit))
873 putithere->typed_val.type = unsigned_type;
875 putithere->typed_val.type = signed_type;
880 /* Called to setup the type stack when we encounter a '(kind=N)' type
881 modifier, performs some bounds checking on 'N' and then pushes this to
882 the type stack followed by the 'tp_kind' marker. */
884 push_kind_type (LONGEST val, struct type *type)
888 if (type->is_unsigned ())
890 ULONGEST uval = static_cast <ULONGEST> (val);
892 error (_("kind value out of range"));
893 ival = static_cast <int> (uval);
897 if (val > INT_MAX || val < 0)
898 error (_("kind value out of range"));
899 ival = static_cast <int> (val);
902 type_stack->push (ival);
903 type_stack->push (tp_kind);
906 /* Called when a type has a '(kind=N)' modifier after it, for example
907 'character(kind=1)'. The BASETYPE is the type described by 'character'
908 in our example, and KIND is the integer '1'. This function returns a
909 new type that represents the basetype of a specific kind. */
911 convert_to_kind_type (struct type *basetype, int kind)
913 if (basetype == parse_f_type (pstate)->builtin_character)
915 /* Character of kind 1 is a special case, this is the same as the
916 base character type. */
918 return parse_f_type (pstate)->builtin_character;
920 else if (basetype == parse_f_type (pstate)->builtin_complex_s8)
923 return parse_f_type (pstate)->builtin_complex_s8;
925 return parse_f_type (pstate)->builtin_complex_s16;
927 return parse_f_type (pstate)->builtin_complex_s32;
929 else if (basetype == parse_f_type (pstate)->builtin_real)
932 return parse_f_type (pstate)->builtin_real;
934 return parse_f_type (pstate)->builtin_real_s8;
936 return parse_f_type (pstate)->builtin_real_s16;
938 else if (basetype == parse_f_type (pstate)->builtin_logical)
941 return parse_f_type (pstate)->builtin_logical_s1;
943 return parse_f_type (pstate)->builtin_logical_s2;
945 return parse_f_type (pstate)->builtin_logical;
947 return parse_f_type (pstate)->builtin_logical_s8;
949 else if (basetype == parse_f_type (pstate)->builtin_integer)
952 return parse_f_type (pstate)->builtin_integer_s2;
954 return parse_f_type (pstate)->builtin_integer;
956 return parse_f_type (pstate)->builtin_integer_s8;
959 error (_("unsupported kind %d for type %s"),
960 kind, TYPE_SAFE_NAME (basetype));
962 /* Should never get here. */
968 /* The string to match against. */
971 /* The lexer token to return. */
974 /* The expression opcode to embed within the token. */
975 enum exp_opcode opcode;
977 /* When this is true the string in OPER is matched exactly including
978 case, when this is false OPER is matched case insensitively. */
982 static const struct token dot_ops[] =
984 { ".and.", BOOL_AND, BINOP_END, false },
985 { ".or.", BOOL_OR, BINOP_END, false },
986 { ".not.", BOOL_NOT, BINOP_END, false },
987 { ".eq.", EQUAL, BINOP_END, false },
988 { ".eqv.", EQUAL, BINOP_END, false },
989 { ".neqv.", NOTEQUAL, BINOP_END, false },
990 { ".ne.", NOTEQUAL, BINOP_END, false },
991 { ".le.", LEQ, BINOP_END, false },
992 { ".ge.", GEQ, BINOP_END, false },
993 { ".gt.", GREATERTHAN, BINOP_END, false },
994 { ".lt.", LESSTHAN, BINOP_END, false },
997 /* Holds the Fortran representation of a boolean, and the integer value we
998 substitute in when one of the matching strings is parsed. */
999 struct f77_boolean_val
1001 /* The string representing a Fortran boolean. */
1004 /* The integer value to replace it with. */
1008 /* The set of Fortran booleans. These are matched case insensitively. */
1009 static const struct f77_boolean_val boolean_values[] =
1015 static const struct token f77_keywords[] =
1017 /* Historically these have always been lowercase only in GDB. */
1018 { "complex_16", COMPLEX_S16_KEYWORD, BINOP_END, true },
1019 { "complex_32", COMPLEX_S32_KEYWORD, BINOP_END, true },
1020 { "character", CHARACTER, BINOP_END, true },
1021 { "integer_2", INT_S2_KEYWORD, BINOP_END, true },
1022 { "logical_1", LOGICAL_S1_KEYWORD, BINOP_END, true },
1023 { "logical_2", LOGICAL_S2_KEYWORD, BINOP_END, true },
1024 { "logical_8", LOGICAL_S8_KEYWORD, BINOP_END, true },
1025 { "complex_8", COMPLEX_S8_KEYWORD, BINOP_END, true },
1026 { "integer", INT_KEYWORD, BINOP_END, true },
1027 { "logical", LOGICAL_KEYWORD, BINOP_END, true },
1028 { "real_16", REAL_S16_KEYWORD, BINOP_END, true },
1029 { "complex", COMPLEX_KEYWORD, BINOP_END, true },
1030 { "sizeof", SIZEOF, BINOP_END, true },
1031 { "real_8", REAL_S8_KEYWORD, BINOP_END, true },
1032 { "real", REAL_KEYWORD, BINOP_END, true },
1033 { "single", SINGLE, BINOP_END, true },
1034 { "double", DOUBLE, BINOP_END, true },
1035 { "precision", PRECISION, BINOP_END, true },
1036 /* The following correspond to actual functions in Fortran and are case
1038 { "kind", KIND, BINOP_END, false },
1039 { "abs", UNOP_INTRINSIC, UNOP_ABS, false },
1040 { "mod", BINOP_INTRINSIC, BINOP_MOD, false },
1041 { "floor", UNOP_INTRINSIC, UNOP_FORTRAN_FLOOR, false },
1042 { "ceiling", UNOP_INTRINSIC, UNOP_FORTRAN_CEILING, false },
1043 { "modulo", BINOP_INTRINSIC, BINOP_FORTRAN_MODULO, false },
1044 { "cmplx", BINOP_INTRINSIC, BINOP_FORTRAN_CMPLX, false },
1047 /* Implementation of a dynamically expandable buffer for processing input
1048 characters acquired through lexptr and building a value to return in
1049 yylval. Ripped off from ch-exp.y */
1051 static char *tempbuf; /* Current buffer contents */
1052 static int tempbufsize; /* Size of allocated buffer */
1053 static int tempbufindex; /* Current index into buffer */
1055 #define GROWBY_MIN_SIZE 64 /* Minimum amount to grow buffer by */
1057 #define CHECKBUF(size) \
1059 if (tempbufindex + (size) >= tempbufsize) \
1061 growbuf_by_size (size); \
1066 /* Grow the static temp buffer if necessary, including allocating the
1067 first one on demand. */
1070 growbuf_by_size (int count)
1074 growby = std::max (count, GROWBY_MIN_SIZE);
1075 tempbufsize += growby;
1076 if (tempbuf == NULL)
1077 tempbuf = (char *) malloc (tempbufsize);
1079 tempbuf = (char *) realloc (tempbuf, tempbufsize);
1082 /* Blatantly ripped off from ch-exp.y. This routine recognizes F77
1085 Recognize a string literal. A string literal is a nonzero sequence
1086 of characters enclosed in matching single quotes, except that
1087 a single character inside single quotes is a character literal, which
1088 we reject as a string literal. To embed the terminator character inside
1089 a string, it is simply doubled (I.E. 'this''is''one''string') */
1092 match_string_literal (void)
1094 const char *tokptr = pstate->lexptr;
1096 for (tempbufindex = 0, tokptr++; *tokptr != '\0'; tokptr++)
1099 if (*tokptr == *pstate->lexptr)
1101 if (*(tokptr + 1) == *pstate->lexptr)
1106 tempbuf[tempbufindex++] = *tokptr;
1108 if (*tokptr == '\0' /* no terminator */
1109 || tempbufindex == 0) /* no string */
1113 tempbuf[tempbufindex] = '\0';
1114 yylval.sval.ptr = tempbuf;
1115 yylval.sval.length = tempbufindex;
1116 pstate->lexptr = ++tokptr;
1117 return STRING_LITERAL;
1121 /* This is set if a NAME token appeared at the very end of the input
1122 string, with no whitespace separating the name from the EOF. This
1123 is used only when parsing to do field name completion. */
1124 static bool saw_name_at_eof;
1126 /* This is set if the previously-returned token was a structure
1128 static bool last_was_structop;
1130 /* Read one token, getting characters through lexptr. */
1138 const char *tokstart;
1139 bool saw_structop = last_was_structop;
1141 last_was_structop = false;
1145 pstate->prev_lexptr = pstate->lexptr;
1147 tokstart = pstate->lexptr;
1149 /* First of all, let us make sure we are not dealing with the
1150 special tokens .true. and .false. which evaluate to 1 and 0. */
1152 if (*pstate->lexptr == '.')
1154 for (int i = 0; i < ARRAY_SIZE (boolean_values); i++)
1156 if (strncasecmp (tokstart, boolean_values[i].name,
1157 strlen (boolean_values[i].name)) == 0)
1159 pstate->lexptr += strlen (boolean_values[i].name);
1160 yylval.lval = boolean_values[i].value;
1161 return BOOLEAN_LITERAL;
1166 /* See if it is a special .foo. operator. */
1167 for (int i = 0; i < ARRAY_SIZE (dot_ops); i++)
1168 if (strncasecmp (tokstart, dot_ops[i].oper,
1169 strlen (dot_ops[i].oper)) == 0)
1171 gdb_assert (!dot_ops[i].case_sensitive);
1172 pstate->lexptr += strlen (dot_ops[i].oper);
1173 yylval.opcode = dot_ops[i].opcode;
1174 return dot_ops[i].token;
1177 /* See if it is an exponentiation operator. */
1179 if (strncmp (tokstart, "**", 2) == 0)
1181 pstate->lexptr += 2;
1182 yylval.opcode = BINOP_EXP;
1186 switch (c = *tokstart)
1189 if (saw_name_at_eof)
1191 saw_name_at_eof = false;
1194 else if (pstate->parse_completion && saw_structop)
1205 token = match_string_literal ();
1216 if (paren_depth == 0)
1223 if (pstate->comma_terminates && paren_depth == 0)
1229 /* Might be a floating point number. */
1230 if (pstate->lexptr[1] < '0' || pstate->lexptr[1] > '9')
1231 goto symbol; /* Nope, must be a symbol. */
1245 /* It's a number. */
1246 int got_dot = 0, got_e = 0, got_d = 0, toktype;
1247 const char *p = tokstart;
1248 int hex = input_radix > 10;
1250 if (c == '0' && (p[1] == 'x' || p[1] == 'X'))
1255 else if (c == '0' && (p[1]=='t' || p[1]=='T'
1256 || p[1]=='d' || p[1]=='D'))
1264 if (!hex && !got_e && (*p == 'e' || *p == 'E'))
1265 got_dot = got_e = 1;
1266 else if (!hex && !got_d && (*p == 'd' || *p == 'D'))
1267 got_dot = got_d = 1;
1268 else if (!hex && !got_dot && *p == '.')
1270 else if (((got_e && (p[-1] == 'e' || p[-1] == 'E'))
1271 || (got_d && (p[-1] == 'd' || p[-1] == 'D')))
1272 && (*p == '-' || *p == '+'))
1273 /* This is the sign of the exponent, not the end of the
1276 /* We will take any letters or digits. parse_number will
1277 complain if past the radix, or if L or U are not final. */
1278 else if ((*p < '0' || *p > '9')
1279 && ((*p < 'a' || *p > 'z')
1280 && (*p < 'A' || *p > 'Z')))
1283 toktype = parse_number (pstate, tokstart, p - tokstart,
1284 got_dot|got_e|got_d,
1286 if (toktype == ERROR)
1288 char *err_copy = (char *) alloca (p - tokstart + 1);
1290 memcpy (err_copy, tokstart, p - tokstart);
1291 err_copy[p - tokstart] = 0;
1292 error (_("Invalid number \"%s\"."), err_copy);
1299 last_was_structop = true;
1325 if (!(c == '_' || c == '$' || c ==':'
1326 || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')))
1327 /* We must have come across a bad character (e.g. ';'). */
1328 error (_("Invalid character '%c' in expression."), c);
1331 for (c = tokstart[namelen];
1332 (c == '_' || c == '$' || c == ':' || (c >= '0' && c <= '9')
1333 || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z'));
1334 c = tokstart[++namelen]);
1336 /* The token "if" terminates the expression and is NOT
1337 removed from the input stream. */
1339 if (namelen == 2 && tokstart[0] == 'i' && tokstart[1] == 'f')
1342 pstate->lexptr += namelen;
1344 /* Catch specific keywords. */
1346 for (int i = 0; i < ARRAY_SIZE (f77_keywords); i++)
1347 if (strlen (f77_keywords[i].oper) == namelen
1348 && ((!f77_keywords[i].case_sensitive
1349 && strncasecmp (tokstart, f77_keywords[i].oper, namelen) == 0)
1350 || (f77_keywords[i].case_sensitive
1351 && strncmp (tokstart, f77_keywords[i].oper, namelen) == 0)))
1353 yylval.opcode = f77_keywords[i].opcode;
1354 return f77_keywords[i].token;
1357 yylval.sval.ptr = tokstart;
1358 yylval.sval.length = namelen;
1360 if (*tokstart == '$')
1361 return DOLLAR_VARIABLE;
1363 /* Use token-type TYPENAME for symbols that happen to be defined
1364 currently as names of types; NAME for other symbols.
1365 The caller is not constrained to care about the distinction. */
1367 std::string tmp = copy_name (yylval.sval);
1368 struct block_symbol result;
1369 enum domain_enum_tag lookup_domains[] =
1377 for (int i = 0; i < ARRAY_SIZE (lookup_domains); ++i)
1379 result = lookup_symbol (tmp.c_str (), pstate->expression_context_block,
1380 lookup_domains[i], NULL);
1381 if (result.symbol && SYMBOL_CLASS (result.symbol) == LOC_TYPEDEF)
1383 yylval.tsym.type = SYMBOL_TYPE (result.symbol);
1392 = language_lookup_primitive_type (pstate->language (),
1393 pstate->gdbarch (), tmp.c_str ());
1394 if (yylval.tsym.type != NULL)
1397 /* Input names that aren't symbols but ARE valid hex numbers,
1398 when the input radix permits them, can be names or numbers
1399 depending on the parse. Note we support radixes > 16 here. */
1401 && ((tokstart[0] >= 'a' && tokstart[0] < 'a' + input_radix - 10)
1402 || (tokstart[0] >= 'A' && tokstart[0] < 'A' + input_radix - 10)))
1404 YYSTYPE newlval; /* Its value is ignored. */
1405 hextype = parse_number (pstate, tokstart, namelen, 0, &newlval);
1408 yylval.ssym.sym = result;
1409 yylval.ssym.is_a_field_of_this = false;
1414 if (pstate->parse_completion && *pstate->lexptr == '\0')
1415 saw_name_at_eof = true;
1417 /* Any other kind of symbol */
1418 yylval.ssym.sym = result;
1419 yylval.ssym.is_a_field_of_this = false;
1425 f_language::parser (struct parser_state *par_state) const
1427 /* Setting up the parser state. */
1428 scoped_restore pstate_restore = make_scoped_restore (&pstate);
1429 scoped_restore restore_yydebug = make_scoped_restore (&yydebug,
1431 gdb_assert (par_state != NULL);
1433 last_was_structop = false;
1434 saw_name_at_eof = false;
1437 struct type_stack stack;
1438 scoped_restore restore_type_stack = make_scoped_restore (&type_stack,
1445 yyerror (const char *msg)
1447 if (pstate->prev_lexptr)
1448 pstate->lexptr = pstate->prev_lexptr;
1450 error (_("A %s in expression, near `%s'."), msg, pstate->lexptr);