2 /* YACC parser for Fortran expressions, for GDB.
3 Copyright (C) 1986-2020 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
153 %type <ssym> name_not_typename
155 /* A NAME_OR_INT is a symbol which is not known in the symbol table,
156 but which would parse as a valid number in the current input radix.
157 E.g. "c" when input_radix==16. Depending on the parse, it will be
158 turned into a name or into a number. */
160 %token <ssym> NAME_OR_INT
165 /* Special type cases, put in to allow the parser to distinguish different
167 %token INT_KEYWORD INT_S2_KEYWORD LOGICAL_S1_KEYWORD LOGICAL_S2_KEYWORD
168 %token LOGICAL_S8_KEYWORD
169 %token LOGICAL_KEYWORD REAL_KEYWORD REAL_S8_KEYWORD REAL_S16_KEYWORD
170 %token COMPLEX_KEYWORD
171 %token COMPLEX_S8_KEYWORD COMPLEX_S16_KEYWORD COMPLEX_S32_KEYWORD
172 %token BOOL_AND BOOL_OR BOOL_NOT
173 %token SINGLE DOUBLE PRECISION
174 %token <lval> CHARACTER
176 %token <voidval> DOLLAR_VARIABLE
178 %token <opcode> ASSIGN_MODIFY
179 %token <opcode> UNOP_INTRINSIC BINOP_INTRINSIC
183 %right '=' ASSIGN_MODIFY
192 %left LESSTHAN GREATERTHAN LEQ GEQ
210 { write_exp_elt_opcode (pstate, OP_TYPE);
211 write_exp_elt_type (pstate, $1);
212 write_exp_elt_opcode (pstate, OP_TYPE); }
219 /* Expressions, not including the comma operator. */
220 exp : '*' exp %prec UNARY
221 { write_exp_elt_opcode (pstate, UNOP_IND); }
224 exp : '&' exp %prec UNARY
225 { write_exp_elt_opcode (pstate, UNOP_ADDR); }
228 exp : '-' exp %prec UNARY
229 { write_exp_elt_opcode (pstate, UNOP_NEG); }
232 exp : BOOL_NOT exp %prec UNARY
233 { write_exp_elt_opcode (pstate, UNOP_LOGICAL_NOT); }
236 exp : '~' exp %prec UNARY
237 { write_exp_elt_opcode (pstate, UNOP_COMPLEMENT); }
240 exp : SIZEOF exp %prec UNARY
241 { write_exp_elt_opcode (pstate, UNOP_SIZEOF); }
244 exp : KIND '(' exp ')' %prec UNARY
245 { write_exp_elt_opcode (pstate, UNOP_FORTRAN_KIND); }
248 /* No more explicit array operators, we treat everything in F77 as
249 a function call. The disambiguation as to whether we are
250 doing a subscript operation or a function call is done
254 { pstate->start_arglist (); }
256 { write_exp_elt_opcode (pstate,
257 OP_F77_UNDETERMINED_ARGLIST);
258 write_exp_elt_longcst (pstate,
259 pstate->end_arglist ());
260 write_exp_elt_opcode (pstate,
261 OP_F77_UNDETERMINED_ARGLIST); }
264 exp : UNOP_INTRINSIC '(' exp ')'
265 { write_exp_elt_opcode (pstate, $1); }
268 exp : BINOP_INTRINSIC '(' exp ',' exp ')'
269 { write_exp_elt_opcode (pstate, $1); }
276 { pstate->arglist_len = 1; }
280 { pstate->arglist_len = 1; }
283 arglist : arglist ',' exp %prec ABOVE_COMMA
284 { pstate->arglist_len++; }
287 arglist : arglist ',' subrange %prec ABOVE_COMMA
288 { pstate->arglist_len++; }
291 /* There are four sorts of subrange types in F90. */
293 subrange: exp ':' exp %prec ABOVE_COMMA
294 { write_exp_elt_opcode (pstate, OP_RANGE);
295 write_exp_elt_longcst (pstate, RANGE_STANDARD);
296 write_exp_elt_opcode (pstate, OP_RANGE); }
299 subrange: exp ':' %prec ABOVE_COMMA
300 { write_exp_elt_opcode (pstate, OP_RANGE);
301 write_exp_elt_longcst (pstate,
302 RANGE_HIGH_BOUND_DEFAULT);
303 write_exp_elt_opcode (pstate, OP_RANGE); }
306 subrange: ':' exp %prec ABOVE_COMMA
307 { write_exp_elt_opcode (pstate, OP_RANGE);
308 write_exp_elt_longcst (pstate,
309 RANGE_LOW_BOUND_DEFAULT);
310 write_exp_elt_opcode (pstate, OP_RANGE); }
313 subrange: ':' %prec ABOVE_COMMA
314 { write_exp_elt_opcode (pstate, OP_RANGE);
315 write_exp_elt_longcst (pstate,
316 (RANGE_LOW_BOUND_DEFAULT
317 | RANGE_HIGH_BOUND_DEFAULT));
318 write_exp_elt_opcode (pstate, OP_RANGE); }
321 /* And each of the four subrange types can also have a stride. */
322 subrange: exp ':' exp ':' exp %prec ABOVE_COMMA
323 { write_exp_elt_opcode (pstate, OP_RANGE);
324 write_exp_elt_longcst (pstate, RANGE_HAS_STRIDE);
325 write_exp_elt_opcode (pstate, OP_RANGE); }
328 subrange: exp ':' ':' exp %prec ABOVE_COMMA
329 { write_exp_elt_opcode (pstate, OP_RANGE);
330 write_exp_elt_longcst (pstate,
331 (RANGE_HIGH_BOUND_DEFAULT
332 | RANGE_HAS_STRIDE));
333 write_exp_elt_opcode (pstate, OP_RANGE); }
336 subrange: ':' exp ':' exp %prec ABOVE_COMMA
337 { write_exp_elt_opcode (pstate, OP_RANGE);
338 write_exp_elt_longcst (pstate,
339 (RANGE_LOW_BOUND_DEFAULT
340 | RANGE_HAS_STRIDE));
341 write_exp_elt_opcode (pstate, OP_RANGE); }
344 subrange: ':' ':' exp %prec ABOVE_COMMA
345 { write_exp_elt_opcode (pstate, OP_RANGE);
346 write_exp_elt_longcst (pstate,
347 (RANGE_LOW_BOUND_DEFAULT
348 | RANGE_HIGH_BOUND_DEFAULT
349 | RANGE_HAS_STRIDE));
350 write_exp_elt_opcode (pstate, OP_RANGE); }
353 complexnum: exp ',' exp
357 exp : '(' complexnum ')'
358 { write_exp_elt_opcode (pstate, OP_COMPLEX);
359 write_exp_elt_type (pstate,
360 parse_f_type (pstate)
361 ->builtin_complex_s16);
362 write_exp_elt_opcode (pstate, OP_COMPLEX); }
365 exp : '(' type ')' exp %prec UNARY
366 { write_exp_elt_opcode (pstate, UNOP_CAST);
367 write_exp_elt_type (pstate, $2);
368 write_exp_elt_opcode (pstate, UNOP_CAST); }
372 { write_exp_elt_opcode (pstate, STRUCTOP_STRUCT);
373 write_exp_string (pstate, $3);
374 write_exp_elt_opcode (pstate, STRUCTOP_STRUCT); }
377 /* Binary operators in order of decreasing precedence. */
380 { write_exp_elt_opcode (pstate, BINOP_REPEAT); }
383 exp : exp STARSTAR exp
384 { write_exp_elt_opcode (pstate, BINOP_EXP); }
388 { write_exp_elt_opcode (pstate, BINOP_MUL); }
392 { write_exp_elt_opcode (pstate, BINOP_DIV); }
396 { write_exp_elt_opcode (pstate, BINOP_ADD); }
400 { write_exp_elt_opcode (pstate, BINOP_SUB); }
404 { write_exp_elt_opcode (pstate, BINOP_LSH); }
408 { write_exp_elt_opcode (pstate, BINOP_RSH); }
412 { write_exp_elt_opcode (pstate, BINOP_EQUAL); }
415 exp : exp NOTEQUAL exp
416 { write_exp_elt_opcode (pstate, BINOP_NOTEQUAL); }
420 { write_exp_elt_opcode (pstate, BINOP_LEQ); }
424 { write_exp_elt_opcode (pstate, BINOP_GEQ); }
427 exp : exp LESSTHAN exp
428 { write_exp_elt_opcode (pstate, BINOP_LESS); }
431 exp : exp GREATERTHAN exp
432 { write_exp_elt_opcode (pstate, BINOP_GTR); }
436 { write_exp_elt_opcode (pstate, BINOP_BITWISE_AND); }
440 { write_exp_elt_opcode (pstate, BINOP_BITWISE_XOR); }
444 { write_exp_elt_opcode (pstate, BINOP_BITWISE_IOR); }
447 exp : exp BOOL_AND exp
448 { write_exp_elt_opcode (pstate, BINOP_LOGICAL_AND); }
452 exp : exp BOOL_OR exp
453 { write_exp_elt_opcode (pstate, BINOP_LOGICAL_OR); }
457 { write_exp_elt_opcode (pstate, BINOP_ASSIGN); }
460 exp : exp ASSIGN_MODIFY exp
461 { write_exp_elt_opcode (pstate, BINOP_ASSIGN_MODIFY);
462 write_exp_elt_opcode (pstate, $2);
463 write_exp_elt_opcode (pstate, BINOP_ASSIGN_MODIFY); }
467 { write_exp_elt_opcode (pstate, OP_LONG);
468 write_exp_elt_type (pstate, $1.type);
469 write_exp_elt_longcst (pstate, (LONGEST) ($1.val));
470 write_exp_elt_opcode (pstate, OP_LONG); }
475 parse_number (pstate, $1.stoken.ptr,
476 $1.stoken.length, 0, &val);
477 write_exp_elt_opcode (pstate, OP_LONG);
478 write_exp_elt_type (pstate, val.typed_val.type);
479 write_exp_elt_longcst (pstate,
480 (LONGEST)val.typed_val.val);
481 write_exp_elt_opcode (pstate, OP_LONG); }
485 { write_exp_elt_opcode (pstate, OP_FLOAT);
486 write_exp_elt_type (pstate, $1.type);
487 write_exp_elt_floatcst (pstate, $1.val);
488 write_exp_elt_opcode (pstate, OP_FLOAT); }
494 exp : DOLLAR_VARIABLE
497 exp : SIZEOF '(' type ')' %prec UNARY
498 { write_exp_elt_opcode (pstate, OP_LONG);
499 write_exp_elt_type (pstate,
500 parse_f_type (pstate)
502 $3 = check_typedef ($3);
503 write_exp_elt_longcst (pstate,
504 (LONGEST) TYPE_LENGTH ($3));
505 write_exp_elt_opcode (pstate, OP_LONG); }
508 exp : BOOLEAN_LITERAL
509 { write_exp_elt_opcode (pstate, OP_BOOL);
510 write_exp_elt_longcst (pstate, (LONGEST) $1);
511 write_exp_elt_opcode (pstate, OP_BOOL);
517 write_exp_elt_opcode (pstate, OP_STRING);
518 write_exp_string (pstate, $1);
519 write_exp_elt_opcode (pstate, OP_STRING);
523 variable: name_not_typename
524 { struct block_symbol sym = $1.sym;
528 if (symbol_read_needs_frame (sym.symbol))
529 pstate->block_tracker->update (sym);
530 write_exp_elt_opcode (pstate, OP_VAR_VALUE);
531 write_exp_elt_block (pstate, sym.block);
532 write_exp_elt_sym (pstate, sym.symbol);
533 write_exp_elt_opcode (pstate, OP_VAR_VALUE);
538 struct bound_minimal_symbol msymbol;
539 std::string arg = copy_name ($1.stoken);
542 lookup_bound_minimal_symbol (arg.c_str ());
543 if (msymbol.minsym != NULL)
544 write_exp_msymbol (pstate, msymbol);
545 else if (!have_full_symbols () && !have_partial_symbols ())
546 error (_("No symbol table is loaded. Use the \"file\" command."));
548 error (_("No symbol \"%s\" in current context."),
561 /* This is where the interesting stuff happens. */
564 struct type *follow_type = $1;
565 struct type *range_type;
568 switch (type_stack->pop ())
574 follow_type = lookup_pointer_type (follow_type);
577 follow_type = lookup_lvalue_reference_type (follow_type);
580 array_size = type_stack->pop_int ();
581 if (array_size != -1)
584 create_static_range_type ((struct type *) NULL,
585 parse_f_type (pstate)
589 create_array_type ((struct type *) NULL,
590 follow_type, range_type);
593 follow_type = lookup_pointer_type (follow_type);
596 follow_type = lookup_function_type (follow_type);
600 int kind_val = type_stack->pop_int ();
602 = convert_to_kind_type (follow_type, kind_val);
611 { type_stack->push (tp_pointer); $$ = 0; }
613 { type_stack->push (tp_pointer); $$ = $2; }
615 { type_stack->push (tp_reference); $$ = 0; }
617 { type_stack->push (tp_reference); $$ = $2; }
621 direct_abs_decl: '(' abs_decl ')'
623 | '(' KIND '=' INT ')'
624 { push_kind_type ($4.val, $4.type); }
626 { push_kind_type ($2.val, $2.type); }
627 | direct_abs_decl func_mod
628 { type_stack->push (tp_function); }
630 { type_stack->push (tp_function); }
635 | '(' nonempty_typelist ')'
636 { free ($2); $$ = 0; }
639 typebase /* Implements (approximately): (type-qualifier)* type-specifier */
643 { $$ = parse_f_type (pstate)->builtin_integer; }
645 { $$ = parse_f_type (pstate)->builtin_integer_s2; }
647 { $$ = parse_f_type (pstate)->builtin_character; }
649 { $$ = parse_f_type (pstate)->builtin_logical_s8; }
651 { $$ = parse_f_type (pstate)->builtin_logical; }
653 { $$ = parse_f_type (pstate)->builtin_logical_s2; }
655 { $$ = parse_f_type (pstate)->builtin_logical_s1; }
657 { $$ = parse_f_type (pstate)->builtin_real; }
659 { $$ = parse_f_type (pstate)->builtin_real_s8; }
661 { $$ = parse_f_type (pstate)->builtin_real_s16; }
663 { $$ = parse_f_type (pstate)->builtin_complex_s8; }
665 { $$ = parse_f_type (pstate)->builtin_complex_s8; }
666 | COMPLEX_S16_KEYWORD
667 { $$ = parse_f_type (pstate)->builtin_complex_s16; }
668 | COMPLEX_S32_KEYWORD
669 { $$ = parse_f_type (pstate)->builtin_complex_s32; }
671 { $$ = parse_f_type (pstate)->builtin_real;}
673 { $$ = parse_f_type (pstate)->builtin_real_s8;}
674 | SINGLE COMPLEX_KEYWORD
675 { $$ = parse_f_type (pstate)->builtin_complex_s8;}
676 | DOUBLE COMPLEX_KEYWORD
677 { $$ = parse_f_type (pstate)->builtin_complex_s16;}
682 { $$ = (struct type **) malloc (sizeof (struct type *) * 2);
683 $<ivec>$[0] = 1; /* Number of types in vector */
686 | nonempty_typelist ',' type
687 { int len = sizeof (struct type *) * (++($<ivec>1[0]) + 1);
688 $$ = (struct type **) realloc ((char *) $1, len);
689 $$[$<ivec>$[0]] = $3;
697 name_not_typename : NAME
698 /* These would be useful if name_not_typename was useful, but it is just
699 a fake for "variable", so these cause reduce/reduce conflicts because
700 the parser can't tell whether NAME_OR_INT is a name_not_typename (=variable,
701 =exp) or just an exp. If name_not_typename was ever used in an lvalue
702 context where only a name could occur, this might be useful.
709 /* Take care of parsing a number (anything that starts with a digit).
710 Set yylval and return the token type; update lexptr.
711 LEN is the number of characters in it. */
713 /*** Needs some error checking for the float case ***/
716 parse_number (struct parser_state *par_state,
717 const char *p, int len, int parsed_float, YYSTYPE *putithere)
722 int base = input_radix;
726 struct type *signed_type;
727 struct type *unsigned_type;
731 /* It's a float since it contains a point or an exponent. */
732 /* [dD] is not understood as an exponent by parse_float,
737 for (tmp2 = tmp; *tmp2; ++tmp2)
738 if (*tmp2 == 'd' || *tmp2 == 'D')
741 /* FIXME: Should this use different types? */
742 putithere->typed_val_float.type = parse_f_type (pstate)->builtin_real_s8;
743 bool parsed = parse_float (tmp, len,
744 putithere->typed_val_float.type,
745 putithere->typed_val_float.val);
747 return parsed? FLOAT : ERROR;
750 /* Handle base-switching prefixes 0x, 0t, 0d, 0 */
786 if (len == 0 && c == 'l')
788 else if (len == 0 && c == 'u')
793 if (c >= '0' && c <= '9')
795 else if (c >= 'a' && c <= 'f')
798 return ERROR; /* Char not a digit */
800 return ERROR; /* Invalid digit in this base */
804 /* Portably test for overflow (only works for nonzero values, so make
805 a second check for zero). */
806 if ((prevn >= n) && n != 0)
807 unsigned_p=1; /* Try something unsigned */
808 /* If range checking enabled, portably test for unsigned overflow. */
809 if (RANGE_CHECK && n != 0)
811 if ((unsigned_p && (unsigned)prevn >= (unsigned)n))
812 range_error (_("Overflow on numeric constant."));
817 /* If the number is too big to be an int, or it's got an l suffix
818 then it's a long. Work out if this has to be a long by
819 shifting right and seeing if anything remains, and the
820 target int size is different to the target long size.
822 In the expression below, we could have tested
823 (n >> gdbarch_int_bit (parse_gdbarch))
824 to see if it was zero,
825 but too many compilers warn about that, when ints and longs
826 are the same size. So we shift it twice, with fewer bits
827 each time, for the same result. */
829 if ((gdbarch_int_bit (par_state->gdbarch ())
830 != gdbarch_long_bit (par_state->gdbarch ())
832 >> (gdbarch_int_bit (par_state->gdbarch ())-2))) /* Avoid
836 high_bit = ((ULONGEST)1)
837 << (gdbarch_long_bit (par_state->gdbarch ())-1);
838 unsigned_type = parse_type (par_state)->builtin_unsigned_long;
839 signed_type = parse_type (par_state)->builtin_long;
844 ((ULONGEST)1) << (gdbarch_int_bit (par_state->gdbarch ()) - 1);
845 unsigned_type = parse_type (par_state)->builtin_unsigned_int;
846 signed_type = parse_type (par_state)->builtin_int;
849 putithere->typed_val.val = n;
851 /* If the high bit of the worked out type is set then this number
852 has to be unsigned. */
854 if (unsigned_p || (n & high_bit))
855 putithere->typed_val.type = unsigned_type;
857 putithere->typed_val.type = signed_type;
862 /* Called to setup the type stack when we encounter a '(kind=N)' type
863 modifier, performs some bounds checking on 'N' and then pushes this to
864 the type stack followed by the 'tp_kind' marker. */
866 push_kind_type (LONGEST val, struct type *type)
870 if (type->is_unsigned ())
872 ULONGEST uval = static_cast <ULONGEST> (val);
874 error (_("kind value out of range"));
875 ival = static_cast <int> (uval);
879 if (val > INT_MAX || val < 0)
880 error (_("kind value out of range"));
881 ival = static_cast <int> (val);
884 type_stack->push (ival);
885 type_stack->push (tp_kind);
888 /* Called when a type has a '(kind=N)' modifier after it, for example
889 'character(kind=1)'. The BASETYPE is the type described by 'character'
890 in our example, and KIND is the integer '1'. This function returns a
891 new type that represents the basetype of a specific kind. */
893 convert_to_kind_type (struct type *basetype, int kind)
895 if (basetype == parse_f_type (pstate)->builtin_character)
897 /* Character of kind 1 is a special case, this is the same as the
898 base character type. */
900 return parse_f_type (pstate)->builtin_character;
902 else if (basetype == parse_f_type (pstate)->builtin_complex_s8)
905 return parse_f_type (pstate)->builtin_complex_s8;
907 return parse_f_type (pstate)->builtin_complex_s16;
909 return parse_f_type (pstate)->builtin_complex_s32;
911 else if (basetype == parse_f_type (pstate)->builtin_real)
914 return parse_f_type (pstate)->builtin_real;
916 return parse_f_type (pstate)->builtin_real_s8;
918 return parse_f_type (pstate)->builtin_real_s16;
920 else if (basetype == parse_f_type (pstate)->builtin_logical)
923 return parse_f_type (pstate)->builtin_logical_s1;
925 return parse_f_type (pstate)->builtin_logical_s2;
927 return parse_f_type (pstate)->builtin_logical;
929 return parse_f_type (pstate)->builtin_logical_s8;
931 else if (basetype == parse_f_type (pstate)->builtin_integer)
934 return parse_f_type (pstate)->builtin_integer_s2;
936 return parse_f_type (pstate)->builtin_integer;
938 return parse_f_type (pstate)->builtin_integer_s8;
941 error (_("unsupported kind %d for type %s"),
942 kind, TYPE_SAFE_NAME (basetype));
944 /* Should never get here. */
950 /* The string to match against. */
953 /* The lexer token to return. */
956 /* The expression opcode to embed within the token. */
957 enum exp_opcode opcode;
959 /* When this is true the string in OPER is matched exactly including
960 case, when this is false OPER is matched case insensitively. */
964 static const struct token dot_ops[] =
966 { ".and.", BOOL_AND, BINOP_END, false },
967 { ".or.", BOOL_OR, BINOP_END, false },
968 { ".not.", BOOL_NOT, BINOP_END, false },
969 { ".eq.", EQUAL, BINOP_END, false },
970 { ".eqv.", EQUAL, BINOP_END, false },
971 { ".neqv.", NOTEQUAL, BINOP_END, false },
972 { ".ne.", NOTEQUAL, BINOP_END, false },
973 { ".le.", LEQ, BINOP_END, false },
974 { ".ge.", GEQ, BINOP_END, false },
975 { ".gt.", GREATERTHAN, BINOP_END, false },
976 { ".lt.", LESSTHAN, BINOP_END, false },
979 /* Holds the Fortran representation of a boolean, and the integer value we
980 substitute in when one of the matching strings is parsed. */
981 struct f77_boolean_val
983 /* The string representing a Fortran boolean. */
986 /* The integer value to replace it with. */
990 /* The set of Fortran booleans. These are matched case insensitively. */
991 static const struct f77_boolean_val boolean_values[] =
997 static const struct token f77_keywords[] =
999 /* Historically these have always been lowercase only in GDB. */
1000 { "complex_16", COMPLEX_S16_KEYWORD, BINOP_END, true },
1001 { "complex_32", COMPLEX_S32_KEYWORD, BINOP_END, true },
1002 { "character", CHARACTER, BINOP_END, true },
1003 { "integer_2", INT_S2_KEYWORD, BINOP_END, true },
1004 { "logical_1", LOGICAL_S1_KEYWORD, BINOP_END, true },
1005 { "logical_2", LOGICAL_S2_KEYWORD, BINOP_END, true },
1006 { "logical_8", LOGICAL_S8_KEYWORD, BINOP_END, true },
1007 { "complex_8", COMPLEX_S8_KEYWORD, BINOP_END, true },
1008 { "integer", INT_KEYWORD, BINOP_END, true },
1009 { "logical", LOGICAL_KEYWORD, BINOP_END, true },
1010 { "real_16", REAL_S16_KEYWORD, BINOP_END, true },
1011 { "complex", COMPLEX_KEYWORD, BINOP_END, true },
1012 { "sizeof", SIZEOF, BINOP_END, true },
1013 { "real_8", REAL_S8_KEYWORD, BINOP_END, true },
1014 { "real", REAL_KEYWORD, BINOP_END, true },
1015 { "single", SINGLE, BINOP_END, true },
1016 { "double", DOUBLE, BINOP_END, true },
1017 { "precision", PRECISION, BINOP_END, true },
1018 /* The following correspond to actual functions in Fortran and are case
1020 { "kind", KIND, BINOP_END, false },
1021 { "abs", UNOP_INTRINSIC, UNOP_ABS, false },
1022 { "mod", BINOP_INTRINSIC, BINOP_MOD, false },
1023 { "floor", UNOP_INTRINSIC, UNOP_FORTRAN_FLOOR, false },
1024 { "ceiling", UNOP_INTRINSIC, UNOP_FORTRAN_CEILING, false },
1025 { "modulo", BINOP_INTRINSIC, BINOP_FORTRAN_MODULO, false },
1026 { "cmplx", BINOP_INTRINSIC, BINOP_FORTRAN_CMPLX, false },
1029 /* Implementation of a dynamically expandable buffer for processing input
1030 characters acquired through lexptr and building a value to return in
1031 yylval. Ripped off from ch-exp.y */
1033 static char *tempbuf; /* Current buffer contents */
1034 static int tempbufsize; /* Size of allocated buffer */
1035 static int tempbufindex; /* Current index into buffer */
1037 #define GROWBY_MIN_SIZE 64 /* Minimum amount to grow buffer by */
1039 #define CHECKBUF(size) \
1041 if (tempbufindex + (size) >= tempbufsize) \
1043 growbuf_by_size (size); \
1048 /* Grow the static temp buffer if necessary, including allocating the
1049 first one on demand. */
1052 growbuf_by_size (int count)
1056 growby = std::max (count, GROWBY_MIN_SIZE);
1057 tempbufsize += growby;
1058 if (tempbuf == NULL)
1059 tempbuf = (char *) malloc (tempbufsize);
1061 tempbuf = (char *) realloc (tempbuf, tempbufsize);
1064 /* Blatantly ripped off from ch-exp.y. This routine recognizes F77
1067 Recognize a string literal. A string literal is a nonzero sequence
1068 of characters enclosed in matching single quotes, except that
1069 a single character inside single quotes is a character literal, which
1070 we reject as a string literal. To embed the terminator character inside
1071 a string, it is simply doubled (I.E. 'this''is''one''string') */
1074 match_string_literal (void)
1076 const char *tokptr = pstate->lexptr;
1078 for (tempbufindex = 0, tokptr++; *tokptr != '\0'; tokptr++)
1081 if (*tokptr == *pstate->lexptr)
1083 if (*(tokptr + 1) == *pstate->lexptr)
1088 tempbuf[tempbufindex++] = *tokptr;
1090 if (*tokptr == '\0' /* no terminator */
1091 || tempbufindex == 0) /* no string */
1095 tempbuf[tempbufindex] = '\0';
1096 yylval.sval.ptr = tempbuf;
1097 yylval.sval.length = tempbufindex;
1098 pstate->lexptr = ++tokptr;
1099 return STRING_LITERAL;
1103 /* Read one token, getting characters through lexptr. */
1111 const char *tokstart;
1115 pstate->prev_lexptr = pstate->lexptr;
1117 tokstart = pstate->lexptr;
1119 /* First of all, let us make sure we are not dealing with the
1120 special tokens .true. and .false. which evaluate to 1 and 0. */
1122 if (*pstate->lexptr == '.')
1124 for (int i = 0; i < ARRAY_SIZE (boolean_values); i++)
1126 if (strncasecmp (tokstart, boolean_values[i].name,
1127 strlen (boolean_values[i].name)) == 0)
1129 pstate->lexptr += strlen (boolean_values[i].name);
1130 yylval.lval = boolean_values[i].value;
1131 return BOOLEAN_LITERAL;
1136 /* See if it is a special .foo. operator. */
1137 for (int i = 0; i < ARRAY_SIZE (dot_ops); i++)
1138 if (strncasecmp (tokstart, dot_ops[i].oper,
1139 strlen (dot_ops[i].oper)) == 0)
1141 gdb_assert (!dot_ops[i].case_sensitive);
1142 pstate->lexptr += strlen (dot_ops[i].oper);
1143 yylval.opcode = dot_ops[i].opcode;
1144 return dot_ops[i].token;
1147 /* See if it is an exponentiation operator. */
1149 if (strncmp (tokstart, "**", 2) == 0)
1151 pstate->lexptr += 2;
1152 yylval.opcode = BINOP_EXP;
1156 switch (c = *tokstart)
1168 token = match_string_literal ();
1179 if (paren_depth == 0)
1186 if (pstate->comma_terminates && paren_depth == 0)
1192 /* Might be a floating point number. */
1193 if (pstate->lexptr[1] < '0' || pstate->lexptr[1] > '9')
1194 goto symbol; /* Nope, must be a symbol. */
1208 /* It's a number. */
1209 int got_dot = 0, got_e = 0, got_d = 0, toktype;
1210 const char *p = tokstart;
1211 int hex = input_radix > 10;
1213 if (c == '0' && (p[1] == 'x' || p[1] == 'X'))
1218 else if (c == '0' && (p[1]=='t' || p[1]=='T'
1219 || p[1]=='d' || p[1]=='D'))
1227 if (!hex && !got_e && (*p == 'e' || *p == 'E'))
1228 got_dot = got_e = 1;
1229 else if (!hex && !got_d && (*p == 'd' || *p == 'D'))
1230 got_dot = got_d = 1;
1231 else if (!hex && !got_dot && *p == '.')
1233 else if (((got_e && (p[-1] == 'e' || p[-1] == 'E'))
1234 || (got_d && (p[-1] == 'd' || p[-1] == 'D')))
1235 && (*p == '-' || *p == '+'))
1236 /* This is the sign of the exponent, not the end of the
1239 /* We will take any letters or digits. parse_number will
1240 complain if past the radix, or if L or U are not final. */
1241 else if ((*p < '0' || *p > '9')
1242 && ((*p < 'a' || *p > 'z')
1243 && (*p < 'A' || *p > 'Z')))
1246 toktype = parse_number (pstate, tokstart, p - tokstart,
1247 got_dot|got_e|got_d,
1249 if (toktype == ERROR)
1251 char *err_copy = (char *) alloca (p - tokstart + 1);
1253 memcpy (err_copy, tokstart, p - tokstart);
1254 err_copy[p - tokstart] = 0;
1255 error (_("Invalid number \"%s\"."), err_copy);
1286 if (!(c == '_' || c == '$' || c ==':'
1287 || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')))
1288 /* We must have come across a bad character (e.g. ';'). */
1289 error (_("Invalid character '%c' in expression."), c);
1292 for (c = tokstart[namelen];
1293 (c == '_' || c == '$' || c == ':' || (c >= '0' && c <= '9')
1294 || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z'));
1295 c = tokstart[++namelen]);
1297 /* The token "if" terminates the expression and is NOT
1298 removed from the input stream. */
1300 if (namelen == 2 && tokstart[0] == 'i' && tokstart[1] == 'f')
1303 pstate->lexptr += namelen;
1305 /* Catch specific keywords. */
1307 for (int i = 0; i < ARRAY_SIZE (f77_keywords); i++)
1308 if (strlen (f77_keywords[i].oper) == namelen
1309 && ((!f77_keywords[i].case_sensitive
1310 && strncasecmp (tokstart, f77_keywords[i].oper, namelen) == 0)
1311 || (f77_keywords[i].case_sensitive
1312 && strncmp (tokstart, f77_keywords[i].oper, namelen) == 0)))
1314 yylval.opcode = f77_keywords[i].opcode;
1315 return f77_keywords[i].token;
1318 yylval.sval.ptr = tokstart;
1319 yylval.sval.length = namelen;
1321 if (*tokstart == '$')
1323 write_dollar_variable (pstate, yylval.sval);
1324 return DOLLAR_VARIABLE;
1327 /* Use token-type TYPENAME for symbols that happen to be defined
1328 currently as names of types; NAME for other symbols.
1329 The caller is not constrained to care about the distinction. */
1331 std::string tmp = copy_name (yylval.sval);
1332 struct block_symbol result;
1333 enum domain_enum_tag lookup_domains[] =
1341 for (int i = 0; i < ARRAY_SIZE (lookup_domains); ++i)
1343 result = lookup_symbol (tmp.c_str (), pstate->expression_context_block,
1344 lookup_domains[i], NULL);
1345 if (result.symbol && SYMBOL_CLASS (result.symbol) == LOC_TYPEDEF)
1347 yylval.tsym.type = SYMBOL_TYPE (result.symbol);
1356 = language_lookup_primitive_type (pstate->language (),
1357 pstate->gdbarch (), tmp.c_str ());
1358 if (yylval.tsym.type != NULL)
1361 /* Input names that aren't symbols but ARE valid hex numbers,
1362 when the input radix permits them, can be names or numbers
1363 depending on the parse. Note we support radixes > 16 here. */
1365 && ((tokstart[0] >= 'a' && tokstart[0] < 'a' + input_radix - 10)
1366 || (tokstart[0] >= 'A' && tokstart[0] < 'A' + input_radix - 10)))
1368 YYSTYPE newlval; /* Its value is ignored. */
1369 hextype = parse_number (pstate, tokstart, namelen, 0, &newlval);
1372 yylval.ssym.sym = result;
1373 yylval.ssym.is_a_field_of_this = false;
1378 /* Any other kind of symbol */
1379 yylval.ssym.sym = result;
1380 yylval.ssym.is_a_field_of_this = false;
1386 f_language::parser (struct parser_state *par_state) const
1388 /* Setting up the parser state. */
1389 scoped_restore pstate_restore = make_scoped_restore (&pstate);
1390 scoped_restore restore_yydebug = make_scoped_restore (&yydebug,
1392 gdb_assert (par_state != NULL);
1396 struct type_stack stack;
1397 scoped_restore restore_type_stack = make_scoped_restore (&type_stack,
1404 yyerror (const char *msg)
1406 if (pstate->prev_lexptr)
1407 pstate->lexptr = pstate->prev_lexptr;
1409 error (_("A %s in expression, near `%s'."), msg, pstate->lexptr);