bld.c

gcc-2.95.3 Linux下最常用的C编译器

/* bld.c -- Implementation File (module.c template V1.0)
   Copyright (C) 1995, 1996 Free Software Foundation, Inc.
   Contributed by James Craig Burley.

This file is part of GNU Fortran.

GNU Fortran 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 2, or (at your option)
any later version.

GNU Fortran 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 GNU Fortran; see the file COPYING.  If not, write to
the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
02111-1307, USA.

   Related Modules:
      None

   Description:
      The primary "output" of the FFE includes ffebld objects, which
      connect expressions, operators, and operands together, along with
      connecting lists of expressions together for argument or dimension
      lists.

   Modifications:
      30-Aug-92	 JCB  1.1
	 Change names of some things for consistency.
*/

/* Include files. */

#include "proj.h"
#include "bld.h"
#include "bit.h"
#include "info.h"
#include "lex.h"
#include "malloc.h"
#include "target.h"
#include "where.h"

/* Externals defined here.  */

ffebldArity ffebld_arity_op_[]
=
{
#define FFEBLD_OP(KWD,NAME,ARITY) ARITY,
#include "bld-op.def"
#undef FFEBLD_OP
};
struct _ffebld_pool_stack_ ffebld_pool_stack_;

/* Simple definitions and enumerations. */


/* Internal typedefs. */


/* Private include files. */


/* Internal structure definitions. */


/* Static objects accessed by functions in this module.	 */

#if FFEBLD_BLANK_
static struct _ffebld_ ffebld_blank_
=
{
  0,
  {FFEINFO_basictypeNONE, FFEINFO_kindtypeNONE, 0, FFEINFO_kindNONE,
   FFEINFO_whereNONE, FFETARGET_charactersizeNONE},
  {NULL, NULL}
};
#endif
#if FFETARGET_okCHARACTER1
static ffebldConstant ffebld_constant_character1_;
#endif
#if FFETARGET_okCHARACTER2
static ffebldConstant ffebld_constant_character2_;
#endif
#if FFETARGET_okCHARACTER3
static ffebldConstant ffebld_constant_character3_;
#endif
#if FFETARGET_okCHARACTER4
static ffebldConstant ffebld_constant_character4_;
#endif
#if FFETARGET_okCHARACTER5
static ffebldConstant ffebld_constant_character5_;
#endif
#if FFETARGET_okCHARACTER6
static ffebldConstant ffebld_constant_character6_;
#endif
#if FFETARGET_okCHARACTER7
static ffebldConstant ffebld_constant_character7_;
#endif
#if FFETARGET_okCHARACTER8
static ffebldConstant ffebld_constant_character8_;
#endif
#if FFETARGET_okCOMPLEX1
static ffebldConstant ffebld_constant_complex1_;
#endif
#if FFETARGET_okCOMPLEX2
static ffebldConstant ffebld_constant_complex2_;
#endif
#if FFETARGET_okCOMPLEX3
static ffebldConstant ffebld_constant_complex3_;
#endif
#if FFETARGET_okCOMPLEX4
static ffebldConstant ffebld_constant_complex4_;
#endif
#if FFETARGET_okCOMPLEX5
static ffebldConstant ffebld_constant_complex5_;
#endif
#if FFETARGET_okCOMPLEX6
static ffebldConstant ffebld_constant_complex6_;
#endif
#if FFETARGET_okCOMPLEX7
static ffebldConstant ffebld_constant_complex7_;
#endif
#if FFETARGET_okCOMPLEX8
static ffebldConstant ffebld_constant_complex8_;
#endif
#if FFETARGET_okINTEGER1
static ffebldConstant ffebld_constant_integer1_;
#endif
#if FFETARGET_okINTEGER2
static ffebldConstant ffebld_constant_integer2_;
#endif
#if FFETARGET_okINTEGER3
static ffebldConstant ffebld_constant_integer3_;
#endif
#if FFETARGET_okINTEGER4
static ffebldConstant ffebld_constant_integer4_;
#endif
#if FFETARGET_okINTEGER5
static ffebldConstant ffebld_constant_integer5_;
#endif
#if FFETARGET_okINTEGER6
static ffebldConstant ffebld_constant_integer6_;
#endif
#if FFETARGET_okINTEGER7
static ffebldConstant ffebld_constant_integer7_;
#endif
#if FFETARGET_okINTEGER8
static ffebldConstant ffebld_constant_integer8_;
#endif
#if FFETARGET_okLOGICAL1
static ffebldConstant ffebld_constant_logical1_;
#endif
#if FFETARGET_okLOGICAL2
static ffebldConstant ffebld_constant_logical2_;
#endif
#if FFETARGET_okLOGICAL3
static ffebldConstant ffebld_constant_logical3_;
#endif
#if FFETARGET_okLOGICAL4
static ffebldConstant ffebld_constant_logical4_;
#endif
#if FFETARGET_okLOGICAL5
static ffebldConstant ffebld_constant_logical5_;
#endif
#if FFETARGET_okLOGICAL6
static ffebldConstant ffebld_constant_logical6_;
#endif
#if FFETARGET_okLOGICAL7
static ffebldConstant ffebld_constant_logical7_;
#endif
#if FFETARGET_okLOGICAL8
static ffebldConstant ffebld_constant_logical8_;
#endif
#if FFETARGET_okREAL1
static ffebldConstant ffebld_constant_real1_;
#endif
#if FFETARGET_okREAL2
static ffebldConstant ffebld_constant_real2_;
#endif
#if FFETARGET_okREAL3
static ffebldConstant ffebld_constant_real3_;
#endif
#if FFETARGET_okREAL4
static ffebldConstant ffebld_constant_real4_;
#endif
#if FFETARGET_okREAL5
static ffebldConstant ffebld_constant_real5_;
#endif
#if FFETARGET_okREAL6
static ffebldConstant ffebld_constant_real6_;
#endif
#if FFETARGET_okREAL7
static ffebldConstant ffebld_constant_real7_;
#endif
#if FFETARGET_okREAL8
static ffebldConstant ffebld_constant_real8_;
#endif
static ffebldConstant ffebld_constant_hollerith_;
static ffebldConstant ffebld_constant_typeless_[FFEBLD_constTYPELESS_LAST
					  - FFEBLD_constTYPELESS_FIRST + 1];

