Subversion Repositories openrisc

/* YACC parser for Pascal expressions, for GDB.

   Copyright (C) 2000, 2006, 2007, 2008, 2009, 2010

   Free Software Foundation, Inc.

   This file is part of GDB.

   This program is free software; you can redistribute it and/or modify

   it under the terms of the GNU General Public License as published by

   the Free Software Foundation; either version 3 of the License, or

   (at your option) any later version.

   This program is distributed in the hope that it will be useful,

   but WITHOUT ANY WARRANTY; without even the implied warranty of

   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the

   GNU General Public License for more details.

   You should have received a copy of the GNU General Public License

   along with this program.  If not, see .  */

/* This file is derived from c-exp.y */

/* Parse a Pascal expression from text in a string,

   and return the result as a  struct expression  pointer.

   That structure contains arithmetic operations in reverse polish,

   with constants represented by operations that are followed by special data.

   See expression.h for the details of the format.

   What is important here is that it can be built up sequentially

   during the process of parsing; the lower levels of the tree always

   come first in the result.

   Note that malloc's and realloc's in this file are transformed to

   xmalloc and xrealloc respectively by the same sed command in the

   makefile that remaps any other malloc/realloc inserted by the parser

   generator.  Doing this with #defines and trying to control the interaction

   with include files ( and  for example) just became

   too messy, particularly when such includes can be inserted at random

   times by the parser generator.  */

/* Known bugs or limitations:

    - pascal string operations are not supported at all.

    - there are some problems with boolean types.

    - Pascal type hexadecimal constants are not supported

      because they conflict with the internal variables format.

   Probably also lots of other problems, less well defined PM */

%{

#include "defs.h"

#include "gdb_string.h"

#include 

#include "expression.h"

#include "value.h"

#include "parser-defs.h"

#include "language.h"

#include "p-lang.h"

#include "bfd.h" /* Required by objfiles.h.  */

#include "symfile.h" /* Required by objfiles.h.  */

#include "objfiles.h" /* For have_full_symbols and have_partial_symbols */

#include "block.h"

#define parse_type builtin_type (parse_gdbarch)

/* Remap normal yacc parser interface names (yyparse, yylex, yyerror, etc),

   as well as gratuitiously global symbol names, so we can have multiple

   yacc generated parsers in gdb.  Note that these are only the variables

   produced by yacc.  If other parser generators (bison, byacc, etc) produce

   additional global names that conflict at link time, then those parser

   generators need to be fixed instead of adding those names to this list. */

#define yymaxdepth pascal_maxdepth

#define yyparse pascal_parse

#define yylex   pascal_lex

#define yyerror pascal_error

#define yylval  pascal_lval

#define yychar  pascal_char

#define yydebug pascal_debug

#define yypact  pascal_pact

#define yyr1    pascal_r1

#define yyr2    pascal_r2

#define yydef   pascal_def

#define yychk   pascal_chk

#define yypgo   pascal_pgo

#define yyact   pascal_act

#define yyexca  pascal_exca

#define yyerrflag pascal_errflag

#define yynerrs pascal_nerrs

#define yyps    pascal_ps

#define yypv    pascal_pv

#define yys     pascal_s

#define yy_yys  pascal_yys

#define yystate pascal_state

#define yytmp   pascal_tmp

#define yyv     pascal_v

#define yy_yyv  pascal_yyv

#define yyval   pascal_val

#define yylloc  pascal_lloc

#define yyreds  pascal_reds             /* With YYDEBUG defined */

#define yytoks  pascal_toks             /* With YYDEBUG defined */

#define yyname  pascal_name             /* With YYDEBUG defined */

#define yyrule  pascal_rule             /* With YYDEBUG defined */

#define yylhs   pascal_yylhs

#define yylen   pascal_yylen

#define yydefred pascal_yydefred

#define yydgoto pascal_yydgoto

#define yysindex pascal_yysindex

#define yyrindex pascal_yyrindex

#define yygindex pascal_yygindex

#define yytable  pascal_yytable

#define yycheck  pascal_yycheck

#ifndef YYDEBUG

#define YYDEBUG 1               /* Default to yydebug support */

#endif

#define YYFPRINTF parser_fprintf

int yyparse (void);

static int yylex (void);

void

yyerror (char *);

static char * uptok (char *, int);

%}

