diff options
Diffstat (limited to 'gcc/f/bld.c')
| -rw-r--r-- | gcc/f/bld.c | 5782 |
1 files changed, 5782 insertions, 0 deletions
diff --git a/gcc/f/bld.c b/gcc/f/bld.c new file mode 100644 index 00000000000..3a95727adc1 --- /dev/null +++ b/gcc/f/bld.c @@ -0,0 +1,5782 @@ +/* bld.c -- Implementation File (module.c template V1.0) + Copyright (C) 1995, 1996 Free Software Foundation, Inc. + Contributed by James Craig Burley (burley@gnu.ai.mit.edu). + +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 <ctype.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 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. */ + +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; + } +} + +/* 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. */ + +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, "\\)"); + +} + +/* 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. */ + +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; + } +} + +/* ffebld_dump -- Dump expression tree in concise form + + ffebld b; + ffebld_dump(b); */ + +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; + } + } +} + +/* ffebld_dump_prefix -- Dump the prefix for a constant of a given type + + ffebld_dump_prefix(dmpout,FFEINFO_basictypeINTEGER, + FFEINFO_kindtypeINTEGER1); */ + +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; + } +} + +/* 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; + 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; + 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; + 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; + 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; + 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; + 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. */ + +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; + } +} |