2 /* YACC parser for Fortran expressions, for GDB.
3 Copyright (C) 1986-2023 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"
54 #include "type-stack.h"
57 #define parse_type(ps) builtin_type (ps->gdbarch ())
58 #define parse_f_type(ps) builtin_f_type (ps->gdbarch ())
60 /* Remap normal yacc parser interface names (yyparse, yylex, yyerror,
62 #define GDB_YY_REMAP_PREFIX f_
65 /* The state of the parser, used internally when we are parsing the
68 static struct parser_state
*pstate
= NULL
;
70 /* Depth of parentheses. */
71 static int paren_depth
;
73 /* The current type stack. */
74 static struct type_stack
*type_stack
;
78 static int yylex (void);
80 static void yyerror (const char *);
82 static void growbuf_by_size
(int);
84 static int match_string_literal
(void);
86 static void push_kind_type
(LONGEST val
, struct type
*type
);
88 static struct type
*convert_to_kind_type
(struct type
*basetype
, int kind
);
90 static void wrap_unop_intrinsic
(exp_opcode opcode
);
92 static void wrap_binop_intrinsic
(exp_opcode opcode
);
94 static void wrap_ternop_intrinsic
(exp_opcode opcode
);
97 static void fortran_wrap2_kind
(type
*base_type
);
100 static void fortran_wrap3_kind
(type
*base_type
);
102 using namespace expr
;
105 /* Although the yacc "value" of an expression is not used,
106 since the result is stored in the structure being created,
107 other node types do have values. */
124 struct symtoken ssym
;
126 enum exp_opcode opcode
;
127 struct internalvar
*ivar
;
134 /* YYSTYPE gets defined by %union */
135 static int parse_number
(struct parser_state
*, const char *, int,
139 %type
<voidval
> exp type_exp start variable
140 %type
<tval
> type typebase
141 %type
<tvec
> nonempty_typelist
142 /* %type <bval> block */
144 /* Fancy type parsing. */
145 %type
<voidval
> func_mod direct_abs_decl abs_decl
148 %token
<typed_val
> INT
149 %token
<typed_val_float
> FLOAT
151 /* Both NAME and TYPENAME tokens represent symbols in the input,
152 and both convey their data as strings.
153 But a TYPENAME is a string that happens to be defined as a typedef
154 or builtin type name (such as int or char)
155 and a NAME is any other symbol.
156 Contexts where this distinction is not important can use the
157 nonterminal "name", which matches either NAME or TYPENAME. */
159 %token
<sval
> STRING_LITERAL
160 %token
<lval
> BOOLEAN_LITERAL
162 %token
<tsym
> TYPENAME
163 %token
<voidval
> COMPLETE
165 %type
<ssym
> name_not_typename
167 /* A NAME_OR_INT is a symbol which is not known in the symbol table,
168 but which would parse as a valid number in the current input radix.
169 E.g. "c" when input_radix==16. Depending on the parse, it will be
170 turned into a name or into a number. */
172 %token
<ssym
> NAME_OR_INT
177 /* Special type cases, put in to allow the parser to distinguish different
179 %token INT_S1_KEYWORD INT_S2_KEYWORD INT_KEYWORD INT_S4_KEYWORD INT_S8_KEYWORD
180 %token LOGICAL_S1_KEYWORD LOGICAL_S2_KEYWORD LOGICAL_KEYWORD LOGICAL_S4_KEYWORD
181 %token LOGICAL_S8_KEYWORD
182 %token REAL_KEYWORD REAL_S4_KEYWORD REAL_S8_KEYWORD REAL_S16_KEYWORD
183 %token COMPLEX_KEYWORD COMPLEX_S4_KEYWORD COMPLEX_S8_KEYWORD
184 %token COMPLEX_S16_KEYWORD
185 %token BOOL_AND BOOL_OR BOOL_NOT
186 %token SINGLE DOUBLE PRECISION
187 %token
<lval
> CHARACTER
189 %token
<sval
> DOLLAR_VARIABLE
191 %token
<opcode
> ASSIGN_MODIFY
192 %token
<opcode
> UNOP_INTRINSIC BINOP_INTRINSIC
193 %token
<opcode
> UNOP_OR_BINOP_INTRINSIC UNOP_OR_BINOP_OR_TERNOP_INTRINSIC
197 %right
'=' ASSIGN_MODIFY
206 %left LESSTHAN GREATERTHAN LEQ GEQ
224 { pstate
->push_new
<type_operation
> ($1); }
231 /* Expressions, not including the comma operator. */
232 exp
: '*' exp %prec UNARY
233 { pstate
->wrap
<unop_ind_operation
> (); }
236 exp
: '&' exp %prec UNARY
237 { pstate
->wrap
<unop_addr_operation
> (); }
240 exp
: '-' exp %prec UNARY
241 { pstate
->wrap
<unary_neg_operation
> (); }
244 exp
: BOOL_NOT exp %prec UNARY
245 { pstate
->wrap
<unary_logical_not_operation
> (); }
248 exp
: '~' exp %prec UNARY
249 { pstate
->wrap
<unary_complement_operation
> (); }
252 exp
: SIZEOF exp %prec UNARY
253 { pstate
->wrap
<unop_sizeof_operation
> (); }
256 exp
: KIND
'(' exp
')' %prec UNARY
257 { pstate
->wrap
<fortran_kind_operation
> (); }
260 /* No more explicit array operators, we treat everything in F77 as
261 a function call. The disambiguation as to whether we are
262 doing a subscript operation or a function call is done
266 { pstate
->start_arglist
(); }
269 std
::vector
<operation_up
> args
270 = pstate
->pop_vector
(pstate
->end_arglist
());
271 pstate
->push_new
<fortran_undetermined
>
272 (pstate
->pop
(), std
::move
(args
));
276 exp
: UNOP_INTRINSIC
'(' exp
')'
278 wrap_unop_intrinsic
($1);
282 exp
: BINOP_INTRINSIC
'(' exp
',' exp
')'
284 wrap_binop_intrinsic
($1);
288 exp
: UNOP_OR_BINOP_INTRINSIC
'('
289 { pstate
->start_arglist
(); }
292 const int n
= pstate
->end_arglist
();
297 wrap_unop_intrinsic
($1);
300 wrap_binop_intrinsic
($1);
303 gdb_assert_not_reached
304 ("wrong number of arguments for intrinsics");
308 exp
: UNOP_OR_BINOP_OR_TERNOP_INTRINSIC
'('
309 { pstate
->start_arglist
(); }
312 const int n
= pstate
->end_arglist
();
317 wrap_unop_intrinsic
($1);
320 wrap_binop_intrinsic
($1);
323 wrap_ternop_intrinsic
($1);
326 gdb_assert_not_reached
327 ("wrong number of arguments for intrinsics");
336 { pstate
->arglist_len
= 1; }
340 { pstate
->arglist_len
= 1; }
343 arglist
: arglist
',' exp %prec ABOVE_COMMA
344 { pstate
->arglist_len
++; }
347 arglist
: arglist
',' subrange %prec ABOVE_COMMA
348 { pstate
->arglist_len
++; }
351 /* There are four sorts of subrange types in F90. */
353 subrange: exp
':' exp %prec ABOVE_COMMA
355 operation_up high
= pstate
->pop
();
356 operation_up low
= pstate
->pop
();
357 pstate
->push_new
<fortran_range_operation
>
358 (RANGE_STANDARD
, std
::move
(low
),
359 std
::move
(high
), operation_up
());
363 subrange: exp
':' %prec ABOVE_COMMA
365 operation_up low
= pstate
->pop
();
366 pstate
->push_new
<fortran_range_operation
>
367 (RANGE_HIGH_BOUND_DEFAULT
, std
::move
(low
),
368 operation_up
(), operation_up
());
372 subrange: ':' exp %prec ABOVE_COMMA
374 operation_up high
= pstate
->pop
();
375 pstate
->push_new
<fortran_range_operation
>
376 (RANGE_LOW_BOUND_DEFAULT
, operation_up
(),
377 std
::move
(high
), operation_up
());
381 subrange: ':' %prec ABOVE_COMMA
383 pstate
->push_new
<fortran_range_operation
>
384 (RANGE_LOW_BOUND_DEFAULT
385 | RANGE_HIGH_BOUND_DEFAULT
,
386 operation_up
(), operation_up
(),
391 /* And each of the four subrange types can also have a stride. */
392 subrange: exp
':' exp
':' exp %prec ABOVE_COMMA
394 operation_up stride
= pstate
->pop
();
395 operation_up high
= pstate
->pop
();
396 operation_up low
= pstate
->pop
();
397 pstate
->push_new
<fortran_range_operation
>
398 (RANGE_STANDARD | RANGE_HAS_STRIDE
,
399 std
::move
(low
), std
::move
(high
),
404 subrange: exp
':' ':' exp %prec ABOVE_COMMA
406 operation_up stride
= pstate
->pop
();
407 operation_up low
= pstate
->pop
();
408 pstate
->push_new
<fortran_range_operation
>
409 (RANGE_HIGH_BOUND_DEFAULT
411 std
::move
(low
), operation_up
(),
416 subrange: ':' exp
':' exp %prec ABOVE_COMMA
418 operation_up stride
= pstate
->pop
();
419 operation_up high
= pstate
->pop
();
420 pstate
->push_new
<fortran_range_operation
>
421 (RANGE_LOW_BOUND_DEFAULT
423 operation_up
(), std
::move
(high
),
428 subrange: ':' ':' exp %prec ABOVE_COMMA
430 operation_up stride
= pstate
->pop
();
431 pstate
->push_new
<fortran_range_operation
>
432 (RANGE_LOW_BOUND_DEFAULT
433 | RANGE_HIGH_BOUND_DEFAULT
435 operation_up
(), operation_up
(),
440 complexnum: exp
',' exp
444 exp
: '(' complexnum
')'
446 operation_up rhs
= pstate
->pop
();
447 operation_up lhs
= pstate
->pop
();
448 pstate
->push_new
<complex_operation
>
449 (std
::move
(lhs
), std
::move
(rhs
),
450 parse_f_type
(pstate
)->builtin_complex_s16
);
454 exp
: '(' type
')' exp %prec UNARY
456 pstate
->push_new
<unop_cast_operation
>
457 (pstate
->pop
(), $2);
463 pstate
->push_new
<fortran_structop_operation
>
464 (pstate
->pop
(), copy_name
($3));
468 exp
: exp
'%' name COMPLETE
470 structop_base_operation
*op
471 = new fortran_structop_operation
(pstate
->pop
(),
473 pstate
->mark_struct_expression
(op
);
474 pstate
->push
(operation_up
(op
));
478 exp
: exp
'%' COMPLETE
480 structop_base_operation
*op
481 = new fortran_structop_operation
(pstate
->pop
(),
483 pstate
->mark_struct_expression
(op
);
484 pstate
->push
(operation_up
(op
));
488 /* Binary operators in order of decreasing precedence. */
491 { pstate
->wrap2
<repeat_operation
> (); }
494 exp
: exp STARSTAR exp
495 { pstate
->wrap2
<exp_operation
> (); }
499 { pstate
->wrap2
<mul_operation
> (); }
503 { pstate
->wrap2
<div_operation
> (); }
507 { pstate
->wrap2
<add_operation
> (); }
511 { pstate
->wrap2
<sub_operation
> (); }
515 { pstate
->wrap2
<lsh_operation
> (); }
519 { pstate
->wrap2
<rsh_operation
> (); }
523 { pstate
->wrap2
<equal_operation
> (); }
526 exp
: exp NOTEQUAL exp
527 { pstate
->wrap2
<notequal_operation
> (); }
531 { pstate
->wrap2
<leq_operation
> (); }
535 { pstate
->wrap2
<geq_operation
> (); }
538 exp
: exp LESSTHAN exp
539 { pstate
->wrap2
<less_operation
> (); }
542 exp
: exp GREATERTHAN exp
543 { pstate
->wrap2
<gtr_operation
> (); }
547 { pstate
->wrap2
<bitwise_and_operation
> (); }
551 { pstate
->wrap2
<bitwise_xor_operation
> (); }
555 { pstate
->wrap2
<bitwise_ior_operation
> (); }
558 exp
: exp BOOL_AND exp
559 { pstate
->wrap2
<logical_and_operation
> (); }
563 exp
: exp BOOL_OR exp
564 { pstate
->wrap2
<logical_or_operation
> (); }
568 { pstate
->wrap2
<assign_operation
> (); }
571 exp
: exp ASSIGN_MODIFY exp
573 operation_up rhs
= pstate
->pop
();
574 operation_up lhs
= pstate
->pop
();
575 pstate
->push_new
<assign_modify_operation
>
576 ($2, std
::move
(lhs
), std
::move
(rhs
));
582 pstate
->push_new
<long_const_operation
>
589 parse_number
(pstate
, $1.stoken.ptr
,
590 $1.stoken.length
, 0, &val
);
591 pstate
->push_new
<long_const_operation
>
600 std
::copy
(std
::begin
($1.val
), std
::end
($1.val
),
602 pstate
->push_new
<float_const_operation
> ($1.type
, data
);
609 exp
: DOLLAR_VARIABLE
610 { pstate
->push_dollar
($1); }
613 exp
: SIZEOF
'(' type
')' %prec UNARY
615 $3 = check_typedef
($3);
616 pstate
->push_new
<long_const_operation
>
617 (parse_f_type
(pstate
)->builtin_integer
,
622 exp
: BOOLEAN_LITERAL
623 { pstate
->push_new
<bool_operation
> ($1); }
628 pstate
->push_new
<string_operation
>
633 variable: name_not_typename
634 { struct block_symbol sym
= $1.sym
;
635 std
::string name
= copy_name
($1.stoken
);
636 pstate
->push_symbol
(name.c_str
(), sym
);
647 /* This is where the interesting stuff happens. */
650 struct type
*follow_type
= $1;
651 struct type
*range_type
;
654 switch
(type_stack
->pop
())
660 follow_type
= lookup_pointer_type
(follow_type
);
663 follow_type
= lookup_lvalue_reference_type
(follow_type
);
666 array_size
= type_stack
->pop_int
();
667 if
(array_size
!= -1)
669 struct type
*idx_type
670 = parse_f_type
(pstate
)->builtin_integer
;
671 type_allocator alloc
(idx_type
);
673 create_static_range_type
(alloc
, idx_type
,
675 follow_type
= create_array_type
(alloc
,
680 follow_type
= lookup_pointer_type
(follow_type
);
683 follow_type
= lookup_function_type
(follow_type
);
687 int kind_val
= type_stack
->pop_int
();
689 = convert_to_kind_type
(follow_type
, kind_val
);
698 { type_stack
->push
(tp_pointer
); $$
= 0; }
700 { type_stack
->push
(tp_pointer
); $$
= $2; }
702 { type_stack
->push
(tp_reference
); $$
= 0; }
704 { type_stack
->push
(tp_reference
); $$
= $2; }
708 direct_abs_decl: '(' abs_decl
')'
710 |
'(' KIND
'=' INT
')'
711 { push_kind_type
($4.val
, $4.type
); }
713 { push_kind_type
($2.val
, $2.type
); }
714 | direct_abs_decl func_mod
715 { type_stack
->push
(tp_function
); }
717 { type_stack
->push
(tp_function
); }
722 |
'(' nonempty_typelist
')'
723 { free
($2); $$
= 0; }
726 typebase
/* Implements (approximately): (type-qualifier)* type-specifier */
730 { $$
= parse_f_type
(pstate
)->builtin_integer_s1
; }
732 { $$
= parse_f_type
(pstate
)->builtin_integer_s2
; }
734 { $$
= parse_f_type
(pstate
)->builtin_integer
; }
736 { $$
= parse_f_type
(pstate
)->builtin_integer
; }
738 { $$
= parse_f_type
(pstate
)->builtin_integer_s8
; }
740 { $$
= parse_f_type
(pstate
)->builtin_character
; }
742 { $$
= parse_f_type
(pstate
)->builtin_logical_s1
; }
744 { $$
= parse_f_type
(pstate
)->builtin_logical_s2
; }
746 { $$
= parse_f_type
(pstate
)->builtin_logical
; }
748 { $$
= parse_f_type
(pstate
)->builtin_logical
; }
750 { $$
= parse_f_type
(pstate
)->builtin_logical_s8
; }
752 { $$
= parse_f_type
(pstate
)->builtin_real
; }
754 { $$
= parse_f_type
(pstate
)->builtin_real
; }
756 { $$
= parse_f_type
(pstate
)->builtin_real_s8
; }
758 { $$
= parse_f_type
(pstate
)->builtin_real_s16
; }
760 { $$
= parse_f_type
(pstate
)->builtin_complex
; }
762 { $$
= parse_f_type
(pstate
)->builtin_complex
; }
764 { $$
= parse_f_type
(pstate
)->builtin_complex_s8
; }
765 | COMPLEX_S16_KEYWORD
766 { $$
= parse_f_type
(pstate
)->builtin_complex_s16
; }
768 { $$
= parse_f_type
(pstate
)->builtin_real
;}
770 { $$
= parse_f_type
(pstate
)->builtin_real_s8
;}
771 | SINGLE COMPLEX_KEYWORD
772 { $$
= parse_f_type
(pstate
)->builtin_complex
;}
773 | DOUBLE COMPLEX_KEYWORD
774 { $$
= parse_f_type
(pstate
)->builtin_complex_s8
;}
779 { $$
= (struct type
**) malloc
(sizeof
(struct type
*) * 2);
780 $
<ivec
>$
[0] = 1; /* Number of types in vector */
783 | nonempty_typelist
',' type
784 { int len
= sizeof
(struct type
*) * (++($
<ivec
>1[0]) + 1);
785 $$
= (struct type
**) realloc
((char *) $1, len
);
786 $$
[$
<ivec
>$
[0]] = $3;
797 name_not_typename
: NAME
798 /* These would be useful if name_not_typename was useful, but it is just
799 a fake for "variable", so these cause reduce/reduce conflicts because
800 the parser can't tell whether NAME_OR_INT is a name_not_typename (=variable,
801 =exp) or just an exp. If name_not_typename was ever used in an lvalue
802 context where only a name could occur, this might be useful.
809 /* Called to match intrinsic function calls with one argument to their
810 respective implementation and push the operation. */
813 wrap_unop_intrinsic
(exp_opcode code
)
818 pstate
->wrap
<fortran_abs_operation
> ();
821 pstate
->wrap
<fortran_floor_operation_1arg
> ();
823 case FORTRAN_CEILING
:
824 pstate
->wrap
<fortran_ceil_operation_1arg
> ();
826 case UNOP_FORTRAN_ALLOCATED
:
827 pstate
->wrap
<fortran_allocated_operation
> ();
829 case UNOP_FORTRAN_RANK
:
830 pstate
->wrap
<fortran_rank_operation
> ();
832 case UNOP_FORTRAN_SHAPE
:
833 pstate
->wrap
<fortran_array_shape_operation
> ();
835 case UNOP_FORTRAN_LOC
:
836 pstate
->wrap
<fortran_loc_operation
> ();
838 case FORTRAN_ASSOCIATED
:
839 pstate
->wrap
<fortran_associated_1arg
> ();
841 case FORTRAN_ARRAY_SIZE
:
842 pstate
->wrap
<fortran_array_size_1arg
> ();
845 pstate
->wrap
<fortran_cmplx_operation_1arg
> ();
849 pstate
->push_new
<fortran_bound_1arg
> (code
, pstate
->pop
());
852 gdb_assert_not_reached
("unhandled intrinsic");
856 /* Called to match intrinsic function calls with two arguments to their
857 respective implementation and push the operation. */
860 wrap_binop_intrinsic
(exp_opcode code
)
865 fortran_wrap2_kind
<fortran_floor_operation_2arg
>
866 (parse_f_type
(pstate
)->builtin_integer
);
868 case FORTRAN_CEILING
:
869 fortran_wrap2_kind
<fortran_ceil_operation_2arg
>
870 (parse_f_type
(pstate
)->builtin_integer
);
873 pstate
->wrap2
<fortran_mod_operation
> ();
875 case BINOP_FORTRAN_MODULO
:
876 pstate
->wrap2
<fortran_modulo_operation
> ();
879 pstate
->wrap2
<fortran_cmplx_operation_2arg
> ();
881 case FORTRAN_ASSOCIATED
:
882 pstate
->wrap2
<fortran_associated_2arg
> ();
884 case FORTRAN_ARRAY_SIZE
:
885 pstate
->wrap2
<fortran_array_size_2arg
> ();
890 operation_up arg2
= pstate
->pop
();
891 operation_up arg1
= pstate
->pop
();
892 pstate
->push_new
<fortran_bound_2arg
> (code
, std
::move
(arg1
),
897 gdb_assert_not_reached
("unhandled intrinsic");
901 /* Called to match intrinsic function calls with three arguments to their
902 respective implementation and push the operation. */
905 wrap_ternop_intrinsic
(exp_opcode code
)
912 operation_up kind_arg
= pstate
->pop
();
913 operation_up arg2
= pstate
->pop
();
914 operation_up arg1
= pstate
->pop
();
916 value
*val
= kind_arg
->evaluate
(nullptr
, pstate
->expout.get
(),
917 EVAL_AVOID_SIDE_EFFECTS
);
918 gdb_assert
(val
!= nullptr
);
921 = convert_to_kind_type
(parse_f_type
(pstate
)->builtin_integer
,
922 value_as_long
(val
));
924 pstate
->push_new
<fortran_bound_3arg
> (code
, std
::move
(arg1
),
925 std
::move
(arg2
), follow_type
);
928 case FORTRAN_ARRAY_SIZE
:
929 fortran_wrap3_kind
<fortran_array_size_3arg
>
930 (parse_f_type
(pstate
)->builtin_integer
);
933 fortran_wrap3_kind
<fortran_cmplx_operation_3arg
>
934 (parse_f_type
(pstate
)->builtin_complex
);
937 gdb_assert_not_reached
("unhandled intrinsic");
941 /* A helper that pops two operations (similar to wrap2), evaluates the last one
942 assuming it is a kind parameter, and wraps them in some other operation
943 pushing it to the stack. */
947 fortran_wrap2_kind
(type
*base_type
)
949 operation_up kind_arg
= pstate
->pop
();
950 operation_up arg
= pstate
->pop
();
952 value
*val
= kind_arg
->evaluate
(nullptr
, pstate
->expout.get
(),
953 EVAL_AVOID_SIDE_EFFECTS
);
954 gdb_assert
(val
!= nullptr
);
956 type
*follow_type
= convert_to_kind_type
(base_type
, value_as_long
(val
));
958 pstate
->push_new
<T
> (std
::move
(arg
), follow_type
);
961 /* A helper that pops three operations, evaluates the last one assuming it is a
962 kind parameter, and wraps them in some other operation pushing it to the
967 fortran_wrap3_kind
(type
*base_type
)
969 operation_up kind_arg
= pstate
->pop
();
970 operation_up arg2
= pstate
->pop
();
971 operation_up arg1
= pstate
->pop
();
973 value
*val
= kind_arg
->evaluate
(nullptr
, pstate
->expout.get
(),
974 EVAL_AVOID_SIDE_EFFECTS
);
975 gdb_assert
(val
!= nullptr
);
977 type
*follow_type
= convert_to_kind_type
(base_type
, value_as_long
(val
));
979 pstate
->push_new
<T
> (std
::move
(arg1
), std
::move
(arg2
), follow_type
);
982 /* Take care of parsing a number (anything that starts with a digit).
983 Set yylval and return the token type; update lexptr.
984 LEN is the number of characters in it. */
986 /*** Needs some error checking for the float case ***/
989 parse_number
(struct parser_state
*par_state
,
990 const char *p
, int len
, int parsed_float
, YYSTYPE *putithere
)
995 int base
= input_radix
;
999 struct type
*signed_type
;
1000 struct type
*unsigned_type
;
1004 /* It's a float since it contains a point or an exponent. */
1005 /* [dD] is not understood as an exponent by parse_float,
1006 change it to 'e'. */
1010 for
(tmp2
= tmp
; *tmp2
; ++tmp2
)
1011 if
(*tmp2
== 'd' ||
*tmp2
== 'D')
1014 /* FIXME: Should this use different types? */
1015 putithere
->typed_val_float.type
= parse_f_type
(pstate
)->builtin_real_s8
;
1016 bool parsed
= parse_float
(tmp
, len
,
1017 putithere
->typed_val_float.type
,
1018 putithere
->typed_val_float.val
);
1020 return parsed? FLOAT
: ERROR
;
1023 /* Handle base-switching prefixes 0x, 0t, 0d, 0 */
1024 if
(p
[0] == '0' && len
> 1)
1059 if
(len
== 0 && c
== 'l')
1061 else if
(len
== 0 && c
== 'u')
1066 if
(c
>= '0' && c
<= '9')
1068 else if
(c
>= 'a' && c
<= 'f')
1071 return ERROR
; /* Char not a digit */
1073 return ERROR
; /* Invalid digit in this base */
1077 /* Test for overflow. */
1078 if
(prevn
== 0 && n
== 0)
1080 else if
(RANGE_CHECK
&& prevn
>= n
)
1081 range_error
(_
("Overflow on numeric constant."));
1085 /* If the number is too big to be an int, or it's got an l suffix
1086 then it's a long. Work out if this has to be a long by
1087 shifting right and seeing if anything remains, and the
1088 target int size is different to the target long size.
1090 In the expression below, we could have tested
1091 (n >> gdbarch_int_bit (parse_gdbarch))
1092 to see if it was zero,
1093 but too many compilers warn about that, when ints and longs
1094 are the same size. So we shift it twice, with fewer bits
1095 each time, for the same result. */
1098 if
((gdbarch_int_bit
(par_state
->gdbarch
())
1099 != gdbarch_long_bit
(par_state
->gdbarch
())
1101 >> (gdbarch_int_bit
(par_state
->gdbarch
())-2))) /* Avoid
1105 bits_available
= gdbarch_long_bit
(par_state
->gdbarch
());
1106 unsigned_type
= parse_type
(par_state
)->builtin_unsigned_long
;
1107 signed_type
= parse_type
(par_state
)->builtin_long
;
1111 bits_available
= gdbarch_int_bit
(par_state
->gdbarch
());
1112 unsigned_type
= parse_type
(par_state
)->builtin_unsigned_int
;
1113 signed_type
= parse_type
(par_state
)->builtin_int
;
1115 high_bit
= ((ULONGEST
)1) << (bits_available
- 1);
1118 && ((n
>> 2) >> (bits_available
- 2)))
1119 range_error
(_
("Overflow on numeric constant."));
1121 putithere
->typed_val.val
= n
;
1123 /* If the high bit of the worked out type is set then this number
1124 has to be unsigned. */
1126 if
(unsigned_p ||
(n
& high_bit
))
1127 putithere
->typed_val.type
= unsigned_type
;
1129 putithere
->typed_val.type
= signed_type
;
1134 /* Called to setup the type stack when we encounter a '(kind=N)' type
1135 modifier, performs some bounds checking on 'N' and then pushes this to
1136 the type stack followed by the 'tp_kind' marker. */
1138 push_kind_type
(LONGEST val
, struct type
*type
)
1142 if
(type
->is_unsigned
())
1144 ULONGEST uval
= static_cast
<ULONGEST
> (val
);
1146 error (_
("kind value out of range"));
1147 ival
= static_cast
<int> (uval
);
1151 if
(val
> INT_MAX || val
< 0)
1152 error (_
("kind value out of range"));
1153 ival
= static_cast
<int> (val
);
1156 type_stack
->push
(ival
);
1157 type_stack
->push
(tp_kind
);
1160 /* Called when a type has a '(kind=N)' modifier after it, for example
1161 'character(kind=1)'. The BASETYPE is the type described by 'character'
1162 in our example, and KIND is the integer '1'. This function returns a
1163 new type that represents the basetype of a specific kind. */
1164 static struct type
*
1165 convert_to_kind_type
(struct type
*basetype
, int kind
)
1167 if
(basetype
== parse_f_type
(pstate
)->builtin_character
)
1169 /* Character of kind 1 is a special case, this is the same as the
1170 base character type. */
1172 return parse_f_type
(pstate
)->builtin_character
;
1174 else if
(basetype
== parse_f_type
(pstate
)->builtin_complex
)
1177 return parse_f_type
(pstate
)->builtin_complex
;
1179 return parse_f_type
(pstate
)->builtin_complex_s8
;
1180 else if
(kind
== 16)
1181 return parse_f_type
(pstate
)->builtin_complex_s16
;
1183 else if
(basetype
== parse_f_type
(pstate
)->builtin_real
)
1186 return parse_f_type
(pstate
)->builtin_real
;
1188 return parse_f_type
(pstate
)->builtin_real_s8
;
1189 else if
(kind
== 16)
1190 return parse_f_type
(pstate
)->builtin_real_s16
;
1192 else if
(basetype
== parse_f_type
(pstate
)->builtin_logical
)
1195 return parse_f_type
(pstate
)->builtin_logical_s1
;
1197 return parse_f_type
(pstate
)->builtin_logical_s2
;
1199 return parse_f_type
(pstate
)->builtin_logical
;
1201 return parse_f_type
(pstate
)->builtin_logical_s8
;
1203 else if
(basetype
== parse_f_type
(pstate
)->builtin_integer
)
1206 return parse_f_type
(pstate
)->builtin_integer_s1
;
1208 return parse_f_type
(pstate
)->builtin_integer_s2
;
1210 return parse_f_type
(pstate
)->builtin_integer
;
1212 return parse_f_type
(pstate
)->builtin_integer_s8
;
1215 error (_
("unsupported kind %d for type %s"),
1216 kind
, TYPE_SAFE_NAME
(basetype
));
1218 /* Should never get here. */
1224 /* The string to match against. */
1227 /* The lexer token to return. */
1230 /* The expression opcode to embed within the token. */
1231 enum exp_opcode opcode
;
1233 /* When this is true the string in OPER is matched exactly including
1234 case, when this is false OPER is matched case insensitively. */
1235 bool case_sensitive
;
1238 /* List of Fortran operators. */
1240 static const struct f_token fortran_operators
[] =
1242 { ".and.", BOOL_AND
, OP_NULL
, false
},
1243 { ".or.", BOOL_OR
, OP_NULL
, false
},
1244 { ".not.", BOOL_NOT
, OP_NULL
, false
},
1245 { ".eq.", EQUAL
, OP_NULL
, false
},
1246 { ".eqv.", EQUAL
, OP_NULL
, false
},
1247 { ".neqv.", NOTEQUAL
, OP_NULL
, false
},
1248 { ".xor.", NOTEQUAL
, OP_NULL
, false
},
1249 { "==", EQUAL
, OP_NULL
, false
},
1250 { ".ne.", NOTEQUAL
, OP_NULL
, false
},
1251 { "/=", NOTEQUAL
, OP_NULL
, false
},
1252 { ".le.", LEQ
, OP_NULL
, false
},
1253 { "<=", LEQ
, OP_NULL
, false
},
1254 { ".ge.", GEQ
, OP_NULL
, false
},
1255 { ">=", GEQ
, OP_NULL
, false
},
1256 { ".gt.", GREATERTHAN
, OP_NULL
, false
},
1257 { ">", GREATERTHAN
, OP_NULL
, false
},
1258 { ".lt.", LESSTHAN
, OP_NULL
, false
},
1259 { "<", LESSTHAN
, OP_NULL
, false
},
1260 { "**", STARSTAR
, BINOP_EXP
, false
},
1263 /* Holds the Fortran representation of a boolean, and the integer value we
1264 substitute in when one of the matching strings is parsed. */
1265 struct f77_boolean_val
1267 /* The string representing a Fortran boolean. */
1270 /* The integer value to replace it with. */
1274 /* The set of Fortran booleans. These are matched case insensitively. */
1275 static const struct f77_boolean_val boolean_values
[] =
1281 static const struct f_token f_intrinsics
[] =
1283 /* The following correspond to actual functions in Fortran and are case
1285 { "kind", KIND
, OP_NULL
, false
},
1286 { "abs", UNOP_INTRINSIC
, UNOP_ABS
, false
},
1287 { "mod", BINOP_INTRINSIC
, BINOP_MOD
, false
},
1288 { "floor", UNOP_OR_BINOP_INTRINSIC
, FORTRAN_FLOOR
, false
},
1289 { "ceiling", UNOP_OR_BINOP_INTRINSIC
, FORTRAN_CEILING
, false
},
1290 { "modulo", BINOP_INTRINSIC
, BINOP_FORTRAN_MODULO
, false
},
1291 { "cmplx", UNOP_OR_BINOP_OR_TERNOP_INTRINSIC
, FORTRAN_CMPLX
, false
},
1292 { "lbound", UNOP_OR_BINOP_OR_TERNOP_INTRINSIC
, FORTRAN_LBOUND
, false
},
1293 { "ubound", UNOP_OR_BINOP_OR_TERNOP_INTRINSIC
, FORTRAN_UBOUND
, false
},
1294 { "allocated", UNOP_INTRINSIC
, UNOP_FORTRAN_ALLOCATED
, false
},
1295 { "associated", UNOP_OR_BINOP_INTRINSIC
, FORTRAN_ASSOCIATED
, false
},
1296 { "rank", UNOP_INTRINSIC
, UNOP_FORTRAN_RANK
, false
},
1297 { "size", UNOP_OR_BINOP_OR_TERNOP_INTRINSIC
, FORTRAN_ARRAY_SIZE
, false
},
1298 { "shape", UNOP_INTRINSIC
, UNOP_FORTRAN_SHAPE
, false
},
1299 { "loc", UNOP_INTRINSIC
, UNOP_FORTRAN_LOC
, false
},
1300 { "sizeof", SIZEOF
, OP_NULL
, false
},
1303 static const f_token f_keywords
[] =
1305 /* Historically these have always been lowercase only in GDB. */
1306 { "character", CHARACTER
, OP_NULL
, true
},
1307 { "complex", COMPLEX_KEYWORD
, OP_NULL
, true
},
1308 { "complex_4", COMPLEX_S4_KEYWORD
, OP_NULL
, true
},
1309 { "complex_8", COMPLEX_S8_KEYWORD
, OP_NULL
, true
},
1310 { "complex_16", COMPLEX_S16_KEYWORD
, OP_NULL
, true
},
1311 { "integer_1", INT_S1_KEYWORD
, OP_NULL
, true
},
1312 { "integer_2", INT_S2_KEYWORD
, OP_NULL
, true
},
1313 { "integer_4", INT_S4_KEYWORD
, OP_NULL
, true
},
1314 { "integer", INT_KEYWORD
, OP_NULL
, true
},
1315 { "integer_8", INT_S8_KEYWORD
, OP_NULL
, true
},
1316 { "logical_1", LOGICAL_S1_KEYWORD
, OP_NULL
, true
},
1317 { "logical_2", LOGICAL_S2_KEYWORD
, OP_NULL
, true
},
1318 { "logical", LOGICAL_KEYWORD
, OP_NULL
, true
},
1319 { "logical_4", LOGICAL_S4_KEYWORD
, OP_NULL
, true
},
1320 { "logical_8", LOGICAL_S8_KEYWORD
, OP_NULL
, true
},
1321 { "real", REAL_KEYWORD
, OP_NULL
, true
},
1322 { "real_4", REAL_S4_KEYWORD
, OP_NULL
, true
},
1323 { "real_8", REAL_S8_KEYWORD
, OP_NULL
, true
},
1324 { "real_16", REAL_S16_KEYWORD
, OP_NULL
, true
},
1325 { "single", SINGLE
, OP_NULL
, true
},
1326 { "double", DOUBLE
, OP_NULL
, true
},
1327 { "precision", PRECISION
, OP_NULL
, true
},
1330 /* Implementation of a dynamically expandable buffer for processing input
1331 characters acquired through lexptr and building a value to return in
1332 yylval. Ripped off from ch-exp.y */
1334 static char *tempbuf
; /* Current buffer contents */
1335 static int tempbufsize
; /* Size of allocated buffer */
1336 static int tempbufindex
; /* Current index into buffer */
1338 #define GROWBY_MIN_SIZE 64 /* Minimum amount to grow buffer by */
1340 #define CHECKBUF(size) \
1342 if
(tempbufindex
+ (size
) >= tempbufsize
) \
1344 growbuf_by_size
(size
); \
1349 /* Grow the static temp buffer if necessary, including allocating the
1350 first one on demand. */
1353 growbuf_by_size
(int count
)
1357 growby
= std
::max
(count
, GROWBY_MIN_SIZE
);
1358 tempbufsize
+= growby
;
1359 if
(tempbuf
== NULL
)
1360 tempbuf
= (char *) malloc
(tempbufsize
);
1362 tempbuf
= (char *) realloc
(tempbuf
, tempbufsize
);
1365 /* Blatantly ripped off from ch-exp.y. This routine recognizes F77
1368 Recognize a string literal. A string literal is a nonzero sequence
1369 of characters enclosed in matching single quotes, except that
1370 a single character inside single quotes is a character literal, which
1371 we reject as a string literal. To embed the terminator character inside
1372 a string, it is simply doubled (I.E. 'this''is''one''string') */
1375 match_string_literal
(void)
1377 const char *tokptr
= pstate
->lexptr
;
1379 for
(tempbufindex
= 0, tokptr
++; *tokptr
!= '\0'; tokptr
++)
1382 if
(*tokptr
== *pstate
->lexptr
)
1384 if
(*(tokptr
+ 1) == *pstate
->lexptr
)
1389 tempbuf
[tempbufindex
++] = *tokptr
;
1391 if
(*tokptr
== '\0' /* no terminator */
1392 || tempbufindex
== 0) /* no string */
1396 tempbuf
[tempbufindex
] = '\0';
1397 yylval.sval.ptr
= tempbuf
;
1398 yylval.sval.length
= tempbufindex
;
1399 pstate
->lexptr
= ++tokptr
;
1400 return STRING_LITERAL
;
1404 /* This is set if a NAME token appeared at the very end of the input
1405 string, with no whitespace separating the name from the EOF. This
1406 is used only when parsing to do field name completion. */
1407 static bool saw_name_at_eof
;
1409 /* This is set if the previously-returned token was a structure
1411 static bool last_was_structop
;
1413 /* Read one token, getting characters through lexptr. */
1421 const char *tokstart
;
1422 bool saw_structop
= last_was_structop
;
1424 last_was_structop
= false
;
1428 pstate
->prev_lexptr
= pstate
->lexptr
;
1430 tokstart
= pstate
->lexptr
;
1432 /* First of all, let us make sure we are not dealing with the
1433 special tokens .true. and .false. which evaluate to 1 and 0. */
1435 if
(*pstate
->lexptr
== '.')
1437 for
(const auto
&candidate
: boolean_values
)
1439 if
(strncasecmp
(tokstart
, candidate.name
,
1440 strlen
(candidate.name
)) == 0)
1442 pstate
->lexptr
+= strlen
(candidate.name
);
1443 yylval.lval
= candidate.value
;
1444 return BOOLEAN_LITERAL
;
1449 /* See if it is a Fortran operator. */
1450 for
(const auto
&candidate
: fortran_operators
)
1451 if
(strncasecmp
(tokstart
, candidate.oper
,
1452 strlen
(candidate.oper
)) == 0)
1454 gdb_assert
(!candidate.case_sensitive
);
1455 pstate
->lexptr
+= strlen
(candidate.oper
);
1456 yylval.opcode
= candidate.opcode
;
1457 return candidate.token
;
1460 switch
(c
= *tokstart
)
1463 if
(saw_name_at_eof
)
1465 saw_name_at_eof
= false
;
1468 else if
(pstate
->parse_completion
&& saw_structop
)
1479 token
= match_string_literal
();
1490 if
(paren_depth
== 0)
1497 if
(pstate
->comma_terminates
&& paren_depth
== 0)
1503 /* Might be a floating point number. */
1504 if
(pstate
->lexptr
[1] < '0' || pstate
->lexptr
[1] > '9')
1505 goto symbol
; /* Nope, must be a symbol. */
1519 /* It's a number. */
1520 int got_dot
= 0, got_e
= 0, got_d
= 0, toktype
;
1521 const char *p
= tokstart
;
1522 int hex
= input_radix
> 10;
1524 if
(c
== '0' && (p
[1] == 'x' || p
[1] == 'X'))
1529 else if
(c
== '0' && (p
[1]=='t' || p
[1]=='T'
1530 || p
[1]=='d' || p
[1]=='D'))
1538 if
(!hex
&& !got_e
&& (*p
== 'e' ||
*p
== 'E'))
1539 got_dot
= got_e
= 1;
1540 else if
(!hex
&& !got_d
&& (*p
== 'd' ||
*p
== 'D'))
1541 got_dot
= got_d
= 1;
1542 else if
(!hex
&& !got_dot
&& *p
== '.')
1544 else if
(((got_e
&& (p
[-1] == 'e' || p
[-1] == 'E'))
1545 ||
(got_d
&& (p
[-1] == 'd' || p
[-1] == 'D')))
1546 && (*p
== '-' ||
*p
== '+'))
1547 /* This is the sign of the exponent, not the end of the
1550 /* We will take any letters or digits. parse_number will
1551 complain if past the radix, or if L or U are not final. */
1552 else if
((*p
< '0' ||
*p
> '9')
1553 && ((*p
< 'a' ||
*p
> 'z')
1554 && (*p
< 'A' ||
*p
> 'Z')))
1557 toktype
= parse_number
(pstate
, tokstart
, p
- tokstart
,
1558 got_dot|got_e|got_d
,
1560 if
(toktype
== ERROR
)
1562 char *err_copy
= (char *) alloca
(p
- tokstart
+ 1);
1564 memcpy
(err_copy
, tokstart
, p
- tokstart
);
1565 err_copy
[p
- tokstart
] = 0;
1566 error (_
("Invalid number \"%s\"."), err_copy
);
1573 last_was_structop
= true
;
1599 if
(!(c
== '_' || c
== '$' || c
==':'
1600 ||
(c
>= 'a' && c
<= 'z') ||
(c
>= 'A' && c
<= 'Z')))
1601 /* We must have come across a bad character (e.g. ';'). */
1602 error (_
("Invalid character '%c' in expression."), c
);
1605 for
(c
= tokstart
[namelen
];
1606 (c
== '_' || c
== '$' || c
== ':' ||
(c
>= '0' && c
<= '9')
1607 ||
(c
>= 'a' && c
<= 'z') ||
(c
>= 'A' && c
<= 'Z'));
1608 c
= tokstart
[++namelen
]);
1610 /* The token "if" terminates the expression and is NOT
1611 removed from the input stream. */
1613 if
(namelen
== 2 && tokstart
[0] == 'i' && tokstart
[1] == 'f')
1616 pstate
->lexptr
+= namelen
;
1618 /* Catch specific keywords. */
1620 for
(const auto
&keyword
: f_keywords
)
1621 if
(strlen
(keyword.oper
) == namelen
1622 && ((!keyword.case_sensitive
1623 && strncasecmp
(tokstart
, keyword.oper
, namelen
) == 0)
1624 ||
(keyword.case_sensitive
1625 && strncmp
(tokstart
, keyword.oper
, namelen
) == 0)))
1627 yylval.opcode
= keyword.opcode
;
1628 return keyword.token
;
1631 yylval.sval.ptr
= tokstart
;
1632 yylval.sval.length
= namelen
;
1634 if
(*tokstart
== '$')
1635 return DOLLAR_VARIABLE
;
1637 /* Use token-type TYPENAME for symbols that happen to be defined
1638 currently as names of types; NAME for other symbols.
1639 The caller is not constrained to care about the distinction. */
1641 std
::string tmp
= copy_name
(yylval.sval
);
1642 struct block_symbol result
;
1643 const domain_enum lookup_domains
[] =
1651 for
(const auto
&domain
: lookup_domains
)
1653 result
= lookup_symbol
(tmp.c_str
(), pstate
->expression_context_block
,
1655 if
(result.symbol
&& result.symbol
->aclass
() == LOC_TYPEDEF
)
1657 yylval.tsym.type
= result.symbol
->type
();
1666 = language_lookup_primitive_type
(pstate
->language
(),
1667 pstate
->gdbarch
(), tmp.c_str
());
1668 if
(yylval.tsym.type
!= NULL
)
1671 /* This is post the symbol search as symbols can hide intrinsics. Also,
1672 give Fortran intrinsics priority over C symbols. This prevents
1673 non-Fortran symbols from hiding intrinsics, for example abs. */
1674 if
(!result.symbol || result.symbol
->language
() != language_fortran
)
1675 for
(const auto
&intrinsic
: f_intrinsics
)
1677 gdb_assert
(!intrinsic.case_sensitive
);
1678 if
(strlen
(intrinsic.oper
) == namelen
1679 && strncasecmp
(tokstart
, intrinsic.oper
, namelen
) == 0)
1681 yylval.opcode
= intrinsic.opcode
;
1682 return intrinsic.token
;
1686 /* Input names that aren't symbols but ARE valid hex numbers,
1687 when the input radix permits them, can be names or numbers
1688 depending on the parse. Note we support radixes > 16 here. */
1690 && ((tokstart
[0] >= 'a' && tokstart
[0] < 'a' + input_radix
- 10)
1691 ||
(tokstart
[0] >= 'A' && tokstart
[0] < 'A' + input_radix
- 10)))
1693 YYSTYPE newlval
; /* Its value is ignored. */
1694 hextype
= parse_number
(pstate
, tokstart
, namelen
, 0, &newlval
);
1697 yylval.ssym.sym
= result
;
1698 yylval.ssym.is_a_field_of_this
= false
;
1703 if
(pstate
->parse_completion
&& *pstate
->lexptr
== '\0')
1704 saw_name_at_eof
= true
;
1706 /* Any other kind of symbol */
1707 yylval.ssym.sym
= result
;
1708 yylval.ssym.is_a_field_of_this
= false
;
1714 f_language::parser
(struct parser_state
*par_state
) const
1716 /* Setting up the parser state. */
1717 scoped_restore pstate_restore
= make_scoped_restore
(&pstate
);
1718 scoped_restore restore_yydebug
= make_scoped_restore
(&yydebug,
1720 gdb_assert
(par_state
!= NULL
);
1722 last_was_structop
= false
;
1723 saw_name_at_eof
= false
;
1726 struct type_stack stack
;
1727 scoped_restore restore_type_stack
= make_scoped_restore
(&type_stack
,
1730 int result
= yyparse ();
1732 pstate
->set_operation
(pstate
->pop
());
1737 yyerror (const char *msg
)
1739 if
(pstate
->prev_lexptr
)
1740 pstate
->lexptr
= pstate
->prev_lexptr
;
1742 error (_
("A %s in expression, near `%s'."), msg
, pstate
->lexptr
);