/* Although the yacc "value" of an expression is not used,

   since the result is stored in the structure being created,

   other node types do have values.  */

%union

  {

    LONGEST lval;

    struct {

      LONGEST val;

      struct type *type;

    } typed_val_int;

    struct {

      DOUBLEST dval;

      struct type *type;

    } typed_val_float;

    struct symbol *sym;

    struct type *tval;

    struct stoken sval;

    struct ttype tsym;

    struct symtoken ssym;

    int voidval;

    struct block *bval;

    enum exp_opcode opcode;

    struct internalvar *ivar;

    struct type **tvec;

    int *ivec;

  }

%{

/* YYSTYPE gets defined by %union */

static int

parse_number (char *, int, int, YYSTYPE *);

static struct type *current_type;

static int leftdiv_is_integer;

static void push_current_type (void);

static void pop_current_type (void);

static int search_field;

%}

%type  exp exp1 type_exp start normal_start variable qualified_name

%type  type typebase

/* %type  block */

/* Fancy type parsing.  */

%type  ptype

%token  INT

%token  FLOAT

/* Both NAME and TYPENAME tokens represent symbols in the input,

   and both convey their data as strings.

   But a TYPENAME is a string that happens to be defined as a typedef

   or builtin type name (such as int or char)

   and a NAME is any other symbol.

   Contexts where this distinction is not important can use the

   nonterminal "name", which matches either NAME or TYPENAME.  */

%token  STRING

%token  FIELDNAME

%token  NAME /* BLOCKNAME defined below to give it higher precedence. */

%token  TYPENAME

%type  name

%type  name_not_typename

/* A NAME_OR_INT is a symbol which is not known in the symbol table,

   but which would parse as a valid number in the current input radix.

   E.g. "c" when input_radix==16.  Depending on the parse, it will be

   turned into a name or into a number.  */

%token  NAME_OR_INT

%token STRUCT CLASS SIZEOF COLONCOLON

%token ERROR

/* Special type cases, put in to allow the parser to distinguish different

   legal basetypes.  */

%token  VARIABLE

/* Object pascal */

%token THIS

%token  TRUEKEYWORD FALSEKEYWORD

%left ','

%left ABOVE_COMMA

%right ASSIGN

%left NOT

%left OR

%left XOR

%left ANDAND

%left '=' NOTEQUAL

%left '<' '>' LEQ GEQ

%left LSH RSH DIV MOD

%left '@'

%left '+' '-'

%left '*' '/'

%right UNARY INCREMENT DECREMENT

%right ARROW '.' '[' '('

%left '^'

%token  BLOCKNAME

%type  block

%left COLONCOLON

%%

start   :       { current_type = NULL;

                  search_field = 0;

                  leftdiv_is_integer = 0;

                }

                normal_start {}

        ;

normal_start    :

                exp1

        |       type_exp

        ;

type_exp:       type

                        { write_exp_elt_opcode(OP_TYPE);

                          write_exp_elt_type($1);

                          write_exp_elt_opcode(OP_TYPE);

                          current_type = $1; } ;

/* Expressions, including the comma operator.  */

exp1    :       exp

        |       exp1 ',' exp

                        { write_exp_elt_opcode (BINOP_COMMA); }

        ;

/* Expressions, not including the comma operator.  */

exp     :       exp '^'   %prec UNARY

                        { write_exp_elt_opcode (UNOP_IND);

                          if (current_type)

                            current_type = TYPE_TARGET_TYPE (current_type); }

        ;

exp     :       '@' exp    %prec UNARY

                        { write_exp_elt_opcode (UNOP_ADDR);

                          if (current_type)

                            current_type = TYPE_POINTER_TYPE (current_type); }

        ;

exp     :       '-' exp    %prec UNARY

                        { write_exp_elt_opcode (UNOP_NEG); }

        ;

exp     :       NOT exp    %prec UNARY

                        { write_exp_elt_opcode (UNOP_LOGICAL_NOT); }

        ;

exp     :       INCREMENT '(' exp ')'   %prec UNARY

                        { write_exp_elt_opcode (UNOP_PREINCREMENT); }

        ;

exp     :       DECREMENT  '(' exp ')'   %prec UNARY

                        { write_exp_elt_opcode (UNOP_PREDECREMENT); }

        ;

