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