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
181 %token <opcode> UNOP_OR_BINOP_INTRINSIC
185 %right '=' ASSIGN_MODIFY
194 %left LESSTHAN GREATERTHAN LEQ GEQ
212 { write_exp_elt_opcode (pstate, OP_TYPE);
213 write_exp_elt_type (pstate, $1);
214 write_exp_elt_opcode (pstate, OP_TYPE); }
221 /* Expressions, not including the comma operator. */
222 exp : '*' exp %prec UNARY
223 { write_exp_elt_opcode (pstate, UNOP_IND); }
226 exp : '&' exp %prec UNARY
227 { write_exp_elt_opcode (pstate, UNOP_ADDR); }
230 exp : '-' exp %prec UNARY
231 { write_exp_elt_opcode (pstate, UNOP_NEG); }
234 exp : BOOL_NOT exp %prec UNARY
235 { write_exp_elt_opcode (pstate, UNOP_LOGICAL_NOT); }
238 exp : '~' exp %prec UNARY
239 { write_exp_elt_opcode (pstate, UNOP_COMPLEMENT); }
242 exp : SIZEOF exp %prec UNARY
243 { write_exp_elt_opcode (pstate, UNOP_SIZEOF); }
246 exp : KIND '(' exp ')' %prec UNARY
247 { write_exp_elt_opcode (pstate, UNOP_FORTRAN_KIND); }
250 exp : UNOP_OR_BINOP_INTRINSIC '('
251 { pstate->start_arglist (); }
253 { write_exp_elt_opcode (pstate, $1);
254 write_exp_elt_longcst (pstate, pstate->end_arglist ());
255 write_exp_elt_opcode (pstate, $1); }
260 { pstate->arglist_len = 1; }
262 { pstate->arglist_len = 2; }
265 /* No more explicit array operators, we treat everything in F77 as
266 a function call. The disambiguation as to whether we are
267 doing a subscript operation or a function call is done
271 { pstate->start_arglist (); }
273 { write_exp_elt_opcode (pstate,
274 OP_F77_UNDETERMINED_ARGLIST);
275 write_exp_elt_longcst (pstate,
276 pstate->end_arglist ());
277 write_exp_elt_opcode (pstate,
278 OP_F77_UNDETERMINED_ARGLIST); }
281 exp : UNOP_INTRINSIC '(' exp ')'
282 { write_exp_elt_opcode (pstate, $1); }
285 exp : BINOP_INTRINSIC '(' exp ',' exp ')'
286 { write_exp_elt_opcode (pstate, $1); }
293 { pstate->arglist_len = 1; }
297 { pstate->arglist_len = 1; }
300 arglist : arglist ',' exp %prec ABOVE_COMMA
301 { pstate->arglist_len++; }
304 arglist : arglist ',' subrange %prec ABOVE_COMMA
305 { pstate->arglist_len++; }
308 /* There are four sorts of subrange types in F90. */
310 subrange: exp ':' exp %prec ABOVE_COMMA
311 { write_exp_elt_opcode (pstate, OP_RANGE);
312 write_exp_elt_longcst (pstate, RANGE_STANDARD);
313 write_exp_elt_opcode (pstate, OP_RANGE); }
316 subrange: exp ':' %prec ABOVE_COMMA
317 { write_exp_elt_opcode (pstate, OP_RANGE);
318 write_exp_elt_longcst (pstate,
319 RANGE_HIGH_BOUND_DEFAULT);
320 write_exp_elt_opcode (pstate, OP_RANGE); }
323 subrange: ':' exp %prec ABOVE_COMMA
324 { write_exp_elt_opcode (pstate, OP_RANGE);
325 write_exp_elt_longcst (pstate,
326 RANGE_LOW_BOUND_DEFAULT);
327 write_exp_elt_opcode (pstate, OP_RANGE); }
330 subrange: ':' %prec ABOVE_COMMA
331 { write_exp_elt_opcode (pstate, OP_RANGE);
332 write_exp_elt_longcst (pstate,
333 (RANGE_LOW_BOUND_DEFAULT
334 | RANGE_HIGH_BOUND_DEFAULT));
335 write_exp_elt_opcode (pstate, OP_RANGE); }
338 /* And each of the four subrange types can also have a stride. */
339 subrange: exp ':' exp ':' exp %prec ABOVE_COMMA
340 { write_exp_elt_opcode (pstate, OP_RANGE);
341 write_exp_elt_longcst (pstate, RANGE_HAS_STRIDE);
342 write_exp_elt_opcode (pstate, OP_RANGE); }
345 subrange: exp ':' ':' exp %prec ABOVE_COMMA
346 { write_exp_elt_opcode (pstate, OP_RANGE);
347 write_exp_elt_longcst (pstate,
348 (RANGE_HIGH_BOUND_DEFAULT
349 | RANGE_HAS_STRIDE));
350 write_exp_elt_opcode (pstate, OP_RANGE); }
353 subrange: ':' exp ':' exp %prec ABOVE_COMMA
354 { write_exp_elt_opcode (pstate, OP_RANGE);
355 write_exp_elt_longcst (pstate,
356 (RANGE_LOW_BOUND_DEFAULT
357 | RANGE_HAS_STRIDE));
358 write_exp_elt_opcode (pstate, OP_RANGE); }
361 subrange: ':' ':' exp %prec ABOVE_COMMA
362 { write_exp_elt_opcode (pstate, OP_RANGE);
363 write_exp_elt_longcst (pstate,
364 (RANGE_LOW_BOUND_DEFAULT
365 | RANGE_HIGH_BOUND_DEFAULT
366 | RANGE_HAS_STRIDE));
367 write_exp_elt_opcode (pstate, OP_RANGE); }
370 complexnum: exp ',' exp
374 exp : '(' complexnum ')'
375 { write_exp_elt_opcode (pstate, OP_COMPLEX);
376 write_exp_elt_type (pstate,
377 parse_f_type (pstate)
378 ->builtin_complex_s16);
379 write_exp_elt_opcode (pstate, OP_COMPLEX); }
382 exp : '(' type ')' exp %prec UNARY
383 { write_exp_elt_opcode (pstate, UNOP_CAST);
384 write_exp_elt_type (pstate, $2);
385 write_exp_elt_opcode (pstate, UNOP_CAST); }
389 { write_exp_elt_opcode (pstate, STRUCTOP_STRUCT);
390 write_exp_string (pstate, $3);
391 write_exp_elt_opcode (pstate, STRUCTOP_STRUCT); }
394 exp : exp '%' name COMPLETE
395 { pstate->mark_struct_expression ();
396 write_exp_elt_opcode (pstate, STRUCTOP_STRUCT);
397 write_exp_string (pstate, $3);
398 write_exp_elt_opcode (pstate, STRUCTOP_STRUCT); }
401 exp : exp '%' COMPLETE
403 pstate->mark_struct_expression ();
404 write_exp_elt_opcode (pstate, STRUCTOP_PTR);
407 write_exp_string (pstate, s);
408 write_exp_elt_opcode (pstate, STRUCTOP_PTR); }
410 /* Binary operators in order of decreasing precedence. */
413 { write_exp_elt_opcode (pstate, BINOP_REPEAT); }
416 exp : exp STARSTAR exp
417 { write_exp_elt_opcode (pstate, BINOP_EXP); }
421 { write_exp_elt_opcode (pstate, BINOP_MUL); }
425 { write_exp_elt_opcode (pstate, BINOP_DIV); }
429 { write_exp_elt_opcode (pstate, BINOP_ADD); }
433 { write_exp_elt_opcode (pstate, BINOP_SUB); }
437 { write_exp_elt_opcode (pstate, BINOP_LSH); }
441 { write_exp_elt_opcode (pstate, BINOP_RSH); }
445 { write_exp_elt_opcode (pstate, BINOP_EQUAL); }
448 exp : exp NOTEQUAL exp
449 { write_exp_elt_opcode (pstate, BINOP_NOTEQUAL); }
453 { write_exp_elt_opcode (pstate, BINOP_LEQ); }
457 { write_exp_elt_opcode (pstate, BINOP_GEQ); }
460 exp : exp LESSTHAN exp
461 { write_exp_elt_opcode (pstate, BINOP_LESS); }
464 exp : exp GREATERTHAN exp
465 { write_exp_elt_opcode (pstate, BINOP_GTR); }
469 { write_exp_elt_opcode (pstate, BINOP_BITWISE_AND); }
473 { write_exp_elt_opcode (pstate, BINOP_BITWISE_XOR); }
477 { write_exp_elt_opcode (pstate, BINOP_BITWISE_IOR); }
480 exp : exp BOOL_AND exp
481 { write_exp_elt_opcode (pstate, BINOP_LOGICAL_AND); }
485 exp : exp BOOL_OR exp
486 { write_exp_elt_opcode (pstate, BINOP_LOGICAL_OR); }
490 { write_exp_elt_opcode (pstate, BINOP_ASSIGN); }
493 exp : exp ASSIGN_MODIFY exp
494 { write_exp_elt_opcode (pstate, BINOP_ASSIGN_MODIFY);
495 write_exp_elt_opcode (pstate, $2);
496 write_exp_elt_opcode (pstate, BINOP_ASSIGN_MODIFY); }
500 { write_exp_elt_opcode (pstate, OP_LONG);
501 write_exp_elt_type (pstate, $1.type);
502 write_exp_elt_longcst (pstate, (LONGEST) ($1.val));
503 write_exp_elt_opcode (pstate, OP_LONG); }
508 parse_number (pstate, $1.stoken.ptr,
509 $1.stoken.length, 0, &val);
510 write_exp_elt_opcode (pstate, OP_LONG);
511 write_exp_elt_type (pstate, val.typed_val.type);
512 write_exp_elt_longcst (pstate,
513 (LONGEST)val.typed_val.val);
514 write_exp_elt_opcode (pstate, OP_LONG); }
518 { write_exp_elt_opcode (pstate, OP_FLOAT);
519 write_exp_elt_type (pstate, $1.type);
520 write_exp_elt_floatcst (pstate, $1.val);
521 write_exp_elt_opcode (pstate, OP_FLOAT); }
527 exp : DOLLAR_VARIABLE
528 { write_dollar_variable (pstate, $1); }
531 exp : SIZEOF '(' type ')' %prec UNARY
532 { write_exp_elt_opcode (pstate, OP_LONG);
533 write_exp_elt_type (pstate,
534 parse_f_type (pstate)
536 $3 = check_typedef ($3);
537 write_exp_elt_longcst (pstate,
538 (LONGEST) TYPE_LENGTH ($3));
539 write_exp_elt_opcode (pstate, OP_LONG); }
542 exp : BOOLEAN_LITERAL
543 { write_exp_elt_opcode (pstate, OP_BOOL);
544 write_exp_elt_longcst (pstate, (LONGEST) $1);
545 write_exp_elt_opcode (pstate, OP_BOOL);
551 write_exp_elt_opcode (pstate, OP_STRING);
552 write_exp_string (pstate, $1);
553 write_exp_elt_opcode (pstate, OP_STRING);
557 variable: name_not_typename
558 { struct block_symbol sym = $1.sym;
559 std::string name = copy_name ($1.stoken);
560 write_exp_symbol_reference (pstate, name.c_str (),
572 /* This is where the interesting stuff happens. */
575 struct type *follow_type = $1;
576 struct type *range_type;
579 switch (type_stack->pop ())
585 follow_type = lookup_pointer_type (follow_type);
588 follow_type = lookup_lvalue_reference_type (follow_type);
591 array_size = type_stack->pop_int ();
592 if (array_size != -1)
595 create_static_range_type ((struct type *) NULL,
596 parse_f_type (pstate)
600 create_array_type ((struct type *) NULL,
601 follow_type, range_type);
604 follow_type = lookup_pointer_type (follow_type);
607 follow_type = lookup_function_type (follow_type);
611 int kind_val = type_stack->pop_int ();
613 = convert_to_kind_type (follow_type, kind_val);
622 { type_stack->push (tp_pointer); $$ = 0; }
624 { type_stack->push (tp_pointer); $$ = $2; }
626 { type_stack->push (tp_reference); $$ = 0; }
628 { type_stack->push (tp_reference); $$ = $2; }
632 direct_abs_decl: '(' abs_decl ')'
634 | '(' KIND '=' INT ')'
635 { push_kind_type ($4.val, $4.type); }
637 { push_kind_type ($2.val, $2.type); }
638 | direct_abs_decl func_mod
639 { type_stack->push (tp_function); }
641 { type_stack->push (tp_function); }
646 | '(' nonempty_typelist ')'
647 { free ($2); $$ = 0; }
650 typebase /* Implements (approximately): (type-qualifier)* type-specifier */
654 { $$ = parse_f_type (pstate)->builtin_integer; }
656 { $$ = parse_f_type (pstate)->builtin_integer_s2; }
658 { $$ = parse_f_type (pstate)->builtin_character; }
660 { $$ = parse_f_type (pstate)->builtin_logical_s8; }
662 { $$ = parse_f_type (pstate)->builtin_logical; }
664 { $$ = parse_f_type (pstate)->builtin_logical_s2; }
666 { $$ = parse_f_type (pstate)->builtin_logical_s1; }
668 { $$ = parse_f_type (pstate)->builtin_real; }
670 { $$ = parse_f_type (pstate)->builtin_real_s8; }
672 { $$ = parse_f_type (pstate)->builtin_real_s16; }
674 { $$ = parse_f_type (pstate)->builtin_complex_s8; }
676 { $$ = parse_f_type (pstate)->builtin_complex_s8; }
677 | COMPLEX_S16_KEYWORD
678 { $$ = parse_f_type (pstate)->builtin_complex_s16; }
679 | COMPLEX_S32_KEYWORD
680 { $$ = parse_f_type (pstate)->builtin_complex_s32; }
682 { $$ = parse_f_type (pstate)->builtin_real;}
684 { $$ = parse_f_type (pstate)->builtin_real_s8;}
685 | SINGLE COMPLEX_KEYWORD
686 { $$ = parse_f_type (pstate)->builtin_complex_s8;}
687 | DOUBLE COMPLEX_KEYWORD
688 { $$ = parse_f_type (pstate)->builtin_complex_s16;}
693 { $$ = (struct type **) malloc (sizeof (struct type *) * 2);
694 $<ivec>$[0] = 1; /* Number of types in vector */
697 | nonempty_typelist ',' type
698 { int len = sizeof (struct type *) * (++($<ivec>1[0]) + 1);
699 $$ = (struct type **) realloc ((char *) $1, len);
700 $$[$<ivec>$[0]] = $3;
708 name_not_typename : NAME
709 /* These would be useful if name_not_typename was useful, but it is just
710 a fake for "variable", so these cause reduce/reduce conflicts because
711 the parser can't tell whether NAME_OR_INT is a name_not_typename (=variable,
712 =exp) or just an exp. If name_not_typename was ever used in an lvalue
713 context where only a name could occur, this might be useful.
720 /* Take care of parsing a number (anything that starts with a digit).
721 Set yylval and return the token type; update lexptr.
722 LEN is the number of characters in it. */
724 /*** Needs some error checking for the float case ***/
727 parse_number (struct parser_state *par_state,
728 const char *p, int len, int parsed_float, YYSTYPE *putithere)
733 int base = input_radix;
737 struct type *signed_type;
738 struct type *unsigned_type;
742 /* It's a float since it contains a point or an exponent. */
743 /* [dD] is not understood as an exponent by parse_float,
748 for (tmp2 = tmp; *tmp2; ++tmp2)
749 if (*tmp2 == 'd' || *tmp2 == 'D')
752 /* FIXME: Should this use different types? */
753 putithere->typed_val_float.type = parse_f_type (pstate)->builtin_real_s8;
754 bool parsed = parse_float (tmp, len,
755 putithere->typed_val_float.type,
756 putithere->typed_val_float.val);
758 return parsed? FLOAT : ERROR;
761 /* Handle base-switching prefixes 0x, 0t, 0d, 0 */
797 if (len == 0 && c == 'l')
799 else if (len == 0 && c == 'u')
804 if (c >= '0' && c <= '9')
806 else if (c >= 'a' && c <= 'f')
809 return ERROR; /* Char not a digit */
811 return ERROR; /* Invalid digit in this base */
815 /* Portably test for overflow (only works for nonzero values, so make
816 a second check for zero). */
817 if ((prevn >= n) && n != 0)
818 unsigned_p=1; /* Try something unsigned */
819 /* If range checking enabled, portably test for unsigned overflow. */
820 if (RANGE_CHECK && n != 0)
822 if ((unsigned_p && (unsigned)prevn >= (unsigned)n))
823 range_error (_("Overflow on numeric constant."));
828 /* If the number is too big to be an int, or it's got an l suffix
829 then it's a long. Work out if this has to be a long by
830 shifting right and seeing if anything remains, and the
831 target int size is different to the target long size.
833 In the expression below, we could have tested
834 (n >> gdbarch_int_bit (parse_gdbarch))
835 to see if it was zero,
836 but too many compilers warn about that, when ints and longs
837 are the same size. So we shift it twice, with fewer bits
838 each time, for the same result. */
840 if ((gdbarch_int_bit (par_state->gdbarch ())
841 != gdbarch_long_bit (par_state->gdbarch ())
843 >> (gdbarch_int_bit (par_state->gdbarch ())-2))) /* Avoid
847 high_bit = ((ULONGEST)1)
848 << (gdbarch_long_bit (par_state->gdbarch ())-1);
849 unsigned_type = parse_type (par_state)->builtin_unsigned_long;
850 signed_type = parse_type (par_state)->builtin_long;
855 ((ULONGEST)1) << (gdbarch_int_bit (par_state->gdbarch ()) - 1);
856 unsigned_type = parse_type (par_state)->builtin_unsigned_int;
857 signed_type = parse_type (par_state)->builtin_int;
860 putithere->typed_val.val = n;
862 /* If the high bit of the worked out type is set then this number
863 has to be unsigned. */
865 if (unsigned_p || (n & high_bit))
866 putithere->typed_val.type = unsigned_type;
868 putithere->typed_val.type = signed_type;
873 /* Called to setup the type stack when we encounter a '(kind=N)' type
874 modifier, performs some bounds checking on 'N' and then pushes this to
875 the type stack followed by the 'tp_kind' marker. */
877 push_kind_type (LONGEST val, struct type *type)
881 if (type->is_unsigned ())
883 ULONGEST uval = static_cast <ULONGEST> (val);
885 error (_("kind value out of range"));
886 ival = static_cast <int> (uval);
890 if (val > INT_MAX || val < 0)
891 error (_("kind value out of range"));
892 ival = static_cast <int> (val);
895 type_stack->push (ival);
896 type_stack->push (tp_kind);
899 /* Called when a type has a '(kind=N)' modifier after it, for example
900 'character(kind=1)'. The BASETYPE is the type described by 'character'
901 in our example, and KIND is the integer '1'. This function returns a
902 new type that represents the basetype of a specific kind. */
904 convert_to_kind_type (struct type *basetype, int kind)
906 if (basetype == parse_f_type (pstate)->builtin_character)
908 /* Character of kind 1 is a special case, this is the same as the
909 base character type. */
911 return parse_f_type (pstate)->builtin_character;
913 else if (basetype == parse_f_type (pstate)->builtin_complex_s8)
916 return parse_f_type (pstate)->builtin_complex_s8;
918 return parse_f_type (pstate)->builtin_complex_s16;
920 return parse_f_type (pstate)->builtin_complex_s32;
922 else if (basetype == parse_f_type (pstate)->builtin_real)
925 return parse_f_type (pstate)->builtin_real;
927 return parse_f_type (pstate)->builtin_real_s8;
929 return parse_f_type (pstate)->builtin_real_s16;
931 else if (basetype == parse_f_type (pstate)->builtin_logical)
934 return parse_f_type (pstate)->builtin_logical_s1;
936 return parse_f_type (pstate)->builtin_logical_s2;
938 return parse_f_type (pstate)->builtin_logical;
940 return parse_f_type (pstate)->builtin_logical_s8;
942 else if (basetype == parse_f_type (pstate)->builtin_integer)
945 return parse_f_type (pstate)->builtin_integer_s2;
947 return parse_f_type (pstate)->builtin_integer;
949 return parse_f_type (pstate)->builtin_integer_s8;
952 error (_("unsupported kind %d for type %s"),
953 kind, TYPE_SAFE_NAME (basetype));
955 /* Should never get here. */
961 /* The string to match against. */
964 /* The lexer token to return. */
967 /* The expression opcode to embed within the token. */
968 enum exp_opcode opcode;
970 /* When this is true the string in OPER is matched exactly including
971 case, when this is false OPER is matched case insensitively. */
975 /* List of Fortran operators. */
977 static const struct token fortran_operators[] =
979 { ".and.", BOOL_AND, BINOP_END, false },
980 { ".or.", BOOL_OR, BINOP_END, false },
981 { ".not.", BOOL_NOT, BINOP_END, false },
982 { ".eq.", EQUAL, BINOP_END, false },
983 { ".eqv.", EQUAL, BINOP_END, false },
984 { ".neqv.", NOTEQUAL, BINOP_END, false },
985 { ".xor.", NOTEQUAL, BINOP_END, false },
986 { "==", EQUAL, BINOP_END, false },
987 { ".ne.", NOTEQUAL, BINOP_END, false },
988 { "/=", NOTEQUAL, BINOP_END, false },
989 { ".le.", LEQ, BINOP_END, false },
990 { "<=", LEQ, BINOP_END, false },
991 { ".ge.", GEQ, BINOP_END, false },
992 { ">=", GEQ, BINOP_END, false },
993 { ".gt.", GREATERTHAN, BINOP_END, false },
994 { ">", GREATERTHAN, BINOP_END, false },
995 { ".lt.", LESSTHAN, BINOP_END, false },
996 { "<", LESSTHAN, BINOP_END, false },
997 { "**", STARSTAR, BINOP_EXP, false },
1000 /* Holds the Fortran representation of a boolean, and the integer value we
1001 substitute in when one of the matching strings is parsed. */
1002 struct f77_boolean_val
1004 /* The string representing a Fortran boolean. */
1007 /* The integer value to replace it with. */
1011 /* The set of Fortran booleans. These are matched case insensitively. */
1012 static const struct f77_boolean_val boolean_values[] =
1018 static const struct token f77_keywords[] =
1020 /* Historically these have always been lowercase only in GDB. */
1021 { "complex_16", COMPLEX_S16_KEYWORD, BINOP_END, true },
1022 { "complex_32", COMPLEX_S32_KEYWORD, BINOP_END, true },
1023 { "character", CHARACTER, BINOP_END, true },
1024 { "integer_2", INT_S2_KEYWORD, BINOP_END, true },
1025 { "logical_1", LOGICAL_S1_KEYWORD, BINOP_END, true },
1026 { "logical_2", LOGICAL_S2_KEYWORD, BINOP_END, true },
1027 { "logical_8", LOGICAL_S8_KEYWORD, BINOP_END, true },
1028 { "complex_8", COMPLEX_S8_KEYWORD, BINOP_END, true },
1029 { "integer", INT_KEYWORD, BINOP_END, true },
1030 { "logical", LOGICAL_KEYWORD, BINOP_END, true },
1031 { "real_16", REAL_S16_KEYWORD, BINOP_END, true },
1032 { "complex", COMPLEX_KEYWORD, BINOP_END, true },
1033 { "sizeof", SIZEOF, BINOP_END, true },
1034 { "real_8", REAL_S8_KEYWORD, BINOP_END, true },
1035 { "real", REAL_KEYWORD, BINOP_END, true },
1036 { "single", SINGLE, BINOP_END, true },
1037 { "double", DOUBLE, BINOP_END, true },
1038 { "precision", PRECISION, BINOP_END, true },
1039 /* The following correspond to actual functions in Fortran and are case
1041 { "kind", KIND, BINOP_END, false },
1042 { "abs", UNOP_INTRINSIC, UNOP_ABS, false },
1043 { "mod", BINOP_INTRINSIC, BINOP_MOD, false },
1044 { "floor", UNOP_INTRINSIC, UNOP_FORTRAN_FLOOR, false },
1045 { "ceiling", UNOP_INTRINSIC, UNOP_FORTRAN_CEILING, false },
1046 { "modulo", BINOP_INTRINSIC, BINOP_FORTRAN_MODULO, false },
1047 { "cmplx", BINOP_INTRINSIC, BINOP_FORTRAN_CMPLX, false },
1048 { "lbound", UNOP_OR_BINOP_INTRINSIC, FORTRAN_LBOUND, false },
1049 { "ubound", UNOP_OR_BINOP_INTRINSIC, FORTRAN_UBOUND, false },
1050 { "allocated", UNOP_INTRINSIC, UNOP_FORTRAN_ALLOCATED, false },
1051 { "associated", UNOP_OR_BINOP_INTRINSIC, FORTRAN_ASSOCIATED, false },
1054 /* Implementation of a dynamically expandable buffer for processing input
1055 characters acquired through lexptr and building a value to return in
1056 yylval. Ripped off from ch-exp.y */
1058 static char *tempbuf; /* Current buffer contents */
1059 static int tempbufsize; /* Size of allocated buffer */
1060 static int tempbufindex; /* Current index into buffer */
1062 #define GROWBY_MIN_SIZE 64 /* Minimum amount to grow buffer by */
1064 #define CHECKBUF(size) \
1066 if (tempbufindex + (size) >= tempbufsize) \
1068 growbuf_by_size (size); \
1073 /* Grow the static temp buffer if necessary, including allocating the
1074 first one on demand. */
1077 growbuf_by_size (int count)
1081 growby = std::max (count, GROWBY_MIN_SIZE);
1082 tempbufsize += growby;
1083 if (tempbuf == NULL)
1084 tempbuf = (char *) malloc (tempbufsize);
1086 tempbuf = (char *) realloc (tempbuf, tempbufsize);
1089 /* Blatantly ripped off from ch-exp.y. This routine recognizes F77
1092 Recognize a string literal. A string literal is a nonzero sequence
1093 of characters enclosed in matching single quotes, except that
1094 a single character inside single quotes is a character literal, which
1095 we reject as a string literal. To embed the terminator character inside
1096 a string, it is simply doubled (I.E. 'this''is''one''string') */
1099 match_string_literal (void)
1101 const char *tokptr = pstate->lexptr;
1103 for (tempbufindex = 0, tokptr++; *tokptr != '\0'; tokptr++)
1106 if (*tokptr == *pstate->lexptr)
1108 if (*(tokptr + 1) == *pstate->lexptr)
1113 tempbuf[tempbufindex++] = *tokptr;
1115 if (*tokptr == '\0' /* no terminator */
1116 || tempbufindex == 0) /* no string */
1120 tempbuf[tempbufindex] = '\0';
1121 yylval.sval.ptr = tempbuf;
1122 yylval.sval.length = tempbufindex;
1123 pstate->lexptr = ++tokptr;
1124 return STRING_LITERAL;
1128 /* This is set if a NAME token appeared at the very end of the input
1129 string, with no whitespace separating the name from the EOF. This
1130 is used only when parsing to do field name completion. */
1131 static bool saw_name_at_eof;
1133 /* This is set if the previously-returned token was a structure
1135 static bool last_was_structop;
1137 /* Read one token, getting characters through lexptr. */
1145 const char *tokstart;
1146 bool saw_structop = last_was_structop;
1148 last_was_structop = false;
1152 pstate->prev_lexptr = pstate->lexptr;
1154 tokstart = pstate->lexptr;
1156 /* First of all, let us make sure we are not dealing with the
1157 special tokens .true. and .false. which evaluate to 1 and 0. */
1159 if (*pstate->lexptr == '.')
1161 for (int i = 0; i < ARRAY_SIZE (boolean_values); i++)
1163 if (strncasecmp (tokstart, boolean_values[i].name,
1164 strlen (boolean_values[i].name)) == 0)
1166 pstate->lexptr += strlen (boolean_values[i].name);
1167 yylval.lval = boolean_values[i].value;
1168 return BOOLEAN_LITERAL;
1173 /* See if it is a Fortran operator. */
1174 for (int i = 0; i < ARRAY_SIZE (fortran_operators); i++)
1175 if (strncasecmp (tokstart, fortran_operators[i].oper,
1176 strlen (fortran_operators[i].oper)) == 0)
1178 gdb_assert (!fortran_operators[i].case_sensitive);
1179 pstate->lexptr += strlen (fortran_operators[i].oper);
1180 yylval.opcode = fortran_operators[i].opcode;
1181 return fortran_operators[i].token;
1184 switch (c = *tokstart)
1187 if (saw_name_at_eof)
1189 saw_name_at_eof = false;
1192 else if (pstate->parse_completion && saw_structop)
1203 token = match_string_literal ();
1214 if (paren_depth == 0)
1221 if (pstate->comma_terminates && paren_depth == 0)
1227 /* Might be a floating point number. */
1228 if (pstate->lexptr[1] < '0' || pstate->lexptr[1] > '9')
1229 goto symbol; /* Nope, must be a symbol. */
1243 /* It's a number. */
1244 int got_dot = 0, got_e = 0, got_d = 0, toktype;
1245 const char *p = tokstart;
1246 int hex = input_radix > 10;
1248 if (c == '0' && (p[1] == 'x' || p[1] == 'X'))
1253 else if (c == '0' && (p[1]=='t' || p[1]=='T'
1254 || p[1]=='d' || p[1]=='D'))
1262 if (!hex && !got_e && (*p == 'e' || *p == 'E'))
1263 got_dot = got_e = 1;
1264 else if (!hex && !got_d && (*p == 'd' || *p == 'D'))
1265 got_dot = got_d = 1;
1266 else if (!hex && !got_dot && *p == '.')
1268 else if (((got_e && (p[-1] == 'e' || p[-1] == 'E'))
1269 || (got_d && (p[-1] == 'd' || p[-1] == 'D')))
1270 && (*p == '-' || *p == '+'))
1271 /* This is the sign of the exponent, not the end of the
1274 /* We will take any letters or digits. parse_number will
1275 complain if past the radix, or if L or U are not final. */
1276 else if ((*p < '0' || *p > '9')
1277 && ((*p < 'a' || *p > 'z')
1278 && (*p < 'A' || *p > 'Z')))
1281 toktype = parse_number (pstate, tokstart, p - tokstart,
1282 got_dot|got_e|got_d,
1284 if (toktype == ERROR)
1286 char *err_copy = (char *) alloca (p - tokstart + 1);
1288 memcpy (err_copy, tokstart, p - tokstart);
1289 err_copy[p - tokstart] = 0;
1290 error (_("Invalid number \"%s\"."), err_copy);
1297 last_was_structop = true;
1323 if (!(c == '_' || c == '$' || c ==':'
1324 || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')))
1325 /* We must have come across a bad character (e.g. ';'). */
1326 error (_("Invalid character '%c' in expression."), c);
1329 for (c = tokstart[namelen];
1330 (c == '_' || c == '$' || c == ':' || (c >= '0' && c <= '9')
1331 || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z'));
1332 c = tokstart[++namelen]);
1334 /* The token "if" terminates the expression and is NOT
1335 removed from the input stream. */
1337 if (namelen == 2 && tokstart[0] == 'i' && tokstart[1] == 'f')
1340 pstate->lexptr += namelen;
1342 /* Catch specific keywords. */
1344 for (int i = 0; i < ARRAY_SIZE (f77_keywords); i++)
1345 if (strlen (f77_keywords[i].oper) == namelen
1346 && ((!f77_keywords[i].case_sensitive
1347 && strncasecmp (tokstart, f77_keywords[i].oper, namelen) == 0)
1348 || (f77_keywords[i].case_sensitive
1349 && strncmp (tokstart, f77_keywords[i].oper, namelen) == 0)))
1351 yylval.opcode = f77_keywords[i].opcode;
1352 return f77_keywords[i].token;
1355 yylval.sval.ptr = tokstart;
1356 yylval.sval.length = namelen;
1358 if (*tokstart == '$')
1359 return DOLLAR_VARIABLE;
1361 /* Use token-type TYPENAME for symbols that happen to be defined
1362 currently as names of types; NAME for other symbols.
1363 The caller is not constrained to care about the distinction. */
1365 std::string tmp = copy_name (yylval.sval);
1366 struct block_symbol result;
1367 enum domain_enum_tag lookup_domains[] =
1375 for (int i = 0; i < ARRAY_SIZE (lookup_domains); ++i)
1377 result = lookup_symbol (tmp.c_str (), pstate->expression_context_block,
1378 lookup_domains[i], NULL);
1379 if (result.symbol && SYMBOL_CLASS (result.symbol) == LOC_TYPEDEF)
1381 yylval.tsym.type = SYMBOL_TYPE (result.symbol);
1390 = language_lookup_primitive_type (pstate->language (),
1391 pstate->gdbarch (), tmp.c_str ());
1392 if (yylval.tsym.type != NULL)
1395 /* Input names that aren't symbols but ARE valid hex numbers,
1396 when the input radix permits them, can be names or numbers
1397 depending on the parse. Note we support radixes > 16 here. */
1399 && ((tokstart[0] >= 'a' && tokstart[0] < 'a' + input_radix - 10)
1400 || (tokstart[0] >= 'A' && tokstart[0] < 'A' + input_radix - 10)))
1402 YYSTYPE newlval; /* Its value is ignored. */
1403 hextype = parse_number (pstate, tokstart, namelen, 0, &newlval);
1406 yylval.ssym.sym = result;
1407 yylval.ssym.is_a_field_of_this = false;
1412 if (pstate->parse_completion && *pstate->lexptr == '\0')
1413 saw_name_at_eof = true;
1415 /* Any other kind of symbol */
1416 yylval.ssym.sym = result;
1417 yylval.ssym.is_a_field_of_this = false;
1423 f_language::parser (struct parser_state *par_state) const
1425 /* Setting up the parser state. */
1426 scoped_restore pstate_restore = make_scoped_restore (&pstate);
1427 scoped_restore restore_yydebug = make_scoped_restore (&yydebug,
1429 gdb_assert (par_state != NULL);
1431 last_was_structop = false;
1432 saw_name_at_eof = false;
1435 struct type_stack stack;
1436 scoped_restore restore_type_stack = make_scoped_restore (&type_stack,
1443 yyerror (const char *msg)
1445 if (pstate->prev_lexptr)
1446 pstate->lexptr = pstate->prev_lexptr;
1448 error (_("A %s in expression, near `%s'."), msg, pstate->lexptr);