exp     :       exp '.' { search_field = 1; }

                FIELDNAME

                /* name */

                        { write_exp_elt_opcode (STRUCTOP_STRUCT);

                          write_exp_string ($4);

                          write_exp_elt_opcode (STRUCTOP_STRUCT);

                          search_field = 0;

                          if (current_type)

                            { while (TYPE_CODE (current_type) == TYPE_CODE_PTR)

                                current_type = TYPE_TARGET_TYPE (current_type);

                              current_type = lookup_struct_elt_type (

                                current_type, $4.ptr, 0); };

                         } ;

exp     :       exp '['

                        /* We need to save the current_type value */

                        { char *arrayname;

                          int arrayfieldindex;

                          arrayfieldindex = is_pascal_string_type (

                                current_type, NULL, NULL,

                                NULL, NULL, &arrayname);

                          if (arrayfieldindex)

                            {

                              struct stoken stringsval;

                              stringsval.ptr = alloca (strlen (arrayname) + 1);

                              stringsval.length = strlen (arrayname);

                              strcpy (stringsval.ptr, arrayname);

                              current_type = TYPE_FIELD_TYPE (current_type,

                                arrayfieldindex - 1);

                              write_exp_elt_opcode (STRUCTOP_STRUCT);

                              write_exp_string (stringsval);

                              write_exp_elt_opcode (STRUCTOP_STRUCT);

                            }

                          push_current_type ();  }

                exp1 ']'

                        { pop_current_type ();

                          write_exp_elt_opcode (BINOP_SUBSCRIPT);

                          if (current_type)

                            current_type = TYPE_TARGET_TYPE (current_type); }

        ;

exp     :       exp '('

                        /* This is to save the value of arglist_len

                           being accumulated by an outer function call.  */

                        { push_current_type ();

                          start_arglist (); }

                arglist ')'     %prec ARROW

                        { write_exp_elt_opcode (OP_FUNCALL);

                          write_exp_elt_longcst ((LONGEST) end_arglist ());

                          write_exp_elt_opcode (OP_FUNCALL);

                          pop_current_type ();

                          if (current_type)

                            current_type = TYPE_TARGET_TYPE (current_type);

                        }

        ;

arglist :

         | exp

                        { arglist_len = 1; }

         | arglist ',' exp   %prec ABOVE_COMMA

                        { arglist_len++; }

        ;

exp     :       type '(' exp ')' %prec UNARY

                        { if (current_type)

                            {

                              /* Allow automatic dereference of classes.  */

                              if ((TYPE_CODE (current_type) == TYPE_CODE_PTR)

                                  && (TYPE_CODE (TYPE_TARGET_TYPE (current_type)) == TYPE_CODE_CLASS)

                                  && (TYPE_CODE ($1) == TYPE_CODE_CLASS))

                                write_exp_elt_opcode (UNOP_IND);

                            }

                          write_exp_elt_opcode (UNOP_CAST);

                          write_exp_elt_type ($1);

                          write_exp_elt_opcode (UNOP_CAST);

                          current_type = $1; }

        ;

exp     :       '(' exp1 ')'

                        { }

        ;

/* Binary operators in order of decreasing precedence.  */

exp     :       exp '*' exp

                        { write_exp_elt_opcode (BINOP_MUL); }

        ;

exp     :       exp '/' {

                          if (current_type && is_integral_type (current_type))

                            leftdiv_is_integer = 1;

                        }

                exp

                        {

                          if (leftdiv_is_integer && current_type

                              && is_integral_type (current_type))

                            {

                              write_exp_elt_opcode (UNOP_CAST);

                              write_exp_elt_type (parse_type->builtin_long_double);

                              current_type = parse_type->builtin_long_double;

                              write_exp_elt_opcode (UNOP_CAST);

                              leftdiv_is_integer = 0;

                            }

                          write_exp_elt_opcode (BINOP_DIV);

                        }

        ;

exp     :       exp DIV exp

                        { write_exp_elt_opcode (BINOP_INTDIV); }

        ;

exp     :       exp MOD exp

                        { write_exp_elt_opcode (BINOP_REM); }

        ;

exp     :       exp '+' exp

                        { write_exp_elt_opcode (BINOP_ADD); }

        ;

