Aren
/
NetBSD
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
NetBSD/gnu/dist/toolchain/gcc/f/bld.c

5804 lines
128 KiB
C
Raw Normal View History

Import of gcc 2.95.2 into new gnu/dist/toolchain layout.
2000-07-26 04:17:09 +04:00
/* 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);
break;
#endif
#if FFETARGET_okLOGICAL2
case FFEBLD_constLOGICAL2:
ffebld_dump_prefix (dmpout, FFEINFO_basictypeLOGICAL,
FFEINFO_kindtypeLOGICAL2);
ffebld_constantunion_dump (ffebld_constant_union (c),
FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL2);
break;
#endif
#if FFETARGET_okLOGICAL3
case FFEBLD_constLOGICAL3:
ffebld_dump_prefix (dmpout, FFEINFO_basictypeLOGICAL,
FFEINFO_kindtypeLOGICAL3);
ffebld_constantunion_dump (ffebld_constant_union (c),
FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL3);
break;
#endif
#if FFETARGET_okLOGICAL4
case FFEBLD_constLOGICAL4:
ffebld_dump_prefix (dmpout, FFEINFO_basictypeLOGICAL,
FFEINFO_kindtypeLOGICAL4);
ffebld_constantunion_dump (ffebld_constant_union (c),
FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL4);
break;
#endif
#if FFETARGET_okLOGICAL5
case FFEBLD_constLOGICAL5:
ffebld_dump_prefix (dmpout, FFEINFO_basictypeLOGICAL,
FFEINFO_kindtypeLOGICAL5);
ffebld_constantunion_dump (ffebld_constant_union (c),
FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL5);
break;
#endif
#if FFETARGET_okLOGICAL6
case FFEBLD_constLOGICAL6:
ffebld_dump_prefix (dmpout, FFEINFO_basictypeLOGICAL,
FFEINFO_kindtypeLOGICAL6);
ffebld_constantunion_dump (ffebld_constant_union (c),
FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL6);
break;
#endif
#if FFETARGET_okLOGICAL7
case FFEBLD_constLOGICAL7:
ffebld_dump_prefix (dmpout, FFEINFO_basictypeLOGICAL,
FFEINFO_kindtypeLOGICAL7);
ffebld_constantunion_dump (ffebld_constant_union (c),
FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL7);
break;
#endif
#if FFETARGET_okLOGICAL8
case FFEBLD_constLOGICAL8:
ffebld_dump_prefix (dmpout, FFEINFO_basictypeLOGICAL,
FFEINFO_kindtypeLOGICAL8);
ffebld_constantunion_dump (ffebld_constant_union (c),
FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL8);
break;
#endif
#if FFETARGET_okREAL1
case FFEBLD_constREAL1:
ffebld_dump_prefix (dmpout, FFEINFO_basictypeREAL,
FFEINFO_kindtypeREAL1);
ffebld_constantunion_dump (ffebld_constant_union (c),
FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL1);
break;
#endif
#if FFETARGET_okREAL2
case FFEBLD_constREAL2:
ffebld_dump_prefix (dmpout, FFEINFO_basictypeREAL,
FFEINFO_kindtypeREAL2);
ffebld_constantunion_dump (ffebld_constant_union (c),
FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL2);
break;
#endif
#if FFETARGET_okREAL3
case FFEBLD_constREAL3:
ffebld_dump_prefix (dmpout, FFEINFO_basictypeREAL,
FFEINFO_kindtypeREAL3);
ffebld_constantunion_dump (ffebld_constant_union (c),
FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL3);
break;
#endif
#if FFETARGET_okREAL4
case FFEBLD_constREAL4:
ffebld_dump_prefix (dmpout, FFEINFO_basictypeREAL,
FFEINFO_kindtypeREAL4);
ffebld_constantunion_dump (ffebld_constant_union (c),
FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL4);
break;
#endif
#if FFETARGET_okREAL5
case FFEBLD_constREAL5:
ffebld_dump_prefix (dmpout, FFEINFO_basictypeREAL,
FFEINFO_kindtypeREAL5);
ffebld_constantunion_dump (ffebld_constant_union (c),
FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL5);
break;
#endif
#if FFETARGET_okREAL6
case FFEBLD_constREAL6:
ffebld_dump_prefix (dmpout, FFEINFO_basictypeREAL,
FFEINFO_kindtypeREAL6);
ffebld_constantunion_dump (ffebld_constant_union (c),
FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL6);
break;
#endif
#if FFETARGET_okREAL7
case FFEBLD_constREAL7:
ffebld_dump_prefix (dmpout, FFEINFO_basictypeREAL,
FFEINFO_kindtypeREAL7);
ffebld_constantunion_dump (ffebld_constant_union (c),
FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL7);
break;
#endif
#if FFETARGET_okREAL8
case FFEBLD_constREAL8:
ffebld_dump_prefix (dmpout, FFEINFO_basictypeREAL,
FFEINFO_kindtypeREAL8);
ffebld_constantunion_dump (ffebld_constant_union (c),
FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL8);
break;
#endif
#if FFETARGET_okCOMPLEX1
case FFEBLD_constCOMPLEX1:
ffebld_dump_prefix (dmpout, FFEINFO_basictypeCOMPLEX,
FFEINFO_kindtypeREAL1);
ffebld_constantunion_dump (ffebld_constant_union (c),
FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL1);
break;
#endif
#if FFETARGET_okCOMPLEX2
case FFEBLD_constCOMPLEX2:
ffebld_dump_prefix (dmpout, FFEINFO_basictypeCOMPLEX,
FFEINFO_kindtypeREAL2);
ffebld_constantunion_dump (ffebld_constant_union (c),
FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL2);
break;
#endif
#if FFETARGET_okCOMPLEX3
case FFEBLD_constCOMPLEX3:
ffebld_dump_prefix (dmpout, FFEINFO_basictypeCOMPLEX,
FFEINFO_kindtypeREAL3);
ffebld_constantunion_dump (ffebld_constant_union (c),
FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL3);
break;
#endif
#if FFETARGET_okCOMPLEX4
case FFEBLD_constCOMPLEX4:
ffebld_dump_prefix (dmpout, FFEINFO_basictypeCOMPLEX,
FFEINFO_kindtypeREAL4);
ffebld_constantunion_dump (ffebld_constant_union (c),
FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL4);
break;
#endif
#if FFETARGET_okCOMPLEX5
case FFEBLD_constCOMPLEX5:
ffebld_dump_prefix (dmpout, FFEINFO_basictypeCOMPLEX,
FFEINFO_kindtypeREAL5);
ffebld_constantunion_dump (ffebld_constant_union (c),
FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL5);
break;
#endif
#if FFETARGET_okCOMPLEX6
case FFEBLD_constCOMPLEX6:
ffebld_dump_prefix (dmpout, FFEINFO_basictypeCOMPLEX,
FFEINFO_kindtypeREAL6);
ffebld_constantunion_dump (ffebld_constant_union (c),
FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL6);
break;
#endif
#if FFETARGET_okCOMPLEX7
case FFEBLD_constCOMPLEX7:
ffebld_dump_prefix (dmpout, FFEINFO_basictypeCOMPLEX,
FFEINFO_kindtypeREAL7);
ffebld_constantunion_dump (ffebld_constant_union (c),
FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL7);
break;
#endif
#if FFETARGET_okCOMPLEX8
case FFEBLD_constCOMPLEX8:
ffebld_dump_prefix (dmpout, FFEINFO_basictypeCOMPLEX,
FFEINFO_kindtypeREAL8);
ffebld_constantunion_dump (ffebld_constant_union (c),
FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL8);
break;
#endif
#if FFETARGET_okCHARACTER1
case FFEBLD_constCHARACTER1:
ffebld_dump_prefix (dmpout, FFEINFO_basictypeCHARACTER,
FFEINFO_kindtypeCHARACTER1);
ffebld_constantunion_dump (ffebld_constant_union (c),
FFEINFO_basictypeCHARACTER, FFEINFO_kindtypeCHARACTER1);
break;
#endif
#if FFETARGET_okCHARACTER2
case FFEBLD_constCHARACTER2:
ffebld_dump_prefix (dmpout, FFEINFO_basictypeCHARACTER,
FFEINFO_kindtypeCHARACTER2);
ffebld_constantunion_dump (ffebld_constant_union (c),
FFEINFO_basictypeCHARACTER, FFEINFO_kindtypeCHARACTER2);
break;
#endif
#if FFETARGET_okCHARACTER3
case FFEBLD_constCHARACTER3:
ffebld_dump_prefix (dmpout, FFEINFO_basictypeCHARACTER,
FFEINFO_kindtypeCHARACTER3);
ffebld_constantunion_dump (ffebld_constant_union (c),
FFEINFO_basictypeCHARACTER, FFEINFO_kindtypeCHARACTER3);
break;
#endif
#if FFETARGET_okCHARACTER4
case FFEBLD_constCHARACTER4:
ffebld_dump_prefix (dmpout, FFEINFO_basictypeCHARACTER,
FFEINFO_kindtypeCHARACTER4);
ffebld_constantunion_dump (ffebld_constant_union (c),
FFEINFO_basictypeCHARACTER, FFEINFO_kindtypeCHARACTER4);
break;
#endif
#if FFETARGET_okCHARACTER5
case FFEBLD_constCHARACTER5:
ffebld_dump_prefix (dmpout, FFEINFO_basictypeCHARACTER,
FFEINFO_kindtypeCHARACTER5);
ffebld_constantunion_dump (ffebld_constant_union (c),
FFEINFO_basictypeCHARACTER, FFEINFO_kindtypeCHARACTER5);
break;
#endif
#if FFETARGET_okCHARACTER6
case FFEBLD_constCHARACTER6:
ffebld_dump_prefix (dmpout, FFEINFO_basictypeCHARACTER,
FFEINFO_kindtypeCHARACTER6);
ffebld_constantunion_dump (ffebld_constant_union (c),
FFEINFO_basictypeCHARACTER, FFEINFO_kindtypeCHARACTER6);
break;
#endif
#if FFETARGET_okCHARACTER7
case FFEBLD_constCHARACTER7:
ffebld_dump_prefix (dmpout, FFEINFO_basictypeCHARACTER,
FFEINFO_kindtypeCHARACTER7);
ffebld_constantunion_dump (ffebld_constant_union (c),
FFEINFO_basictypeCHARACTER, FFEINFO_kindtypeCHARACTER7);
break;
#endif
#if FFETARGET_okCHARACTER8
case FFEBLD_constCHARACTER8:
ffebld_dump_prefix (dmpout, FFEINFO_basictypeCHARACTER,
FFEINFO_kindtypeCHARACTER8);
ffebld_constantunion_dump (ffebld_constant_union (c),
FFEINFO_basictypeCHARACTER, FFEINFO_kindtypeCHARACTER8);
break;
#endif
case FFEBLD_constHOLLERITH:
fprintf (dmpout, "H%" ffetargetHollerithSize_f "u/",
ffebld_constant_hollerith (c).length);
ffetarget_print_hollerith (dmpout, ffebld_constant_hollerith (c));
break;
case FFEBLD_constBINARY_MIL:
fprintf (dmpout, "BM/");
ffetarget_print_binarymil (dmpout, ffebld_constant_typeless (c));
break;
case FFEBLD_constBINARY_VXT:
fprintf (dmpout, "BV/");
ffetarget_print_binaryvxt (dmpout, ffebld_constant_typeless (c));
break;
case FFEBLD_constOCTAL_MIL:
fprintf (dmpout, "OM/");
ffetarget_print_octalmil (dmpout, ffebld_constant_typeless (c));
break;
case FFEBLD_constOCTAL_VXT:
fprintf (dmpout, "OV/");
ffetarget_print_octalvxt (dmpout, ffebld_constant_typeless (c));
break;
case FFEBLD_constHEX_X_MIL:
fprintf (dmpout, "XM/");
ffetarget_print_hexxmil (dmpout, ffebld_constant_typeless (c));
break;
case FFEBLD_constHEX_X_VXT:
fprintf (dmpout, "XV/");
ffetarget_print_hexxvxt (dmpout, ffebld_constant_typeless (c));
break;
case FFEBLD_constHEX_Z_MIL:
fprintf (dmpout, "ZM/");
ffetarget_print_hexzmil (dmpout, ffebld_constant_typeless (c));
break;
case FFEBLD_constHEX_Z_VXT:
fprintf (dmpout, "ZV/");
ffetarget_print_hexzvxt (dmpout, ffebld_constant_typeless (c));
break;
default:
assert ("bad constant type" == NULL);
fprintf (dmpout, "?/?");
break;
}
}
#endif
/* ffebld_constant_is_magical -- Determine if integer is "magical"
ffebldConstant c;
if (ffebld_constant_is_magical(c))
// it is 2**(n-1), where n is # bits in ffetargetIntegerDefault type
// (this test is important for 2's-complement machines only). */
bool
ffebld_constant_is_magical (ffebldConstant c)
{
switch (ffebld_constant_type (c))
{
case FFEBLD_constINTEGERDEFAULT:
return ffetarget_integerdefault_is_magical (ffebld_constant_integer1 (c));
default:
return FALSE;
}
}
/* Determine if constant is zero. Used to ensure step count
for DO loops isn't zero, also to determine if values will
be binary zeros, so not entirely portable at this point. */
bool
ffebld_constant_is_zero (ffebldConstant c)
{
switch (ffebld_constant_type (c))
{
#if FFETARGET_okINTEGER1
case FFEBLD_constINTEGER1:
return ffebld_constant_integer1 (c) == 0;
#endif
#if FFETARGET_okINTEGER2
case FFEBLD_constINTEGER2:
return ffebld_constant_integer2 (c) == 0;
#endif
#if FFETARGET_okINTEGER3
case FFEBLD_constINTEGER3:
return ffebld_constant_integer3 (c) == 0;
#endif
#if FFETARGET_okINTEGER4
case FFEBLD_constINTEGER4:
return ffebld_constant_integer4 (c) == 0;
#endif
#if FFETARGET_okINTEGER5
case FFEBLD_constINTEGER5:
return ffebld_constant_integer5 (c) == 0;
#endif
#if FFETARGET_okINTEGER6
case FFEBLD_constINTEGER6:
return ffebld_constant_integer6 (c) == 0;
#endif
#if FFETARGET_okINTEGER7
case FFEBLD_constINTEGER7:
return ffebld_constant_integer7 (c) == 0;
#endif
#if FFETARGET_okINTEGER8
case FFEBLD_constINTEGER8:
return ffebld_constant_integer8 (c) == 0;
#endif
#if FFETARGET_okLOGICAL1
case FFEBLD_constLOGICAL1:
return ffebld_constant_logical1 (c) == 0;
#endif
#if FFETARGET_okLOGICAL2
case FFEBLD_constLOGICAL2:
return ffebld_constant_logical2 (c) == 0;
#endif
#if FFETARGET_okLOGICAL3
case FFEBLD_constLOGICAL3:
return ffebld_constant_logical3 (c) == 0;
#endif
#if FFETARGET_okLOGICAL4
case FFEBLD_constLOGICAL4:
return ffebld_constant_logical4 (c) == 0;
#endif
#if FFETARGET_okLOGICAL5
case FFEBLD_constLOGICAL5:
return ffebld_constant_logical5 (c) == 0;
#endif
#if FFETARGET_okLOGICAL6
case FFEBLD_constLOGICAL6:
return ffebld_constant_logical6 (c) == 0;
#endif
#if FFETARGET_okLOGICAL7
case FFEBLD_constLOGICAL7:
return ffebld_constant_logical7 (c) == 0;
#endif
#if FFETARGET_okLOGICAL8
case FFEBLD_constLOGICAL8:
return ffebld_constant_logical8 (c) == 0;
#endif
#if FFETARGET_okREAL1
case FFEBLD_constREAL1:
return ffetarget_iszero_real1 (ffebld_constant_real1 (c));
#endif
#if FFETARGET_okREAL2
case FFEBLD_constREAL2:
return ffetarget_iszero_real2 (ffebld_constant_real2 (c));
#endif
#if FFETARGET_okREAL3
case FFEBLD_constREAL3:
return ffetarget_iszero_real3 (ffebld_constant_real3 (c));
#endif
#if FFETARGET_okREAL4
case FFEBLD_constREAL4:
return ffetarget_iszero_real4 (ffebld_constant_real4 (c));
#endif
#if FFETARGET_okREAL5
case FFEBLD_constREAL5:
return ffetarget_iszero_real5 (ffebld_constant_real5 (c));
#endif
#if FFETARGET_okREAL6
case FFEBLD_constREAL6:
return ffetarget_iszero_real6 (ffebld_constant_real6 (c));
#endif
#if FFETARGET_okREAL7
case FFEBLD_constREAL7:
return ffetarget_iszero_real7 (ffebld_constant_real7 (c));
#endif
#if FFETARGET_okREAL8
case FFEBLD_constREAL8:
return ffetarget_iszero_real8 (ffebld_constant_real8 (c));
#endif
#if FFETARGET_okCOMPLEX1
case FFEBLD_constCOMPLEX1:
return ffetarget_iszero_real1 (ffebld_constant_complex1 (c).real)
&& ffetarget_iszero_real1 (ffebld_constant_complex1 (c).imaginary);
#endif
#if FFETARGET_okCOMPLEX2
case FFEBLD_constCOMPLEX2:
return ffetarget_iszero_real2 (ffebld_constant_complex2 (c).real)
&& ffetarget_iszero_real2 (ffebld_constant_complex2 (c).imaginary);
#endif
#if FFETARGET_okCOMPLEX3
case FFEBLD_constCOMPLEX3:
return ffetarget_iszero_real3 (ffebld_constant_complex3 (c).real)
&& ffetarget_iszero_real3 (ffebld_constant_complex3 (c).imaginary);
#endif
#if FFETARGET_okCOMPLEX4
case FFEBLD_constCOMPLEX4:
return ffetarget_iszero_real4 (ffebld_constant_complex4 (c).real)
&& ffetarget_iszero_real4 (ffebld_constant_complex4 (c).imaginary);
#endif
#if FFETARGET_okCOMPLEX5
case FFEBLD_constCOMPLEX5:
return ffetarget_iszero_real5 (ffebld_constant_complex5 (c).real)
&& ffetarget_iszero_real5 (ffebld_constant_complex5 (c).imaginary);
#endif
#if FFETARGET_okCOMPLEX6
case FFEBLD_constCOMPLEX6:
return ffetarget_iszero_real6 (ffebld_constant_complex6 (c).real)
&& ffetarget_iszero_real6 (ffebld_constant_complex6 (c).imaginary);
#endif
#if FFETARGET_okCOMPLEX7
case FFEBLD_constCOMPLEX7:
return ffetarget_iszero_real7 (ffebld_constant_complex7 (c).real)
&& ffetarget_iszero_real7 (ffebld_constant_complex7 (c).imaginary);
#endif
#if FFETARGET_okCOMPLEX8
case FFEBLD_constCOMPLEX8:
return ffetarget_iszero_real8 (ffebld_constant_complex8 (c).real)
&& ffetarget_iszero_real8 (ffebld_constant_complex8 (c).imaginary);
#endif
#if FFETARGET_okCHARACTER1
case FFEBLD_constCHARACTER1:
return ffetarget_iszero_character1 (ffebld_constant_character1 (c));
#endif
#if FFETARGET_okCHARACTER2 || FFETARGET_okCHARACTER3 /* ... */
#error "no support for these!!"
#endif
case FFEBLD_constHOLLERITH:
return ffetarget_iszero_hollerith (ffebld_constant_hollerith (c));
case FFEBLD_constBINARY_MIL:
case FFEBLD_constBINARY_VXT:
case FFEBLD_constOCTAL_MIL:
case FFEBLD_constOCTAL_VXT:
case FFEBLD_constHEX_X_MIL:
case FFEBLD_constHEX_X_VXT:
case FFEBLD_constHEX_Z_MIL:
case FFEBLD_constHEX_Z_VXT:
return ffetarget_iszero_typeless (ffebld_constant_typeless (c));
default:
return FALSE;
}
}
/* ffebld_constant_new_character1 -- Return character1 constant object from token
See prototype. */
#if FFETARGET_okCHARACTER1
ffebldConstant
ffebld_constant_new_character1 (ffelexToken t)
{
ffetargetCharacter1 val;
ffetarget_character1 (&val, t, ffebld_constant_pool());
return ffebld_constant_new_character1_val (val);
}
#endif
/* ffebld_constant_new_character1_val -- Return an character1 constant object
See prototype. */
#if FFETARGET_okCHARACTER1
ffebldConstant
ffebld_constant_new_character1_val (ffetargetCharacter1 val)
{
ffebldConstant c;
ffebldConstant nc;
int cmp;
ffetarget_verify_character1 (ffebld_constant_pool(), val);
for (c = (ffebldConstant) &ffebld_constant_character1_;
c->next != NULL;
c = c->next)
{
malloc_verify_kp (ffebld_constant_pool(),
c->next,
sizeof (*(c->next)));
ffetarget_verify_character1 (ffebld_constant_pool(),
ffebld_constant_character1 (c->next));
cmp = ffetarget_cmp_character1 (val,
ffebld_constant_character1 (c->next));
if (cmp == 0)
return c->next;
if (cmp > 0)
break;
}
nc = malloc_new_kp (ffebld_constant_pool(),
"FFEBLD_constCHARACTER1",
sizeof (*nc));
nc->next = c->next;
nc->consttype = FFEBLD_constCHARACTER1;
nc->u.character1 = val;
#ifdef FFECOM_constantHOOK
nc->hook = FFECOM_constantNULL;
#endif
c->next = nc;
return nc;
}
#endif
/* ffebld_constant_new_complex1 -- Return complex1 constant object from token
See prototype. */
#if FFETARGET_okCOMPLEX1
ffebldConstant
ffebld_constant_new_complex1 (ffebldConstant real,
ffebldConstant imaginary)
{
ffetargetComplex1 val;
val.real = ffebld_constant_real1 (real);
val.imaginary = ffebld_constant_real1 (imaginary);
return ffebld_constant_new_complex1_val (val);
}
#endif
/* ffebld_constant_new_complex1_val -- Return a complex1 constant object
See prototype. */
#if FFETARGET_okCOMPLEX1
ffebldConstant
ffebld_constant_new_complex1_val (ffetargetComplex1 val)
{
ffebldConstant c;
ffebldConstant nc;
int cmp;
for (c = (ffebldConstant) &ffebld_constant_complex1_;
c->next != NULL;
c = c->next)
{
cmp = ffetarget_cmp_real1 (val.real, ffebld_constant_complex1 (c->next).real);
if (cmp == 0)
cmp = ffetarget_cmp_real1 (val.imaginary,
ffebld_constant_complex1 (c->next).imaginary);
if (cmp == 0)
return c->next;
if (cmp > 0)
break;
}
nc = malloc_new_kp (ffebld_constant_pool(),
"FFEBLD_constCOMPLEX1",
sizeof (*nc));
nc->next = c->next;
nc->consttype = FFEBLD_constCOMPLEX1;
nc->u.complex1 = val;
#ifdef FFECOM_constantHOOK
nc->hook = FFECOM_constantNULL;
#endif
c->next = nc;
return nc;
}
#endif
/* ffebld_constant_new_complex2 -- Return complex2 constant object from token
See prototype. */
#if FFETARGET_okCOMPLEX2
ffebldConstant
ffebld_constant_new_complex2 (ffebldConstant real,
ffebldConstant imaginary)
{
ffetargetComplex2 val;
val.real = ffebld_constant_real2 (real);
val.imaginary = ffebld_constant_real2 (imaginary);
return ffebld_constant_new_complex2_val (val);
}
#endif
/* ffebld_constant_new_complex2_val -- Return a complex2 constant object
See prototype. */
#if FFETARGET_okCOMPLEX2
ffebldConstant
ffebld_constant_new_complex2_val (ffetargetComplex2 val)
{
ffebldConstant c;
ffebldConstant nc;
int cmp;
for (c = (ffebldConstant) &ffebld_constant_complex2_;
c->next != NULL;
c = c->next)
{
cmp = ffetarget_cmp_real2 (val.real, ffebld_constant_complex2 (c->next).real);
if (cmp == 0)
cmp = ffetarget_cmp_real2 (val.imaginary,
ffebld_constant_complex2 (c->next).imaginary);
if (cmp == 0)
return c->next;
if (cmp > 0)
break;
}
nc = malloc_new_kp (ffebld_constant_pool(),
"FFEBLD_constCOMPLEX2",
sizeof (*nc));
nc->next = c->next;
nc->consttype = FFEBLD_constCOMPLEX2;
nc->u.complex2 = val;
#ifdef FFECOM_constantHOOK
nc->hook = FFECOM_constantNULL;
#endif
c->next = nc;
return nc;
}
#endif
/* ffebld_constant_new_hollerith -- Return hollerith constant object from token
See prototype. */
ffebldConstant
ffebld_constant_new_hollerith (ffelexToken t)
{
ffetargetHollerith val;
ffetarget_hollerith (&val, t, ffebld_constant_pool());
return ffebld_constant_new_hollerith_val (val);
}
/* ffebld_constant_new_hollerith_val -- Return an hollerith constant object
See prototype. */
ffebldConstant
ffebld_constant_new_hollerith_val (ffetargetHollerith val)
{
ffebldConstant c;
ffebldConstant nc;
int cmp;
for (c = (ffebldConstant) &ffebld_constant_hollerith_;
c->next != NULL;
c = c->next)
{
cmp = ffetarget_cmp_hollerith (val, ffebld_constant_hollerith (c->next));
if (cmp == 0)
return c->next;
if (cmp > 0)
break;
}
nc = malloc_new_kp (ffebld_constant_pool(),
"FFEBLD_constHOLLERITH",
sizeof (*nc));
nc->next = c->next;
nc->consttype = FFEBLD_constHOLLERITH;
nc->u.hollerith = val;
#ifdef FFECOM_constantHOOK
nc->hook = FFECOM_constantNULL;
#endif
c->next = nc;
return nc;
}
/* ffebld_constant_new_integer1 -- Return integer1 constant object from token
See prototype.
Parses the token as a decimal integer constant, thus it must be an
FFELEX_typeNUMBER. */
#if FFETARGET_okINTEGER1
ffebldConstant
ffebld_constant_new_integer1 (ffelexToken t)
{
ffetargetInteger1 val;
assert (ffelex_token_type (t) == FFELEX_typeNUMBER);
ffetarget_integer1 (&val, t);
return ffebld_constant_new_integer1_val (val);
}
#endif
/* ffebld_constant_new_integer1_val -- Return an integer1 constant object
See prototype. */
#if FFETARGET_okINTEGER1
ffebldConstant
ffebld_constant_new_integer1_val (ffetargetInteger1 val)
{
ffebldConstant c;
ffebldConstant nc;
int cmp;
for (c = (ffebldConstant) &ffebld_constant_integer1_;
c->next != NULL;
c = c->next)
{
cmp = ffetarget_cmp_integer1 (val, ffebld_constant_integer1 (c->next));
if (cmp == 0)
return c->next;
if (cmp > 0)
break;
}
nc = malloc_new_kp (ffebld_constant_pool(),
"FFEBLD_constINTEGER1",
sizeof (*nc));
nc->next = c->next;
nc->consttype = FFEBLD_constINTEGER1;
nc->u.integer1 = val;
#ifdef FFECOM_constantHOOK
nc->hook = FFECOM_constantNULL;
#endif
c->next = nc;
return nc;
}
#endif
/* ffebld_constant_new_integer2_val -- Return an integer2 constant object
See prototype. */
#if FFETARGET_okINTEGER2
ffebldConstant
ffebld_constant_new_integer2_val (ffetargetInteger2 val)
{
ffebldConstant c;
ffebldConstant nc;
int cmp;
for (c = (ffebldConstant) &ffebld_constant_integer2_;
c->next != NULL;
c = c->next)
{
cmp = ffetarget_cmp_integer2 (val, ffebld_constant_integer2 (c->next));
if (cmp == 0)
return c->next;
if (cmp > 0)
break;
}
nc = malloc_new_kp (ffebld_constant_pool(),
"FFEBLD_constINTEGER2",
sizeof (*nc));
nc->next = c->next;
nc->consttype = FFEBLD_constINTEGER2;
nc->u.integer2 = val;
#ifdef FFECOM_constantHOOK
nc->hook = FFECOM_constantNULL;
#endif
c->next = nc;
return nc;
}
#endif
/* ffebld_constant_new_integer3_val -- Return an integer3 constant object
See prototype. */
#if FFETARGET_okINTEGER3
ffebldConstant
ffebld_constant_new_integer3_val (ffetargetInteger3 val)
{
ffebldConstant c;
ffebldConstant nc;
int cmp;
for (c = (ffebldConstant) &ffebld_constant_integer3_;
c->next != NULL;
c = c->next)
{
cmp = ffetarget_cmp_integer3 (val, ffebld_constant_integer3 (c->next));
if (cmp == 0)
return c->next;
if (cmp > 0)
break;
}
nc = malloc_new_kp (ffebld_constant_pool(),
"FFEBLD_constINTEGER3",
sizeof (*nc));
nc->next = c->next;
nc->consttype = FFEBLD_constINTEGER3;
nc->u.integer3 = val;
#ifdef FFECOM_constantHOOK
nc->hook = FFECOM_constantNULL;
#endif
c->next = nc;
return nc;
}
#endif
/* ffebld_constant_new_integer4_val -- Return an integer4 constant object
See prototype. */
#if FFETARGET_okINTEGER4
ffebldConstant
ffebld_constant_new_integer4_val (ffetargetInteger4 val)
{
ffebldConstant c;
ffebldConstant nc;
int cmp;
for (c = (ffebldConstant) &ffebld_constant_integer4_;
c->next != NULL;
c = c->next)
{
cmp = ffetarget_cmp_integer4 (val, ffebld_constant_integer4 (c->next));
if (cmp == 0)
return c->next;
if (cmp > 0)
break;
}
nc = malloc_new_kp (ffebld_constant_pool(),
"FFEBLD_constINTEGER4",
sizeof (*nc));
nc->next = c->next;
nc->consttype = FFEBLD_constINTEGER4;
nc->u.integer4 = val;
#ifdef FFECOM_constantHOOK
nc->hook = FFECOM_constantNULL;
#endif
c->next = nc;
return nc;
}
#endif
/* ffebld_constant_new_integerbinary -- Return binary constant object from token
See prototype.
Parses the token as a binary integer constant, thus it must be an
FFELEX_typeNUMBER. */
ffebldConstant
ffebld_constant_new_integerbinary (ffelexToken t)
{
ffetargetIntegerDefault val;
assert ((ffelex_token_type (t) == FFELEX_typeNAME)
|| (ffelex_token_type (t) == FFELEX_typeNUMBER));
ffetarget_integerbinary (&val, t);
return ffebld_constant_new_integerdefault_val (val);
}
/* ffebld_constant_new_integerhex -- Return hex constant object from token
See prototype.
Parses the token as a hex integer constant, thus it must be an
FFELEX_typeNUMBER. */
ffebldConstant
ffebld_constant_new_integerhex (ffelexToken t)
{
ffetargetIntegerDefault val;
assert ((ffelex_token_type (t) == FFELEX_typeNAME)
|| (ffelex_token_type (t) == FFELEX_typeNUMBER));
ffetarget_integerhex (&val, t);
return ffebld_constant_new_integerdefault_val (val);
}
/* ffebld_constant_new_integeroctal -- Return octal constant object from token
See prototype.
Parses the token as a octal integer constant, thus it must be an
FFELEX_typeNUMBER. */
ffebldConstant
ffebld_constant_new_integeroctal (ffelexToken t)
{
ffetargetIntegerDefault val;
assert ((ffelex_token_type (t) == FFELEX_typeNAME)
|| (ffelex_token_type (t) == FFELEX_typeNUMBER));
ffetarget_integeroctal (&val, t);
return ffebld_constant_new_integerdefault_val (val);
}
/* ffebld_constant_new_logical1 -- Return logical1 constant object from token
See prototype.
Parses the token as a decimal logical constant, thus it must be an
FFELEX_typeNUMBER. */
#if FFETARGET_okLOGICAL1
ffebldConstant
ffebld_constant_new_logical1 (bool truth)
{
ffetargetLogical1 val;
ffetarget_logical1 (&val, truth);
return ffebld_constant_new_logical1_val (val);
}
#endif
/* ffebld_constant_new_logical1_val -- Return a logical1 constant object
See prototype. */
#if FFETARGET_okLOGICAL1
ffebldConstant
ffebld_constant_new_logical1_val (ffetargetLogical1 val)
{
ffebldConstant c;
ffebldConstant nc;
int cmp;
for (c = (ffebldConstant) &ffebld_constant_logical1_;
c->next != NULL;
c = c->next)
{
cmp = ffetarget_cmp_logical1 (val, ffebld_constant_logical1 (c->next));
if (cmp == 0)
return c->next;
if (cmp > 0)
break;
}
nc = malloc_new_kp (ffebld_constant_pool(),
"FFEBLD_constLOGICAL1",
sizeof (*nc));
nc->next = c->next;
nc->consttype = FFEBLD_constLOGICAL1;
nc->u.logical1 = val;
#ifdef FFECOM_constantHOOK
nc->hook = FFECOM_constantNULL;
#endif
c->next = nc;
return nc;
}
#endif
/* ffebld_constant_new_logical2_val -- Return a logical2 constant object
See prototype. */
#if FFETARGET_okLOGICAL2
ffebldConstant
ffebld_constant_new_logical2_val (ffetargetLogical2 val)
{
ffebldConstant c;
ffebldConstant nc;
int cmp;
for (c = (ffebldConstant) &ffebld_constant_logical2_;
c->next != NULL;
c = c->next)
{
cmp = ffetarget_cmp_logical2 (val, ffebld_constant_logical2 (c->next));
if (cmp == 0)
return c->next;
if (cmp > 0)
break;
}
nc = malloc_new_kp (ffebld_constant_pool(),
"FFEBLD_constLOGICAL2",
sizeof (*nc));
nc->next = c->next;
nc->consttype = FFEBLD_constLOGICAL2;
nc->u.logical2 = val;
#ifdef FFECOM_constantHOOK
nc->hook = FFECOM_constantNULL;
#endif
c->next = nc;
return nc;
}
#endif
/* ffebld_constant_new_logical3_val -- Return a logical3 constant object
See prototype. */
#if FFETARGET_okLOGICAL3
ffebldConstant
ffebld_constant_new_logical3_val (ffetargetLogical3 val)
{
ffebldConstant c;
ffebldConstant nc;
int cmp;
for (c = (ffebldConstant) &ffebld_constant_logical3_;
c->next != NULL;
c = c->next)
{
cmp = ffetarget_cmp_logical3 (val, ffebld_constant_logical3 (c->next));
if (cmp == 0)
return c->next;
if (cmp > 0)
break;
}
nc = malloc_new_kp (ffebld_constant_pool(),
"FFEBLD_constLOGICAL3",
sizeof (*nc));
nc->next = c->next;
nc->consttype = FFEBLD_constLOGICAL3;
nc->u.logical3 = val;
#ifdef FFECOM_constantHOOK
nc->hook = FFECOM_constantNULL;
#endif
c->next = nc;
return nc;
}
#endif
/* ffebld_constant_new_logical4_val -- Return a logical4 constant object
See prototype. */
#if FFETARGET_okLOGICAL4
ffebldConstant
ffebld_constant_new_logical4_val (ffetargetLogical4 val)
{
ffebldConstant c;
ffebldConstant nc;
int cmp;
for (c = (ffebldConstant) &ffebld_constant_logical4_;
c->next != NULL;
c = c->next)
{
cmp = ffetarget_cmp_logical4 (val, ffebld_constant_logical4 (c->next));
if (cmp == 0)
return c->next;
if (cmp > 0)
break;
}
nc = malloc_new_kp (ffebld_constant_pool(),
"FFEBLD_constLOGICAL4",
sizeof (*nc));
nc->next = c->next;
nc->consttype = FFEBLD_constLOGICAL4;
nc->u.logical4 = val;
#ifdef FFECOM_constantHOOK
nc->hook = FFECOM_constantNULL;
#endif
c->next = nc;
return nc;
}
#endif
/* ffebld_constant_new_real1 -- Return real1 constant object from token
See prototype. */
#if FFETARGET_okREAL1
ffebldConstant
ffebld_constant_new_real1 (ffelexToken integer, ffelexToken decimal,
ffelexToken fraction, ffelexToken exponent, ffelexToken exponent_sign,
ffelexToken exponent_digits)
{
ffetargetReal1 val;
ffetarget_real1 (&val,
integer, decimal, fraction, exponent, exponent_sign, exponent_digits);
return ffebld_constant_new_real1_val (val);
}
#endif
/* ffebld_constant_new_real1_val -- Return an real1 constant object
See prototype. */
#if FFETARGET_okREAL1
ffebldConstant
ffebld_constant_new_real1_val (ffetargetReal1 val)
{
ffebldConstant c;
ffebldConstant nc;
int cmp;
for (c = (ffebldConstant) &ffebld_constant_real1_;
c->next != NULL;
c = c->next)
{
cmp = ffetarget_cmp_real1 (val, ffebld_constant_real1 (c->next));
if (cmp == 0)
return c->next;
if (cmp > 0)
break;
}
nc = malloc_new_kp (ffebld_constant_pool(),
"FFEBLD_constREAL1",
sizeof (*nc));
nc->next = c->next;
nc->consttype = FFEBLD_constREAL1;
nc->u.real1 = val;
#ifdef FFECOM_constantHOOK
nc->hook = FFECOM_constantNULL;
#endif
c->next = nc;
return nc;
}
#endif
/* ffebld_constant_new_real2 -- Return real2 constant object from token
See prototype. */
#if FFETARGET_okREAL2
ffebldConstant
ffebld_constant_new_real2 (ffelexToken integer, ffelexToken decimal,
ffelexToken fraction, ffelexToken exponent, ffelexToken exponent_sign,
ffelexToken exponent_digits)
{
ffetargetReal2 val;
ffetarget_real2 (&val,
integer, decimal, fraction, exponent, exponent_sign, exponent_digits);
return ffebld_constant_new_real2_val (val);
}
#endif
/* ffebld_constant_new_real2_val -- Return an real2 constant object
See prototype. */
#if FFETARGET_okREAL2
ffebldConstant
ffebld_constant_new_real2_val (ffetargetReal2 val)
{
ffebldConstant c;
ffebldConstant nc;
int cmp;
for (c = (ffebldConstant) &ffebld_constant_real2_;
c->next != NULL;
c = c->next)
{
cmp = ffetarget_cmp_real2 (val, ffebld_constant_real2 (c->next));
if (cmp == 0)
return c->next;
if (cmp > 0)
break;
}
nc = malloc_new_kp (ffebld_constant_pool(),
"FFEBLD_constREAL2",
sizeof (*nc));
nc->next = c->next;
nc->consttype = FFEBLD_constREAL2;
nc->u.real2 = val;
#ifdef FFECOM_constantHOOK
nc->hook = FFECOM_constantNULL;
#endif
c->next = nc;
return nc;
}
#endif
/* ffebld_constant_new_typeless_bm -- Return typeless constant object from token
See prototype.
Parses the token as a decimal integer constant, thus it must be an
FFELEX_typeNUMBER. */
ffebldConstant
ffebld_constant_new_typeless_bm (ffelexToken t)
{
ffetargetTypeless val;
ffetarget_binarymil (&val, t);
return ffebld_constant_new_typeless_val (FFEBLD_constBINARY_MIL, val);
}
/* ffebld_constant_new_typeless_bv -- Return typeless constant object from token
See prototype.
Parses the token as a decimal integer constant, thus it must be an
FFELEX_typeNUMBER. */
ffebldConstant
ffebld_constant_new_typeless_bv (ffelexToken t)
{
ffetargetTypeless val;
ffetarget_binaryvxt (&val, t);
return ffebld_constant_new_typeless_val (FFEBLD_constBINARY_VXT, val);
}
/* ffebld_constant_new_typeless_hxm -- Return typeless constant object from token
See prototype.
Parses the token as a decimal integer constant, thus it must be an
FFELEX_typeNUMBER. */
ffebldConstant
ffebld_constant_new_typeless_hxm (ffelexToken t)
{
ffetargetTypeless val;
ffetarget_hexxmil (&val, t);
return ffebld_constant_new_typeless_val (FFEBLD_constHEX_X_MIL, val);
}
/* ffebld_constant_new_typeless_hxv -- Return typeless constant object from token
See prototype.
Parses the token as a decimal integer constant, thus it must be an
FFELEX_typeNUMBER. */
ffebldConstant
ffebld_constant_new_typeless_hxv (ffelexToken t)
{
ffetargetTypeless val;
ffetarget_hexxvxt (&val, t);
return ffebld_constant_new_typeless_val (FFEBLD_constHEX_X_VXT, val);
}
/* ffebld_constant_new_typeless_hzm -- Return typeless constant object from token
See prototype.
Parses the token as a decimal integer constant, thus it must be an
FFELEX_typeNUMBER. */
ffebldConstant
ffebld_constant_new_typeless_hzm (ffelexToken t)
{
ffetargetTypeless val;
ffetarget_hexzmil (&val, t);
return ffebld_constant_new_typeless_val (FFEBLD_constHEX_Z_MIL, val);
}
/* ffebld_constant_new_typeless_hzv -- Return typeless constant object from token
See prototype.
Parses the token as a decimal integer constant, thus it must be an
FFELEX_typeNUMBER. */
ffebldConstant
ffebld_constant_new_typeless_hzv (ffelexToken t)
{
ffetargetTypeless val;
ffetarget_hexzvxt (&val, t);
return ffebld_constant_new_typeless_val (FFEBLD_constHEX_Z_VXT, val);
}
/* ffebld_constant_new_typeless_om -- Return typeless constant object from token
See prototype.
Parses the token as a decimal integer constant, thus it must be an
FFELEX_typeNUMBER. */
ffebldConstant
ffebld_constant_new_typeless_om (ffelexToken t)
{
ffetargetTypeless val;
ffetarget_octalmil (&val, t);
return ffebld_constant_new_typeless_val (FFEBLD_constOCTAL_MIL, val);
}
/* ffebld_constant_new_typeless_ov -- Return typeless constant object from token
See prototype.
Parses the token as a decimal integer constant, thus it must be an
FFELEX_typeNUMBER. */
ffebldConstant
ffebld_constant_new_typeless_ov (ffelexToken t)
{
ffetargetTypeless val;
ffetarget_octalvxt (&val, t);
return ffebld_constant_new_typeless_val (FFEBLD_constOCTAL_VXT, val);
}
/* ffebld_constant_new_typeless_val -- Return a typeless constant object
See prototype. */
ffebldConstant
ffebld_constant_new_typeless_val (ffebldConst type, ffetargetTypeless val)
{
ffebldConstant c;
ffebldConstant nc;
int cmp;
for (c = (ffebldConstant) &ffebld_constant_typeless_[type
- FFEBLD_constTYPELESS_FIRST];
c->next != NULL;
c = c->next)
{
cmp = ffetarget_cmp_typeless (val, ffebld_constant_typeless (c->next));
if (cmp == 0)
return c->next;
if (cmp > 0)
break;
}
nc = malloc_new_kp (ffebld_constant_pool(),
"FFEBLD_constTYPELESS",
sizeof (*nc));
nc->next = c->next;
nc->consttype = type;
nc->u.typeless = val;
#ifdef FFECOM_constantHOOK
nc->hook = FFECOM_constantNULL;
#endif
c->next = nc;
return nc;
}
/* ffebld_constantarray_dump -- Display summary of array's contents
ffebldConstantArray a;
ffeinfoBasictype bt;
ffeinfoKindtype kt;
ffetargetOffset size;
ffebld_constant_dump(a,bt,kt,size,NULL);
Displays the constant array in summary form. The fifth argument, if
supplied, is an ffebit object that is consulted as to whether the
constant at a particular offset is valid. */
#if FFECOM_targetCURRENT == FFECOM_targetFFE
void
ffebld_constantarray_dump (ffebldConstantArray array, ffeinfoBasictype bt,
ffeinfoKindtype kt, ffetargetOffset size, ffebit bits)
{
ffetargetOffset i;
ffebitCount j;
ffebld_dump_prefix (dmpout, bt, kt);
fprintf (dmpout, "\\(");
if (bits == NULL)
{
for (i = 0; i < size; ++i)
{
ffebld_constantunion_dump (ffebld_constantarray_get (array, bt, kt, i), bt,
kt);
if (i != size - 1)
fputc (',', dmpout);
}
}
else
{
bool value;
ffebitCount length;
ffetargetOffset offset = 0;
do
{
ffebit_test (bits, offset, &value, &length);
if (value && (length != 0))
{
if (length == 1)
fprintf (dmpout, "[%" ffetargetOffset_f "d]:", offset);
else
fprintf (dmpout,
"[%" ffetargetOffset_f "u..%" ffetargetOffset_f "d]:",
offset, offset + (ffetargetOffset) length - 1);
for (j = 0; j < length; ++j, ++offset)
{
ffebld_constantunion_dump (ffebld_constantarray_get (array, bt, kt,
offset), bt, kt);
if (j != length - 1)
fputc (',', dmpout);
}
fprintf (dmpout, ";");
}
else
offset += length;
}
while (length != 0);
}
fprintf (dmpout, "\\)");
}
#endif
/* ffebld_constantarray_get -- Get a value from an array of constants
See prototype. */
ffebldConstantUnion
ffebld_constantarray_get (ffebldConstantArray array, ffeinfoBasictype bt,
ffeinfoKindtype kt, ffetargetOffset offset)
{
ffebldConstantUnion u;
switch (bt)
{
case FFEINFO_basictypeINTEGER:
switch (kt)
{
#if FFETARGET_okINTEGER1
case FFEINFO_kindtypeINTEGER1:
u.integer1 = *(array.integer1 + offset);
break;
#endif
#if FFETARGET_okINTEGER2
case FFEINFO_kindtypeINTEGER2:
u.integer2 = *(array.integer2 + offset);
break;
#endif
#if FFETARGET_okINTEGER3
case FFEINFO_kindtypeINTEGER3:
u.integer3 = *(array.integer3 + offset);
break;
#endif
#if FFETARGET_okINTEGER4
case FFEINFO_kindtypeINTEGER4:
u.integer4 = *(array.integer4 + offset);
break;
#endif
#if FFETARGET_okINTEGER5
case FFEINFO_kindtypeINTEGER5:
u.integer5 = *(array.integer5 + offset);
break;
#endif
#if FFETARGET_okINTEGER6
case FFEINFO_kindtypeINTEGER6:
u.integer6 = *(array.integer6 + offset);
break;
#endif
#if FFETARGET_okINTEGER7
case FFEINFO_kindtypeINTEGER7:
u.integer7 = *(array.integer7 + offset);
break;
#endif
#if FFETARGET_okINTEGER8
case FFEINFO_kindtypeINTEGER8:
u.integer8 = *(array.integer8 + offset);
break;
#endif
default:
assert ("bad INTEGER kindtype" == NULL);
break;
}
break;
case FFEINFO_basictypeLOGICAL:
switch (kt)
{
#if FFETARGET_okLOGICAL1
case FFEINFO_kindtypeLOGICAL1:
u.logical1 = *(array.logical1 + offset);
break;
#endif
#if FFETARGET_okLOGICAL2
case FFEINFO_kindtypeLOGICAL2:
u.logical2 = *(array.logical2 + offset);
break;
#endif
#if FFETARGET_okLOGICAL3
case FFEINFO_kindtypeLOGICAL3:
u.logical3 = *(array.logical3 + offset);
break;
#endif
#if FFETARGET_okLOGICAL4
case FFEINFO_kindtypeLOGICAL4:
u.logical4 = *(array.logical4 + offset);
break;
#endif
#if FFETARGET_okLOGICAL5
case FFEINFO_kindtypeLOGICAL5:
u.logical5 = *(array.logical5 + offset);
break;
#endif
#if FFETARGET_okLOGICAL6
case FFEINFO_kindtypeLOGICAL6:
u.logical6 = *(array.logical6 + offset);
break;
#endif
#if FFETARGET_okLOGICAL7
case FFEINFO_kindtypeLOGICAL7:
u.logical7 = *(array.logical7 + offset);
break;
#endif
#if FFETARGET_okLOGICAL8
case FFEINFO_kindtypeLOGICAL8:
u.logical8 = *(array.logical8 + offset);
break;
#endif
default:
assert ("bad LOGICAL kindtype" == NULL);
break;
}
break;
case FFEINFO_basictypeREAL:
switch (kt)
{
#if FFETARGET_okREAL1
case FFEINFO_kindtypeREAL1:
u.real1 = *(array.real1 + offset);
break;
#endif
#if FFETARGET_okREAL2
case FFEINFO_kindtypeREAL2:
u.real2 = *(array.real2 + offset);
break;
#endif
#if FFETARGET_okREAL3
case FFEINFO_kindtypeREAL3:
u.real3 = *(array.real3 + offset);
break;
#endif
#if FFETARGET_okREAL4
case FFEINFO_kindtypeREAL4:
u.real4 = *(array.real4 + offset);
break;
#endif
#if FFETARGET_okREAL5
case FFEINFO_kindtypeREAL5:
u.real5 = *(array.real5 + offset);
break;
#endif
#if FFETARGET_okREAL6
case FFEINFO_kindtypeREAL6:
u.real6 = *(array.real6 + offset);
break;
#endif
#if FFETARGET_okREAL7
case FFEINFO_kindtypeREAL7:
u.real7 = *(array.real7 + offset);
break;
#endif
#if FFETARGET_okREAL8
case FFEINFO_kindtypeREAL8:
u.real8 = *(array.real8 + offset);
break;
#endif
default:
assert ("bad REAL kindtype" == NULL);
break;
}
break;
case FFEINFO_basictypeCOMPLEX:
switch (kt)
{
#if FFETARGET_okCOMPLEX1
case FFEINFO_kindtypeREAL1:
u.complex1 = *(array.complex1 + offset);
break;
#endif
#if FFETARGET_okCOMPLEX2
case FFEINFO_kindtypeREAL2:
u.complex2 = *(array.complex2 + offset);
break;
#endif
#if FFETARGET_okCOMPLEX3
case FFEINFO_kindtypeREAL3:
u.complex3 = *(array.complex3 + offset);
break;
#endif
#if FFETARGET_okCOMPLEX4
case FFEINFO_kindtypeREAL4:
u.complex4 = *(array.complex4 + offset);
break;
#endif
#if FFETARGET_okCOMPLEX5
case FFEINFO_kindtypeREAL5:
u.complex5 = *(array.complex5 + offset);
break;
#endif
#if FFETARGET_okCOMPLEX6
case FFEINFO_kindtypeREAL6:
u.complex6 = *(array.complex6 + offset);
break;
#endif
#if FFETARGET_okCOMPLEX7
case FFEINFO_kindtypeREAL7:
u.complex7 = *(array.complex7 + offset);
break;
#endif
#if FFETARGET_okCOMPLEX8
case FFEINFO_kindtypeREAL8:
u.complex8 = *(array.complex8 + offset);
break;
#endif
default:
assert ("bad COMPLEX kindtype" == NULL);
break;
}
break;
case FFEINFO_basictypeCHARACTER:
switch (kt)
{
#if FFETARGET_okCHARACTER1
case FFEINFO_kindtypeCHARACTER1:
u.character1.length = 1;
u.character1.text = array.character1 + offset;
break;
#endif
#if FFETARGET_okCHARACTER2
case FFEINFO_kindtypeCHARACTER2:
u.character2.length = 1;
u.character2.text = array.character2 + offset;
break;
#endif
#if FFETARGET_okCHARACTER3
case FFEINFO_kindtypeCHARACTER3:
u.character3.length = 1;
u.character3.text = array.character3 + offset;
break;
#endif
#if FFETARGET_okCHARACTER4
case FFEINFO_kindtypeCHARACTER4:
u.character4.length = 1;
u.character4.text = array.character4 + offset;
break;
#endif
#if FFETARGET_okCHARACTER5
case FFEINFO_kindtypeCHARACTER5:
u.character5.length = 1;
u.character5.text = array.character5 + offset;
break;
#endif
#if FFETARGET_okCHARACTER6
case FFEINFO_kindtypeCHARACTER6:
u.character6.length = 1;
u.character6.text = array.character6 + offset;
break;
#endif
#if FFETARGET_okCHARACTER7
case FFEINFO_kindtypeCHARACTER7:
u.character7.length = 1;
u.character7.text = array.character7 + offset;
break;
#endif
#if FFETARGET_okCHARACTER8
case FFEINFO_kindtypeCHARACTER8:
u.character8.length = 1;
u.character8.text = array.character8 + offset;
break;
#endif
default:
assert ("bad CHARACTER kindtype" == NULL);
break;
}
break;
default:
assert ("bad basictype" == NULL);
break;
}
return u;
}
/* ffebld_constantarray_new -- Make an array of constants
See prototype. */
ffebldConstantArray
ffebld_constantarray_new (ffeinfoBasictype bt,
ffeinfoKindtype kt, ffetargetOffset size)
{
ffebldConstantArray ptr;
switch (bt)
{
case FFEINFO_basictypeINTEGER:
switch (kt)
{
#if FFETARGET_okINTEGER1
case FFEINFO_kindtypeINTEGER1:
ptr.integer1 = malloc_new_zkp (ffebld_constant_pool(),
"ffebldConstantArray",
size *= sizeof (ffetargetInteger1),
0);
break;
#endif
#if FFETARGET_okINTEGER2
case FFEINFO_kindtypeINTEGER2:
ptr.integer2 = malloc_new_zkp (ffebld_constant_pool(),
"ffebldConstantArray",
size *= sizeof (ffetargetInteger2),
0);
break;
#endif
#if FFETARGET_okINTEGER3
case FFEINFO_kindtypeINTEGER3:
ptr.integer3 = malloc_new_zkp (ffebld_constant_pool(),
"ffebldConstantArray",
size *= sizeof (ffetargetInteger3),
0);
break;
#endif
#if FFETARGET_okINTEGER4
case FFEINFO_kindtypeINTEGER4:
ptr.integer4 = malloc_new_zkp (ffebld_constant_pool(),
"ffebldConstantArray",
size *= sizeof (ffetargetInteger4),
0);
break;
#endif
#if FFETARGET_okINTEGER5
case FFEINFO_kindtypeINTEGER5:
ptr.integer5 = malloc_new_zkp (ffebld_constant_pool(),
"ffebldConstantArray",
size *= sizeof (ffetargetInteger5),
0);
break;
#endif
#if FFETARGET_okINTEGER6
case FFEINFO_kindtypeINTEGER6:
ptr.integer6 = malloc_new_zkp (ffebld_constant_pool(),
"ffebldConstantArray",
size *= sizeof (ffetargetInteger6),
0);
break;
#endif
#if FFETARGET_okINTEGER7
case FFEINFO_kindtypeINTEGER7:
ptr.integer7 = malloc_new_zkp (ffebld_constant_pool(),
"ffebldConstantArray",
size *= sizeof (ffetargetInteger7),
0);
break;
#endif
#if FFETARGET_okINTEGER8
case FFEINFO_kindtypeINTEGER8:
ptr.integer8 = malloc_new_zkp (ffebld_constant_pool(),
"ffebldConstantArray",
size *= sizeof (ffetargetInteger8),
0);
break;
#endif
default:
assert ("bad INTEGER kindtype" == NULL);
break;
}
break;
case FFEINFO_basictypeLOGICAL:
switch (kt)
{
#if FFETARGET_okLOGICAL1
case FFEINFO_kindtypeLOGICAL1:
ptr.logical1 = malloc_new_zkp (ffebld_constant_pool(),
"ffebldConstantArray",
size *= sizeof (ffetargetLogical1),
0);
break;
#endif
#if FFETARGET_okLOGICAL2
case FFEINFO_kindtypeLOGICAL2:
ptr.logical2 = malloc_new_zkp (ffebld_constant_pool(),
"ffebldConstantArray",
size *= sizeof (ffetargetLogical2),
0);
break;
#endif
#if FFETARGET_okLOGICAL3
case FFEINFO_kindtypeLOGICAL3:
ptr.logical3 = malloc_new_zkp (ffebld_constant_pool(),
"ffebldConstantArray",
size *= sizeof (ffetargetLogical3),
0);
break;
#endif
#if FFETARGET_okLOGICAL4
case FFEINFO_kindtypeLOGICAL4:
ptr.logical4 = malloc_new_zkp (ffebld_constant_pool(),
"ffebldConstantArray",
size *= sizeof (ffetargetLogical4),
0);
break;
#endif
#if FFETARGET_okLOGICAL5
case FFEINFO_kindtypeLOGICAL5:
ptr.logical5 = malloc_new_zkp (ffebld_constant_pool(),
"ffebldConstantArray",
size *= sizeof (ffetargetLogical5),
0);
break;
#endif
#if FFETARGET_okLOGICAL6
case FFEINFO_kindtypeLOGICAL6:
ptr.logical6 = malloc_new_zkp (ffebld_constant_pool(),
"ffebldConstantArray",
size *= sizeof (ffetargetLogical6),
0);
break;
#endif
#if FFETARGET_okLOGICAL7
case FFEINFO_kindtypeLOGICAL7:
ptr.logical7 = malloc_new_zkp (ffebld_constant_pool(),
"ffebldConstantArray",
size *= sizeof (ffetargetLogical7),
0);
break;
#endif
#if FFETARGET_okLOGICAL8
case FFEINFO_kindtypeLOGICAL8:
ptr.logical8 = malloc_new_zkp (ffebld_constant_pool(),
"ffebldConstantArray",
size *= sizeof (ffetargetLogical8),
0);
break;
#endif
default:
assert ("bad LOGICAL kindtype" == NULL);
break;
}
break;
case FFEINFO_basictypeREAL:
switch (kt)
{
#if FFETARGET_okREAL1
case FFEINFO_kindtypeREAL1:
ptr.real1 = malloc_new_zkp (ffebld_constant_pool(),
"ffebldConstantArray",
size *= sizeof (ffetargetReal1),
0);
break;
#endif
#if FFETARGET_okREAL2
case FFEINFO_kindtypeREAL2:
ptr.real2 = malloc_new_zkp (ffebld_constant_pool(),
"ffebldConstantArray",
size *= sizeof (ffetargetReal2),
0);
break;
#endif
#if FFETARGET_okREAL3
case FFEINFO_kindtypeREAL3:
ptr.real3 = malloc_new_zkp (ffebld_constant_pool(),
"ffebldConstantArray",
size *= sizeof (ffetargetReal3),
0);
break;
#endif
#if FFETARGET_okREAL4
case FFEINFO_kindtypeREAL4:
ptr.real4 = malloc_new_zkp (ffebld_constant_pool(),
"ffebldConstantArray",
size *= sizeof (ffetargetReal4),
0);
break;
#endif
#if FFETARGET_okREAL5
case FFEINFO_kindtypeREAL5:
ptr.real5 = malloc_new_zkp (ffebld_constant_pool(),
"ffebldConstantArray",
size *= sizeof (ffetargetReal5),
0);
break;
#endif
#if FFETARGET_okREAL6
case FFEINFO_kindtypeREAL6:
ptr.real6 = malloc_new_zkp (ffebld_constant_pool(),
"ffebldConstantArray",
size *= sizeof (ffetargetReal6),
0);
break;
#endif
#if FFETARGET_okREAL7
case FFEINFO_kindtypeREAL7:
ptr.real7 = malloc_new_zkp (ffebld_constant_pool(),
"ffebldConstantArray",
size *= sizeof (ffetargetReal7),
0);
break;
#endif
#if FFETARGET_okREAL8
case FFEINFO_kindtypeREAL8:
ptr.real8 = malloc_new_zkp (ffebld_constant_pool(),
"ffebldConstantArray",
size *= sizeof (ffetargetReal8),
0);
break;
#endif
default:
assert ("bad REAL kindtype" == NULL);
break;
}
break;
case FFEINFO_basictypeCOMPLEX:
switch (kt)
{
#if FFETARGET_okCOMPLEX1
case FFEINFO_kindtypeREAL1:
ptr.complex1 = malloc_new_zkp (ffebld_constant_pool(),
"ffebldConstantArray",
size *= sizeof (ffetargetComplex1),
0);
break;
#endif
#if FFETARGET_okCOMPLEX2
case FFEINFO_kindtypeREAL2:
ptr.complex2 = malloc_new_zkp (ffebld_constant_pool(),
"ffebldConstantArray",
size *= sizeof (ffetargetComplex2),
0);
break;
#endif
#if FFETARGET_okCOMPLEX3
case FFEINFO_kindtypeREAL3:
ptr.complex3 = malloc_new_zkp (ffebld_constant_pool(),
"ffebldConstantArray",
size *= sizeof (ffetargetComplex3),
0);
break;
#endif
#if FFETARGET_okCOMPLEX4
case FFEINFO_kindtypeREAL4:
ptr.complex4 = malloc_new_zkp (ffebld_constant_pool(),
"ffebldConstantArray",
size *= sizeof (ffetargetComplex4),
0);
break;
#endif
#if FFETARGET_okCOMPLEX5
case FFEINFO_kindtypeREAL5:
ptr.complex5 = malloc_new_zkp (ffebld_constant_pool(),
"ffebldConstantArray",
size *= sizeof (ffetargetComplex5),
0);
break;
#endif
#if FFETARGET_okCOMPLEX6
case FFEINFO_kindtypeREAL6:
ptr.complex6 = malloc_new_zkp (ffebld_constant_pool(),
"ffebldConstantArray",
size *= sizeof (ffetargetComplex6),
0);
break;
#endif
#if FFETARGET_okCOMPLEX7
case FFEINFO_kindtypeREAL7:
ptr.complex7 = malloc_new_zkp (ffebld_constant_pool(),
"ffebldConstantArray",
size *= sizeof (ffetargetComplex7),
0);
break;
#endif
#if FFETARGET_okCOMPLEX8
case FFEINFO_kindtypeREAL8:
ptr.complex8 = malloc_new_zkp (ffebld_constant_pool(),
"ffebldConstantArray",
size *= sizeof (ffetargetComplex8),
0);
break;
#endif
default:
assert ("bad COMPLEX kindtype" == NULL);
break;
}
break;
case FFEINFO_basictypeCHARACTER:
switch (kt)
{
#if FFETARGET_okCHARACTER1
case FFEINFO_kindtypeCHARACTER1:
ptr.character1 = malloc_new_zkp (ffebld_constant_pool(),
"ffebldConstantArray",
size
*= sizeof (ffetargetCharacterUnit1),
0);
break;
#endif
#if FFETARGET_okCHARACTER2
case FFEINFO_kindtypeCHARACTER2:
ptr.character2 = malloc_new_zkp (ffebld_constant_pool(),
"ffebldConstantArray",
size
*= sizeof (ffetargetCharacterUnit2),
0);
break;
#endif
#if FFETARGET_okCHARACTER3
case FFEINFO_kindtypeCHARACTER3:
ptr.character3 = malloc_new_zkp (ffebld_constant_pool(),
"ffebldConstantArray",
size
*= sizeof (ffetargetCharacterUnit3),
0);
break;
#endif
#if FFETARGET_okCHARACTER4
case FFEINFO_kindtypeCHARACTER4:
ptr.character4 = malloc_new_zkp (ffebld_constant_pool(),
"ffebldConstantArray",
size
*= sizeof (ffetargetCharacterUnit4),
0);
break;
#endif
#if FFETARGET_okCHARACTER5
case FFEINFO_kindtypeCHARACTER5:
ptr.character5 = malloc_new_zkp (ffebld_constant_pool(),
"ffebldConstantArray",
size
*= sizeof (ffetargetCharacterUnit5),
0);
break;
#endif
#if FFETARGET_okCHARACTER6
case FFEINFO_kindtypeCHARACTER6:
ptr.character6 = malloc_new_zkp (ffebld_constant_pool(),
"ffebldConstantArray",
size
*= sizeof (ffetargetCharacterUnit6),
0);
break;
#endif
#if FFETARGET_okCHARACTER7
case FFEINFO_kindtypeCHARACTER7:
ptr.character7 = malloc_new_zkp (ffebld_constant_pool(),
"ffebldConstantArray",
size
*= sizeof (ffetargetCharacterUnit7),
0);
break;
#endif
#if FFETARGET_okCHARACTER8
case FFEINFO_kindtypeCHARACTER8:
ptr.character8 = malloc_new_zkp (ffebld_constant_pool(),
"ffebldConstantArray",
size
*= sizeof (ffetargetCharacterUnit8),
0);
break;
#endif
default:
assert ("bad CHARACTER kindtype" == NULL);
break;
}
break;
default:
assert ("bad basictype" == NULL);
break;
}
return ptr;
}
/* ffebld_constantarray_preparray -- Prepare for copy between arrays
See prototype.
Like _prepare, but the source is an array instead of a single-value
constant. */
void
ffebld_constantarray_preparray (void **aptr, void **cptr, size_t *size,
ffebldConstantArray array, ffeinfoBasictype abt, ffeinfoKindtype akt,
ffetargetOffset offset, ffebldConstantArray source_array,
ffeinfoBasictype cbt, ffeinfoKindtype ckt)
{
switch (abt)
{
case FFEINFO_basictypeINTEGER:
switch (akt)
{
#if FFETARGET_okINTEGER1
case FFEINFO_kindtypeINTEGER1:
*aptr = array.integer1 + offset;
break;
#endif
#if FFETARGET_okINTEGER2
case FFEINFO_kindtypeINTEGER2:
*aptr = array.integer2 + offset;
break;
#endif
#if FFETARGET_okINTEGER3
case FFEINFO_kindtypeINTEGER3:
*aptr = array.integer3 + offset;
break;
#endif
#if FFETARGET_okINTEGER4
case FFEINFO_kindtypeINTEGER4:
*aptr = array.integer4 + offset;
break;
#endif
#if FFETARGET_okINTEGER5
case FFEINFO_kindtypeINTEGER5:
*aptr = array.integer5 + offset;
break;
#endif
#if FFETARGET_okINTEGER6
case FFEINFO_kindtypeINTEGER6:
*aptr = array.integer6 + offset;
break;
#endif
#if FFETARGET_okINTEGER7
case FFEINFO_kindtypeINTEGER7:
*aptr = array.integer7 + offset;
break;
#endif
#if FFETARGET_okINTEGER8
case FFEINFO_kindtypeINTEGER8:
*aptr = array.integer8 + offset;
break;
#endif
default:
assert ("bad INTEGER akindtype" == NULL);
break;
}
break;
case FFEINFO_basictypeLOGICAL:
switch (akt)
{
#if FFETARGET_okLOGICAL1
case FFEINFO_kindtypeLOGICAL1:
*aptr = array.logical1 + offset;
break;
#endif
#if FFETARGET_okLOGICAL2
case FFEINFO_kindtypeLOGICAL2:
*aptr = array.logical2 + offset;
break;
#endif
#if FFETARGET_okLOGICAL3
case FFEINFO_kindtypeLOGICAL3:
*aptr = array.logical3 + offset;
break;
#endif
#if FFETARGET_okLOGICAL4
case FFEINFO_kindtypeLOGICAL4:
*aptr = array.logical4 + offset;
break;
#endif
#if FFETARGET_okLOGICAL5
case FFEINFO_kindtypeLOGICAL5:
*aptr = array.logical5 + offset;
break;
#endif
#if FFETARGET_okLOGICAL6
case FFEINFO_kindtypeLOGICAL6:
*aptr = array.logical6 + offset;
break;
#endif
#if FFETARGET_okLOGICAL7
case FFEINFO_kindtypeLOGICAL7:
*aptr = array.logical7 + offset;
break;
#endif
#if FFETARGET_okLOGICAL8
case FFEINFO_kindtypeLOGICAL8:
*aptr = array.logical8 + offset;
break;
#endif
default:
assert ("bad LOGICAL akindtype" == NULL);
break;
}
break;
case FFEINFO_basictypeREAL:
switch (akt)
{
#if FFETARGET_okREAL1
case FFEINFO_kindtypeREAL1:
*aptr = array.real1 + offset;
break;
#endif
#if FFETARGET_okREAL2
case FFEINFO_kindtypeREAL2:
*aptr = array.real2 + offset;
break;
#endif
#if FFETARGET_okREAL3
case FFEINFO_kindtypeREAL3:
*aptr = array.real3 + offset;
break;
#endif
#if FFETARGET_okREAL4
case FFEINFO_kindtypeREAL4:
*aptr = array.real4 + offset;
break;
#endif
#if FFETARGET_okREAL5
case FFEINFO_kindtypeREAL5:
*aptr = array.real5 + offset;
break;
#endif
#if FFETARGET_okREAL6
case FFEINFO_kindtypeREAL6:
*aptr = array.real6 + offset;
break;
#endif
#if FFETARGET_okREAL7
case FFEINFO_kindtypeREAL7:
*aptr = array.real7 + offset;
break;
#endif
#if FFETARGET_okREAL8
case FFEINFO_kindtypeREAL8:
*aptr = array.real8 + offset;
break;
#endif
default:
assert ("bad REAL akindtype" == NULL);
break;
}
break;
case FFEINFO_basictypeCOMPLEX:
switch (akt)
{
#if FFETARGET_okCOMPLEX1
case FFEINFO_kindtypeREAL1:
*aptr = array.complex1 + offset;
break;
#endif
#if FFETARGET_okCOMPLEX2
case FFEINFO_kindtypeREAL2:
*aptr = array.complex2 + offset;
break;
#endif
#if FFETARGET_okCOMPLEX3
case FFEINFO_kindtypeREAL3:
*aptr = array.complex3 + offset;
break;
#endif
#if FFETARGET_okCOMPLEX4
case FFEINFO_kindtypeREAL4:
*aptr = array.complex4 + offset;
break;
#endif
#if FFETARGET_okCOMPLEX5
case FFEINFO_kindtypeREAL5:
*aptr = array.complex5 + offset;
break;
#endif
#if FFETARGET_okCOMPLEX6
case FFEINFO_kindtypeREAL6:
*aptr = array.complex6 + offset;
break;
#endif
#if FFETARGET_okCOMPLEX7
case FFEINFO_kindtypeREAL7:
*aptr = array.complex7 + offset;
break;
#endif
#if FFETARGET_okCOMPLEX8
case FFEINFO_kindtypeREAL8:
*aptr = array.complex8 + offset;
break;
#endif
default:
assert ("bad COMPLEX akindtype" == NULL);
break;
}
break;
case FFEINFO_basictypeCHARACTER:
switch (akt)
{
#if FFETARGET_okCHARACTER1
case FFEINFO_kindtypeCHARACTER1:
*aptr = array.character1 + offset;
break;
#endif
#if FFETARGET_okCHARACTER2
case FFEINFO_kindtypeCHARACTER2:
*aptr = array.character2 + offset;
break;
#endif
#if FFETARGET_okCHARACTER3
case FFEINFO_kindtypeCHARACTER3:
*aptr = array.character3 + offset;
break;
#endif
#if FFETARGET_okCHARACTER4
case FFEINFO_kindtypeCHARACTER4:
*aptr = array.character4 + offset;
break;
#endif
#if FFETARGET_okCHARACTER5
case FFEINFO_kindtypeCHARACTER5:
*aptr = array.character5 + offset;
break;
#endif
#if FFETARGET_okCHARACTER6
case FFEINFO_kindtypeCHARACTER6:
*aptr = array.character6 + offset;
break;
#endif
#if FFETARGET_okCHARACTER7
case FFEINFO_kindtypeCHARACTER7:
*aptr = array.character7 + offset;
break;
#endif
#if FFETARGET_okCHARACTER8
case FFEINFO_kindtypeCHARACTER8:
*aptr = array.character8 + offset;
break;
#endif
default:
assert ("bad CHARACTER akindtype" == NULL);
break;
}
break;
default:
assert ("bad abasictype" == NULL);
break;
}
switch (cbt)
{
case FFEINFO_basictypeINTEGER:
switch (ckt)
{
#if FFETARGET_okINTEGER1
case FFEINFO_kindtypeINTEGER1:
*cptr = source_array.integer1;
*size = sizeof (*source_array.integer1);
break;
#endif
#if FFETARGET_okINTEGER2
case FFEINFO_kindtypeINTEGER2:
*cptr = source_array.integer2;
*size = sizeof (*source_array.integer2);
break;
#endif
#if FFETARGET_okINTEGER3
case FFEINFO_kindtypeINTEGER3:
*cptr = source_array.integer3;
*size = sizeof (*source_array.integer3);
break;
#endif
#if FFETARGET_okINTEGER4
case FFEINFO_kindtypeINTEGER4:
*cptr = source_array.integer4;
*size = sizeof (*source_array.integer4);
break;
#endif
#if FFETARGET_okINTEGER5
case FFEINFO_kindtypeINTEGER5:
*cptr = source_array.integer5;
*size = sizeof (*source_array.integer5);
break;
#endif
#if FFETARGET_okINTEGER6
case FFEINFO_kindtypeINTEGER6:
*cptr = source_array.integer6;
*size = sizeof (*source_array.integer6);
break;
#endif
#if FFETARGET_okINTEGER7
case FFEINFO_kindtypeINTEGER7:
*cptr = source_array.integer7;
*size = sizeof (*source_array.integer7);
break;
#endif
#if FFETARGET_okINTEGER8
case FFEINFO_kindtypeINTEGER8:
*cptr = source_array.integer8;
*size = sizeof (*source_array.integer8);
break;
#endif
default:
assert ("bad INTEGER ckindtype" == NULL);
break;
}
break;
case FFEINFO_basictypeLOGICAL:
switch (ckt)
{
#if FFETARGET_okLOGICAL1
case FFEINFO_kindtypeLOGICAL1:
*cptr = source_array.logical1;
*size = sizeof (*source_array.logical1);
break;
#endif
#if FFETARGET_okLOGICAL2
case FFEINFO_kindtypeLOGICAL2:
*cptr = source_array.logical2;
*size = sizeof (*source_array.logical2);
break;
#endif
#if FFETARGET_okLOGICAL3
case FFEINFO_kindtypeLOGICAL3:
*cptr = source_array.logical3;
*size = sizeof (*source_array.logical3);
break;
#endif
#if FFETARGET_okLOGICAL4
case FFEINFO_kindtypeLOGICAL4:
*cptr = source_array.logical4;
*size = sizeof (*source_array.logical4);
break;
#endif
#if FFETARGET_okLOGICAL5
case FFEINFO_kindtypeLOGICAL5:
*cptr = source_array.logical5;
*size = sizeof (*source_array.logical5);
break;
#endif
#if FFETARGET_okLOGICAL6
case FFEINFO_kindtypeLOGICAL6:
*cptr = source_array.logical6;
*size = sizeof (*source_array.logical6);
break;
#endif
#if FFETARGET_okLOGICAL7
case FFEINFO_kindtypeLOGICAL7:
*cptr = source_array.logical7;
*size = sizeof (*source_array.logical7);
break;
#endif
#if FFETARGET_okLOGICAL8
case FFEINFO_kindtypeLOGICAL8:
*cptr = source_array.logical8;
*size = sizeof (*source_array.logical8);
break;
#endif
default:
assert ("bad LOGICAL ckindtype" == NULL);
break;
}
break;
case FFEINFO_basictypeREAL:
switch (ckt)
{
#if FFETARGET_okREAL1
case FFEINFO_kindtypeREAL1:
*cptr = source_array.real1;
*size = sizeof (*source_array.real1);
break;
#endif
#if FFETARGET_okREAL2
case FFEINFO_kindtypeREAL2:
*cptr = source_array.real2;
*size = sizeof (*source_array.real2);
break;
#endif
#if FFETARGET_okREAL3
case FFEINFO_kindtypeREAL3:
*cptr = source_array.real3;
*size = sizeof (*source_array.real3);
break;
#endif
#if FFETARGET_okREAL4
case FFEINFO_kindtypeREAL4:
*cptr = source_array.real4;
*size = sizeof (*source_array.real4);
break;
#endif
#if FFETARGET_okREAL5
case FFEINFO_kindtypeREAL5:
*cptr = source_array.real5;
*size = sizeof (*source_array.real5);
break;
#endif
#if FFETARGET_okREAL6
case FFEINFO_kindtypeREAL6:
*cptr = source_array.real6;
*size = sizeof (*source_array.real6);
break;
#endif
#if FFETARGET_okREAL7
case FFEINFO_kindtypeREAL7:
*cptr = source_array.real7;
*size = sizeof (*source_array.real7);
break;
#endif
#if FFETARGET_okREAL8
case FFEINFO_kindtypeREAL8:
*cptr = source_array.real8;
*size = sizeof (*source_array.real8);
break;
#endif
default:
assert ("bad REAL ckindtype" == NULL);
break;
}
break;
case FFEINFO_basictypeCOMPLEX:
switch (ckt)
{
#if FFETARGET_okCOMPLEX1
case FFEINFO_kindtypeREAL1:
*cptr = source_array.complex1;
*size = sizeof (*source_array.complex1);
break;
#endif
#if FFETARGET_okCOMPLEX2
case FFEINFO_kindtypeREAL2:
*cptr = source_array.complex2;
*size = sizeof (*source_array.complex2);
break;
#endif
#if FFETARGET_okCOMPLEX3
case FFEINFO_kindtypeREAL3:
*cptr = source_array.complex3;
*size = sizeof (*source_array.complex3);
break;
#endif
#if FFETARGET_okCOMPLEX4
case FFEINFO_kindtypeREAL4:
*cptr = source_array.complex4;
*size = sizeof (*source_array.complex4);
break;
#endif
#if FFETARGET_okCOMPLEX5
case FFEINFO_kindtypeREAL5:
*cptr = source_array.complex5;
*size = sizeof (*source_array.complex5);
break;
#endif
#if FFETARGET_okCOMPLEX6
case FFEINFO_kindtypeREAL6:
*cptr = source_array.complex6;
*size = sizeof (*source_array.complex6);
break;
#endif
#if FFETARGET_okCOMPLEX7
case FFEINFO_kindtypeREAL7:
*cptr = source_array.complex7;
*size = sizeof (*source_array.complex7);
break;
#endif
#if FFETARGET_okCOMPLEX8
case FFEINFO_kindtypeREAL8:
*cptr = source_array.complex8;
*size = sizeof (*source_array.complex8);
break;
#endif
default:
assert ("bad COMPLEX ckindtype" == NULL);
break;
}
break;
case FFEINFO_basictypeCHARACTER:
switch (ckt)
{
#if FFETARGET_okCHARACTER1
case FFEINFO_kindtypeCHARACTER1:
*cptr = source_array.character1;
*size = sizeof (*source_array.character1);
break;
#endif
#if FFETARGET_okCHARACTER2
case FFEINFO_kindtypeCHARACTER2:
*cptr = source_array.character2;
*size = sizeof (*source_array.character2);
break;
#endif
#if FFETARGET_okCHARACTER3
case FFEINFO_kindtypeCHARACTER3:
*cptr = source_array.character3;
*size = sizeof (*source_array.character3);
break;
#endif
#if FFETARGET_okCHARACTER4
case FFEINFO_kindtypeCHARACTER4:
*cptr = source_array.character4;
*size = sizeof (*source_array.character4);
break;
#endif
#if FFETARGET_okCHARACTER5
case FFEINFO_kindtypeCHARACTER5:
*cptr = source_array.character5;
*size = sizeof (*source_array.character5);
break;
#endif
#if FFETARGET_okCHARACTER6
case FFEINFO_kindtypeCHARACTER6:
*cptr = source_array.character6;
*size = sizeof (*source_array.character6);
break;
#endif
#if FFETARGET_okCHARACTER7
case FFEINFO_kindtypeCHARACTER7:
*cptr = source_array.character7;
*size = sizeof (*source_array.character7);
break;
#endif
#if FFETARGET_okCHARACTER8
case FFEINFO_kindtypeCHARACTER8:
*cptr = source_array.character8;
*size = sizeof (*source_array.character8);
break;
#endif
default:
assert ("bad CHARACTER ckindtype" == NULL);
break;
}
break;
default:
assert ("bad cbasictype" == NULL);
break;
}
}
/* ffebld_constantarray_prepare -- Prepare for copy between value and array
See prototype.
Like _put, but just returns the pointers to the beginnings of the
array and the constant and returns the size (the amount of info to
copy). The idea is that the caller can use memcpy to accomplish the
same thing as _put (though slower), or the caller can use a different
function that swaps bytes, words, etc for a different target machine.
Also, the type of the array may be different from the type of the
constant; the array type is used to determine the meaning (scale) of
the offset field (to calculate the array pointer), the constant type is
used to determine the constant pointer and the size (amount of info to
copy). */
void
ffebld_constantarray_prepare (void **aptr, void **cptr, size_t *size,
ffebldConstantArray array, ffeinfoBasictype abt, ffeinfoKindtype akt,
ffetargetOffset offset, ffebldConstantUnion *constant,
ffeinfoBasictype cbt, ffeinfoKindtype ckt)
{
switch (abt)
{
case FFEINFO_basictypeINTEGER:
switch (akt)
{
#if FFETARGET_okINTEGER1
case FFEINFO_kindtypeINTEGER1:
*aptr = array.integer1 + offset;
break;
#endif
#if FFETARGET_okINTEGER2
case FFEINFO_kindtypeINTEGER2:
*aptr = array.integer2 + offset;
break;
#endif
#if FFETARGET_okINTEGER3
case FFEINFO_kindtypeINTEGER3:
*aptr = array.integer3 + offset;
break;
#endif
#if FFETARGET_okINTEGER4
case FFEINFO_kindtypeINTEGER4:
*aptr = array.integer4 + offset;
break;
#endif
#if FFETARGET_okINTEGER5
case FFEINFO_kindtypeINTEGER5:
*aptr = array.integer5 + offset;
break;
#endif
#if FFETARGET_okINTEGER6
case FFEINFO_kindtypeINTEGER6:
*aptr = array.integer6 + offset;
break;
#endif
#if FFETARGET_okINTEGER7
case FFEINFO_kindtypeINTEGER7:
*aptr = array.integer7 + offset;
break;
#endif
#if FFETARGET_okINTEGER8
case FFEINFO_kindtypeINTEGER8:
*aptr = array.integer8 + offset;
break;
#endif
default:
assert ("bad INTEGER akindtype" == NULL);
break;
}
break;
case FFEINFO_basictypeLOGICAL:
switch (akt)
{
#if FFETARGET_okLOGICAL1
case FFEINFO_kindtypeLOGICAL1:
*aptr = array.logical1 + offset;
break;
#endif
#if FFETARGET_okLOGICAL2
case FFEINFO_kindtypeLOGICAL2:
*aptr = array.logical2 + offset;
break;
#endif
#if FFETARGET_okLOGICAL3
case FFEINFO_kindtypeLOGICAL3:
*aptr = array.logical3 + offset;
break;
#endif
#if FFETARGET_okLOGICAL4
case FFEINFO_kindtypeLOGICAL4:
*aptr = array.logical4 + offset;
break;
#endif
#if FFETARGET_okLOGICAL5
case FFEINFO_kindtypeLOGICAL5:
*aptr = array.logical5 + offset;
break;
#endif
#if FFETARGET_okLOGICAL6
case FFEINFO_kindtypeLOGICAL6:
*aptr = array.logical6 + offset;
break;
#endif
#if FFETARGET_okLOGICAL7
case FFEINFO_kindtypeLOGICAL7:
*aptr = array.logical7 + offset;
break;
#endif
#if FFETARGET_okLOGICAL8
case FFEINFO_kindtypeLOGICAL8:
*aptr = array.logical8 + offset;
break;
#endif
default:
assert ("bad LOGICAL akindtype" == NULL);
break;
}
break;
case FFEINFO_basictypeREAL:
switch (akt)
{
#if FFETARGET_okREAL1
case FFEINFO_kindtypeREAL1:
*aptr = array.real1 + offset;
break;
#endif
#if FFETARGET_okREAL2
case FFEINFO_kindtypeREAL2:
*aptr = array.real2 + offset;
break;
#endif
#if FFETARGET_okREAL3
case FFEINFO_kindtypeREAL3:
*aptr = array.real3 + offset;
break;
#endif
#if FFETARGET_okREAL4
case FFEINFO_kindtypeREAL4:
*aptr = array.real4 + offset;
break;
#endif
#if FFETARGET_okREAL5
case FFEINFO_kindtypeREAL5:
*aptr = array.real5 + offset;
break;
#endif
#if FFETARGET_okREAL6
case FFEINFO_kindtypeREAL6:
*aptr = array.real6 + offset;
break;
#endif
#if FFETARGET_okREAL7
case FFEINFO_kindtypeREAL7:
*aptr = array.real7 + offset;
break;
#endif
#if FFETARGET_okREAL8
case FFEINFO_kindtypeREAL8:
*aptr = array.real8 + offset;
break;
#endif
default:
assert ("bad REAL akindtype" == NULL);
break;
}
break;
case FFEINFO_basictypeCOMPLEX:
switch (akt)
{
#if FFETARGET_okCOMPLEX1
case FFEINFO_kindtypeREAL1:
*aptr = array.complex1 + offset;
break;
#endif
#if FFETARGET_okCOMPLEX2
case FFEINFO_kindtypeREAL2:
*aptr = array.complex2 + offset;
break;
#endif
#if FFETARGET_okCOMPLEX3
case FFEINFO_kindtypeREAL3:
*aptr = array.complex3 + offset;
break;
#endif
#if FFETARGET_okCOMPLEX4
case FFEINFO_kindtypeREAL4:
*aptr = array.complex4 + offset;
break;
#endif
#if FFETARGET_okCOMPLEX5
case FFEINFO_kindtypeREAL5:
*aptr = array.complex5 + offset;
break;
#endif
#if FFETARGET_okCOMPLEX6
case FFEINFO_kindtypeREAL6:
*aptr = array.complex6 + offset;
break;
#endif
#if FFETARGET_okCOMPLEX7
case FFEINFO_kindtypeREAL7:
*aptr = array.complex7 + offset;
break;
#endif
#if FFETARGET_okCOMPLEX8
case FFEINFO_kindtypeREAL8:
*aptr = array.complex8 + offset;
break;
#endif
default:
assert ("bad COMPLEX akindtype" == NULL);
break;
}
break;
case FFEINFO_basictypeCHARACTER:
switch (akt)
{
#if FFETARGET_okCHARACTER1
case FFEINFO_kindtypeCHARACTER1:
*aptr = array.character1 + offset;
break;
#endif
#if FFETARGET_okCHARACTER2
case FFEINFO_kindtypeCHARACTER2:
*aptr = array.character2 + offset;
break;
#endif
#if FFETARGET_okCHARACTER3
case FFEINFO_kindtypeCHARACTER3:
*aptr = array.character3 + offset;
break;
#endif
#if FFETARGET_okCHARACTER4
case FFEINFO_kindtypeCHARACTER4:
*aptr = array.character4 + offset;
break;
#endif
#if FFETARGET_okCHARACTER5
case FFEINFO_kindtypeCHARACTER5:
*aptr = array.character5 + offset;
break;
#endif
#if FFETARGET_okCHARACTER6
case FFEINFO_kindtypeCHARACTER6:
*aptr = array.character6 + offset;
break;
#endif
#if FFETARGET_okCHARACTER7
case FFEINFO_kindtypeCHARACTER7:
*aptr = array.character7 + offset;
break;
#endif
#if FFETARGET_okCHARACTER8
case FFEINFO_kindtypeCHARACTER8:
*aptr = array.character8 + offset;
break;
#endif
default:
assert ("bad CHARACTER akindtype" == NULL);
break;
}
break;
default:
assert ("bad abasictype" == NULL);
break;
}
switch (cbt)
{
case FFEINFO_basictypeINTEGER:
switch (ckt)
{
#if FFETARGET_okINTEGER1
case FFEINFO_kindtypeINTEGER1:
*cptr = &constant->integer1;
*size = sizeof (constant->integer1);
break;
#endif
#if FFETARGET_okINTEGER2
case FFEINFO_kindtypeINTEGER2:
*cptr = &constant->integer2;
*size = sizeof (constant->integer2);
break;
#endif
#if FFETARGET_okINTEGER3
case FFEINFO_kindtypeINTEGER3:
*cptr = &constant->integer3;
*size = sizeof (constant->integer3);
break;
#endif
#if FFETARGET_okINTEGER4
case FFEINFO_kindtypeINTEGER4:
*cptr = &constant->integer4;
*size = sizeof (constant->integer4);
break;
#endif
#if FFETARGET_okINTEGER5
case FFEINFO_kindtypeINTEGER5:
*cptr = &constant->integer5;
*size = sizeof (constant->integer5);
break;
#endif
#if FFETARGET_okINTEGER6
case FFEINFO_kindtypeINTEGER6:
*cptr = &constant->integer6;
*size = sizeof (constant->integer6);
break;
#endif
#if FFETARGET_okINTEGER7
case FFEINFO_kindtypeINTEGER7:
*cptr = &constant->integer7;
*size = sizeof (constant->integer7);
break;
#endif
#if FFETARGET_okINTEGER8
case FFEINFO_kindtypeINTEGER8:
*cptr = &constant->integer8;
*size = sizeof (constant->integer8);
break;
#endif
default:
assert ("bad INTEGER ckindtype" == NULL);
break;
}
break;
case FFEINFO_basictypeLOGICAL:
switch (ckt)
{
#if FFETARGET_okLOGICAL1
case FFEINFO_kindtypeLOGICAL1:
*cptr = &constant->logical1;
*size = sizeof (constant->logical1);
break;
#endif
#if FFETARGET_okLOGICAL2
case FFEINFO_kindtypeLOGICAL2:
*cptr = &constant->logical2;
*size = sizeof (constant->logical2);
break;
#endif
#if FFETARGET_okLOGICAL3
case FFEINFO_kindtypeLOGICAL3:
*cptr = &constant->logical3;
*size = sizeof (constant->logical3);
break;
#endif
#if FFETARGET_okLOGICAL4
case FFEINFO_kindtypeLOGICAL4:
*cptr = &constant->logical4;
*size = sizeof (constant->logical4);
break;
#endif
#if FFETARGET_okLOGICAL5
case FFEINFO_kindtypeLOGICAL5:
*cptr = &constant->logical5;
*size = sizeof (constant->logical5);
break;
#endif
#if FFETARGET_okLOGICAL6
case FFEINFO_kindtypeLOGICAL6:
*cptr = &constant->logical6;
*size = sizeof (constant->logical6);
break;
#endif
#if FFETARGET_okLOGICAL7
case FFEINFO_kindtypeLOGICAL7:
*cptr = &constant->logical7;
*size = sizeof (constant->logical7);
break;
#endif
#if FFETARGET_okLOGICAL8
case FFEINFO_kindtypeLOGICAL8:
*cptr = &constant->logical8;
*size = sizeof (constant->logical8);
break;
#endif
default:
assert ("bad LOGICAL ckindtype" == NULL);
break;
}
break;
case FFEINFO_basictypeREAL:
switch (ckt)
{
#if FFETARGET_okREAL1
case FFEINFO_kindtypeREAL1:
*cptr = &constant->real1;
*size = sizeof (constant->real1);
break;
#endif
#if FFETARGET_okREAL2
case FFEINFO_kindtypeREAL2:
*cptr = &constant->real2;
*size = sizeof (constant->real2);
break;
#endif
#if FFETARGET_okREAL3
case FFEINFO_kindtypeREAL3:
*cptr = &constant->real3;
*size = sizeof (constant->real3);
break;
#endif
#if FFETARGET_okREAL4
case FFEINFO_kindtypeREAL4:
*cptr = &constant->real4;
*size = sizeof (constant->real4);
break;
#endif
#if FFETARGET_okREAL5
case FFEINFO_kindtypeREAL5:
*cptr = &constant->real5;
*size = sizeof (constant->real5);
break;
#endif
#if FFETARGET_okREAL6
case FFEINFO_kindtypeREAL6:
*cptr = &constant->real6;
*size = sizeof (constant->real6);
break;
#endif
#if FFETARGET_okREAL7
case FFEINFO_kindtypeREAL7:
*cptr = &constant->real7;
*size = sizeof (constant->real7);
break;
#endif
#if FFETARGET_okREAL8
case FFEINFO_kindtypeREAL8:
*cptr = &constant->real8;
*size = sizeof (constant->real8);
break;
#endif
default:
assert ("bad REAL ckindtype" == NULL);
break;
}
break;
case FFEINFO_basictypeCOMPLEX:
switch (ckt)
{
#if FFETARGET_okCOMPLEX1
case FFEINFO_kindtypeREAL1:
*cptr = &constant->complex1;
*size = sizeof (constant->complex1);
break;
#endif
#if FFETARGET_okCOMPLEX2
case FFEINFO_kindtypeREAL2:
*cptr = &constant->complex2;
*size = sizeof (constant->complex2);
break;
#endif
#if FFETARGET_okCOMPLEX3
case FFEINFO_kindtypeREAL3:
*cptr = &constant->complex3;
*size = sizeof (constant->complex3);
break;
#endif
#if FFETARGET_okCOMPLEX4
case FFEINFO_kindtypeREAL4:
*cptr = &constant->complex4;
*size = sizeof (constant->complex4);
break;
#endif
#if FFETARGET_okCOMPLEX5
case FFEINFO_kindtypeREAL5:
*cptr = &constant->complex5;
*size = sizeof (constant->complex5);
break;
#endif
#if FFETARGET_okCOMPLEX6
case FFEINFO_kindtypeREAL6:
*cptr = &constant->complex6;
*size = sizeof (constant->complex6);
break;
#endif
#if FFETARGET_okCOMPLEX7
case FFEINFO_kindtypeREAL7:
*cptr = &constant->complex7;
*size = sizeof (constant->complex7);
break;
#endif
#if FFETARGET_okCOMPLEX8
case FFEINFO_kindtypeREAL8:
*cptr = &constant->complex8;
*size = sizeof (constant->complex8);
break;
#endif
default:
assert ("bad COMPLEX ckindtype" == NULL);
break;
}
break;
case FFEINFO_basictypeCHARACTER:
switch (ckt)
{
#if FFETARGET_okCHARACTER1
case FFEINFO_kindtypeCHARACTER1:
*cptr = ffetarget_text_character1 (constant->character1);
*size = ffetarget_length_character1 (constant->character1);
break;
#endif
#if FFETARGET_okCHARACTER2
case FFEINFO_kindtypeCHARACTER2:
*cptr = ffetarget_text_character2 (constant->character2);
*size = ffetarget_length_character2 (constant->character2);
break;
#endif
#if FFETARGET_okCHARACTER3
case FFEINFO_kindtypeCHARACTER3:
*cptr = ffetarget_text_character3 (constant->character3);
*size = ffetarget_length_character3 (constant->character3);
break;
#endif
#if FFETARGET_okCHARACTER4
case FFEINFO_kindtypeCHARACTER4:
*cptr = ffetarget_text_character4 (constant->character4);
*size = ffetarget_length_character4 (constant->character4);
break;
#endif
#if FFETARGET_okCHARACTER5
case FFEINFO_kindtypeCHARACTER5:
*cptr = ffetarget_text_character5 (constant->character5);
*size = ffetarget_length_character5 (constant->character5);
break;
#endif
#if FFETARGET_okCHARACTER6
case FFEINFO_kindtypeCHARACTER6:
*cptr = ffetarget_text_character6 (constant->character6);
*size = ffetarget_length_character6 (constant->character6);
break;
#endif
#if FFETARGET_okCHARACTER7
case FFEINFO_kindtypeCHARACTER7:
*cptr = ffetarget_text_character7 (constant->character7);
*size = ffetarget_length_character7 (constant->character7);
break;
#endif
#if FFETARGET_okCHARACTER8
case FFEINFO_kindtypeCHARACTER8:
*cptr = ffetarget_text_character8 (constant->character8);
*size = ffetarget_length_character8 (constant->character8);
break;
#endif
default:
assert ("bad CHARACTER ckindtype" == NULL);
break;
}
break;
default:
assert ("bad cbasictype" == NULL);
break;
}
}
/* ffebld_constantarray_put -- Put a value into an array of constants
See prototype. */
void
ffebld_constantarray_put (ffebldConstantArray array, ffeinfoBasictype bt,
ffeinfoKindtype kt, ffetargetOffset offset, ffebldConstantUnion constant)
{
switch (bt)
{
case FFEINFO_basictypeINTEGER:
switch (kt)
{
#if FFETARGET_okINTEGER1
case FFEINFO_kindtypeINTEGER1:
*(array.integer1 + offset) = constant.integer1;
break;
#endif
#if FFETARGET_okINTEGER2
case FFEINFO_kindtypeINTEGER2:
*(array.integer2 + offset) = constant.integer2;
break;
#endif
#if FFETARGET_okINTEGER3
case FFEINFO_kindtypeINTEGER3:
*(array.integer3 + offset) = constant.integer3;
break;
#endif
#if FFETARGET_okINTEGER4
case FFEINFO_kindtypeINTEGER4:
*(array.integer4 + offset) = constant.integer4;
break;
#endif
#if FFETARGET_okINTEGER5
case FFEINFO_kindtypeINTEGER5:
*(array.integer5 + offset) = constant.integer5;
break;
#endif
#if FFETARGET_okINTEGER6
case FFEINFO_kindtypeINTEGER6:
*(array.integer6 + offset) = constant.integer6;
break;
#endif
#if FFETARGET_okINTEGER7
case FFEINFO_kindtypeINTEGER7:
*(array.integer7 + offset) = constant.integer7;
break;
#endif
#if FFETARGET_okINTEGER8
case FFEINFO_kindtypeINTEGER8:
*(array.integer8 + offset) = constant.integer8;
break;
#endif
default:
assert ("bad INTEGER kindtype" == NULL);
break;
}
break;
case FFEINFO_basictypeLOGICAL:
switch (kt)
{
#if FFETARGET_okLOGICAL1
case FFEINFO_kindtypeLOGICAL1:
*(array.logical1 + offset) = constant.logical1;
break;
#endif
#if FFETARGET_okLOGICAL2
case FFEINFO_kindtypeLOGICAL2:
*(array.logical2 + offset) = constant.logical2;
break;
#endif
#if FFETARGET_okLOGICAL3
case FFEINFO_kindtypeLOGICAL3:
*(array.logical3 + offset) = constant.logical3;
break;
#endif
#if FFETARGET_okLOGICAL4
case FFEINFO_kindtypeLOGICAL4:
*(array.logical4 + offset) = constant.logical4;
break;
#endif
#if FFETARGET_okLOGICAL5
case FFEINFO_kindtypeLOGICAL5:
*(array.logical5 + offset) = constant.logical5;
break;
#endif
#if FFETARGET_okLOGICAL6
case FFEINFO_kindtypeLOGICAL6:
*(array.logical6 + offset) = constant.logical6;
break;
#endif
#if FFETARGET_okLOGICAL7
case FFEINFO_kindtypeLOGICAL7:
*(array.logical7 + offset) = constant.logical7;
break;
#endif
#if FFETARGET_okLOGICAL8
case FFEINFO_kindtypeLOGICAL8:
*(array.logical8 + offset) = constant.logical8;
break;
#endif
default:
assert ("bad LOGICAL kindtype" == NULL);
break;
}
break;
case FFEINFO_basictypeREAL:
switch (kt)
{
#if FFETARGET_okREAL1
case FFEINFO_kindtypeREAL1:
*(array.real1 + offset) = constant.real1;
break;
#endif
#if FFETARGET_okREAL2
case FFEINFO_kindtypeREAL2:
*(array.real2 + offset) = constant.real2;
break;
#endif
#if FFETARGET_okREAL3
case FFEINFO_kindtypeREAL3:
*(array.real3 + offset) = constant.real3;
break;
#endif
#if FFETARGET_okREAL4
case FFEINFO_kindtypeREAL4:
*(array.real4 + offset) = constant.real4;
break;
#endif
#if FFETARGET_okREAL5
case FFEINFO_kindtypeREAL5:
*(array.real5 + offset) = constant.real5;
break;
#endif
#if FFETARGET_okREAL6
case FFEINFO_kindtypeREAL6:
*(array.real6 + offset) = constant.real6;
break;
#endif
#if FFETARGET_okREAL7
case FFEINFO_kindtypeREAL7:
*(array.real7 + offset) = constant.real7;
break;
#endif
#if FFETARGET_okREAL8
case FFEINFO_kindtypeREAL8:
*(array.real8 + offset) = constant.real8;
break;
#endif
default:
assert ("bad REAL kindtype" == NULL);
break;
}
break;
case FFEINFO_basictypeCOMPLEX:
switch (kt)
{
#if FFETARGET_okCOMPLEX1
case FFEINFO_kindtypeREAL1:
*(array.complex1 + offset) = constant.complex1;
break;
#endif
#if FFETARGET_okCOMPLEX2
case FFEINFO_kindtypeREAL2:
*(array.complex2 + offset) = constant.complex2;
break;
#endif
#if FFETARGET_okCOMPLEX3
case FFEINFO_kindtypeREAL3:
*(array.complex3 + offset) = constant.complex3;
break;
#endif
#if FFETARGET_okCOMPLEX4
case FFEINFO_kindtypeREAL4:
*(array.complex4 + offset) = constant.complex4;
break;
#endif
#if FFETARGET_okCOMPLEX5
case FFEINFO_kindtypeREAL5:
*(array.complex5 + offset) = constant.complex5;
break;
#endif
#if FFETARGET_okCOMPLEX6
case FFEINFO_kindtypeREAL6:
*(array.complex6 + offset) = constant.complex6;
break;
#endif
#if FFETARGET_okCOMPLEX7
case FFEINFO_kindtypeREAL7:
*(array.complex7 + offset) = constant.complex7;
break;
#endif
#if FFETARGET_okCOMPLEX8
case FFEINFO_kindtypeREAL8:
*(array.complex8 + offset) = constant.complex8;
break;
#endif
default:
assert ("bad COMPLEX kindtype" == NULL);
break;
}
break;
case FFEINFO_basictypeCHARACTER:
switch (kt)
{
#if FFETARGET_okCHARACTER1
case FFEINFO_kindtypeCHARACTER1:
memcpy (array.character1 + offset,
ffetarget_text_character1 (constant.character1),
ffetarget_length_character1 (constant.character1));
break;
#endif
#if FFETARGET_okCHARACTER2
case FFEINFO_kindtypeCHARACTER2:
memcpy (array.character2 + offset,
ffetarget_text_character2 (constant.character2),
ffetarget_length_character2 (constant.character2));
break;
#endif
#if FFETARGET_okCHARACTER3
case FFEINFO_kindtypeCHARACTER3:
memcpy (array.character3 + offset,
ffetarget_text_character3 (constant.character3),
ffetarget_length_character3 (constant.character3));
break;
#endif
#if FFETARGET_okCHARACTER4
case FFEINFO_kindtypeCHARACTER4:
memcpy (array.character4 + offset,
ffetarget_text_character4 (constant.character4),
ffetarget_length_character4 (constant.character4));
break;
#endif
#if FFETARGET_okCHARACTER5
case FFEINFO_kindtypeCHARACTER5:
memcpy (array.character5 + offset,
ffetarget_text_character5 (constant.character5),
ffetarget_length_character5 (constant.character5));
break;
#endif
#if FFETARGET_okCHARACTER6
case FFEINFO_kindtypeCHARACTER6:
memcpy (array.character6 + offset,
ffetarget_text_character6 (constant.character6),
ffetarget_length_character6 (constant.character6));
break;
#endif
#if FFETARGET_okCHARACTER7
case FFEINFO_kindtypeCHARACTER7:
memcpy (array.character7 + offset,
ffetarget_text_character7 (constant.character7),
ffetarget_length_character7 (constant.character7));
break;
#endif
#if FFETARGET_okCHARACTER8
case FFEINFO_kindtypeCHARACTER8:
memcpy (array.character8 + offset,
ffetarget_text_character8 (constant.character8),
ffetarget_length_character8 (constant.character8));
break;
#endif
default:
assert ("bad CHARACTER kindtype" == NULL);
break;
}
break;
default:
assert ("bad basictype" == NULL);
break;
}
}
/* ffebld_constantunion_dump -- Dump a constant
See prototype. */
#if FFECOM_targetCURRENT == FFECOM_targetFFE
void
ffebld_constantunion_dump (ffebldConstantUnion u, ffeinfoBasictype bt,
ffeinfoKindtype kt)
{
switch (bt)
{
case FFEINFO_basictypeINTEGER:
switch (kt)
{
#if FFETARGET_okINTEGER1
case FFEINFO_kindtypeINTEGER1:
ffetarget_print_integer1 (dmpout, u.integer1);
break;
#endif
#if FFETARGET_okINTEGER2
case FFEINFO_kindtypeINTEGER2:
ffetarget_print_integer2 (dmpout, u.integer2);
break;
#endif
#if FFETARGET_okINTEGER3
case FFEINFO_kindtypeINTEGER3:
ffetarget_print_integer3 (dmpout, u.integer3);
break;
#endif
#if FFETARGET_okINTEGER4
case FFEINFO_kindtypeINTEGER4:
ffetarget_print_integer4 (dmpout, u.integer4);
break;
#endif
#if FFETARGET_okINTEGER5
case FFEINFO_kindtypeINTEGER5:
ffetarget_print_integer5 (dmpout, u.integer5);
break;
#endif
#if FFETARGET_okINTEGER6
case FFEINFO_kindtypeINTEGER6:
ffetarget_print_integer6 (dmpout, u.integer6);
break;
#endif
#if FFETARGET_okINTEGER7
case FFEINFO_kindtypeINTEGER7:
ffetarget_print_integer7 (dmpout, u.integer7);
break;
#endif
#if FFETARGET_okINTEGER8
case FFEINFO_kindtypeINTEGER8:
ffetarget_print_integer8 (dmpout, u.integer8);
break;
#endif
default:
assert ("bad INTEGER kindtype" == NULL);
break;
}
break;
case FFEINFO_basictypeLOGICAL:
switch (kt)
{
#if FFETARGET_okLOGICAL1
case FFEINFO_kindtypeLOGICAL1:
ffetarget_print_logical1 (dmpout, u.logical1);
break;
#endif
#if FFETARGET_okLOGICAL2
case FFEINFO_kindtypeLOGICAL2:
ffetarget_print_logical2 (dmpout, u.logical2);
break;
#endif
#if FFETARGET_okLOGICAL3
case FFEINFO_kindtypeLOGICAL3:
ffetarget_print_logical3 (dmpout, u.logical3);
break;
#endif
#if FFETARGET_okLOGICAL4
case FFEINFO_kindtypeLOGICAL4:
ffetarget_print_logical4 (dmpout, u.logical4);
break;
#endif
#if FFETARGET_okLOGICAL5
case FFEINFO_kindtypeLOGICAL5:
ffetarget_print_logical5 (dmpout, u.logical5);
break;
#endif
#if FFETARGET_okLOGICAL6
case FFEINFO_kindtypeLOGICAL6:
ffetarget_print_logical6 (dmpout, u.logical6);
break;
#endif
#if FFETARGET_okLOGICAL7
case FFEINFO_kindtypeLOGICAL7:
ffetarget_print_logical7 (dmpout, u.logical7);
break;
#endif
#if FFETARGET_okLOGICAL8
case FFEINFO_kindtypeLOGICAL8:
ffetarget_print_logical8 (dmpout, u.logical8);
break;
#endif
default:
assert ("bad LOGICAL kindtype" == NULL);
break;
}
break;
case FFEINFO_basictypeREAL:
switch (kt)
{
#if FFETARGET_okREAL1
case FFEINFO_kindtypeREAL1:
ffetarget_print_real1 (dmpout, u.real1);
break;
#endif
#if FFETARGET_okREAL2
case FFEINFO_kindtypeREAL2:
ffetarget_print_real2 (dmpout, u.real2);
break;
#endif
#if FFETARGET_okREAL3
case FFEINFO_kindtypeREAL3:
ffetarget_print_real3 (dmpout, u.real3);
break;
#endif
#if FFETARGET_okREAL4
case FFEINFO_kindtypeREAL4:
ffetarget_print_real4 (dmpout, u.real4);
break;
#endif
#if FFETARGET_okREAL5
case FFEINFO_kindtypeREAL5:
ffetarget_print_real5 (dmpout, u.real5);
break;
#endif
#if FFETARGET_okREAL6
case FFEINFO_kindtypeREAL6:
ffetarget_print_real6 (dmpout, u.real6);
break;
#endif
#if FFETARGET_okREAL7
case FFEINFO_kindtypeREAL7:
ffetarget_print_real7 (dmpout, u.real7);
break;
#endif
#if FFETARGET_okREAL8
case FFEINFO_kindtypeREAL8:
ffetarget_print_real8 (dmpout, u.real8);
break;
#endif
default:
assert ("bad REAL kindtype" == NULL);
break;
}
break;
case FFEINFO_basictypeCOMPLEX:
switch (kt)
{
#if FFETARGET_okCOMPLEX1
case FFEINFO_kindtypeREAL1:
fprintf (dmpout, "(");
ffetarget_print_real1 (dmpout, u.complex1.real);
fprintf (dmpout, ",");
ffetarget_print_real1 (dmpout, u.complex1.imaginary);
fprintf (dmpout, ")");
break;
#endif
#if FFETARGET_okCOMPLEX2
case FFEINFO_kindtypeREAL2:
fprintf (dmpout, "(");
ffetarget_print_real2 (dmpout, u.complex2.real);
fprintf (dmpout, ",");
ffetarget_print_real2 (dmpout, u.complex2.imaginary);
fprintf (dmpout, ")");
break;
#endif
#if FFETARGET_okCOMPLEX3
case FFEINFO_kindtypeREAL3:
fprintf (dmpout, "(");
ffetarget_print_real3 (dmpout, u.complex3.real);
fprintf (dmpout, ",");
ffetarget_print_real3 (dmpout, u.complex3.imaginary);
fprintf (dmpout, ")");
break;
#endif
#if FFETARGET_okCOMPLEX4
case FFEINFO_kindtypeREAL4:
fprintf (dmpout, "(");
ffetarget_print_real4 (dmpout, u.complex4.real);
fprintf (dmpout, ",");
ffetarget_print_real4 (dmpout, u.complex4.imaginary);
fprintf (dmpout, ")");
break;
#endif
#if FFETARGET_okCOMPLEX5
case FFEINFO_kindtypeREAL5:
fprintf (dmpout, "(");
ffetarget_print_real5 (dmpout, u.complex5.real);
fprintf (dmpout, ",");
ffetarget_print_real5 (dmpout, u.complex5.imaginary);
fprintf (dmpout, ")");
break;
#endif
#if FFETARGET_okCOMPLEX6
case FFEINFO_kindtypeREAL6:
fprintf (dmpout, "(");
ffetarget_print_real6 (dmpout, u.complex6.real);
fprintf (dmpout, ",");
ffetarget_print_real6 (dmpout, u.complex6.imaginary);
fprintf (dmpout, ")");
break;
#endif
#if FFETARGET_okCOMPLEX7
case FFEINFO_kindtypeREAL7:
fprintf (dmpout, "(");
ffetarget_print_real7 (dmpout, u.complex7.real);
fprintf (dmpout, ",");
ffetarget_print_real7 (dmpout, u.complex7.imaginary);
fprintf (dmpout, ")");
break;
#endif
#if FFETARGET_okCOMPLEX8
case FFEINFO_kindtypeREAL8:
fprintf (dmpout, "(");
ffetarget_print_real8 (dmpout, u.complex8.real);
fprintf (dmpout, ",");
ffetarget_print_real8 (dmpout, u.complex8.imaginary);
fprintf (dmpout, ")");
break;
#endif
default:
assert ("bad COMPLEX kindtype" == NULL);
break;
}
break;
case FFEINFO_basictypeCHARACTER:
switch (kt)
{
#if FFETARGET_okCHARACTER1
case FFEINFO_kindtypeCHARACTER1:
ffetarget_print_character1 (dmpout, u.character1);
break;
#endif
#if FFETARGET_okCHARACTER2
case FFEINFO_kindtypeCHARACTER2:
ffetarget_print_character2 (dmpout, u.character2);
break;
#endif
#if FFETARGET_okCHARACTER3
case FFEINFO_kindtypeCHARACTER3:
ffetarget_print_character3 (dmpout, u.character3);
break;
#endif
#if FFETARGET_okCHARACTER4
case FFEINFO_kindtypeCHARACTER4:
ffetarget_print_character4 (dmpout, u.character4);
break;
#endif
#if FFETARGET_okCHARACTER5
case FFEINFO_kindtypeCHARACTER5:
ffetarget_print_character5 (dmpout, u.character5);
break;
#endif
#if FFETARGET_okCHARACTER6
case FFEINFO_kindtypeCHARACTER6:
ffetarget_print_character6 (dmpout, u.character6);
break;
#endif
#if FFETARGET_okCHARACTER7
case FFEINFO_kindtypeCHARACTER7:
ffetarget_print_character7 (dmpout, u.character7);
break;
#endif
#if FFETARGET_okCHARACTER8
case FFEINFO_kindtypeCHARACTER8:
ffetarget_print_character8 (dmpout, u.character8);
break;
#endif
default:
assert ("bad CHARACTER kindtype" == NULL);
break;
}
break;
default:
assert ("bad basictype" == NULL);
break;
}
}
#endif
/* ffebld_dump -- Dump expression tree in concise form
ffebld b;
ffebld_dump(b); */
#if FFECOM_targetCURRENT == FFECOM_targetFFE
void
ffebld_dump (ffebld b)
{
ffeinfoKind k;
ffeinfoWhere w;
if (b == NULL)
{
fprintf (dmpout, "(null)");
return;
}
switch (ffebld_op (b))
{
case FFEBLD_opITEM:
fputs ("[", dmpout);
while (b != NULL)
{
ffebld_dump (ffebld_head (b));
if ((b = ffebld_trail (b)) != NULL)
fputs (",", dmpout);
}
fputs ("]", dmpout);
return;
case FFEBLD_opSTAR:
case FFEBLD_opBOUNDS:
case FFEBLD_opREPEAT:
case FFEBLD_opLABTER:
case FFEBLD_opLABTOK:
case FFEBLD_opIMPDO:
fputs (ffebld_op_string (ffebld_op (b)), dmpout);
break;
default:
if (ffeinfo_size (ffebld_info (b)) != FFETARGET_charactersizeNONE)
fprintf (dmpout, "%s%d%s%s*%" ffetargetCharacterSize_f "u",
ffebld_op_string (ffebld_op (b)),
(int) ffeinfo_rank (ffebld_info (b)),
ffeinfo_basictype_string (ffeinfo_basictype (ffebld_info (b))),
ffeinfo_kindtype_string (ffeinfo_kindtype (ffebld_info (b))),
ffeinfo_size (ffebld_info (b)));
else
fprintf (dmpout, "%s%d%s%s", ffebld_op_string (ffebld_op (b)),
(int) ffeinfo_rank (ffebld_info (b)),
ffeinfo_basictype_string (ffeinfo_basictype (ffebld_info (b))),
ffeinfo_kindtype_string (ffeinfo_kindtype (ffebld_info (b))));
if ((k = ffeinfo_kind (ffebld_info (b))) != FFEINFO_kindNONE)
fprintf (dmpout, "/%s", ffeinfo_kind_string (k));
if ((w = ffeinfo_where (ffebld_info (b))) != FFEINFO_whereNONE)
fprintf (dmpout, "@%s", ffeinfo_where_string (w));
break;
}
switch (ffebld_arity (b))
{
case 2:
fputs ("(", dmpout);
ffebld_dump (ffebld_left (b));
fputs (",", dmpout);
ffebld_dump (ffebld_right (b));
fputs (")", dmpout);
break;
case 1:
fputs ("(", dmpout);
ffebld_dump (ffebld_left (b));
fputs (")", dmpout);
break;
default:
switch (ffebld_op (b))
{
case FFEBLD_opCONTER:
fprintf (dmpout, "<");
ffebld_constant_dump (b->u.conter.expr);
fprintf (dmpout, ">");
break;
case FFEBLD_opACCTER:
fprintf (dmpout, "<");
ffebld_constantarray_dump (b->u.accter.array,
ffeinfo_basictype (ffebld_info (b)),
ffeinfo_kindtype (ffebld_info (b)),
ffebit_size (b->u.accter.bits), b->u.accter.bits);
fprintf (dmpout, ">");
break;
case FFEBLD_opARRTER:
fprintf (dmpout, "<");
ffebld_constantarray_dump (b->u.arrter.array,
ffeinfo_basictype (ffebld_info (b)),
ffeinfo_kindtype (ffebld_info (b)),
b->u.arrter.size, NULL);
fprintf (dmpout, ">");
break;
case FFEBLD_opLABTER:
if (b->u.labter == NULL)
fprintf (dmpout, "<>");
else
fprintf (dmpout, "<%" ffelabValue_f "u>", ffelab_value (b->u.labter));
break;
case FFEBLD_opLABTOK:
fprintf (dmpout, "<%s>", ffelex_token_text (b->u.labtok));
break;
case FFEBLD_opSYMTER:
fprintf (dmpout, "<");
ffesymbol_dump (b->u.symter.symbol);
if ((b->u.symter.generic != FFEINTRIN_genNONE)
|| (b->u.symter.specific != FFEINTRIN_specNONE))
fprintf (dmpout, "{%s:%s:%s}",
ffeintrin_name_generic (b->u.symter.generic),
ffeintrin_name_specific (b->u.symter.specific),
ffeintrin_name_implementation (b->u.symter.implementation));
if (b->u.symter.do_iter)
fprintf (dmpout, "{/do-iter}");
fprintf (dmpout, ">");
break;
default:
break;
}
}
}
#endif
/* ffebld_dump_prefix -- Dump the prefix for a constant of a given type
ffebld_dump_prefix(dmpout,FFEINFO_basictypeINTEGER,
FFEINFO_kindtypeINTEGER1); */
#if FFECOM_targetCURRENT == FFECOM_targetFFE
void
ffebld_dump_prefix (FILE *out, ffeinfoBasictype bt, ffeinfoKindtype kt)
{
switch (bt)
{
case FFEINFO_basictypeINTEGER:
switch (kt)
{
#if FFETARGET_okINTEGER1
case FFEINFO_kindtypeINTEGER1:
fprintf (out, "I" STRX (FFETARGET_kindINTEGER1) "/");
break;
#endif
#if FFETARGET_okINTEGER2
case FFEINFO_kindtypeINTEGER2:
fprintf (out, "I" STRX (FFETARGET_kindINTEGER2) "/");
break;
#endif
#if FFETARGET_okINTEGER3
case FFEINFO_kindtypeINTEGER3:
fprintf (out, "I" STRX (FFETARGET_kindINTEGER3) "/");
break;
#endif
#if FFETARGET_okINTEGER4
case FFEINFO_kindtypeINTEGER4:
fprintf (out, "I" STRX (FFETARGET_kindINTEGER4) "/");
break;
#endif
#if FFETARGET_okINTEGER5
case FFEINFO_kindtypeINTEGER5:
fprintf (out, "I" STRX (FFETARGET_kindINTEGER5) "/");
break;
#endif
#if FFETARGET_okINTEGER6
case FFEINFO_kindtypeINTEGER6:
fprintf (out, "I" STRX (FFETARGET_kindINTEGER6) "/");
break;
#endif
#if FFETARGET_okINTEGER7
case FFEINFO_kindtypeINTEGER7:
fprintf (out, "I" STRX (FFETARGET_kindINTEGER7) "/");
break;
#endif
#if FFETARGET_okINTEGER8
case FFEINFO_kindtypeINTEGER8:
fprintf (out, "I" STRX (FFETARGET_kindINTEGER8) "/");
break;
#endif
default:
assert ("bad INTEGER kindtype" == NULL);
break;
}
break;
case FFEINFO_basictypeLOGICAL:
switch (kt)
{
#if FFETARGET_okLOGICAL1
case FFEINFO_kindtypeLOGICAL1:
fprintf (out, "L" STRX (FFETARGET_kindLOGICAL1) "/");
break;
#endif
#if FFETARGET_okLOGICAL2
case FFEINFO_kindtypeLOGICAL2:
fprintf (out, "L" STRX (FFETARGET_kindLOGICAL2) "/");
break;
#endif
#if FFETARGET_okLOGICAL3
case FFEINFO_kindtypeLOGICAL3:
fprintf (out, "L" STRX (FFETARGET_kindLOGICAL3) "/");
break;
#endif
#if FFETARGET_okLOGICAL4
case FFEINFO_kindtypeLOGICAL4:
fprintf (out, "L" STRX (FFETARGET_kindLOGICAL4) "/");
break;
#endif
#if FFETARGET_okLOGICAL5
case FFEINFO_kindtypeLOGICAL5:
fprintf (out, "L" STRX (FFETARGET_kindLOGICAL5) "/");
break;
#endif
#if FFETARGET_okLOGICAL6
case FFEINFO_kindtypeLOGICAL6:
fprintf (out, "L" STRX (FFETARGET_kindLOGICAL6) "/");
break;
#endif
#if FFETARGET_okLOGICAL7
case FFEINFO_kindtypeLOGICAL7:
fprintf (out, "L" STRX (FFETARGET_kindLOGICAL7) "/");
break;
#endif
#if FFETARGET_okLOGICAL8
case FFEINFO_kindtypeLOGICAL8:
fprintf (out, "L" STRX (FFETARGET_kindLOGICAL8) "/");
break;
#endif
default:
assert ("bad LOGICAL kindtype" == NULL);
break;
}
break;
case FFEINFO_basictypeREAL:
switch (kt)
{
#if FFETARGET_okREAL1
case FFEINFO_kindtypeREAL1:
fprintf (out, "R" STRX (FFETARGET_kindREAL1) "/");
break;
#endif
#if FFETARGET_okREAL2
case FFEINFO_kindtypeREAL2:
fprintf (out, "R" STRX (FFETARGET_kindREAL2) "/");
break;
#endif
#if FFETARGET_okREAL3
case FFEINFO_kindtypeREAL3:
fprintf (out, "R" STRX (FFETARGET_kindREAL3) "/");
break;
#endif
#if FFETARGET_okREAL4
case FFEINFO_kindtypeREAL4:
fprintf (out, "R" STRX (FFETARGET_kindREAL4) "/");
break;
#endif
#if FFETARGET_okREAL5
case FFEINFO_kindtypeREAL5:
fprintf (out, "R" STRX (FFETARGET_kindREAL5) "/");
break;
#endif
#if FFETARGET_okREAL6
case FFEINFO_kindtypeREAL6:
fprintf (out, "R" STRX (FFETARGET_kindREAL6) "/");
break;
#endif
#if FFETARGET_okREAL7
case FFEINFO_kindtypeREAL7:
fprintf (out, "R" STRX (FFETARGET_kindREAL7) "/");
break;
#endif
#if FFETARGET_okREAL8
case FFEINFO_kindtypeREAL8:
fprintf (out, "R" STRX (FFETARGET_kindREAL8) "/");
break;
#endif
default:
assert ("bad REAL kindtype" == NULL);
break;
}
break;
case FFEINFO_basictypeCOMPLEX:
switch (kt)
{
#if FFETARGET_okCOMPLEX1
case FFEINFO_kindtypeREAL1:
fprintf (out, "C" STRX (FFETARGET_kindCOMPLEX1) "/");
break;
#endif
#if FFETARGET_okCOMPLEX2
case FFEINFO_kindtypeREAL2:
fprintf (out, "C" STRX (FFETARGET_kindCOMPLEX2) "/");
break;
#endif
#if FFETARGET_okCOMPLEX3
case FFEINFO_kindtypeREAL3:
fprintf (out, "C" STRX (FFETARGET_kindCOMPLEX3) "/");
break;
#endif
#if FFETARGET_okCOMPLEX4
case FFEINFO_kindtypeREAL4:
fprintf (out, "C" STRX (FFETARGET_kindCOMPLEX4) "/");
break;
#endif
#if FFETARGET_okCOMPLEX5
case FFEINFO_kindtypeREAL5:
fprintf (out, "C" STRX (FFETARGET_kindCOMPLEX5) "/");
break;
#endif
#if FFETARGET_okCOMPLEX6
case FFEINFO_kindtypeREAL6:
fprintf (out, "C" STRX (FFETARGET_kindCOMPLEX6) "/");
break;
#endif
#if FFETARGET_okCOMPLEX7
case FFEINFO_kindtypeREAL7:
fprintf (out, "C" STRX (FFETARGET_kindCOMPLEX7) "/");
break;
#endif
#if FFETARGET_okCOMPLEX8
case FFEINFO_kindtypeREAL8:
fprintf (out, "C" STRX (FFETARGET_kindCOMPLEX8) "/");
break;
#endif
default:
assert ("bad COMPLEX kindtype" == NULL);
break;
}
break;
case FFEINFO_basictypeCHARACTER:
switch (kt)
{
#if FFETARGET_okCHARACTER1
case FFEINFO_kindtypeCHARACTER1:
fprintf (out, "A" STRX (FFETARGET_kindCHARACTER1) "/");
break;
#endif
#if FFETARGET_okCHARACTER2
case FFEINFO_kindtypeCHARACTER2:
fprintf (out, "A" STRX (FFETARGET_kindCHARACTER2) "/");
break;
#endif
#if FFETARGET_okCHARACTER3
case FFEINFO_kindtypeCHARACTER3:
fprintf (out, "A" STRX (FFETARGET_kindCHARACTER3) "/");
break;
#endif
#if FFETARGET_okCHARACTER4
case FFEINFO_kindtypeCHARACTER4:
fprintf (out, "A" STRX (FFETARGET_kindCHARACTER4) "/");
break;
#endif
#if FFETARGET_okCHARACTER5
case FFEINFO_kindtypeCHARACTER5:
fprintf (out, "A" STRX (FFETARGET_kindCHARACTER5) "/");
break;
#endif
#if FFETARGET_okCHARACTER6
case FFEINFO_kindtypeCHARACTER6:
fprintf (out, "A" STRX (FFETARGET_kindCHARACTER6) "/");
break;
#endif
#if FFETARGET_okCHARACTER7
case FFEINFO_kindtypeCHARACTER7:
fprintf (out, "A" STRX (FFETARGET_kindCHARACTER7) "/");
break;
#endif
#if FFETARGET_okCHARACTER8
case FFEINFO_kindtypeCHARACTER8:
fprintf (out, "A" STRX (FFETARGET_kindCHARACTER8) "/");
break;
#endif
default:
assert ("bad CHARACTER kindtype" == NULL);
break;
}
break;
default:
assert ("bad basictype" == NULL);
fprintf (out, "?/?");
break;
}
}
#endif
/* ffebld_init_0 -- Initialize the module
ffebld_init_0(); */
void
ffebld_init_0 ()
{
assert (FFEBLD_op == ARRAY_SIZE (ffebld_op_string_));
assert (FFEBLD_op == ARRAY_SIZE (ffebld_arity_op_));
}
/* ffebld_init_1 -- Initialize the module for a file
ffebld_init_1(); */
void
ffebld_init_1 ()
{
#if FFEBLD_whereconstCURRENT_ == FFEBLD_whereconstFILE_
int i;
#if FFETARGET_okCHARACTER1
ffebld_constant_character1_ = NULL;
#endif
#if FFETARGET_okCHARACTER2
ffebld_constant_character2_ = NULL;
#endif
#if FFETARGET_okCHARACTER3
ffebld_constant_character3_ = NULL;
#endif
#if FFETARGET_okCHARACTER4
ffebld_constant_character4_ = NULL;
#endif
#if FFETARGET_okCHARACTER5
ffebld_constant_character5_ = NULL;
#endif
#if FFETARGET_okCHARACTER6
ffebld_constant_character6_ = NULL;
#endif
#if FFETARGET_okCHARACTER7
ffebld_constant_character7_ = NULL;
#endif
#if FFETARGET_okCHARACTER8
ffebld_constant_character8_ = NULL;
#endif
#if FFETARGET_okCOMPLEX1
ffebld_constant_complex1_ = NULL;
#endif
#if FFETARGET_okCOMPLEX2
ffebld_constant_complex2_ = NULL;
#endif
#if FFETARGET_okCOMPLEX3
ffebld_constant_complex3_ = NULL;
#endif
#if FFETARGET_okCOMPLEX4
ffebld_constant_complex4_ = NULL;
#endif
#if FFETARGET_okCOMPLEX5
ffebld_constant_complex5_ = NULL;
#endif
#if FFETARGET_okCOMPLEX6
ffebld_constant_complex6_ = NULL;
#endif
#if FFETARGET_okCOMPLEX7
ffebld_constant_complex7_ = NULL;
#endif
#if FFETARGET_okCOMPLEX8
ffebld_constant_complex8_ = NULL;
#endif
#if FFETARGET_okINTEGER1
ffebld_constant_integer1_ = NULL;
#endif
#if FFETARGET_okINTEGER2
ffebld_constant_integer2_ = NULL;
#endif
#if FFETARGET_okINTEGER3
ffebld_constant_integer3_ = NULL;
#endif
#if FFETARGET_okINTEGER4
ffebld_constant_integer4_ = NULL;
#endif
#if FFETARGET_okINTEGER5
ffebld_constant_integer5_ = NULL;
#endif
#if FFETARGET_okINTEGER6
ffebld_constant_integer6_ = NULL;
#endif
#if FFETARGET_okINTEGER7
ffebld_constant_integer7_ = NULL;
#endif
#if FFETARGET_okINTEGER8
ffebld_constant_integer8_ = NULL;
#endif
#if FFETARGET_okLOGICAL1
ffebld_constant_logical1_ = NULL;
#endif
#if FFETARGET_okLOGICAL2
ffebld_constant_logical2_ = NULL;
#endif
#if FFETARGET_okLOGICAL3
ffebld_constant_logical3_ = NULL;
#endif
#if FFETARGET_okLOGICAL4
ffebld_constant_logical4_ = NULL;
#endif
#if FFETARGET_okLOGICAL5
ffebld_constant_logical5_ = NULL;
#endif
#if FFETARGET_okLOGICAL6
ffebld_constant_logical6_ = NULL;
#endif
#if FFETARGET_okLOGICAL7
ffebld_constant_logical7_ = NULL;
#endif
#if FFETARGET_okLOGICAL8
ffebld_constant_logical8_ = NULL;
#endif
#if FFETARGET_okREAL1
ffebld_constant_real1_ = NULL;
#endif
#if FFETARGET_okREAL2
ffebld_constant_real2_ = NULL;
#endif
#if FFETARGET_okREAL3
ffebld_constant_real3_ = NULL;
#endif
#if FFETARGET_okREAL4
ffebld_constant_real4_ = NULL;
#endif
#if FFETARGET_okREAL5
ffebld_constant_real5_ = NULL;
#endif
#if FFETARGET_okREAL6
ffebld_constant_real6_ = NULL;
#endif
#if FFETARGET_okREAL7
ffebld_constant_real7_ = NULL;
#endif
#if FFETARGET_okREAL8
ffebld_constant_real8_ = NULL;
#endif
ffebld_constant_hollerith_ = NULL;
for (i = FFEBLD_constTYPELESS_FIRST; i <= FFEBLD_constTYPELESS_LAST; ++i)
ffebld_constant_typeless_[i - FFEBLD_constTYPELESS_FIRST] = NULL;
#endif
}
/* ffebld_init_2 -- Initialize the module
ffebld_init_2(); */
void
ffebld_init_2 ()
{
#if FFEBLD_whereconstCURRENT_ == FFEBLD_whereconstPROGUNIT_
int i;
#endif
ffebld_pool_stack_.next = NULL;
ffebld_pool_stack_.pool = ffe_pool_program_unit ();
#if FFEBLD_whereconstCURRENT_ == FFEBLD_whereconstPROGUNIT_
#if FFETARGET_okCHARACTER1
ffebld_constant_character1_ = NULL;
#endif
#if FFETARGET_okCHARACTER2
ffebld_constant_character2_ = NULL;
#endif
#if FFETARGET_okCHARACTER3
ffebld_constant_character3_ = NULL;
#endif
#if FFETARGET_okCHARACTER4
ffebld_constant_character4_ = NULL;
#endif
#if FFETARGET_okCHARACTER5
ffebld_constant_character5_ = NULL;
#endif
#if FFETARGET_okCHARACTER6
ffebld_constant_character6_ = NULL;
#endif
#if FFETARGET_okCHARACTER7
ffebld_constant_character7_ = NULL;
#endif
#if FFETARGET_okCHARACTER8
ffebld_constant_character8_ = NULL;
#endif
#if FFETARGET_okCOMPLEX1
ffebld_constant_complex1_ = NULL;
#endif
#if FFETARGET_okCOMPLEX2
ffebld_constant_complex2_ = NULL;
#endif
#if FFETARGET_okCOMPLEX3
ffebld_constant_complex3_ = NULL;
#endif
#if FFETARGET_okCOMPLEX4
ffebld_constant_complex4_ = NULL;
#endif
#if FFETARGET_okCOMPLEX5
ffebld_constant_complex5_ = NULL;
#endif
#if FFETARGET_okCOMPLEX6
ffebld_constant_complex6_ = NULL;
#endif
#if FFETARGET_okCOMPLEX7
ffebld_constant_complex7_ = NULL;
#endif
#if FFETARGET_okCOMPLEX8
ffebld_constant_complex8_ = NULL;
#endif
#if FFETARGET_okINTEGER1
ffebld_constant_integer1_ = NULL;
#endif
#if FFETARGET_okINTEGER2
ffebld_constant_integer2_ = NULL;
#endif
#if FFETARGET_okINTEGER3
ffebld_constant_integer3_ = NULL;
#endif
#if FFETARGET_okINTEGER4
ffebld_constant_integer4_ = NULL;
#endif
#if FFETARGET_okINTEGER5
ffebld_constant_integer5_ = NULL;
#endif
#if FFETARGET_okINTEGER6
ffebld_constant_integer6_ = NULL;
#endif
#if FFETARGET_okINTEGER7
ffebld_constant_integer7_ = NULL;
#endif
#if FFETARGET_okINTEGER8
ffebld_constant_integer8_ = NULL;
#endif
#if FFETARGET_okLOGICAL1
ffebld_constant_logical1_ = NULL;
#endif
#if FFETARGET_okLOGICAL2
ffebld_constant_logical2_ = NULL;
#endif
#if FFETARGET_okLOGICAL3
ffebld_constant_logical3_ = NULL;
#endif
#if FFETARGET_okLOGICAL4
ffebld_constant_logical4_ = NULL;
#endif
#if FFETARGET_okLOGICAL5
ffebld_constant_logical5_ = NULL;
#endif
#if FFETARGET_okLOGICAL6
ffebld_constant_logical6_ = NULL;
#endif
#if FFETARGET_okLOGICAL7
ffebld_constant_logical7_ = NULL;
#endif
#if FFETARGET_okLOGICAL8
ffebld_constant_logical8_ = NULL;
#endif
#if FFETARGET_okREAL1
ffebld_constant_real1_ = NULL;
#endif
#if FFETARGET_okREAL2
ffebld_constant_real2_ = NULL;
#endif
#if FFETARGET_okREAL3
ffebld_constant_real3_ = NULL;
#endif
#if FFETARGET_okREAL4
ffebld_constant_real4_ = NULL;
#endif
#if FFETARGET_okREAL5
ffebld_constant_real5_ = NULL;
#endif
#if FFETARGET_okREAL6
ffebld_constant_real6_ = NULL;
#endif
#if FFETARGET_okREAL7
ffebld_constant_real7_ = NULL;
#endif
#if FFETARGET_okREAL8
ffebld_constant_real8_ = NULL;
#endif
ffebld_constant_hollerith_ = NULL;
for (i = FFEBLD_constTYPELESS_FIRST; i <= FFEBLD_constTYPELESS_LAST; ++i)
ffebld_constant_typeless_[i - FFEBLD_constTYPELESS_FIRST] = NULL;
#endif
}
/* ffebld_list_length -- Return # of opITEMs in list
ffebld list; // Must be NULL or opITEM
ffebldListLength length;
length = ffebld_list_length(list);
Returns 0 if list is NULL, 1 if it's ffebld_trail is NULL, and so on. */
ffebldListLength
ffebld_list_length (ffebld list)
{
ffebldListLength length;
for (length = 0; list != NULL; ++length, list = ffebld_trail (list))
;
return length;
}
/* ffebld_new_accter -- Create an ffebld object that is an array
ffebld x;
ffebldConstantArray a;
ffebit b;
x = ffebld_new_accter(a,b); */
ffebld
ffebld_new_accter (ffebldConstantArray a, ffebit b)
{
ffebld x;
x = ffebld_new ();
#if FFEBLD_BLANK_
*x = ffebld_blank_;
#endif
x->op = FFEBLD_opACCTER;
x->u.accter.array = a;
x->u.accter.bits = b;
x->u.accter.pad = 0;
return x;
}
/* ffebld_new_arrter -- Create an ffebld object that is an array
ffebld x;
ffebldConstantArray a;
ffetargetOffset size;
x = ffebld_new_arrter(a,size); */
ffebld
ffebld_new_arrter (ffebldConstantArray a, ffetargetOffset size)
{
ffebld x;
x = ffebld_new ();
#if FFEBLD_BLANK_
*x = ffebld_blank_;
#endif
x->op = FFEBLD_opARRTER;
x->u.arrter.array = a;
x->u.arrter.size = size;
x->u.arrter.pad = 0;
return x;
}
/* ffebld_new_conter_with_orig -- Create an ffebld object that is a constant
ffebld x;
ffebldConstant c;
x = ffebld_new_conter_with_orig(c,NULL); */
ffebld
ffebld_new_conter_with_orig (ffebldConstant c, ffebld o)
{
ffebld x;
x = ffebld_new ();
#if FFEBLD_BLANK_
*x = ffebld_blank_;
#endif
x->op = FFEBLD_opCONTER;
x->u.conter.expr = c;
x->u.conter.orig = o;
x->u.conter.pad = 0;
return x;
}
/* ffebld_new_item -- Create an ffebld item object
ffebld x,y,z;
x = ffebld_new_item(y,z); */
ffebld
ffebld_new_item (ffebld head, ffebld trail)
{
ffebld x;
x = ffebld_new ();
#if FFEBLD_BLANK_
*x = ffebld_blank_;
#endif
x->op = FFEBLD_opITEM;
x->u.item.head = head;
x->u.item.trail = trail;
#ifdef FFECOM_itemHOOK
x->u.item.hook = FFECOM_itemNULL;
#endif
return x;
}
/* ffebld_new_labter -- Create an ffebld object that is a label
ffebld x;
ffelab l;
x = ffebld_new_labter(c); */
ffebld
ffebld_new_labter (ffelab l)
{
ffebld x;
x = ffebld_new ();
#if FFEBLD_BLANK_
*x = ffebld_blank_;
#endif
x->op = FFEBLD_opLABTER;
x->u.labter = l;
return x;
}
/* ffebld_new_labtok -- Create object that is a label's NUMBER token
ffebld x;
ffelexToken t;
x = ffebld_new_labter(c);
Like the other ffebld_new_ functions, the
supplied argument is stored exactly as is: ffelex_token_use is NOT
called, so the token is "consumed", if one is indeed supplied (it may
be NULL). */
ffebld
ffebld_new_labtok (ffelexToken t)
{
ffebld x;
x = ffebld_new ();
#if FFEBLD_BLANK_
*x = ffebld_blank_;
#endif
x->op = FFEBLD_opLABTOK;
x->u.labtok = t;
return x;
}
/* ffebld_new_none -- Create an ffebld object with no arguments
ffebld x;
x = ffebld_new_none(FFEBLD_opWHATEVER); */
ffebld
ffebld_new_none (ffebldOp o)
{
ffebld x;
x = ffebld_new ();
#if FFEBLD_BLANK_
*x = ffebld_blank_;
#endif
x->op = o;
return x;
}
/* ffebld_new_one -- Create an ffebld object with one argument
ffebld x,y;
x = ffebld_new_one(FFEBLD_opWHATEVER,y); */
ffebld
ffebld_new_one (ffebldOp o, ffebld left)
{
ffebld x;
x = ffebld_new ();
#if FFEBLD_BLANK_
*x = ffebld_blank_;
#endif
x->op = o;
x->u.nonter.left = left;
#ifdef FFECOM_nonterHOOK
x->u.nonter.hook = FFECOM_nonterNULL;
#endif
return x;
}
/* ffebld_new_symter -- Create an ffebld object that is a symbol
ffebld x;
ffesymbol s;
ffeintrinGen gen; // Generic intrinsic id, if any
ffeintrinSpec spec; // Specific intrinsic id, if any
ffeintrinImp imp; // Implementation intrinsic id, if any
x = ffebld_new_symter (s, gen, spec, imp); */
ffebld
ffebld_new_symter (ffesymbol s, ffeintrinGen gen, ffeintrinSpec spec,
ffeintrinImp imp)
{
ffebld x;
x = ffebld_new ();
#if FFEBLD_BLANK_
*x = ffebld_blank_;
#endif
x->op = FFEBLD_opSYMTER;
x->u.symter.symbol = s;
x->u.symter.generic = gen;
x->u.symter.specific = spec;
x->u.symter.implementation = imp;
x->u.symter.do_iter = FALSE;
return x;
}
/* ffebld_new_two -- Create an ffebld object with two arguments
ffebld x,y,z;
x = ffebld_new_two(FFEBLD_opWHATEVER,y,z); */
ffebld
ffebld_new_two (ffebldOp o, ffebld left, ffebld right)
{
ffebld x;
x = ffebld_new ();
#if FFEBLD_BLANK_
*x = ffebld_blank_;
#endif
x->op = o;
x->u.nonter.left = left;
x->u.nonter.right = right;
#ifdef FFECOM_nonterHOOK
x->u.nonter.hook = FFECOM_nonterNULL;
#endif
return x;
}
/* ffebld_pool_pop -- Pop ffebld's pool stack
ffebld_pool_pop(); */
void
ffebld_pool_pop ()
{
ffebldPoolstack_ ps;
assert (ffebld_pool_stack_.next != NULL);
ps = ffebld_pool_stack_.next;
ffebld_pool_stack_.next = ps->next;
ffebld_pool_stack_.pool = ps->pool;
malloc_kill_ks (malloc_pool_image (), ps, sizeof (*ps));
}
/* ffebld_pool_push -- Push ffebld's pool stack
ffebld_pool_push(); */
void
ffebld_pool_push (mallocPool pool)
{
ffebldPoolstack_ ps;
ps = malloc_new_ks (malloc_pool_image (), "Pool stack", sizeof (*ps));
ps->next = ffebld_pool_stack_.next;
ps->pool = ffebld_pool_stack_.pool;
ffebld_pool_stack_.next = ps;
ffebld_pool_stack_.pool = pool;
}
/* ffebld_op_string -- Return short string describing op
ffebldOp o;
ffebld_op_string(o);
Returns a short string (uppercase) containing the name of the op. */
const char *
ffebld_op_string (ffebldOp o)
{
if (o >= ARRAY_SIZE (ffebld_op_string_))
return "?\?\?";
return ffebld_op_string_[o];
}
/* ffebld_size_max -- Return maximum possible size of CHARACTER-type expr
ffetargetCharacterSize sz;
ffebld b;
sz = ffebld_size_max (b);
Like ffebld_size_known, but if that would return NONE and the expression
is opSUBSTR, opCONVERT, opPAREN, or opCONCATENATE, returns ffebld_size_max
of the subexpression(s). */
ffetargetCharacterSize
ffebld_size_max (ffebld b)
{
ffetargetCharacterSize sz;
recurse: /* :::::::::::::::::::: */
sz = ffebld_size_known (b);
if (sz != FFETARGET_charactersizeNONE)
return sz;
switch (ffebld_op (b))
{
case FFEBLD_opSUBSTR:
case FFEBLD_opCONVERT:
case FFEBLD_opPAREN:
b = ffebld_left (b);
goto recurse; /* :::::::::::::::::::: */
case FFEBLD_opCONCATENATE:
sz = ffebld_size_max (ffebld_left (b))
+ ffebld_size_max (ffebld_right (b));
return sz;
default:
return sz;
}
}