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