exp     :       exp '-' exp

                        { write_exp_elt_opcode (BINOP_SUB); }

        ;

exp     :       exp LSH exp

                        { write_exp_elt_opcode (BINOP_LSH); }

        ;

exp     :       exp RSH exp

                        { write_exp_elt_opcode (BINOP_RSH); }

        ;

exp     :       exp '=' exp

                        { write_exp_elt_opcode (BINOP_EQUAL);

                          current_type = parse_type->builtin_bool;

                        }

        ;

exp     :       exp NOTEQUAL exp

                        { write_exp_elt_opcode (BINOP_NOTEQUAL);

                          current_type = parse_type->builtin_bool;

                        }

        ;

exp     :       exp LEQ exp

                        { write_exp_elt_opcode (BINOP_LEQ);

                          current_type = parse_type->builtin_bool;

                        }

        ;

exp     :       exp GEQ exp

                        { write_exp_elt_opcode (BINOP_GEQ);

                          current_type = parse_type->builtin_bool;

                        }

        ;

exp     :       exp '<' exp

                        { write_exp_elt_opcode (BINOP_LESS);

                          current_type = parse_type->builtin_bool;

                        }

        ;

exp     :       exp '>' exp

                        { write_exp_elt_opcode (BINOP_GTR);

                          current_type = parse_type->builtin_bool;

                        }

        ;

exp     :       exp ANDAND exp

                        { write_exp_elt_opcode (BINOP_BITWISE_AND); }

        ;

exp     :       exp XOR exp

                        { write_exp_elt_opcode (BINOP_BITWISE_XOR); }

        ;

exp     :       exp OR exp

                        { write_exp_elt_opcode (BINOP_BITWISE_IOR); }

        ;

exp     :       exp ASSIGN exp

                        { write_exp_elt_opcode (BINOP_ASSIGN); }

        ;

exp     :       TRUEKEYWORD

                        { write_exp_elt_opcode (OP_BOOL);

                          write_exp_elt_longcst ((LONGEST) $1);

                          current_type = parse_type->builtin_bool;

                          write_exp_elt_opcode (OP_BOOL); }

        ;

exp     :       FALSEKEYWORD

                        { write_exp_elt_opcode (OP_BOOL);

                          write_exp_elt_longcst ((LONGEST) $1);

                          current_type = parse_type->builtin_bool;

                          write_exp_elt_opcode (OP_BOOL); }

        ;

exp     :       INT

                        { write_exp_elt_opcode (OP_LONG);

                          write_exp_elt_type ($1.type);

                          current_type = $1.type;

                          write_exp_elt_longcst ((LONGEST)($1.val));

                          write_exp_elt_opcode (OP_LONG); }

        ;

exp     :       NAME_OR_INT

                        { YYSTYPE val;

                          parse_number ($1.stoken.ptr, $1.stoken.length, 0, &val);

                          write_exp_elt_opcode (OP_LONG);

                          write_exp_elt_type (val.typed_val_int.type);

                          current_type = val.typed_val_int.type;

                          write_exp_elt_longcst ((LONGEST)val.typed_val_int.val);

                          write_exp_elt_opcode (OP_LONG);

                        }

        ;

exp     :       FLOAT

                        { write_exp_elt_opcode (OP_DOUBLE);

                          write_exp_elt_type ($1.type);

                          current_type = $1.type;

                          write_exp_elt_dblcst ($1.dval);

                          write_exp_elt_opcode (OP_DOUBLE); }

        ;

exp     :       variable

        ;

exp     :       VARIABLE

                        /* Already written by write_dollar_variable. */

        ;

exp     :       SIZEOF '(' type ')'     %prec UNARY

                        { write_exp_elt_opcode (OP_LONG);

                          write_exp_elt_type (parse_type->builtin_int);

                          CHECK_TYPEDEF ($3);

                          write_exp_elt_longcst ((LONGEST) TYPE_LENGTH ($3));

                          write_exp_elt_opcode (OP_LONG); }

        ;