static const char *ffebld_op_string_[]
=
{
#define FFEBLD_OP(KWD,NAME,ARITY) NAME,
#include "bld-op.def"
#undef FFEBLD_OP
};

/* Static functions (internal). */


/* Internal macros. */

#define integerdefault_ CATX(integer,FFETARGET_ktINTEGERDEFAULT)
#define logicaldefault_ CATX(logical,FFETARGET_ktLOGICALDEFAULT)
#define realdefault_ CATX(real,FFETARGET_ktREALDEFAULT)
#define realdouble_ CATX(real,FFETARGET_ktREALDOUBLE)
#define realquad_ CATX(real,FFETARGET_ktREALQUAD)

/* ffebld_constant_cmp -- Compare two constants a la strcmp

   ffebldConstant c1, c2;
   if (ffebld_constant_cmp(c1,c2) == 0)
       // they're equal, else they're not.

   Returns -1 if c1 < c2, 0 if c1 == c2, +1 if c1 == c2.  */

int
ffebld_constant_cmp (ffebldConstant c1, ffebldConstant c2)
{
  if (c1 == c2)
    return 0;

  assert (ffebld_constant_type (c1) == ffebld_constant_type (c2));

  switch (ffebld_constant_type (c1))
    {
#if FFETARGET_okINTEGER1
    case FFEBLD_constINTEGER1:
      return ffetarget_cmp_integer1 (ffebld_constant_integer1 (c1),
				     ffebld_constant_integer1 (c2));
#endif

#if FFETARGET_okINTEGER2
    case FFEBLD_constINTEGER2:
      return ffetarget_cmp_integer2 (ffebld_constant_integer2 (c1),
				     ffebld_constant_integer2 (c2));
#endif

#if FFETARGET_okINTEGER3
    case FFEBLD_constINTEGER3:
      return ffetarget_cmp_integer3 (ffebld_constant_integer3 (c1),
				     ffebld_constant_integer3 (c2));
#endif

#if FFETARGET_okINTEGER4
    case FFEBLD_constINTEGER4:
      return ffetarget_cmp_integer4 (ffebld_constant_integer4 (c1),
				     ffebld_constant_integer4 (c2));
#endif

#if FFETARGET_okINTEGER5
    case FFEBLD_constINTEGER5:
      return ffetarget_cmp_integer5 (ffebld_constant_integer5 (c1),
				     ffebld_constant_integer5 (c2));
#endif

#if FFETARGET_okINTEGER6
    case FFEBLD_constINTEGER6:
      return ffetarget_cmp_integer6 (ffebld_constant_integer6 (c1),
				     ffebld_constant_integer6 (c2));
#endif

#if FFETARGET_okINTEGER7
    case FFEBLD_constINTEGER7:
      return ffetarget_cmp_integer7 (ffebld_constant_integer7 (c1),
				     ffebld_constant_integer7 (c2));
#endif

#if FFETARGET_okINTEGER8
    case FFEBLD_constINTEGER8:
      return ffetarget_cmp_integer8 (ffebld_constant_integer8 (c1),
				     ffebld_constant_integer8 (c2));
#endif

#if FFETARGET_okLOGICAL1
    case FFEBLD_constLOGICAL1:
      return ffetarget_cmp_logical1 (ffebld_constant_logical1 (c1),
				     ffebld_constant_logical1 (c2));
#endif

#if FFETARGET_okLOGICAL2
    case FFEBLD_constLOGICAL2:
      return ffetarget_cmp_logical2 (ffebld_constant_logical2 (c1),
				     ffebld_constant_logical2 (c2));
#endif

#if FFETARGET_okLOGICAL3
    case FFEBLD_constLOGICAL3:
      return ffetarget_cmp_logical3 (ffebld_constant_logical3 (c1),
				     ffebld_constant_logical3 (c2));
#endif

#if FFETARGET_okLOGICAL4
    case FFEBLD_constLOGICAL4:
      return ffetarget_cmp_logical4 (ffebld_constant_logical4 (c1),
				     ffebld_constant_logical4 (c2));
#endif

#if FFETARGET_okLOGICAL5
    case FFEBLD_constLOGICAL5:
      return ffetarget_cmp_logical5 (ffebld_constant_logical5 (c1),
				     ffebld_constant_logical5 (c2));
#endif

#if FFETARGET_okLOGICAL6
    case FFEBLD_constLOGICAL6:
      return ffetarget_cmp_logical6 (ffebld_constant_logical6 (c1),
				     ffebld_constant_logical6 (c2));
#endif

#if FFETARGET_okLOGICAL7
    case FFEBLD_constLOGICAL7:
      return ffetarget_cmp_logical7 (ffebld_constant_logical7 (c1),
				     ffebld_constant_logical7 (c2));
#endif

#if FFETARGET_okLOGICAL8
    case FFEBLD_constLOGICAL8:
      return ffetarget_cmp_logical8 (ffebld_constant_logical8 (c1),
				     ffebld_constant_logical8 (c2));
#endif

#if FFETARGET_okREAL1
    case FFEBLD_constREAL1:
      return ffetarget_cmp_real1 (ffebld_constant_real1 (c1),
				  ffebld_constant_real1 (c2));
#endif

#if FFETARGET_okREAL2
    case FFEBLD_constREAL2:
      return ffetarget_cmp_real2 (ffebld_constant_real2 (c1),
				  ffebld_constant_real2 (c2));
#endif

#if FFETARGET_okREAL3
    case FFEBLD_constREAL3:
      return ffetarget_cmp_real3 (ffebld_constant_real3 (c1),
				  ffebld_constant_real3 (c2));
#endif

#if FFETARGET_okREAL4
    case FFEBLD_constREAL4:
      return ffetarget_cmp_real4 (ffebld_constant_real4 (c1),
				  ffebld_constant_real4 (c2));
#endif

#if FFETARGET_okREAL5
    case FFEBLD_constREAL5:
      return ffetarget_cmp_real5 (ffebld_constant_real5 (c1),
				  ffebld_constant_real5 (c2));
#endif

#if FFETARGET_okREAL6
    case FFEBLD_constREAL6:
      return ffetarget_cmp_real6 (ffebld_constant_real6 (c1),
				  ffebld_constant_real6 (c2));
#endif

#if FFETARGET_okREAL7
    case FFEBLD_constREAL7:
      return ffetarget_cmp_real7 (ffebld_constant_real7 (c1),
				  ffebld_constant_real7 (c2));
#endif

#if FFETARGET_okREAL8
    case FFEBLD_constREAL8:
      return ffetarget_cmp_real8 (ffebld_constant_real8 (c1),
				  ffebld_constant_real8 (c2));
#endif

#if FFETARGET_okCHARACTER1
    case FFEBLD_constCHARACTER1:
      return ffetarget_cmp_character1 (ffebld_constant_character1 (c1),
				       ffebld_constant_character1 (c2));
#endif

#if FFETARGET_okCHARACTER2
    case FFEBLD_constCHARACTER2:
      return ffetarget_cmp_character2 (ffebld_constant_character2 (c1),
				       ffebld_constant_character2 (c2));
#endif

#if FFETARGET_okCHARACTER3
    case FFEBLD_constCHARACTER3:
      return ffetarget_cmp_character3 (ffebld_constant_character3 (c1),
				       ffebld_constant_character3 (c2));
#endif

#if FFETARGET_okCHARACTER4
    case FFEBLD_constCHARACTER4:
      return ffetarget_cmp_character4 (ffebld_constant_character4 (c1),
				       ffebld_constant_character4 (c2));
#endif

#if FFETARGET_okCHARACTER5
    case FFEBLD_constCHARACTER5:
      return ffetarget_cmp_character5 (ffebld_constant_character5 (c1),
				       ffebld_constant_character5 (c2));
#endif

#if FFETARGET_okCHARACTER6
    case FFEBLD_constCHARACTER6:
      return ffetarget_cmp_character6 (ffebld_constant_character6 (c1),
				       ffebld_constant_character6 (c2));
#endif

#if FFETARGET_okCHARACTER7
    case FFEBLD_constCHARACTER7:
      return ffetarget_cmp_character7 (ffebld_constant_character7 (c1),
				       ffebld_constant_character7 (c2));
#endif

#if FFETARGET_okCHARACTER8
    case FFEBLD_constCHARACTER8:
      return ffetarget_cmp_character8 (ffebld_constant_character8 (c1),
				       ffebld_constant_character8 (c2));
#endif

    default:
      assert ("bad constant type" == NULL);
      return 0;
    }
}

