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