exp     :       STRING

                        { /* C strings are converted into array constants with

                             an explicit null byte added at the end.  Thus

                             the array upper bound is the string length.

                             There is no such thing in C as a completely empty

                             string. */

                          char *sp = $1.ptr; int count = $1.length;

                          while (count-- > 0)

                            {

                              write_exp_elt_opcode (OP_LONG);

                              write_exp_elt_type (parse_type->builtin_char);

                              write_exp_elt_longcst ((LONGEST)(*sp++));

                              write_exp_elt_opcode (OP_LONG);

                            }

                          write_exp_elt_opcode (OP_LONG);

                          write_exp_elt_type (parse_type->builtin_char);

                          write_exp_elt_longcst ((LONGEST)'\0');

                          write_exp_elt_opcode (OP_LONG);

                          write_exp_elt_opcode (OP_ARRAY);

                          write_exp_elt_longcst ((LONGEST) 0);

                          write_exp_elt_longcst ((LONGEST) ($1.length));

                          write_exp_elt_opcode (OP_ARRAY); }

        ;

/* Object pascal  */

exp     :       THIS

                        {

                          struct value * this_val;

                          struct type * this_type;

                          write_exp_elt_opcode (OP_THIS);

                          write_exp_elt_opcode (OP_THIS);

                          /* we need type of this */

                          this_val = value_of_this (0);

                          if (this_val)

                            this_type = value_type (this_val);

                          else

                            this_type = NULL;

                          if (this_type)

                            {

                              if (TYPE_CODE (this_type) == TYPE_CODE_PTR)

                                {

                                  this_type = TYPE_TARGET_TYPE (this_type);

                                  write_exp_elt_opcode (UNOP_IND);

                                }

                            }

                          current_type = this_type;

                        }

        ;

/* end of object pascal.  */

block   :       BLOCKNAME

                        {

                          if ($1.sym != 0)

                              $$ = SYMBOL_BLOCK_VALUE ($1.sym);

                          else

                            {

                              struct symtab *tem =

                                  lookup_symtab (copy_name ($1.stoken));

                              if (tem)

                                $$ = BLOCKVECTOR_BLOCK (BLOCKVECTOR (tem), STATIC_BLOCK);

                              else

                                error ("No file or function \"%s\".",

                                       copy_name ($1.stoken));

                            }

                        }

        ;

block   :       block COLONCOLON name

                        { struct symbol *tem

                            = lookup_symbol (copy_name ($3), $1,

                                             VAR_DOMAIN, (int *) NULL);

                          if (!tem || SYMBOL_CLASS (tem) != LOC_BLOCK)

                            error ("No function \"%s\" in specified context.",

                                   copy_name ($3));

                          $$ = SYMBOL_BLOCK_VALUE (tem); }

        ;

variable:       block COLONCOLON name

                        { struct symbol *sym;

                          sym = lookup_symbol (copy_name ($3), $1,

                                               VAR_DOMAIN, (int *) NULL);

                          if (sym == 0)

                            error ("No symbol \"%s\" in specified context.",

                                   copy_name ($3));

                          write_exp_elt_opcode (OP_VAR_VALUE);

                          /* block_found is set by lookup_symbol.  */

                          write_exp_elt_block (block_found);

                          write_exp_elt_sym (sym);

                          write_exp_elt_opcode (OP_VAR_VALUE); }

        ;

qualified_name: typebase COLONCOLON name

                        {

                          struct type *type = $1;

                          if (TYPE_CODE (type) != TYPE_CODE_STRUCT

                              && TYPE_CODE (type) != TYPE_CODE_UNION)

                            error ("`%s' is not defined as an aggregate type.",

                                   TYPE_NAME (type));

                          write_exp_elt_opcode (OP_SCOPE);

                          write_exp_elt_type (type);

                          write_exp_string ($3);

                          write_exp_elt_opcode (OP_SCOPE);

                        }

        ;

variable:       qualified_name

        |       COLONCOLON name

                        {

                          char *name = copy_name ($2);

                          struct symbol *sym;

                          struct minimal_symbol *msymbol;

                          sym =

                            lookup_symbol (name, (const struct block *) NULL,

                                           VAR_DOMAIN, (int *) NULL);

                          if (sym)

                            {

                              write_exp_elt_opcode (OP_VAR_VALUE);

                              write_exp_elt_block (NULL);

                              write_exp_elt_sym (sym);

                              write_exp_elt_opcode (OP_VAR_VALUE);

                              break;

                            }

                          msymbol = lookup_minimal_symbol (name, NULL, NULL);

                          if (msymbol != NULL)

                            write_exp_msymbol (msymbol);

                          else if (!have_full_symbols () && !have_partial_symbols ())

                            error ("No symbol table is loaded.  Use the \"file\" command.");

                          else

                            error ("No symbol \"%s\" in current context.", name);

                        }

        ;

