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