/* ffebld_constant_dump -- Display summary of constant's contents

   ffebldConstant c;
   ffebld_constant_dump(c);

   Displays the constant in summary form.  */

#if FFECOM_targetCURRENT == FFECOM_targetFFE
void
ffebld_constant_dump (ffebldConstant c)
{
  switch (ffebld_constant_type (c))
    {
#if FFETARGET_okINTEGER1
    case FFEBLD_constINTEGER1:
      ffebld_dump_prefix (dmpout, FFEINFO_basictypeINTEGER,
			  FFEINFO_kindtypeINTEGER1);
      ffebld_constantunion_dump (ffebld_constant_union (c),
			FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER1);
      break;
#endif

#if FFETARGET_okINTEGER2
    case FFEBLD_constINTEGER2:
      ffebld_dump_prefix (dmpout, FFEINFO_basictypeINTEGER,
			  FFEINFO_kindtypeINTEGER2);
      ffebld_constantunion_dump (ffebld_constant_union (c),
			FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER2);
      break;
#endif

#if FFETARGET_okINTEGER3
    case FFEBLD_constINTEGER3:
      ffebld_dump_prefix (dmpout, FFEINFO_basictypeINTEGER,
			  FFEINFO_kindtypeINTEGER3);
      ffebld_constantunion_dump (ffebld_constant_union (c),
			FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER3);
      break;
#endif

#if FFETARGET_okINTEGER4
    case FFEBLD_constINTEGER4:
      ffebld_dump_prefix (dmpout, FFEINFO_basictypeINTEGER,
			  FFEINFO_kindtypeINTEGER4);
      ffebld_constantunion_dump (ffebld_constant_union (c),
			FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER4);
      break;
#endif

#if FFETARGET_okINTEGER5
    case FFEBLD_constINTEGER5:
      ffebld_dump_prefix (dmpout, FFEINFO_basictypeINTEGER,
			  FFEINFO_kindtypeINTEGER5);
      ffebld_constantunion_dump (ffebld_constant_union (c),
			FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER5);
      break;
#endif

#if FFETARGET_okINTEGER6
    case FFEBLD_constINTEGER6:
      ffebld_dump_prefix (dmpout, FFEINFO_basictypeINTEGER,
			  FFEINFO_kindtypeINTEGER6);
      ffebld_constantunion_dump (ffebld_constant_union (c),
			FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER6);
      break;
#endif

#if FFETARGET_okINTEGER7
    case FFEBLD_constINTEGER7:
      ffebld_dump_prefix (dmpout, FFEINFO_basictypeINTEGER,
			  FFEINFO_kindtypeINTEGER7);
      ffebld_constantunion_dump (ffebld_constant_union (c),
			FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER7);
      break;
#endif

#if FFETARGET_okINTEGER8
    case FFEBLD_constINTEGER8:
      ffebld_dump_prefix (dmpout, FFEINFO_basictypeINTEGER,
			  FFEINFO_kindtypeINTEGER8);
      ffebld_constantunion_dump (ffebld_constant_union (c),
			FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER8);
      break;
#endif

#if FFETARGET_okLOGICAL1
    case FFEBLD_constLOGICAL1:
      ffebld_dump_prefix (dmpout, FFEINFO_basictypeLOGICAL,
			  FFEINFO_kindtypeLOGICAL1);
      ffebld_constantunion_dump (ffebld_constant_union (c),
			FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL1);