variable:       name_not_typename

                        { struct symbol *sym = $1.sym;

                          if (sym)

                            {

                              if (symbol_read_needs_frame (sym))

                                {

                                  if (innermost_block == 0

                                      || contained_in (block_found,

                                                       innermost_block))

                                    innermost_block = block_found;

                                }

                              write_exp_elt_opcode (OP_VAR_VALUE);

                              /* We want to use the selected frame, not

                                 another more inner frame which happens to

                                 be in the same block.  */

                              write_exp_elt_block (NULL);

                              write_exp_elt_sym (sym);

                              write_exp_elt_opcode (OP_VAR_VALUE);

                              current_type = sym->type; }

                          else if ($1.is_a_field_of_this)

                            {

                              struct value * this_val;

                              struct type * this_type;

                              /* Object pascal: it hangs off of `this'.  Must

                                 not inadvertently convert from a method call

                                 to data ref.  */

                              if (innermost_block == 0

                                  || contained_in (block_found,

                                                   innermost_block))

                                innermost_block = block_found;

                              write_exp_elt_opcode (OP_THIS);

                              write_exp_elt_opcode (OP_THIS);

                              write_exp_elt_opcode (STRUCTOP_PTR);

                              write_exp_string ($1.stoken);

                              write_exp_elt_opcode (STRUCTOP_PTR);

                              /* we need type of this */

                              this_val = value_of_this (0);

                              if (this_val)

                                this_type = value_type (this_val);

                              else

                                this_type = NULL;

                              if (this_type)

                                current_type = lookup_struct_elt_type (

                                  this_type,

                                  copy_name ($1.stoken), 0);

                              else

                                current_type = NULL;

                            }

                          else

                            {

                              struct minimal_symbol *msymbol;

                              char *arg = copy_name ($1.stoken);

                              msymbol =

                                lookup_minimal_symbol (arg, NULL, NULL);

                              if (msymbol != NULL)

                                write_exp_msymbol (msymbol);

                              else if (!have_full_symbols () && !have_partial_symbols ())

                                error ("No symbol table is loaded.  Use the \"file\" command.");

                              else

                                error ("No symbol \"%s\" in current context.",

                                       copy_name ($1.stoken));

                            }

                        }

        ;

ptype   :       typebase

        ;

/* We used to try to recognize more pointer to member types here, but

   that didn't work (shift/reduce conflicts meant that these rules never

   got executed).  The problem is that

     int (foo::bar::baz::bizzle)

   is a function type but

     int (foo::bar::baz::bizzle::*)

   is a pointer to member type.  Stroustrup loses again!  */

type    :       ptype

        ;

typebase  /* Implements (approximately): (type-qualifier)* type-specifier */

        :       '^' typebase

                        { $$ = lookup_pointer_type ($2); }

        |       TYPENAME

                        { $$ = $1.type; }

        |       STRUCT name

                        { $$ = lookup_struct (copy_name ($2),

                                              expression_context_block); }

        |       CLASS name

                        { $$ = lookup_struct (copy_name ($2),

                                              expression_context_block); }

        /* "const" and "volatile" are curently ignored.  A type qualifier

           after the type is handled in the ptype rule.  I think these could

           be too.  */

        ;

name    :       NAME { $$ = $1.stoken; }

        |       BLOCKNAME { $$ = $1.stoken; }

        |       TYPENAME { $$ = $1.stoken; }

        |       NAME_OR_INT  { $$ = $1.stoken; }

        ;

name_not_typename :     NAME

        |       BLOCKNAME

/* These would be useful if name_not_typename was useful, but it is just

   a fake for "variable", so these cause reduce/reduce conflicts because

   the parser can't tell whether NAME_OR_INT is a name_not_typename (=variable,

   =exp) or just an exp.  If name_not_typename was ever used in an lvalue

   context where only a name could occur, this might be useful.

        |       NAME_OR_INT

 */

        ;

%%

