2004-07-28 Andrew Cagney <cagney@gnu.org>
[platform/upstream/binutils.git] / gdb / f-exp.y
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 \f
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
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
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
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
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     yylval.tsym.type
1154       = language_lookup_primitive_type_by_name (current_language,
1155                                                 current_gdbarch, tmp);
1156     if (yylval.tsym.type != NULL)
1157       return TYPENAME;
1158     
1159     /* Input names that aren't symbols but ARE valid hex numbers,
1160        when the input radix permits them, can be names or numbers
1161        depending on the parse.  Note we support radixes > 16 here.  */
1162     if (!sym
1163         && ((tokstart[0] >= 'a' && tokstart[0] < 'a' + input_radix - 10)
1164             || (tokstart[0] >= 'A' && tokstart[0] < 'A' + input_radix - 10)))
1165       {
1166         YYSTYPE newlval;        /* Its value is ignored.  */
1167         hextype = parse_number (tokstart, namelen, 0, &newlval);
1168         if (hextype == INT)
1169           {
1170             yylval.ssym.sym = sym;
1171             yylval.ssym.is_a_field_of_this = is_a_field_of_this;
1172             return NAME_OR_INT;
1173           }
1174       }
1175     
1176     /* Any other kind of symbol */
1177     yylval.ssym.sym = sym;
1178     yylval.ssym.is_a_field_of_this = is_a_field_of_this;
1179     return NAME;
1180   }
1181 }
1182
1183 void
1184 yyerror (msg)
1185      char *msg;
1186 {
1187   if (prev_lexptr)
1188     lexptr = prev_lexptr;
1189
1190   error ("A %s in expression, near `%s'.", (msg ? msg : "error"), lexptr);
1191 }