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