/* Take care of parsing a number (anything that starts with a digit).

   Set yylval and return the token type; update lexptr.

   LEN is the number of characters in it.  */

/*** Needs some error checking for the float case ***/

static int

parse_number (p, len, parsed_float, putithere)

     char *p;

     int len;

     int parsed_float;

     YYSTYPE *putithere;

{

  /* FIXME: Shouldn't these be unsigned?  We don't deal with negative values

     here, and we do kind of silly things like cast to unsigned.  */

  LONGEST n = 0;

  LONGEST prevn = 0;

  ULONGEST un;

  int i = 0;

  int c;

  int base = input_radix;

  int unsigned_p = 0;

  /* Number of "L" suffixes encountered.  */

  int long_p = 0;

  /* We have found a "L" or "U" suffix.  */

  int found_suffix = 0;

  ULONGEST high_bit;

  struct type *signed_type;

  struct type *unsigned_type;

  if (parsed_float)

    {

      /* It's a float since it contains a point or an exponent.  */

      char c;

      int num = 0;      /* number of tokens scanned by scanf */

      char saved_char = p[len];

      p[len] = 0;       /* null-terminate the token */

      num = sscanf (p, "%" DOUBLEST_SCAN_FORMAT "%c",

                    &putithere->typed_val_float.dval, &c);

      p[len] = saved_char;      /* restore the input stream */

      if (num != 1)             /* check scanf found ONLY a float ... */

        return ERROR;

      /* See if it has `f' or `l' suffix (float or long double).  */

      c = tolower (p[len - 1]);

      if (c == 'f')

        putithere->typed_val_float.type = parse_type->builtin_float;

      else if (c == 'l')

        putithere->typed_val_float.type = parse_type->builtin_long_double;

      else if (isdigit (c) || c == '.')

        putithere->typed_val_float.type = parse_type->builtin_double;

      else

        return ERROR;

      return FLOAT;

    }

  /* Handle base-switching prefixes 0x, 0t, 0d, 0 */

  if (p[0] == '0')

    switch (p[1])

      {

      case 'x':

      case 'X':

        if (len >= 3)

          {

            p += 2;

            base = 16;

            len -= 2;

          }

        break;

      case 't':

      case 'T':

      case 'd':

      case 'D':

        if (len >= 3)

          {

            p += 2;

            base = 10;

            len -= 2;

          }

        break;

      default:

        base = 8;

        break;

      }

  while (len-- > 0)

    {

      c = *p++;

      if (c >= 'A' && c <= 'Z')

        c += 'a' - 'A';

      if (c != 'l' && c != 'u')

        n *= base;

      if (c >= '0' && c <= '9')

        {

          if (found_suffix)

            return ERROR;

          n += i = c - '0';

        }

      else

        {

          if (base > 10 && c >= 'a' && c <= 'f')

            {

              if (found_suffix)

                return ERROR;

              n += i = c - 'a' + 10;

            }

          else if (c == 'l')

            {

              ++long_p;

              found_suffix = 1;

            }

          else if (c == 'u')

            {

              unsigned_p = 1;

              found_suffix = 1;

            }

          else

            return ERROR;       /* Char not a digit */

        }

      if (i >= base)

        return ERROR;           /* Invalid digit in this base */

      /* Portably test for overflow (only works for nonzero values, so make

         a second check for zero).  FIXME: Can't we just make n and prevn

         unsigned and avoid this?  */

      if (c != 'l' && c != 'u' && (prevn >= n) && n != 0)

        unsigned_p = 1;         /* Try something unsigned */

      /* Portably test for unsigned overflow.

         FIXME: This check is wrong; for example it doesn't find overflow

         on 0x123456789 when LONGEST is 32 bits.  */

      if (c != 'l' && c != 'u' && n != 0)

        {

          if ((unsigned_p && (ULONGEST) prevn >= (ULONGEST) n))

            error ("Numeric constant too large.");

        }

      prevn = n;

    }

  /* An integer constant is an int, a long, or a long long.  An L

     suffix forces it to be long; an LL suffix forces it to be long

     long.  If not forced to a larger size, it gets the first type of

     the above that it fits in.  To figure out whether it fits, we

     shift it right and see whether anything remains.  Note that we

     can't shift sizeof (LONGEST) * HOST_CHAR_BIT bits or more in one