gcc/f/bld.c

   1 /* bld.c -- Implementation File (module.c template V1.0)
   2    Copyright (C) 1995, 1996 Free Software Foundation, Inc.
   3    Contributed by James Craig Burley.
   4
   5 This file is part of GNU Fortran.
   6
   7 GNU Fortran is free software; you can redistribute it and/or modify
   8 it under the terms of the GNU General Public License as published by
   9 the Free Software Foundation; either version 2, or (at your option)
  10 any later version.
  11
  12 GNU Fortran is distributed in the hope that it will be useful,
  13 but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 GNU General Public License for more details.
  16
  17 You should have received a copy of the GNU General Public License
  18 along with GNU Fortran; see the file COPYING.  If not, write to
  19 the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
  20 02111-1307, USA.
  21
  22    Related Modules:
  23       None
  24
  25    Description:
  26       The primary "output" of the FFE includes ffebld objects, which
  27       connect expressions, operators, and operands together, along with
  28       connecting lists of expressions together for argument or dimension
  29       lists.
  30
  31    Modifications:
  32       30-Aug-92  JCB  1.1
  33          Change names of some things for consistency.
  34 */
  35
  36 /* Include files. */
  37
  38 #include "proj.h"
  39 #include "bld.h"
  40 #include "bit.h"
  41 #include "info.h"
  42 #include "lex.h"
  43 #include "malloc.h"
  44 #include "target.h"
  45 #include "where.h"
  46
  47 /* Externals defined here.  */
  48
  49 const ffebldArity ffebld_arity_op_[]
  50 =
  51 {
  52 #define FFEBLD_OP(KWD,NAME,ARITY) ARITY,
  53 #include "bld-op.def"
  54 #undef FFEBLD_OP
  55 };
  56 struct _ffebld_pool_stack_ ffebld_pool_stack_;
  57
  58 /* Simple definitions and enumerations. */
  59
  60
  61 /* Internal typedefs. */
  62
  63
  64 /* Private include files. */
  65
  66
  67 /* Internal structure definitions. */
  68
  69
  70 /* Static objects accessed by functions in this module.  */
  71
  72 #if FFEBLD_BLANK_
  73 static struct _ffebld_ ffebld_blank_
  74 =
  75 {
  76   0,
  77   {FFEINFO_basictypeNONE, FFEINFO_kindtypeNONE, 0, FFEINFO_kindNONE,
  78    FFEINFO_whereNONE, FFETARGET_charactersizeNONE},
  79   {NULL, NULL}
  80 };
  81 #endif
  82 #if FFETARGET_okCHARACTER1
  83 static ffebldConstant ffebld_constant_character1_;
  84 #endif
  85 #if FFETARGET_okCHARACTER2
  86 static ffebldConstant ffebld_constant_character2_;
  87 #endif
  88 #if FFETARGET_okCHARACTER3
  89 static ffebldConstant ffebld_constant_character3_;
  90 #endif
  91 #if FFETARGET_okCHARACTER4
  92 static ffebldConstant ffebld_constant_character4_;
  93 #endif
  94 #if FFETARGET_okCHARACTER5
  95 static ffebldConstant ffebld_constant_character5_;
  96 #endif
  97 #if FFETARGET_okCHARACTER6
  98 static ffebldConstant ffebld_constant_character6_;
  99 #endif
 100 #if FFETARGET_okCHARACTER7
 101 static ffebldConstant ffebld_constant_character7_;
 102 #endif
 103 #if FFETARGET_okCHARACTER8
 104 static ffebldConstant ffebld_constant_character8_;
 105 #endif
 106 #if FFETARGET_okCOMPLEX1
 107 static ffebldConstant ffebld_constant_complex1_;
 108 #endif
 109 #if FFETARGET_okCOMPLEX2
 110 static ffebldConstant ffebld_constant_complex2_;
 111 #endif
 112 #if FFETARGET_okCOMPLEX3
 113 static ffebldConstant ffebld_constant_complex3_;
 114 #endif
 115 #if FFETARGET_okCOMPLEX4
 116 static ffebldConstant ffebld_constant_complex4_;
 117 #endif
 118 #if FFETARGET_okCOMPLEX5
 119 static ffebldConstant ffebld_constant_complex5_;
 120 #endif
 121 #if FFETARGET_okCOMPLEX6
 122 static ffebldConstant ffebld_constant_complex6_;
 123 #endif
 124 #if FFETARGET_okCOMPLEX7
 125 static ffebldConstant ffebld_constant_complex7_;
 126 #endif
 127 #if FFETARGET_okCOMPLEX8
 128 static ffebldConstant ffebld_constant_complex8_;
 129 #endif
 130 #if FFETARGET_okINTEGER1
 131 static ffebldConstant ffebld_constant_integer1_;
 132 #endif
 133 #if FFETARGET_okINTEGER2
 134 static ffebldConstant ffebld_constant_integer2_;
 135 #endif
 136 #if FFETARGET_okINTEGER3
 137 static ffebldConstant ffebld_constant_integer3_;
 138 #endif
 139 #if FFETARGET_okINTEGER4
 140 static ffebldConstant ffebld_constant_integer4_;
 141 #endif
 142 #if FFETARGET_okINTEGER5
 143 static ffebldConstant ffebld_constant_integer5_;
 144 #endif
 145 #if FFETARGET_okINTEGER6
 146 static ffebldConstant ffebld_constant_integer6_;
 147 #endif
 148 #if FFETARGET_okINTEGER7
 149 static ffebldConstant ffebld_constant_integer7_;
 150 #endif
 151 #if FFETARGET_okINTEGER8
 152 static ffebldConstant ffebld_constant_integer8_;
 153 #endif
 154 #if FFETARGET_okLOGICAL1
 155 static ffebldConstant ffebld_constant_logical1_;
 156 #endif
 157 #if FFETARGET_okLOGICAL2
 158 static ffebldConstant ffebld_constant_logical2_;
 159 #endif
 160 #if FFETARGET_okLOGICAL3
 161 static ffebldConstant ffebld_constant_logical3_;
 162 #endif
 163 #if FFETARGET_okLOGICAL4
 164 static ffebldConstant ffebld_constant_logical4_;
 165 #endif
 166 #if FFETARGET_okLOGICAL5
 167 static ffebldConstant ffebld_constant_logical5_;
 168 #endif
 169 #if FFETARGET_okLOGICAL6
 170 static ffebldConstant ffebld_constant_logical6_;
 171 #endif
 172 #if FFETARGET_okLOGICAL7
 173 static ffebldConstant ffebld_constant_logical7_;
 174 #endif
 175 #if FFETARGET_okLOGICAL8
 176 static ffebldConstant ffebld_constant_logical8_;
 177 #endif
 178 #if FFETARGET_okREAL1
 179 static ffebldConstant ffebld_constant_real1_;
 180 #endif
 181 #if FFETARGET_okREAL2
 182 static ffebldConstant ffebld_constant_real2_;
 183 #endif
 184 #if FFETARGET_okREAL3
 185 static ffebldConstant ffebld_constant_real3_;
 186 #endif
 187 #if FFETARGET_okREAL4
 188 static ffebldConstant ffebld_constant_real4_;
 189 #endif
 190 #if FFETARGET_okREAL5
 191 static ffebldConstant ffebld_constant_real5_;
 192 #endif
 193 #if FFETARGET_okREAL6
 194 static ffebldConstant ffebld_constant_real6_;
 195 #endif
 196 #if FFETARGET_okREAL7
 197 static ffebldConstant ffebld_constant_real7_;
 198 #endif
 199 #if FFETARGET_okREAL8
 200 static ffebldConstant ffebld_constant_real8_;
 201 #endif
 202 static ffebldConstant ffebld_constant_hollerith_;
 203 static ffebldConstant ffebld_constant_typeless_[FFEBLD_constTYPELESS_LAST
 204                                           - FFEBLD_constTYPELESS_FIRST + 1];
 205
 206 static const char *const ffebld_op_string_[]
 207 =
 208 {
 209 #define FFEBLD_OP(KWD,NAME,ARITY) NAME,
 210 #include "bld-op.def"
 211 #undef FFEBLD_OP
 212 };
 213
 214 /* Static functions (internal). */
 215
 216
 217 /* Internal macros. */
 218
 219 #define integerdefault_ CATX(integer,FFETARGET_ktINTEGERDEFAULT)
 220 #define logicaldefault_ CATX(logical,FFETARGET_ktLOGICALDEFAULT)
 221 #define realdefault_ CATX(real,FFETARGET_ktREALDEFAULT)
 222 #define realdouble_ CATX(real,FFETARGET_ktREALDOUBLE)
 223 #define realquad_ CATX(real,FFETARGET_ktREALQUAD)
 224 \f
 225 /* ffebld_constant_cmp -- Compare two constants a la strcmp
 226
 227    ffebldConstant c1, c2;
 228    if (ffebld_constant_cmp(c1,c2) == 0)
 229        // they're equal, else they're not.
 230
 231    Returns -1 if c1 < c2, 0 if c1 == c2, +1 if c1 == c2.  */
 232
 233 int
 234 ffebld_constant_cmp (ffebldConstant c1, ffebldConstant c2)
 235 {
 236   if (c1 == c2)
 237     return 0;
 238
 239   assert (ffebld_constant_type (c1) == ffebld_constant_type (c2));
 240
 241   switch (ffebld_constant_type (c1))
 242     {
 243 #if FFETARGET_okINTEGER1
 244     case FFEBLD_constINTEGER1:
 245       return ffetarget_cmp_integer1 (ffebld_constant_integer1 (c1),
 246                                      ffebld_constant_integer1 (c2));
 247 #endif
 248
 249 #if FFETARGET_okINTEGER2
 250     case FFEBLD_constINTEGER2:
 251       return ffetarget_cmp_integer2 (ffebld_constant_integer2 (c1),
 252                                      ffebld_constant_integer2 (c2));
 253 #endif
 254
 255 #if FFETARGET_okINTEGER3
 256     case FFEBLD_constINTEGER3:
 257       return ffetarget_cmp_integer3 (ffebld_constant_integer3 (c1),
 258                                      ffebld_constant_integer3 (c2));
 259 #endif
 260
 261 #if FFETARGET_okINTEGER4
 262     case FFEBLD_constINTEGER4:
 263       return ffetarget_cmp_integer4 (ffebld_constant_integer4 (c1),
 264                                      ffebld_constant_integer4 (c2));
 265 #endif
 266
 267 #if FFETARGET_okINTEGER5
 268     case FFEBLD_constINTEGER5:
 269       return ffetarget_cmp_integer5 (ffebld_constant_integer5 (c1),
 270                                      ffebld_constant_integer5 (c2));
 271 #endif
 272
 273 #if FFETARGET_okINTEGER6
 274     case FFEBLD_constINTEGER6:
 275       return ffetarget_cmp_integer6 (ffebld_constant_integer6 (c1),
 276                                      ffebld_constant_integer6 (c2));
 277 #endif
 278
 279 #if FFETARGET_okINTEGER7
 280     case FFEBLD_constINTEGER7:
 281       return ffetarget_cmp_integer7 (ffebld_constant_integer7 (c1),
 282                                      ffebld_constant_integer7 (c2));
 283 #endif
 284
 285 #if FFETARGET_okINTEGER8
 286     case FFEBLD_constINTEGER8:
 287       return ffetarget_cmp_integer8 (ffebld_constant_integer8 (c1),
 288                                      ffebld_constant_integer8 (c2));
 289 #endif
 290
 291 #if FFETARGET_okLOGICAL1
 292     case FFEBLD_constLOGICAL1:
 293       return ffetarget_cmp_logical1 (ffebld_constant_logical1 (c1),
 294                                      ffebld_constant_logical1 (c2));
 295 #endif
 296
 297 #if FFETARGET_okLOGICAL2
 298     case FFEBLD_constLOGICAL2:
 299       return ffetarget_cmp_logical2 (ffebld_constant_logical2 (c1),
 300                                      ffebld_constant_logical2 (c2));
 301 #endif
 302
 303 #if FFETARGET_okLOGICAL3
 304     case FFEBLD_constLOGICAL3:
 305       return ffetarget_cmp_logical3 (ffebld_constant_logical3 (c1),
 306                                      ffebld_constant_logical3 (c2));
 307 #endif
 308
 309 #if FFETARGET_okLOGICAL4
 310     case FFEBLD_constLOGICAL4:
 311       return ffetarget_cmp_logical4 (ffebld_constant_logical4 (c1),
 312                                      ffebld_constant_logical4 (c2));
 313 #endif
 314
 315 #if FFETARGET_okLOGICAL5
 316     case FFEBLD_constLOGICAL5:
 317       return ffetarget_cmp_logical5 (ffebld_constant_logical5 (c1),
 318                                      ffebld_constant_logical5 (c2));
 319 #endif
 320
 321 #if FFETARGET_okLOGICAL6
 322     case FFEBLD_constLOGICAL6:
 323       return ffetarget_cmp_logical6 (ffebld_constant_logical6 (c1),
 324                                      ffebld_constant_logical6 (c2));
 325 #endif
 326
 327 #if FFETARGET_okLOGICAL7
 328     case FFEBLD_constLOGICAL7:
 329       return ffetarget_cmp_logical7 (ffebld_constant_logical7 (c1),
 330                                      ffebld_constant_logical7 (c2));
 331 #endif
 332
 333 #if FFETARGET_okLOGICAL8
 334     case FFEBLD_constLOGICAL8:
 335       return ffetarget_cmp_logical8 (ffebld_constant_logical8 (c1),
 336                                      ffebld_constant_logical8 (c2));
 337 #endif
 338
 339 #if FFETARGET_okREAL1
 340     case FFEBLD_constREAL1:
 341       return ffetarget_cmp_real1 (ffebld_constant_real1 (c1),
 342                                   ffebld_constant_real1 (c2));
 343 #endif
 344
 345 #if FFETARGET_okREAL2
 346     case FFEBLD_constREAL2:
 347       return ffetarget_cmp_real2 (ffebld_constant_real2 (c1),
 348                                   ffebld_constant_real2 (c2));
 349 #endif
 350
 351 #if FFETARGET_okREAL3
 352     case FFEBLD_constREAL3:
 353       return ffetarget_cmp_real3 (ffebld_constant_real3 (c1),
 354                                   ffebld_constant_real3 (c2));
 355 #endif
 356
 357 #if FFETARGET_okREAL4
 358     case FFEBLD_constREAL4:
 359       return ffetarget_cmp_real4 (ffebld_constant_real4 (c1),
 360                                   ffebld_constant_real4 (c2));
 361 #endif
 362
 363 #if FFETARGET_okREAL5
 364     case FFEBLD_constREAL5:
 365       return ffetarget_cmp_real5 (ffebld_constant_real5 (c1),
 366                                   ffebld_constant_real5 (c2));
 367 #endif
 368
 369 #if FFETARGET_okREAL6
 370     case FFEBLD_constREAL6:
 371       return ffetarget_cmp_real6 (ffebld_constant_real6 (c1),
 372                                   ffebld_constant_real6 (c2));
 373 #endif
 374
 375 #if FFETARGET_okREAL7
 376     case FFEBLD_constREAL7:
 377       return ffetarget_cmp_real7 (ffebld_constant_real7 (c1),
 378                                   ffebld_constant_real7 (c2));
 379 #endif
 380
 381 #if FFETARGET_okREAL8
 382     case FFEBLD_constREAL8:
 383       return ffetarget_cmp_real8 (ffebld_constant_real8 (c1),
 384                                   ffebld_constant_real8 (c2));
 385 #endif
 386
 387 #if FFETARGET_okCHARACTER1
 388     case FFEBLD_constCHARACTER1:
 389       return ffetarget_cmp_character1 (ffebld_constant_character1 (c1),
 390                                        ffebld_constant_character1 (c2));
 391 #endif
 392
 393 #if FFETARGET_okCHARACTER2
 394     case FFEBLD_constCHARACTER2:
 395       return ffetarget_cmp_character2 (ffebld_constant_character2 (c1),
 396                                        ffebld_constant_character2 (c2));
 397 #endif
 398
 399 #if FFETARGET_okCHARACTER3
 400     case FFEBLD_constCHARACTER3:
 401       return ffetarget_cmp_character3 (ffebld_constant_character3 (c1),
 402                                        ffebld_constant_character3 (c2));
 403 #endif
 404
 405 #if FFETARGET_okCHARACTER4
 406     case FFEBLD_constCHARACTER4:
 407       return ffetarget_cmp_character4 (ffebld_constant_character4 (c1),
 408                                        ffebld_constant_character4 (c2));
 409 #endif
 410
 411 #if FFETARGET_okCHARACTER5
 412     case FFEBLD_constCHARACTER5:
 413       return ffetarget_cmp_character5 (ffebld_constant_character5 (c1),
 414                                        ffebld_constant_character5 (c2));
 415 #endif
 416
 417 #if FFETARGET_okCHARACTER6
 418     case FFEBLD_constCHARACTER6:
 419       return ffetarget_cmp_character6 (ffebld_constant_character6 (c1),
 420                                        ffebld_constant_character6 (c2));
 421 #endif
 422
 423 #if FFETARGET_okCHARACTER7
 424     case FFEBLD_constCHARACTER7:
 425       return ffetarget_cmp_character7 (ffebld_constant_character7 (c1),
 426                                        ffebld_constant_character7 (c2));
 427 #endif
 428
 429 #if FFETARGET_okCHARACTER8
 430     case FFEBLD_constCHARACTER8:
 431       return ffetarget_cmp_character8 (ffebld_constant_character8 (c1),
 432                                        ffebld_constant_character8 (c2));
 433 #endif
 434
 435     default:
 436       assert ("bad constant type" == NULL);
 437       return 0;
 438     }
 439 }
 440
 441 /* ffebld_constant_dump -- Display summary of constant's contents
 442
 443    ffebldConstant c;
 444    ffebld_constant_dump(c);
 445
 446    Displays the constant in summary form.  */
 447
 448 #if FFECOM_targetCURRENT == FFECOM_targetFFE
 449 void
 450 ffebld_constant_dump (ffebldConstant c)
 451 {
 452   switch (ffebld_constant_type (c))
 453     {
 454 #if FFETARGET_okINTEGER1
 455     case FFEBLD_constINTEGER1:
 456       ffebld_dump_prefix (dmpout, FFEINFO_basictypeINTEGER,
 457                           FFEINFO_kindtypeINTEGER1);
 458       ffebld_constantunion_dump (ffebld_constant_union (c),
 459                         FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER1);
 460       break;
 461 #endif
 462
 463 #if FFETARGET_okINTEGER2
 464     case FFEBLD_constINTEGER2:
 465       ffebld_dump_prefix (dmpout, FFEINFO_basictypeINTEGER,
 466                           FFEINFO_kindtypeINTEGER2);
 467       ffebld_constantunion_dump (ffebld_constant_union (c),
 468                         FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER2);
 469       break;
 470 #endif
 471
 472 #if FFETARGET_okINTEGER3
 473     case FFEBLD_constINTEGER3:
 474       ffebld_dump_prefix (dmpout, FFEINFO_basictypeINTEGER,
 475                           FFEINFO_kindtypeINTEGER3);
 476       ffebld_constantunion_dump (ffebld_constant_union (c),
 477                         FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER3);
 478       break;
 479 #endif
 480
 481 #if FFETARGET_okINTEGER4
 482     case FFEBLD_constINTEGER4:
 483       ffebld_dump_prefix (dmpout, FFEINFO_basictypeINTEGER,
 484                           FFEINFO_kindtypeINTEGER4);
 485       ffebld_constantunion_dump (ffebld_constant_union (c),
 486                         FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER4);
 487       break;
 488 #endif
 489
 490 #if FFETARGET_okINTEGER5
 491     case FFEBLD_constINTEGER5:
 492       ffebld_dump_prefix (dmpout, FFEINFO_basictypeINTEGER,
 493                           FFEINFO_kindtypeINTEGER5);
 494       ffebld_constantunion_dump (ffebld_constant_union (c),
 495                         FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER5);
 496       break;
 497 #endif
 498
 499 #if FFETARGET_okINTEGER6
 500     case FFEBLD_constINTEGER6:
 501       ffebld_dump_prefix (dmpout, FFEINFO_basictypeINTEGER,
 502                           FFEINFO_kindtypeINTEGER6);
 503       ffebld_constantunion_dump (ffebld_constant_union (c),
 504                         FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER6);
 505       break;
 506 #endif
 507
 508 #if FFETARGET_okINTEGER7
 509     case FFEBLD_constINTEGER7:
 510       ffebld_dump_prefix (dmpout, FFEINFO_basictypeINTEGER,
 511                           FFEINFO_kindtypeINTEGER7);
 512       ffebld_constantunion_dump (ffebld_constant_union (c),
 513                         FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER7);
 514       break;
 515 #endif
 516
 517 #if FFETARGET_okINTEGER8
 518     case FFEBLD_constINTEGER8:
 519       ffebld_dump_prefix (dmpout, FFEINFO_basictypeINTEGER,
 520                           FFEINFO_kindtypeINTEGER8);
 521       ffebld_constantunion_dump (ffebld_constant_union (c),
 522                         FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER8);
 523       break;
 524 #endif
 525
 526 #if FFETARGET_okLOGICAL1
 527     case FFEBLD_constLOGICAL1:
 528       ffebld_dump_prefix (dmpout, FFEINFO_basictypeLOGICAL,
 529                           FFEINFO_kindtypeLOGICAL1);
 530       ffebld_constantunion_dump (ffebld_constant_union (c),
 531                         FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL1);
 532       break;
 533 #endif
 534
 535 #if FFETARGET_okLOGICAL2
 536     case FFEBLD_constLOGICAL2:
 537       ffebld_dump_prefix (dmpout, FFEINFO_basictypeLOGICAL,
 538                           FFEINFO_kindtypeLOGICAL2);
 539       ffebld_constantunion_dump (ffebld_constant_union (c),
 540                         FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL2);
 541       break;
 542 #endif
 543
 544 #if FFETARGET_okLOGICAL3
 545     case FFEBLD_constLOGICAL3:
 546       ffebld_dump_prefix (dmpout, FFEINFO_basictypeLOGICAL,
 547                           FFEINFO_kindtypeLOGICAL3);
 548       ffebld_constantunion_dump (ffebld_constant_union (c),
 549                         FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL3);
 550       break;
 551 #endif
 552
 553 #if FFETARGET_okLOGICAL4
 554     case FFEBLD_constLOGICAL4:
 555       ffebld_dump_prefix (dmpout, FFEINFO_basictypeLOGICAL,
 556                           FFEINFO_kindtypeLOGICAL4);
 557       ffebld_constantunion_dump (ffebld_constant_union (c),
 558                         FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL4);
 559       break;
 560 #endif
 561
 562 #if FFETARGET_okLOGICAL5
 563     case FFEBLD_constLOGICAL5:
 564       ffebld_dump_prefix (dmpout, FFEINFO_basictypeLOGICAL,
 565                           FFEINFO_kindtypeLOGICAL5);
 566       ffebld_constantunion_dump (ffebld_constant_union (c),
 567                         FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL5);
 568       break;
 569 #endif
 570
 571 #if FFETARGET_okLOGICAL6
 572     case FFEBLD_constLOGICAL6:
 573       ffebld_dump_prefix (dmpout, FFEINFO_basictypeLOGICAL,
 574                           FFEINFO_kindtypeLOGICAL6);
 575       ffebld_constantunion_dump (ffebld_constant_union (c),
 576                         FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL6);
 577       break;
 578 #endif
 579
 580 #if FFETARGET_okLOGICAL7
 581     case FFEBLD_constLOGICAL7:
 582       ffebld_dump_prefix (dmpout, FFEINFO_basictypeLOGICAL,
 583                           FFEINFO_kindtypeLOGICAL7);
 584       ffebld_constantunion_dump (ffebld_constant_union (c),
 585                         FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL7);
 586       break;
 587 #endif
 588
 589 #if FFETARGET_okLOGICAL8
 590     case FFEBLD_constLOGICAL8:
 591       ffebld_dump_prefix (dmpout, FFEINFO_basictypeLOGICAL,
 592                           FFEINFO_kindtypeLOGICAL8);
 593       ffebld_constantunion_dump (ffebld_constant_union (c),
 594                         FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL8);
 595       break;
 596 #endif
 597
 598 #if FFETARGET_okREAL1
 599     case FFEBLD_constREAL1:
 600       ffebld_dump_prefix (dmpout, FFEINFO_basictypeREAL,
 601                           FFEINFO_kindtypeREAL1);
 602       ffebld_constantunion_dump (ffebld_constant_union (c),
 603                               FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL1);
 604       break;
 605 #endif
 606
 607 #if FFETARGET_okREAL2
 608     case FFEBLD_constREAL2:
 609       ffebld_dump_prefix (dmpout, FFEINFO_basictypeREAL,
 610                           FFEINFO_kindtypeREAL2);
 611       ffebld_constantunion_dump (ffebld_constant_union (c),
 612                               FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL2);
 613       break;
 614 #endif
 615
 616 #if FFETARGET_okREAL3
 617     case FFEBLD_constREAL3:
 618       ffebld_dump_prefix (dmpout, FFEINFO_basictypeREAL,
 619                           FFEINFO_kindtypeREAL3);
 620       ffebld_constantunion_dump (ffebld_constant_union (c),
 621                               FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL3);
 622       break;
 623 #endif
 624
 625 #if FFETARGET_okREAL4
 626     case FFEBLD_constREAL4:
 627       ffebld_dump_prefix (dmpout, FFEINFO_basictypeREAL,
 628                           FFEINFO_kindtypeREAL4);
 629       ffebld_constantunion_dump (ffebld_constant_union (c),
 630                               FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL4);
 631       break;
 632 #endif
 633
 634 #if FFETARGET_okREAL5
 635     case FFEBLD_constREAL5:
 636       ffebld_dump_prefix (dmpout, FFEINFO_basictypeREAL,
 637                           FFEINFO_kindtypeREAL5);
 638       ffebld_constantunion_dump (ffebld_constant_union (c),
 639                               FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL5);
 640       break;
 641 #endif
 642
 643 #if FFETARGET_okREAL6
 644     case FFEBLD_constREAL6:
 645       ffebld_dump_prefix (dmpout, FFEINFO_basictypeREAL,
 646                           FFEINFO_kindtypeREAL6);
 647       ffebld_constantunion_dump (ffebld_constant_union (c),
 648                               FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL6);
 649       break;
 650 #endif
 651
 652 #if FFETARGET_okREAL7
 653     case FFEBLD_constREAL7:
 654       ffebld_dump_prefix (dmpout, FFEINFO_basictypeREAL,
 655                           FFEINFO_kindtypeREAL7);
 656       ffebld_constantunion_dump (ffebld_constant_union (c),
 657                               FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL7);
 658       break;
 659 #endif
 660
 661 #if FFETARGET_okREAL8
 662     case FFEBLD_constREAL8:
 663       ffebld_dump_prefix (dmpout, FFEINFO_basictypeREAL,
 664                           FFEINFO_kindtypeREAL8);
 665       ffebld_constantunion_dump (ffebld_constant_union (c),
 666                               FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL8);
 667       break;
 668 #endif
 669
 670 #if FFETARGET_okCOMPLEX1
 671     case FFEBLD_constCOMPLEX1:
 672       ffebld_dump_prefix (dmpout, FFEINFO_basictypeCOMPLEX,
 673                           FFEINFO_kindtypeREAL1);
 674       ffebld_constantunion_dump (ffebld_constant_union (c),
 675                            FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL1);
 676       break;
 677 #endif
 678
 679 #if FFETARGET_okCOMPLEX2
 680     case FFEBLD_constCOMPLEX2:
 681       ffebld_dump_prefix (dmpout, FFEINFO_basictypeCOMPLEX,
 682                           FFEINFO_kindtypeREAL2);
 683       ffebld_constantunion_dump (ffebld_constant_union (c),
 684                            FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL2);
 685       break;
 686 #endif
 687
 688 #if FFETARGET_okCOMPLEX3
 689     case FFEBLD_constCOMPLEX3:
 690       ffebld_dump_prefix (dmpout, FFEINFO_basictypeCOMPLEX,
 691                           FFEINFO_kindtypeREAL3);
 692       ffebld_constantunion_dump (ffebld_constant_union (c),
 693                            FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL3);
 694       break;
 695 #endif
 696
 697 #if FFETARGET_okCOMPLEX4
 698     case FFEBLD_constCOMPLEX4:
 699       ffebld_dump_prefix (dmpout, FFEINFO_basictypeCOMPLEX,
 700                           FFEINFO_kindtypeREAL4);
 701       ffebld_constantunion_dump (ffebld_constant_union (c),
 702                            FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL4);
 703       break;
 704 #endif
 705
 706 #if FFETARGET_okCOMPLEX5
 707     case FFEBLD_constCOMPLEX5:
 708       ffebld_dump_prefix (dmpout, FFEINFO_basictypeCOMPLEX,
 709                           FFEINFO_kindtypeREAL5);
 710       ffebld_constantunion_dump (ffebld_constant_union (c),
 711                            FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL5);
 712       break;
 713 #endif
 714
 715 #if FFETARGET_okCOMPLEX6
 716     case FFEBLD_constCOMPLEX6:
 717       ffebld_dump_prefix (dmpout, FFEINFO_basictypeCOMPLEX,
 718                           FFEINFO_kindtypeREAL6);
 719       ffebld_constantunion_dump (ffebld_constant_union (c),
 720                            FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL6);
 721       break;
 722 #endif
 723
 724 #if FFETARGET_okCOMPLEX7
 725     case FFEBLD_constCOMPLEX7:
 726       ffebld_dump_prefix (dmpout, FFEINFO_basictypeCOMPLEX,
 727                           FFEINFO_kindtypeREAL7);
 728       ffebld_constantunion_dump (ffebld_constant_union (c),
 729                            FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL7);
 730       break;
 731 #endif
 732
 733 #if FFETARGET_okCOMPLEX8
 734     case FFEBLD_constCOMPLEX8:
 735       ffebld_dump_prefix (dmpout, FFEINFO_basictypeCOMPLEX,
 736                           FFEINFO_kindtypeREAL8);
 737       ffebld_constantunion_dump (ffebld_constant_union (c),
 738                            FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL8);
 739       break;
 740 #endif
 741
 742 #if FFETARGET_okCHARACTER1
 743     case FFEBLD_constCHARACTER1:
 744       ffebld_dump_prefix (dmpout, FFEINFO_basictypeCHARACTER,
 745                           FFEINFO_kindtypeCHARACTER1);
 746       ffebld_constantunion_dump (ffebld_constant_union (c),
 747                     FFEINFO_basictypeCHARACTER, FFEINFO_kindtypeCHARACTER1);
 748       break;
 749 #endif
 750
 751 #if FFETARGET_okCHARACTER2
 752     case FFEBLD_constCHARACTER2:
 753       ffebld_dump_prefix (dmpout, FFEINFO_basictypeCHARACTER,
 754                           FFEINFO_kindtypeCHARACTER2);
 755       ffebld_constantunion_dump (ffebld_constant_union (c),
 756                     FFEINFO_basictypeCHARACTER, FFEINFO_kindtypeCHARACTER2);
 757       break;
 758 #endif
 759
 760 #if FFETARGET_okCHARACTER3
 761     case FFEBLD_constCHARACTER3:
 762       ffebld_dump_prefix (dmpout, FFEINFO_basictypeCHARACTER,
 763                           FFEINFO_kindtypeCHARACTER3);
 764       ffebld_constantunion_dump (ffebld_constant_union (c),
 765                     FFEINFO_basictypeCHARACTER, FFEINFO_kindtypeCHARACTER3);
 766       break;
 767 #endif
 768
 769 #if FFETARGET_okCHARACTER4
 770     case FFEBLD_constCHARACTER4:
 771       ffebld_dump_prefix (dmpout, FFEINFO_basictypeCHARACTER,
 772                           FFEINFO_kindtypeCHARACTER4);
 773       ffebld_constantunion_dump (ffebld_constant_union (c),
 774                     FFEINFO_basictypeCHARACTER, FFEINFO_kindtypeCHARACTER4);
 775       break;
 776 #endif
 777
 778 #if FFETARGET_okCHARACTER5
 779     case FFEBLD_constCHARACTER5:
 780       ffebld_dump_prefix (dmpout, FFEINFO_basictypeCHARACTER,
 781                           FFEINFO_kindtypeCHARACTER5);
 782       ffebld_constantunion_dump (ffebld_constant_union (c),
 783                     FFEINFO_basictypeCHARACTER, FFEINFO_kindtypeCHARACTER5);
 784       break;
 785 #endif
 786
 787 #if FFETARGET_okCHARACTER6
 788     case FFEBLD_constCHARACTER6:
 789       ffebld_dump_prefix (dmpout, FFEINFO_basictypeCHARACTER,
 790                           FFEINFO_kindtypeCHARACTER6);
 791       ffebld_constantunion_dump (ffebld_constant_union (c),
 792                     FFEINFO_basictypeCHARACTER, FFEINFO_kindtypeCHARACTER6);
 793       break;
 794 #endif
 795
 796 #if FFETARGET_okCHARACTER7
 797     case FFEBLD_constCHARACTER7:
 798       ffebld_dump_prefix (dmpout, FFEINFO_basictypeCHARACTER,
 799                           FFEINFO_kindtypeCHARACTER7);
 800       ffebld_constantunion_dump (ffebld_constant_union (c),
 801                     FFEINFO_basictypeCHARACTER, FFEINFO_kindtypeCHARACTER7);
 802       break;
 803 #endif
 804
 805 #if FFETARGET_okCHARACTER8
 806     case FFEBLD_constCHARACTER8:
 807       ffebld_dump_prefix (dmpout, FFEINFO_basictypeCHARACTER,
 808                           FFEINFO_kindtypeCHARACTER8);
 809       ffebld_constantunion_dump (ffebld_constant_union (c),
 810                     FFEINFO_basictypeCHARACTER, FFEINFO_kindtypeCHARACTER8);
 811       break;
 812 #endif
 813
 814     case FFEBLD_constHOLLERITH:
 815       fprintf (dmpout, "H%" ffetargetHollerithSize_f "u/",
 816                ffebld_constant_hollerith (c).length);
 817       ffetarget_print_hollerith (dmpout, ffebld_constant_hollerith (c));
 818       break;
 819
 820     case FFEBLD_constBINARY_MIL:
 821       fprintf (dmpout, "BM/");
 822       ffetarget_print_binarymil (dmpout, ffebld_constant_typeless (c));
 823       break;
 824
 825     case FFEBLD_constBINARY_VXT:
 826       fprintf (dmpout, "BV/");
 827       ffetarget_print_binaryvxt (dmpout, ffebld_constant_typeless (c));
 828       break;
 829
 830     case FFEBLD_constOCTAL_MIL:
 831       fprintf (dmpout, "OM/");
 832       ffetarget_print_octalmil (dmpout, ffebld_constant_typeless (c));
 833       break;
 834
 835     case FFEBLD_constOCTAL_VXT:
 836       fprintf (dmpout, "OV/");
 837       ffetarget_print_octalvxt (dmpout, ffebld_constant_typeless (c));
 838       break;
 839
 840     case FFEBLD_constHEX_X_MIL:
 841       fprintf (dmpout, "XM/");
 842       ffetarget_print_hexxmil (dmpout, ffebld_constant_typeless (c));
 843       break;
 844
 845     case FFEBLD_constHEX_X_VXT:
 846       fprintf (dmpout, "XV/");
 847       ffetarget_print_hexxvxt (dmpout, ffebld_constant_typeless (c));
 848       break;
 849
 850     case FFEBLD_constHEX_Z_MIL:
 851       fprintf (dmpout, "ZM/");
 852       ffetarget_print_hexzmil (dmpout, ffebld_constant_typeless (c));
 853       break;
 854
 855     case FFEBLD_constHEX_Z_VXT:
 856       fprintf (dmpout, "ZV/");
 857       ffetarget_print_hexzvxt (dmpout, ffebld_constant_typeless (c));
 858       break;
 859
 860     default:
 861       assert ("bad constant type" == NULL);
 862       fprintf (dmpout, "?/?");
 863       break;
 864     }
 865 }
 866 #endif
 867
 868 /* ffebld_constant_is_magical -- Determine if integer is "magical"
 869
 870    ffebldConstant c;
 871    if (ffebld_constant_is_magical(c))
 872        // it is 2**(n-1), where n is # bits in ffetargetIntegerDefault type
 873        // (this test is important for 2's-complement machines only).  */
 874
 875 bool
 876 ffebld_constant_is_magical (ffebldConstant c)
 877 {
 878   switch (ffebld_constant_type (c))
 879     {
 880     case FFEBLD_constINTEGERDEFAULT:
 881       return ffetarget_integerdefault_is_magical (ffebld_constant_integer1 (c));
 882
 883     default:
 884       return FALSE;
 885     }
 886 }
 887
 888 /* Determine if constant is zero.  Used to ensure step count
 889    for DO loops isn't zero, also to determine if values will
 890    be binary zeros, so not entirely portable at this point.  */
 891
 892 bool
 893 ffebld_constant_is_zero (ffebldConstant c)
 894 {
 895   switch (ffebld_constant_type (c))
 896     {
 897 #if FFETARGET_okINTEGER1
 898     case FFEBLD_constINTEGER1:
 899       return ffebld_constant_integer1 (c) == 0;
 900 #endif
 901
 902 #if FFETARGET_okINTEGER2
 903     case FFEBLD_constINTEGER2:
 904       return ffebld_constant_integer2 (c) == 0;
 905 #endif
 906
 907 #if FFETARGET_okINTEGER3
 908     case FFEBLD_constINTEGER3:
 909       return ffebld_constant_integer3 (c) == 0;
 910 #endif
 911
 912 #if FFETARGET_okINTEGER4
 913     case FFEBLD_constINTEGER4:
 914       return ffebld_constant_integer4 (c) == 0;
 915 #endif
 916
 917 #if FFETARGET_okINTEGER5
 918     case FFEBLD_constINTEGER5:
 919       return ffebld_constant_integer5 (c) == 0;
 920 #endif
 921
 922 #if FFETARGET_okINTEGER6
 923     case FFEBLD_constINTEGER6:
 924       return ffebld_constant_integer6 (c) == 0;
 925 #endif
 926
 927 #if FFETARGET_okINTEGER7
 928     case FFEBLD_constINTEGER7:
 929       return ffebld_constant_integer7 (c) == 0;
 930 #endif
 931
 932 #if FFETARGET_okINTEGER8
 933     case FFEBLD_constINTEGER8:
 934       return ffebld_constant_integer8 (c) == 0;
 935 #endif
 936
 937 #if FFETARGET_okLOGICAL1
 938     case FFEBLD_constLOGICAL1:
 939       return ffebld_constant_logical1 (c) == 0;
 940 #endif
 941
 942 #if FFETARGET_okLOGICAL2
 943     case FFEBLD_constLOGICAL2:
 944       return ffebld_constant_logical2 (c) == 0;
 945 #endif
 946
 947 #if FFETARGET_okLOGICAL3
 948     case FFEBLD_constLOGICAL3:
 949       return ffebld_constant_logical3 (c) == 0;
 950 #endif
 951
 952 #if FFETARGET_okLOGICAL4
 953     case FFEBLD_constLOGICAL4:
 954       return ffebld_constant_logical4 (c) == 0;
 955 #endif
 956
 957 #if FFETARGET_okLOGICAL5
 958     case FFEBLD_constLOGICAL5:
 959       return ffebld_constant_logical5 (c) == 0;
 960 #endif
 961
 962 #if FFETARGET_okLOGICAL6
 963     case FFEBLD_constLOGICAL6:
 964       return ffebld_constant_logical6 (c) == 0;
 965 #endif
 966
 967 #if FFETARGET_okLOGICAL7
 968     case FFEBLD_constLOGICAL7:
 969       return ffebld_constant_logical7 (c) == 0;
 970 #endif
 971
 972 #if FFETARGET_okLOGICAL8
 973     case FFEBLD_constLOGICAL8:
 974       return ffebld_constant_logical8 (c) == 0;
 975 #endif
 976
 977 #if FFETARGET_okREAL1
 978     case FFEBLD_constREAL1:
 979       return ffetarget_iszero_real1 (ffebld_constant_real1 (c));
 980 #endif
 981
 982 #if FFETARGET_okREAL2
 983     case FFEBLD_constREAL2:
 984       return ffetarget_iszero_real2 (ffebld_constant_real2 (c));
 985 #endif
 986
 987 #if FFETARGET_okREAL3
 988     case FFEBLD_constREAL3:
 989       return ffetarget_iszero_real3 (ffebld_constant_real3 (c));
 990 #endif
 991
 992 #if FFETARGET_okREAL4
 993     case FFEBLD_constREAL4:
 994       return ffetarget_iszero_real4 (ffebld_constant_real4 (c));
 995 #endif
 996
 997 #if FFETARGET_okREAL5
 998     case FFEBLD_constREAL5:
 999       return ffetarget_iszero_real5 (ffebld_constant_real5 (c));
1000 #endif
1001
1002 #if FFETARGET_okREAL6
1003     case FFEBLD_constREAL6:
1004       return ffetarget_iszero_real6 (ffebld_constant_real6 (c));
1005 #endif
1006
1007 #if FFETARGET_okREAL7
1008     case FFEBLD_constREAL7:
1009       return ffetarget_iszero_real7 (ffebld_constant_real7 (c));
1010 #endif
1011
1012 #if FFETARGET_okREAL8
1013     case FFEBLD_constREAL8:
1014       return ffetarget_iszero_real8 (ffebld_constant_real8 (c));
1015 #endif
1016
1017 #if FFETARGET_okCOMPLEX1
1018     case FFEBLD_constCOMPLEX1:
1019       return ffetarget_iszero_real1 (ffebld_constant_complex1 (c).real)
1020      && ffetarget_iszero_real1 (ffebld_constant_complex1 (c).imaginary);
1021 #endif
1022
1023 #if FFETARGET_okCOMPLEX2
1024     case FFEBLD_constCOMPLEX2:
1025       return ffetarget_iszero_real2 (ffebld_constant_complex2 (c).real)
1026      && ffetarget_iszero_real2 (ffebld_constant_complex2 (c).imaginary);
1027 #endif
1028
1029 #if FFETARGET_okCOMPLEX3
1030     case FFEBLD_constCOMPLEX3:
1031       return ffetarget_iszero_real3 (ffebld_constant_complex3 (c).real)
1032      && ffetarget_iszero_real3 (ffebld_constant_complex3 (c).imaginary);
1033 #endif
1034
1035 #if FFETARGET_okCOMPLEX4
1036     case FFEBLD_constCOMPLEX4:
1037       return ffetarget_iszero_real4 (ffebld_constant_complex4 (c).real)
1038      && ffetarget_iszero_real4 (ffebld_constant_complex4 (c).imaginary);
1039 #endif
1040
1041 #if FFETARGET_okCOMPLEX5
1042     case FFEBLD_constCOMPLEX5:
1043       return ffetarget_iszero_real5 (ffebld_constant_complex5 (c).real)
1044      && ffetarget_iszero_real5 (ffebld_constant_complex5 (c).imaginary);
1045 #endif
1046
1047 #if FFETARGET_okCOMPLEX6
1048     case FFEBLD_constCOMPLEX6:
1049       return ffetarget_iszero_real6 (ffebld_constant_complex6 (c).real)
1050      && ffetarget_iszero_real6 (ffebld_constant_complex6 (c).imaginary);
1051 #endif
1052
1053 #if FFETARGET_okCOMPLEX7
1054     case FFEBLD_constCOMPLEX7:
1055       return ffetarget_iszero_real7 (ffebld_constant_complex7 (c).real)
1056      && ffetarget_iszero_real7 (ffebld_constant_complex7 (c).imaginary);
1057 #endif
1058
1059 #if FFETARGET_okCOMPLEX8
1060     case FFEBLD_constCOMPLEX8:
1061       return ffetarget_iszero_real8 (ffebld_constant_complex8 (c).real)
1062      && ffetarget_iszero_real8 (ffebld_constant_complex8 (c).imaginary);
1063 #endif
1064
1065 #if FFETARGET_okCHARACTER1
1066     case FFEBLD_constCHARACTER1:
1067       return ffetarget_iszero_character1 (ffebld_constant_character1 (c));
1068 #endif
1069
1070 #if FFETARGET_okCHARACTER2 || FFETARGET_okCHARACTER3  /* ... */
1071 #error "no support for these!!"
1072 #endif
1073
1074     case FFEBLD_constHOLLERITH:
1075       return ffetarget_iszero_hollerith (ffebld_constant_hollerith (c));
1076
1077     case FFEBLD_constBINARY_MIL:
1078     case FFEBLD_constBINARY_VXT:
1079     case FFEBLD_constOCTAL_MIL:
1080     case FFEBLD_constOCTAL_VXT:
1081     case FFEBLD_constHEX_X_MIL:
1082     case FFEBLD_constHEX_X_VXT:
1083     case FFEBLD_constHEX_Z_MIL:
1084     case FFEBLD_constHEX_Z_VXT:
1085       return ffetarget_iszero_typeless (ffebld_constant_typeless (c));
1086
1087     default:
1088       return FALSE;
1089     }
1090 }
1091
1092 /* ffebld_constant_new_character1 -- Return character1 constant object from token
1093
1094    See prototype.  */
1095
1096 #if FFETARGET_okCHARACTER1
1097 ffebldConstant
1098 ffebld_constant_new_character1 (ffelexToken t)
1099 {
1100   ffetargetCharacter1 val;
1101
1102   ffetarget_character1 (&val, t, ffebld_constant_pool());
1103   return ffebld_constant_new_character1_val (val);
1104 }
1105
1106 #endif
1107 /* ffebld_constant_new_character1_val -- Return an character1 constant object
1108
1109    See prototype.  */
1110
1111 #if FFETARGET_okCHARACTER1
1112 ffebldConstant
1113 ffebld_constant_new_character1_val (ffetargetCharacter1 val)
1114 {
1115   ffebldConstant c;
1116   ffebldConstant nc;
1117   int cmp;
1118
1119   ffetarget_verify_character1 (ffebld_constant_pool(), val);
1120
1121   for (c = (ffebldConstant) &ffebld_constant_character1_;
1122        c->next != NULL;
1123        c = c->next)
1124     {
1125       malloc_verify_kp (ffebld_constant_pool(),
1126                         c->next,
1127                         sizeof (*(c->next)));
1128       ffetarget_verify_character1 (ffebld_constant_pool(),
1129                                    ffebld_constant_character1 (c->next));
1130       cmp = ffetarget_cmp_character1 (val,
1131                                       ffebld_constant_character1 (c->next));
1132       if (cmp == 0)
1133         return c->next;
1134       if (cmp > 0)
1135         break;
1136     }
1137
1138   nc = malloc_new_kp (ffebld_constant_pool(),
1139                       "FFEBLD_constCHARACTER1",
1140                       sizeof (*nc));
1141   nc->next = c->next;
1142   nc->consttype = FFEBLD_constCHARACTER1;
1143   nc->u.character1 = val;
1144 #ifdef FFECOM_constantHOOK
1145   nc->hook = FFECOM_constantNULL;
1146 #endif
1147   c->next = nc;
1148
1149   return nc;
1150 }
1151
1152 #endif
1153 /* ffebld_constant_new_complex1 -- Return complex1 constant object from token
1154
1155    See prototype.  */
1156
1157 #if FFETARGET_okCOMPLEX1
1158 ffebldConstant
1159 ffebld_constant_new_complex1 (ffebldConstant real,
1160                               ffebldConstant imaginary)
1161 {
1162   ffetargetComplex1 val;
1163
1164   val.real = ffebld_constant_real1 (real);
1165   val.imaginary = ffebld_constant_real1 (imaginary);
1166   return ffebld_constant_new_complex1_val (val);
1167 }
1168
1169 #endif
1170 /* ffebld_constant_new_complex1_val -- Return a complex1 constant object
1171
1172    See prototype.  */
1173
1174 #if FFETARGET_okCOMPLEX1
1175 ffebldConstant
1176 ffebld_constant_new_complex1_val (ffetargetComplex1 val)
1177 {
1178   ffebldConstant c;
1179   ffebldConstant nc;
1180   int cmp;
1181
1182   for (c = (ffebldConstant) &ffebld_constant_complex1_;
1183        c->next != NULL;
1184        c = c->next)
1185     {
1186       cmp = ffetarget_cmp_real1 (val.real, ffebld_constant_complex1 (c->next).real);
1187       if (cmp == 0)
1188         cmp = ffetarget_cmp_real1 (val.imaginary,
1189                               ffebld_constant_complex1 (c->next).imaginary);
1190       if (cmp == 0)
1191         return c->next;
1192       if (cmp > 0)
1193         break;
1194     }
1195
1196   nc = malloc_new_kp (ffebld_constant_pool(),
1197                       "FFEBLD_constCOMPLEX1",
1198                       sizeof (*nc));
1199   nc->next = c->next;
1200   nc->consttype = FFEBLD_constCOMPLEX1;
1201   nc->u.complex1 = val;
1202 #ifdef FFECOM_constantHOOK
1203   nc->hook = FFECOM_constantNULL;
1204 #endif
1205   c->next = nc;
1206
1207   return nc;
1208 }
1209
1210 #endif
1211 /* ffebld_constant_new_complex2 -- Return complex2 constant object from token
1212
1213    See prototype.  */
1214
1215 #if FFETARGET_okCOMPLEX2
1216 ffebldConstant
1217 ffebld_constant_new_complex2 (ffebldConstant real,
1218                               ffebldConstant imaginary)
1219 {
1220   ffetargetComplex2 val;
1221
1222   val.real = ffebld_constant_real2 (real);
1223   val.imaginary = ffebld_constant_real2 (imaginary);
1224   return ffebld_constant_new_complex2_val (val);
1225 }
1226
1227 #endif
1228 /* ffebld_constant_new_complex2_val -- Return a complex2 constant object
1229
1230    See prototype.  */
1231
1232 #if FFETARGET_okCOMPLEX2
1233 ffebldConstant
1234 ffebld_constant_new_complex2_val (ffetargetComplex2 val)
1235 {
1236   ffebldConstant c;
1237   ffebldConstant nc;
1238   int cmp;
1239
1240   for (c = (ffebldConstant) &ffebld_constant_complex2_;
1241        c->next != NULL;
1242        c = c->next)
1243     {
1244       cmp = ffetarget_cmp_real2 (val.real, ffebld_constant_complex2 (c->next).real);
1245       if (cmp == 0)
1246         cmp = ffetarget_cmp_real2 (val.imaginary,
1247                               ffebld_constant_complex2 (c->next).imaginary);
1248       if (cmp == 0)
1249         return c->next;
1250       if (cmp > 0)
1251         break;
1252     }
1253
1254   nc = malloc_new_kp (ffebld_constant_pool(),
1255                       "FFEBLD_constCOMPLEX2",
1256                       sizeof (*nc));
1257   nc->next = c->next;
1258   nc->consttype = FFEBLD_constCOMPLEX2;
1259   nc->u.complex2 = val;
1260 #ifdef FFECOM_constantHOOK
1261   nc->hook = FFECOM_constantNULL;
1262 #endif
1263   c->next = nc;
1264
1265   return nc;
1266 }
1267
1268 #endif
1269 /* ffebld_constant_new_hollerith -- Return hollerith constant object from token
1270
1271    See prototype.  */
1272
1273 ffebldConstant
1274 ffebld_constant_new_hollerith (ffelexToken t)
1275 {
1276   ffetargetHollerith val;
1277
1278   ffetarget_hollerith (&val, t, ffebld_constant_pool());
1279   return ffebld_constant_new_hollerith_val (val);
1280 }
1281
1282 /* ffebld_constant_new_hollerith_val -- Return an hollerith constant object
1283
1284    See prototype.  */
1285
1286 ffebldConstant
1287 ffebld_constant_new_hollerith_val (ffetargetHollerith val)
1288 {
1289   ffebldConstant c;
1290   ffebldConstant nc;
1291   int cmp;
1292
1293   for (c = (ffebldConstant) &ffebld_constant_hollerith_;
1294        c->next != NULL;
1295        c = c->next)
1296     {
1297       cmp = ffetarget_cmp_hollerith (val, ffebld_constant_hollerith (c->next));
1298       if (cmp == 0)
1299         return c->next;
1300       if (cmp > 0)
1301         break;
1302     }
1303
1304   nc = malloc_new_kp (ffebld_constant_pool(),
1305                       "FFEBLD_constHOLLERITH",
1306                       sizeof (*nc));
1307   nc->next = c->next;
1308   nc->consttype = FFEBLD_constHOLLERITH;
1309   nc->u.hollerith = val;
1310 #ifdef FFECOM_constantHOOK
1311   nc->hook = FFECOM_constantNULL;
1312 #endif
1313   c->next = nc;
1314
1315   return nc;
1316 }
1317
1318 /* ffebld_constant_new_integer1 -- Return integer1 constant object from token
1319
1320    See prototype.
1321
1322    Parses the token as a decimal integer constant, thus it must be an
1323    FFELEX_typeNUMBER.  */
1324
1325 #if FFETARGET_okINTEGER1
1326 ffebldConstant
1327 ffebld_constant_new_integer1 (ffelexToken t)
1328 {
1329   ffetargetInteger1 val;
1330
1331   assert (ffelex_token_type (t) == FFELEX_typeNUMBER);
1332
1333   ffetarget_integer1 (&val, t);
1334   return ffebld_constant_new_integer1_val (val);
1335 }
1336
1337 #endif
1338 /* ffebld_constant_new_integer1_val -- Return an integer1 constant object
1339
1340    See prototype.  */
1341
1342 #if FFETARGET_okINTEGER1
1343 ffebldConstant
1344 ffebld_constant_new_integer1_val (ffetargetInteger1 val)
1345 {
1346   ffebldConstant c;
1347   ffebldConstant nc;
1348   int cmp;
1349
1350   for (c = (ffebldConstant) &ffebld_constant_integer1_;
1351        c->next != NULL;
1352        c = c->next)
1353     {
1354       cmp = ffetarget_cmp_integer1 (val, ffebld_constant_integer1 (c->next));
1355       if (cmp == 0)
1356         return c->next;
1357       if (cmp > 0)
1358         break;
1359     }
1360
1361   nc = malloc_new_kp (ffebld_constant_pool(),
1362                       "FFEBLD_constINTEGER1",
1363                       sizeof (*nc));
1364   nc->next = c->next;
1365   nc->consttype = FFEBLD_constINTEGER1;
1366   nc->u.integer1 = val;
1367 #ifdef FFECOM_constantHOOK
1368   nc->hook = FFECOM_constantNULL;
1369 #endif
1370   c->next = nc;
1371
1372   return nc;
1373 }
1374
1375 #endif
1376 /* ffebld_constant_new_integer2_val -- Return an integer2 constant object
1377
1378    See prototype.  */
1379
1380 #if FFETARGET_okINTEGER2
1381 ffebldConstant
1382 ffebld_constant_new_integer2_val (ffetargetInteger2 val)
1383 {
1384   ffebldConstant c;
1385   ffebldConstant nc;
1386   int cmp;
1387
1388   for (c = (ffebldConstant) &ffebld_constant_integer2_;
1389        c->next != NULL;
1390        c = c->next)
1391     {
1392       cmp = ffetarget_cmp_integer2 (val, ffebld_constant_integer2 (c->next));
1393       if (cmp == 0)
1394         return c->next;
1395       if (cmp > 0)
1396         break;
1397     }
1398
1399   nc = malloc_new_kp (ffebld_constant_pool(),
1400                       "FFEBLD_constINTEGER2",
1401                       sizeof (*nc));
1402   nc->next = c->next;
1403   nc->consttype = FFEBLD_constINTEGER2;
1404   nc->u.integer2 = val;
1405 #ifdef FFECOM_constantHOOK
1406   nc->hook = FFECOM_constantNULL;
1407 #endif
1408   c->next = nc;
1409
1410   return nc;
1411 }
1412
1413 #endif
1414 /* ffebld_constant_new_integer3_val -- Return an integer3 constant object
1415
1416    See prototype.  */
1417
1418 #if FFETARGET_okINTEGER3
1419 ffebldConstant
1420 ffebld_constant_new_integer3_val (ffetargetInteger3 val)
1421 {
1422   ffebldConstant c;
1423   ffebldConstant nc;
1424   int cmp;
1425
1426   for (c = (ffebldConstant) &ffebld_constant_integer3_;
1427        c->next != NULL;
1428        c = c->next)
1429     {
1430       cmp = ffetarget_cmp_integer3 (val, ffebld_constant_integer3 (c->next));
1431       if (cmp == 0)
1432         return c->next;
1433       if (cmp > 0)
1434         break;
1435     }
1436
1437   nc = malloc_new_kp (ffebld_constant_pool(),
1438                       "FFEBLD_constINTEGER3",
1439                       sizeof (*nc));
1440   nc->next = c->next;
1441   nc->consttype = FFEBLD_constINTEGER3;
1442   nc->u.integer3 = val;
1443 #ifdef FFECOM_constantHOOK
1444   nc->hook = FFECOM_constantNULL;
1445 #endif
1446   c->next = nc;
1447
1448   return nc;
1449 }
1450
1451 #endif
1452 /* ffebld_constant_new_integer4_val -- Return an integer4 constant object
1453
1454    See prototype.  */
1455
1456 #if FFETARGET_okINTEGER4
1457 ffebldConstant
1458 ffebld_constant_new_integer4_val (ffetargetInteger4 val)
1459 {
1460   ffebldConstant c;
1461   ffebldConstant nc;
1462   int cmp;
1463
1464   for (c = (ffebldConstant) &ffebld_constant_integer4_;
1465        c->next != NULL;
1466        c = c->next)
1467     {
1468       cmp = ffetarget_cmp_integer4 (val, ffebld_constant_integer4 (c->next));
1469       if (cmp == 0)
1470         return c->next;
1471       if (cmp > 0)
1472         break;
1473     }
1474
1475   nc = malloc_new_kp (ffebld_constant_pool(),
1476                       "FFEBLD_constINTEGER4",
1477                       sizeof (*nc));
1478   nc->next = c->next;
1479   nc->consttype = FFEBLD_constINTEGER4;
1480   nc->u.integer4 = val;
1481 #ifdef FFECOM_constantHOOK
1482   nc->hook = FFECOM_constantNULL;
1483 #endif
1484   c->next = nc;
1485
1486   return nc;
1487 }
1488
1489 #endif
1490 /* ffebld_constant_new_integerbinary -- Return binary constant object from token
1491
1492    See prototype.
1493
1494    Parses the token as a binary integer constant, thus it must be an
1495    FFELEX_typeNUMBER.  */
1496
1497 ffebldConstant
1498 ffebld_constant_new_integerbinary (ffelexToken t)
1499 {
1500   ffetargetIntegerDefault val;
1501
1502   assert ((ffelex_token_type (t) == FFELEX_typeNAME)
1503           || (ffelex_token_type (t) == FFELEX_typeNUMBER));
1504
1505   ffetarget_integerbinary (&val, t);
1506   return ffebld_constant_new_integerdefault_val (val);
1507 }
1508
1509 /* ffebld_constant_new_integerhex -- Return hex constant object from token
1510
1511    See prototype.
1512
1513    Parses the token as a hex integer constant, thus it must be an
1514    FFELEX_typeNUMBER.  */
1515
1516 ffebldConstant
1517 ffebld_constant_new_integerhex (ffelexToken t)
1518 {
1519   ffetargetIntegerDefault val;
1520
1521   assert ((ffelex_token_type (t) == FFELEX_typeNAME)
1522           || (ffelex_token_type (t) == FFELEX_typeNUMBER));
1523
1524   ffetarget_integerhex (&val, t);
1525   return ffebld_constant_new_integerdefault_val (val);
1526 }
1527
1528 /* ffebld_constant_new_integeroctal -- Return octal constant object from token
1529
1530    See prototype.
1531
1532    Parses the token as a octal integer constant, thus it must be an
1533    FFELEX_typeNUMBER.  */
1534
1535 ffebldConstant
1536 ffebld_constant_new_integeroctal (ffelexToken t)
1537 {
1538   ffetargetIntegerDefault val;
1539
1540   assert ((ffelex_token_type (t) == FFELEX_typeNAME)
1541           || (ffelex_token_type (t) == FFELEX_typeNUMBER));
1542
1543   ffetarget_integeroctal (&val, t);
1544   return ffebld_constant_new_integerdefault_val (val);
1545 }
1546
1547 /* ffebld_constant_new_logical1 -- Return logical1 constant object from token
1548
1549    See prototype.
1550
1551    Parses the token as a decimal logical constant, thus it must be an
1552    FFELEX_typeNUMBER.  */
1553
1554 #if FFETARGET_okLOGICAL1
1555 ffebldConstant
1556 ffebld_constant_new_logical1 (bool truth)
1557 {
1558   ffetargetLogical1 val;
1559
1560   ffetarget_logical1 (&val, truth);
1561   return ffebld_constant_new_logical1_val (val);
1562 }
1563
1564 #endif
1565 /* ffebld_constant_new_logical1_val -- Return a logical1 constant object
1566
1567    See prototype.  */
1568
1569 #if FFETARGET_okLOGICAL1
1570 ffebldConstant
1571 ffebld_constant_new_logical1_val (ffetargetLogical1 val)
1572 {
1573   ffebldConstant c;
1574   ffebldConstant nc;
1575   int cmp;
1576
1577   for (c = (ffebldConstant) &ffebld_constant_logical1_;
1578        c->next != NULL;
1579        c = c->next)
1580     {
1581       cmp = ffetarget_cmp_logical1 (val, ffebld_constant_logical1 (c->next));
1582       if (cmp == 0)
1583         return c->next;
1584       if (cmp > 0)
1585         break;
1586     }
1587
1588   nc = malloc_new_kp (ffebld_constant_pool(),
1589                       "FFEBLD_constLOGICAL1",
1590                       sizeof (*nc));
1591   nc->next = c->next;
1592   nc->consttype = FFEBLD_constLOGICAL1;
1593   nc->u.logical1 = val;
1594 #ifdef FFECOM_constantHOOK
1595   nc->hook = FFECOM_constantNULL;
1596 #endif
1597   c->next = nc;
1598
1599   return nc;
1600 }
1601
1602 #endif
1603 /* ffebld_constant_new_logical2_val -- Return a logical2 constant object
1604
1605    See prototype.  */
1606
1607 #if FFETARGET_okLOGICAL2
1608 ffebldConstant
1609 ffebld_constant_new_logical2_val (ffetargetLogical2 val)
1610 {
1611   ffebldConstant c;
1612   ffebldConstant nc;
1613   int cmp;
1614
1615   for (c = (ffebldConstant) &ffebld_constant_logical2_;
1616        c->next != NULL;
1617        c = c->next)
1618     {
1619       cmp = ffetarget_cmp_logical2 (val, ffebld_constant_logical2 (c->next));
1620       if (cmp == 0)
1621         return c->next;
1622       if (cmp > 0)
1623         break;
1624     }
1625
1626   nc = malloc_new_kp (ffebld_constant_pool(),
1627                       "FFEBLD_constLOGICAL2",
1628                       sizeof (*nc));
1629   nc->next = c->next;
1630   nc->consttype = FFEBLD_constLOGICAL2;
1631   nc->u.logical2 = val;
1632 #ifdef FFECOM_constantHOOK
1633   nc->hook = FFECOM_constantNULL;
1634 #endif
1635   c->next = nc;
1636
1637   return nc;
1638 }
1639
1640 #endif
1641 /* ffebld_constant_new_logical3_val -- Return a logical3 constant object
1642
1643    See prototype.  */
1644
1645 #if FFETARGET_okLOGICAL3
1646 ffebldConstant
1647 ffebld_constant_new_logical3_val (ffetargetLogical3 val)
1648 {
1649   ffebldConstant c;
1650   ffebldConstant nc;
1651   int cmp;
1652
1653   for (c = (ffebldConstant) &ffebld_constant_logical3_;
1654        c->next != NULL;
1655        c = c->next)
1656     {
1657       cmp = ffetarget_cmp_logical3 (val, ffebld_constant_logical3 (c->next));
1658       if (cmp == 0)
1659         return c->next;
1660       if (cmp > 0)
1661         break;
1662     }
1663
1664   nc = malloc_new_kp (ffebld_constant_pool(),
1665                       "FFEBLD_constLOGICAL3",
1666                       sizeof (*nc));
1667   nc->next = c->next;
1668   nc->consttype = FFEBLD_constLOGICAL3;
1669   nc->u.logical3 = val;
1670 #ifdef FFECOM_constantHOOK
1671   nc->hook = FFECOM_constantNULL;
1672 #endif
1673   c->next = nc;
1674
1675   return nc;
1676 }
1677
1678 #endif
1679 /* ffebld_constant_new_logical4_val -- Return a logical4 constant object
1680
1681    See prototype.  */
1682
1683 #if FFETARGET_okLOGICAL4
1684 ffebldConstant
1685 ffebld_constant_new_logical4_val (ffetargetLogical4 val)
1686 {
1687   ffebldConstant c;
1688   ffebldConstant nc;
1689   int cmp;
1690
1691   for (c = (ffebldConstant) &ffebld_constant_logical4_;
1692        c->next != NULL;
1693        c = c->next)
1694     {
1695       cmp = ffetarget_cmp_logical4 (val, ffebld_constant_logical4 (c->next));
1696       if (cmp == 0)
1697         return c->next;
1698       if (cmp > 0)
1699         break;
1700     }
1701
1702   nc = malloc_new_kp (ffebld_constant_pool(),
1703                       "FFEBLD_constLOGICAL4",
1704                       sizeof (*nc));
1705   nc->next = c->next;
1706   nc->consttype = FFEBLD_constLOGICAL4;
1707   nc->u.logical4 = val;
1708 #ifdef FFECOM_constantHOOK
1709   nc->hook = FFECOM_constantNULL;
1710 #endif
1711   c->next = nc;
1712
1713   return nc;
1714 }
1715
1716 #endif
1717 /* ffebld_constant_new_real1 -- Return real1 constant object from token
1718
1719    See prototype.  */
1720
1721 #if FFETARGET_okREAL1
1722 ffebldConstant
1723 ffebld_constant_new_real1 (ffelexToken integer, ffelexToken decimal,
1724       ffelexToken fraction, ffelexToken exponent, ffelexToken exponent_sign,
1725                            ffelexToken exponent_digits)
1726 {
1727   ffetargetReal1 val;
1728
1729   ffetarget_real1 (&val,
1730       integer, decimal, fraction, exponent, exponent_sign, exponent_digits);
1731   return ffebld_constant_new_real1_val (val);
1732 }
1733
1734 #endif
1735 /* ffebld_constant_new_real1_val -- Return an real1 constant object
1736
1737    See prototype.  */
1738
1739 #if FFETARGET_okREAL1
1740 ffebldConstant
1741 ffebld_constant_new_real1_val (ffetargetReal1 val)
1742 {
1743   ffebldConstant c;
1744   ffebldConstant nc;
1745   int cmp;
1746
1747   for (c = (ffebldConstant) &ffebld_constant_real1_;
1748        c->next != NULL;
1749        c = c->next)
1750     {
1751       cmp = ffetarget_cmp_real1 (val, ffebld_constant_real1 (c->next));
1752       if (cmp == 0)
1753         return c->next;
1754       if (cmp > 0)
1755         break;
1756     }
1757
1758   nc = malloc_new_kp (ffebld_constant_pool(),
1759                       "FFEBLD_constREAL1",
1760                       sizeof (*nc));
1761   nc->next = c->next;
1762   nc->consttype = FFEBLD_constREAL1;
1763   nc->u.real1 = val;
1764 #ifdef FFECOM_constantHOOK
1765   nc->hook = FFECOM_constantNULL;
1766 #endif
1767   c->next = nc;
1768
1769   return nc;
1770 }
1771
1772 #endif
1773 /* ffebld_constant_new_real2 -- Return real2 constant object from token
1774
1775    See prototype.  */
1776
1777 #if FFETARGET_okREAL2
1778 ffebldConstant
1779 ffebld_constant_new_real2 (ffelexToken integer, ffelexToken decimal,
1780       ffelexToken fraction, ffelexToken exponent, ffelexToken exponent_sign,
1781                            ffelexToken exponent_digits)
1782 {
1783   ffetargetReal2 val;
1784
1785   ffetarget_real2 (&val,
1786       integer, decimal, fraction, exponent, exponent_sign, exponent_digits);
1787   return ffebld_constant_new_real2_val (val);
1788 }
1789
1790 #endif
1791 /* ffebld_constant_new_real2_val -- Return an real2 constant object
1792
1793    See prototype.  */
1794
1795 #if FFETARGET_okREAL2
1796 ffebldConstant
1797 ffebld_constant_new_real2_val (ffetargetReal2 val)
1798 {
1799   ffebldConstant c;
1800   ffebldConstant nc;
1801   int cmp;
1802
1803   for (c = (ffebldConstant) &ffebld_constant_real2_;
1804        c->next != NULL;
1805        c = c->next)
1806     {
1807       cmp = ffetarget_cmp_real2 (val, ffebld_constant_real2 (c->next));
1808       if (cmp == 0)
1809         return c->next;
1810       if (cmp > 0)
1811         break;
1812     }
1813
1814   nc = malloc_new_kp (ffebld_constant_pool(),
1815                       "FFEBLD_constREAL2",
1816                       sizeof (*nc));
1817   nc->next = c->next;
1818   nc->consttype = FFEBLD_constREAL2;
1819   nc->u.real2 = val;
1820 #ifdef FFECOM_constantHOOK
1821   nc->hook = FFECOM_constantNULL;
1822 #endif
1823   c->next = nc;
1824
1825   return nc;
1826 }
1827
1828 #endif
1829 /* ffebld_constant_new_typeless_bm -- Return typeless constant object from token
1830
1831    See prototype.
1832
1833    Parses the token as a decimal integer constant, thus it must be an
1834    FFELEX_typeNUMBER.  */
1835
1836 ffebldConstant
1837 ffebld_constant_new_typeless_bm (ffelexToken t)
1838 {
1839   ffetargetTypeless val;
1840
1841   ffetarget_binarymil (&val, t);
1842   return ffebld_constant_new_typeless_val (FFEBLD_constBINARY_MIL, val);
1843 }
1844
1845 /* ffebld_constant_new_typeless_bv -- Return typeless constant object from token
1846
1847    See prototype.
1848
1849    Parses the token as a decimal integer constant, thus it must be an
1850    FFELEX_typeNUMBER.  */
1851
1852 ffebldConstant
1853 ffebld_constant_new_typeless_bv (ffelexToken t)
1854 {
1855   ffetargetTypeless val;
1856
1857   ffetarget_binaryvxt (&val, t);
1858   return ffebld_constant_new_typeless_val (FFEBLD_constBINARY_VXT, val);
1859 }
1860
1861 /* ffebld_constant_new_typeless_hxm -- Return typeless constant object from token
1862
1863    See prototype.
1864
1865    Parses the token as a decimal integer constant, thus it must be an
1866    FFELEX_typeNUMBER.  */
1867
1868 ffebldConstant
1869 ffebld_constant_new_typeless_hxm (ffelexToken t)
1870 {
1871   ffetargetTypeless val;
1872
1873   ffetarget_hexxmil (&val, t);
1874   return ffebld_constant_new_typeless_val (FFEBLD_constHEX_X_MIL, val);
1875 }
1876
1877 /* ffebld_constant_new_typeless_hxv -- Return typeless constant object from token
1878
1879    See prototype.
1880
1881    Parses the token as a decimal integer constant, thus it must be an
1882    FFELEX_typeNUMBER.  */
1883
1884 ffebldConstant
1885 ffebld_constant_new_typeless_hxv (ffelexToken t)
1886 {
1887   ffetargetTypeless val;
1888
1889   ffetarget_hexxvxt (&val, t);
1890   return ffebld_constant_new_typeless_val (FFEBLD_constHEX_X_VXT, val);
1891 }
1892
1893 /* ffebld_constant_new_typeless_hzm -- Return typeless constant object from token
1894
1895    See prototype.
1896
1897    Parses the token as a decimal integer constant, thus it must be an
1898    FFELEX_typeNUMBER.  */
1899
1900 ffebldConstant
1901 ffebld_constant_new_typeless_hzm (ffelexToken t)
1902 {
1903   ffetargetTypeless val;
1904
1905   ffetarget_hexzmil (&val, t);
1906   return ffebld_constant_new_typeless_val (FFEBLD_constHEX_Z_MIL, val);
1907 }
1908
1909 /* ffebld_constant_new_typeless_hzv -- Return typeless constant object from token
1910
1911    See prototype.
1912
1913    Parses the token as a decimal integer constant, thus it must be an
1914    FFELEX_typeNUMBER.  */
1915
1916 ffebldConstant
1917 ffebld_constant_new_typeless_hzv (ffelexToken t)
1918 {
1919   ffetargetTypeless val;
1920
1921   ffetarget_hexzvxt (&val, t);
1922   return ffebld_constant_new_typeless_val (FFEBLD_constHEX_Z_VXT, val);
1923 }
1924
1925 /* ffebld_constant_new_typeless_om -- Return typeless constant object from token
1926
1927    See prototype.
1928
1929    Parses the token as a decimal integer constant, thus it must be an
1930    FFELEX_typeNUMBER.  */
1931
1932 ffebldConstant
1933 ffebld_constant_new_typeless_om (ffelexToken t)
1934 {
1935   ffetargetTypeless val;
1936
1937   ffetarget_octalmil (&val, t);
1938   return ffebld_constant_new_typeless_val (FFEBLD_constOCTAL_MIL, val);
1939 }
1940
1941 /* ffebld_constant_new_typeless_ov -- Return typeless constant object from token
1942
1943    See prototype.
1944
1945    Parses the token as a decimal integer constant, thus it must be an
1946    FFELEX_typeNUMBER.  */
1947
1948 ffebldConstant
1949 ffebld_constant_new_typeless_ov (ffelexToken t)
1950 {
1951   ffetargetTypeless val;
1952
1953   ffetarget_octalvxt (&val, t);
1954   return ffebld_constant_new_typeless_val (FFEBLD_constOCTAL_VXT, val);
1955 }
1956
1957 /* ffebld_constant_new_typeless_val -- Return a typeless constant object
1958
1959    See prototype.  */
1960
1961 ffebldConstant
1962 ffebld_constant_new_typeless_val (ffebldConst type, ffetargetTypeless val)
1963 {
1964   ffebldConstant c;
1965   ffebldConstant nc;
1966   int cmp;
1967
1968   for (c = (ffebldConstant) &ffebld_constant_typeless_[type
1969                                               - FFEBLD_constTYPELESS_FIRST];
1970        c->next != NULL;
1971        c = c->next)
1972     {
1973       cmp = ffetarget_cmp_typeless (val, ffebld_constant_typeless (c->next));
1974       if (cmp == 0)
1975         return c->next;
1976       if (cmp > 0)
1977         break;
1978     }
1979
1980   nc = malloc_new_kp (ffebld_constant_pool(),
1981                       "FFEBLD_constTYPELESS",
1982                       sizeof (*nc));
1983   nc->next = c->next;
1984   nc->consttype = type;
1985   nc->u.typeless = val;
1986 #ifdef FFECOM_constantHOOK
1987   nc->hook = FFECOM_constantNULL;
1988 #endif
1989   c->next = nc;
1990
1991   return nc;
1992 }
1993
1994 /* ffebld_constantarray_dump -- Display summary of array's contents
1995
1996    ffebldConstantArray a;
1997    ffeinfoBasictype bt;
1998    ffeinfoKindtype kt;
1999    ffetargetOffset size;
2000    ffebld_constant_dump(a,bt,kt,size,NULL);
2001
2002    Displays the constant array in summary form.  The fifth argument, if
2003    supplied, is an ffebit object that is consulted as to whether the
2004    constant at a particular offset is valid.  */
2005
2006 #if FFECOM_targetCURRENT == FFECOM_targetFFE
2007 void
2008 ffebld_constantarray_dump (ffebldConstantArray array, ffeinfoBasictype bt,
2009                       ffeinfoKindtype kt, ffetargetOffset size, ffebit bits)
2010 {
2011   ffetargetOffset i;
2012   ffebitCount j;
2013
2014   ffebld_dump_prefix (dmpout, bt, kt);
2015
2016   fprintf (dmpout, "\\(");
2017
2018   if (bits == NULL)
2019     {
2020       for (i = 0; i < size; ++i)
2021         {
2022           ffebld_constantunion_dump (ffebld_constantarray_get (array, bt, kt, i), bt,
2023                                      kt);
2024           if (i != size - 1)
2025             fputc (',', dmpout);
2026         }
2027     }
2028   else
2029     {
2030       bool value;
2031       ffebitCount length;
2032       ffetargetOffset offset = 0;
2033
2034       do
2035         {
2036           ffebit_test (bits, offset, &value, &length);
2037           if (value && (length != 0))
2038             {
2039               if (length == 1)
2040                 fprintf (dmpout, "[%" ffetargetOffset_f "d]:", offset);
2041               else
2042                 fprintf (dmpout,
2043                       "[%" ffetargetOffset_f "u..%" ffetargetOffset_f "d]:",
2044                          offset, offset + (ffetargetOffset) length - 1);
2045               for (j = 0; j < length; ++j, ++offset)
2046                 {
2047                   ffebld_constantunion_dump (ffebld_constantarray_get (array, bt, kt,
2048                                                            offset), bt, kt);
2049                   if (j != length - 1)
2050                     fputc (',', dmpout);
2051                 }
2052               fprintf (dmpout, ";");
2053             }
2054           else
2055             offset += length;
2056         }
2057       while (length != 0);
2058     }
2059   fprintf (dmpout, "\\)");
2060
2061 }
2062 #endif
2063
2064 /* ffebld_constantarray_get -- Get a value from an array of constants
2065
2066    See prototype.  */
2067
2068 ffebldConstantUnion
2069 ffebld_constantarray_get (ffebldConstantArray array, ffeinfoBasictype bt,
2070                           ffeinfoKindtype kt, ffetargetOffset offset)
2071 {
2072   ffebldConstantUnion u;
2073
2074   switch (bt)
2075     {
2076     case FFEINFO_basictypeINTEGER:
2077       switch (kt)
2078         {
2079 #if FFETARGET_okINTEGER1
2080         case FFEINFO_kindtypeINTEGER1:
2081           u.integer1 = *(array.integer1 + offset);
2082           break;
2083 #endif
2084
2085 #if FFETARGET_okINTEGER2
2086         case FFEINFO_kindtypeINTEGER2:
2087           u.integer2 = *(array.integer2 + offset);
2088           break;
2089 #endif
2090
2091 #if FFETARGET_okINTEGER3
2092         case FFEINFO_kindtypeINTEGER3:
2093           u.integer3 = *(array.integer3 + offset);
2094           break;
2095 #endif
2096
2097 #if FFETARGET_okINTEGER4
2098         case FFEINFO_kindtypeINTEGER4:
2099           u.integer4 = *(array.integer4 + offset);
2100           break;
2101 #endif
2102
2103 #if FFETARGET_okINTEGER5
2104         case FFEINFO_kindtypeINTEGER5:
2105           u.integer5 = *(array.integer5 + offset);
2106           break;
2107 #endif
2108
2109 #if FFETARGET_okINTEGER6
2110         case FFEINFO_kindtypeINTEGER6:
2111           u.integer6 = *(array.integer6 + offset);
2112           break;
2113 #endif
2114
2115 #if FFETARGET_okINTEGER7
2116         case FFEINFO_kindtypeINTEGER7:
2117           u.integer7 = *(array.integer7 + offset);
2118           break;
2119 #endif
2120
2121 #if FFETARGET_okINTEGER8
2122         case FFEINFO_kindtypeINTEGER8:
2123           u.integer8 = *(array.integer8 + offset);
2124           break;
2125 #endif
2126
2127         default:
2128           assert ("bad INTEGER kindtype" == NULL);
2129           break;
2130         }
2131       break;
2132
2133     case FFEINFO_basictypeLOGICAL:
2134       switch (kt)
2135         {
2136 #if FFETARGET_okLOGICAL1
2137         case FFEINFO_kindtypeLOGICAL1:
2138           u.logical1 = *(array.logical1 + offset);
2139           break;
2140 #endif
2141
2142 #if FFETARGET_okLOGICAL2
2143         case FFEINFO_kindtypeLOGICAL2:
2144           u.logical2 = *(array.logical2 + offset);
2145           break;
2146 #endif
2147
2148 #if FFETARGET_okLOGICAL3
2149         case FFEINFO_kindtypeLOGICAL3:
2150           u.logical3 = *(array.logical3 + offset);
2151           break;
2152 #endif
2153
2154 #if FFETARGET_okLOGICAL4
2155         case FFEINFO_kindtypeLOGICAL4:
2156           u.logical4 = *(array.logical4 + offset);
2157           break;
2158 #endif
2159
2160 #if FFETARGET_okLOGICAL5
2161         case FFEINFO_kindtypeLOGICAL5:
2162           u.logical5 = *(array.logical5 + offset);
2163           break;
2164 #endif
2165
2166 #if FFETARGET_okLOGICAL6
2167         case FFEINFO_kindtypeLOGICAL6:
2168           u.logical6 = *(array.logical6 + offset);
2169           break;
2170 #endif
2171
2172 #if FFETARGET_okLOGICAL7
2173         case FFEINFO_kindtypeLOGICAL7:
2174           u.logical7 = *(array.logical7 + offset);
2175           break;
2176 #endif
2177
2178 #if FFETARGET_okLOGICAL8
2179         case FFEINFO_kindtypeLOGICAL8:
2180           u.logical8 = *(array.logical8 + offset);
2181           break;
2182 #endif
2183
2184         default:
2185           assert ("bad LOGICAL kindtype" == NULL);
2186           break;
2187         }
2188       break;
2189
2190     case FFEINFO_basictypeREAL:
2191       switch (kt)
2192         {
2193 #if FFETARGET_okREAL1
2194         case FFEINFO_kindtypeREAL1:
2195           u.real1 = *(array.real1 + offset);
2196           break;
2197 #endif
2198
2199 #if FFETARGET_okREAL2
2200         case FFEINFO_kindtypeREAL2:
2201           u.real2 = *(array.real2 + offset);
2202           break;
2203 #endif
2204
2205 #if FFETARGET_okREAL3
2206         case FFEINFO_kindtypeREAL3:
2207           u.real3 = *(array.real3 + offset);
2208           break;
2209 #endif
2210
2211 #if FFETARGET_okREAL4
2212         case FFEINFO_kindtypeREAL4:
2213           u.real4 = *(array.real4 + offset);
2214           break;
2215 #endif
2216
2217 #if FFETARGET_okREAL5
2218         case FFEINFO_kindtypeREAL5:
2219           u.real5 = *(array.real5 + offset);
2220           break;
2221 #endif
2222
2223 #if FFETARGET_okREAL6
2224         case FFEINFO_kindtypeREAL6:
2225           u.real6 = *(array.real6 + offset);
2226           break;
2227 #endif
2228
2229 #if FFETARGET_okREAL7
2230         case FFEINFO_kindtypeREAL7:
2231           u.real7 = *(array.real7 + offset);
2232           break;
2233 #endif
2234
2235 #if FFETARGET_okREAL8
2236         case FFEINFO_kindtypeREAL8:
2237           u.real8 = *(array.real8 + offset);
2238           break;
2239 #endif
2240
2241         default:
2242           assert ("bad REAL kindtype" == NULL);
2243           break;
2244         }
2245       break;
2246
2247     case FFEINFO_basictypeCOMPLEX:
2248       switch (kt)
2249         {
2250 #if FFETARGET_okCOMPLEX1
2251         case FFEINFO_kindtypeREAL1:
2252           u.complex1 = *(array.complex1 + offset);
2253           break;
2254 #endif
2255
2256 #if FFETARGET_okCOMPLEX2
2257         case FFEINFO_kindtypeREAL2:
2258           u.complex2 = *(array.complex2 + offset);
2259           break;
2260 #endif
2261
2262 #if FFETARGET_okCOMPLEX3
2263         case FFEINFO_kindtypeREAL3:
2264           u.complex3 = *(array.complex3 + offset);
2265           break;
2266 #endif
2267
2268 #if FFETARGET_okCOMPLEX4
2269         case FFEINFO_kindtypeREAL4:
2270           u.complex4 = *(array.complex4 + offset);
2271           break;
2272 #endif
2273
2274 #if FFETARGET_okCOMPLEX5
2275         case FFEINFO_kindtypeREAL5:
2276           u.complex5 = *(array.complex5 + offset);
2277           break;
2278 #endif
2279
2280 #if FFETARGET_okCOMPLEX6
2281         case FFEINFO_kindtypeREAL6:
2282           u.complex6 = *(array.complex6 + offset);
2283           break;
2284 #endif
2285
2286 #if FFETARGET_okCOMPLEX7
2287         case FFEINFO_kindtypeREAL7:
2288           u.complex7 = *(array.complex7 + offset);
2289           break;
2290 #endif
2291
2292 #if FFETARGET_okCOMPLEX8
2293         case FFEINFO_kindtypeREAL8:
2294           u.complex8 = *(array.complex8 + offset);
2295           break;
2296 #endif
2297
2298         default:
2299           assert ("bad COMPLEX kindtype" == NULL);
2300           break;
2301         }
2302       break;
2303
2304     case FFEINFO_basictypeCHARACTER:
2305       switch (kt)
2306         {
2307 #if FFETARGET_okCHARACTER1
2308         case FFEINFO_kindtypeCHARACTER1:
2309           u.character1.length = 1;
2310           u.character1.text = array.character1 + offset;
2311           break;
2312 #endif
2313
2314 #if FFETARGET_okCHARACTER2
2315         case FFEINFO_kindtypeCHARACTER2:
2316           u.character2.length = 1;
2317           u.character2.text = array.character2 + offset;
2318           break;
2319 #endif
2320
2321 #if FFETARGET_okCHARACTER3
2322         case FFEINFO_kindtypeCHARACTER3:
2323           u.character3.length = 1;
2324           u.character3.text = array.character3 + offset;
2325           break;
2326 #endif
2327
2328 #if FFETARGET_okCHARACTER4
2329         case FFEINFO_kindtypeCHARACTER4:
2330           u.character4.length = 1;
2331           u.character4.text = array.character4 + offset;
2332           break;
2333 #endif
2334
2335 #if FFETARGET_okCHARACTER5
2336         case FFEINFO_kindtypeCHARACTER5:
2337           u.character5.length = 1;
2338           u.character5.text = array.character5 + offset;
2339           break;
2340 #endif
2341
2342 #if FFETARGET_okCHARACTER6
2343         case FFEINFO_kindtypeCHARACTER6:
2344           u.character6.length = 1;
2345           u.character6.text = array.character6 + offset;
2346           break;
2347 #endif
2348
2349 #if FFETARGET_okCHARACTER7
2350         case FFEINFO_kindtypeCHARACTER7:
2351           u.character7.length = 1;
2352           u.character7.text = array.character7 + offset;
2353           break;
2354 #endif
2355
2356 #if FFETARGET_okCHARACTER8
2357         case FFEINFO_kindtypeCHARACTER8:
2358           u.character8.length = 1;
2359           u.character8.text = array.character8 + offset;
2360           break;
2361 #endif
2362
2363         default:
2364           assert ("bad CHARACTER kindtype" == NULL);
2365           break;
2366         }
2367       break;
2368
2369     default:
2370       assert ("bad basictype" == NULL);
2371       break;
2372     }
2373
2374   return u;
2375 }
2376
2377 /* ffebld_constantarray_new -- Make an array of constants
2378
2379    See prototype.  */
2380
2381 ffebldConstantArray
2382 ffebld_constantarray_new (ffeinfoBasictype bt,
2383                           ffeinfoKindtype kt, ffetargetOffset size)
2384 {
2385   ffebldConstantArray ptr;
2386
2387   switch (bt)
2388     {
2389     case FFEINFO_basictypeINTEGER:
2390       switch (kt)
2391         {
2392 #if FFETARGET_okINTEGER1
2393         case FFEINFO_kindtypeINTEGER1:
2394           ptr.integer1 = malloc_new_zkp (ffebld_constant_pool(),
2395                                          "ffebldConstantArray",
2396                                          size *= sizeof (ffetargetInteger1),
2397                                          0);
2398           break;
2399 #endif
2400
2401 #if FFETARGET_okINTEGER2
2402         case FFEINFO_kindtypeINTEGER2:
2403           ptr.integer2 = malloc_new_zkp (ffebld_constant_pool(),
2404                                          "ffebldConstantArray",
2405                                          size *= sizeof (ffetargetInteger2),
2406                                          0);
2407           break;
2408 #endif
2409
2410 #if FFETARGET_okINTEGER3
2411         case FFEINFO_kindtypeINTEGER3:
2412           ptr.integer3 = malloc_new_zkp (ffebld_constant_pool(),
2413                                          "ffebldConstantArray",
2414                                          size *= sizeof (ffetargetInteger3),
2415                                          0);
2416           break;
2417 #endif
2418
2419 #if FFETARGET_okINTEGER4
2420         case FFEINFO_kindtypeINTEGER4:
2421           ptr.integer4 = malloc_new_zkp (ffebld_constant_pool(),
2422                                          "ffebldConstantArray",
2423                                          size *= sizeof (ffetargetInteger4),
2424                                          0);
2425           break;
2426 #endif
2427
2428 #if FFETARGET_okINTEGER5
2429         case FFEINFO_kindtypeINTEGER5:
2430           ptr.integer5 = malloc_new_zkp (ffebld_constant_pool(),
2431                                          "ffebldConstantArray",
2432                                          size *= sizeof (ffetargetInteger5),
2433                                          0);
2434           break;
2435 #endif
2436
2437 #if FFETARGET_okINTEGER6
2438         case FFEINFO_kindtypeINTEGER6:
2439           ptr.integer6 = malloc_new_zkp (ffebld_constant_pool(),
2440                                          "ffebldConstantArray",
2441                                          size *= sizeof (ffetargetInteger6),
2442                                          0);
2443           break;
2444 #endif
2445
2446 #if FFETARGET_okINTEGER7
2447         case FFEINFO_kindtypeINTEGER7:
2448           ptr.integer7 = malloc_new_zkp (ffebld_constant_pool(),
2449                                          "ffebldConstantArray",
2450                                          size *= sizeof (ffetargetInteger7),
2451                                          0);
2452           break;
2453 #endif
2454
2455 #if FFETARGET_okINTEGER8
2456         case FFEINFO_kindtypeINTEGER8:
2457           ptr.integer8 = malloc_new_zkp (ffebld_constant_pool(),
2458                                          "ffebldConstantArray",
2459                                          size *= sizeof (ffetargetInteger8),
2460                                          0);
2461           break;
2462 #endif
2463
2464         default:
2465           assert ("bad INTEGER kindtype" == NULL);
2466           break;
2467         }
2468       break;
2469
2470     case FFEINFO_basictypeLOGICAL:
2471       switch (kt)
2472         {
2473 #if FFETARGET_okLOGICAL1
2474         case FFEINFO_kindtypeLOGICAL1:
2475           ptr.logical1 = malloc_new_zkp (ffebld_constant_pool(),
2476                                          "ffebldConstantArray",
2477                                          size *= sizeof (ffetargetLogical1),
2478                                          0);
2479           break;
2480 #endif
2481
2482 #if FFETARGET_okLOGICAL2
2483         case FFEINFO_kindtypeLOGICAL2:
2484           ptr.logical2 = malloc_new_zkp (ffebld_constant_pool(),
2485                                          "ffebldConstantArray",
2486                                          size *= sizeof (ffetargetLogical2),
2487                                          0);
2488           break;
2489 #endif
2490
2491 #if FFETARGET_okLOGICAL3
2492         case FFEINFO_kindtypeLOGICAL3:
2493           ptr.logical3 = malloc_new_zkp (ffebld_constant_pool(),
2494                                          "ffebldConstantArray",
2495                                          size *= sizeof (ffetargetLogical3),
2496                                          0);
2497           break;
2498 #endif
2499
2500 #if FFETARGET_okLOGICAL4
2501         case FFEINFO_kindtypeLOGICAL4:
2502           ptr.logical4 = malloc_new_zkp (ffebld_constant_pool(),
2503                                          "ffebldConstantArray",
2504                                          size *= sizeof (ffetargetLogical4),
2505                                          0);
2506           break;
2507 #endif
2508
2509 #if FFETARGET_okLOGICAL5
2510         case FFEINFO_kindtypeLOGICAL5:
2511           ptr.logical5 = malloc_new_zkp (ffebld_constant_pool(),
2512                                          "ffebldConstantArray",
2513                                          size *= sizeof (ffetargetLogical5),
2514                                          0);
2515           break;
2516 #endif
2517
2518 #if FFETARGET_okLOGICAL6
2519         case FFEINFO_kindtypeLOGICAL6:
2520           ptr.logical6 = malloc_new_zkp (ffebld_constant_pool(),
2521                                          "ffebldConstantArray",
2522                                          size *= sizeof (ffetargetLogical6),
2523                                          0);
2524           break;
2525 #endif
2526
2527 #if FFETARGET_okLOGICAL7
2528         case FFEINFO_kindtypeLOGICAL7:
2529           ptr.logical7 = malloc_new_zkp (ffebld_constant_pool(),
2530                                          "ffebldConstantArray",
2531                                          size *= sizeof (ffetargetLogical7),
2532                                          0);
2533           break;
2534 #endif
2535
2536 #if FFETARGET_okLOGICAL8
2537         case FFEINFO_kindtypeLOGICAL8:
2538           ptr.logical8 = malloc_new_zkp (ffebld_constant_pool(),
2539                                          "ffebldConstantArray",
2540                                          size *= sizeof (ffetargetLogical8),
2541                                          0);
2542           break;
2543 #endif
2544
2545         default:
2546           assert ("bad LOGICAL kindtype" == NULL);
2547           break;
2548         }
2549       break;
2550
2551     case FFEINFO_basictypeREAL:
2552       switch (kt)
2553         {
2554 #if FFETARGET_okREAL1
2555         case FFEINFO_kindtypeREAL1:
2556           ptr.real1 = malloc_new_zkp (ffebld_constant_pool(),
2557                                       "ffebldConstantArray",
2558                                       size *= sizeof (ffetargetReal1),
2559                                       0);
2560           break;
2561 #endif
2562
2563 #if FFETARGET_okREAL2
2564         case FFEINFO_kindtypeREAL2:
2565           ptr.real2 = malloc_new_zkp (ffebld_constant_pool(),
2566                                       "ffebldConstantArray",
2567                                       size *= sizeof (ffetargetReal2),
2568                                       0);
2569           break;
2570 #endif
2571
2572 #if FFETARGET_okREAL3
2573         case FFEINFO_kindtypeREAL3:
2574           ptr.real3 = malloc_new_zkp (ffebld_constant_pool(),
2575                                       "ffebldConstantArray",
2576                                       size *= sizeof (ffetargetReal3),
2577                                       0);
2578           break;
2579 #endif
2580
2581 #if FFETARGET_okREAL4
2582         case FFEINFO_kindtypeREAL4:
2583           ptr.real4 = malloc_new_zkp (ffebld_constant_pool(),
2584                                       "ffebldConstantArray",
2585                                       size *= sizeof (ffetargetReal4),
2586                                       0);
2587           break;
2588 #endif
2589
2590 #if FFETARGET_okREAL5
2591         case FFEINFO_kindtypeREAL5:
2592           ptr.real5 = malloc_new_zkp (ffebld_constant_pool(),
2593                                       "ffebldConstantArray",
2594                                       size *= sizeof (ffetargetReal5),
2595                                       0);
2596           break;
2597 #endif
2598
2599 #if FFETARGET_okREAL6
2600         case FFEINFO_kindtypeREAL6:
2601           ptr.real6 = malloc_new_zkp (ffebld_constant_pool(),
2602                                       "ffebldConstantArray",
2603                                       size *= sizeof (ffetargetReal6),
2604                                       0);
2605           break;
2606 #endif
2607
2608 #if FFETARGET_okREAL7
2609         case FFEINFO_kindtypeREAL7:
2610           ptr.real7 = malloc_new_zkp (ffebld_constant_pool(),
2611                                       "ffebldConstantArray",
2612                                       size *= sizeof (ffetargetReal7),
2613                                       0);
2614           break;
2615 #endif
2616
2617 #if FFETARGET_okREAL8
2618         case FFEINFO_kindtypeREAL8:
2619           ptr.real8 = malloc_new_zkp (ffebld_constant_pool(),
2620                                       "ffebldConstantArray",
2621                                       size *= sizeof (ffetargetReal8),
2622                                       0);
2623           break;
2624 #endif
2625
2626         default:
2627           assert ("bad REAL kindtype" == NULL);
2628           break;
2629         }
2630       break;
2631
2632     case FFEINFO_basictypeCOMPLEX:
2633       switch (kt)
2634         {
2635 #if FFETARGET_okCOMPLEX1
2636         case FFEINFO_kindtypeREAL1:
2637           ptr.complex1 = malloc_new_zkp (ffebld_constant_pool(),
2638                                          "ffebldConstantArray",
2639                                          size *= sizeof (ffetargetComplex1),
2640                                          0);
2641           break;
2642 #endif
2643
2644 #if FFETARGET_okCOMPLEX2
2645         case FFEINFO_kindtypeREAL2:
2646           ptr.complex2 = malloc_new_zkp (ffebld_constant_pool(),
2647                                          "ffebldConstantArray",
2648                                          size *= sizeof (ffetargetComplex2),
2649                                          0);
2650           break;
2651 #endif
2652
2653 #if FFETARGET_okCOMPLEX3
2654         case FFEINFO_kindtypeREAL3:
2655           ptr.complex3 = malloc_new_zkp (ffebld_constant_pool(),
2656                                          "ffebldConstantArray",
2657                                          size *= sizeof (ffetargetComplex3),
2658                                          0);
2659           break;
2660 #endif
2661
2662 #if FFETARGET_okCOMPLEX4
2663         case FFEINFO_kindtypeREAL4:
2664           ptr.complex4 = malloc_new_zkp (ffebld_constant_pool(),
2665                                          "ffebldConstantArray",
2666                                          size *= sizeof (ffetargetComplex4),
2667                                          0);
2668           break;
2669 #endif
2670
2671 #if FFETARGET_okCOMPLEX5
2672         case FFEINFO_kindtypeREAL5:
2673           ptr.complex5 = malloc_new_zkp (ffebld_constant_pool(),
2674                                          "ffebldConstantArray",
2675                                          size *= sizeof (ffetargetComplex5),
2676                                          0);
2677           break;
2678 #endif
2679
2680 #if FFETARGET_okCOMPLEX6
2681         case FFEINFO_kindtypeREAL6:
2682           ptr.complex6 = malloc_new_zkp (ffebld_constant_pool(),
2683                                          "ffebldConstantArray",
2684                                          size *= sizeof (ffetargetComplex6),
2685                                          0);
2686           break;
2687 #endif
2688
2689 #if FFETARGET_okCOMPLEX7
2690         case FFEINFO_kindtypeREAL7:
2691           ptr.complex7 = malloc_new_zkp (ffebld_constant_pool(),
2692                                          "ffebldConstantArray",
2693                                          size *= sizeof (ffetargetComplex7),
2694                                          0);
2695           break;
2696 #endif
2697
2698 #if FFETARGET_okCOMPLEX8
2699         case FFEINFO_kindtypeREAL8:
2700           ptr.complex8 = malloc_new_zkp (ffebld_constant_pool(),
2701                                          "ffebldConstantArray",
2702                                          size *= sizeof (ffetargetComplex8),
2703                                          0);
2704           break;
2705 #endif
2706
2707         default:
2708           assert ("bad COMPLEX kindtype" == NULL);
2709           break;
2710         }
2711       break;
2712
2713     case FFEINFO_basictypeCHARACTER:
2714       switch (kt)
2715         {
2716 #if FFETARGET_okCHARACTER1
2717         case FFEINFO_kindtypeCHARACTER1:
2718           ptr.character1 = malloc_new_zkp (ffebld_constant_pool(),
2719                                            "ffebldConstantArray",
2720                                            size
2721                                            *= sizeof (ffetargetCharacterUnit1),
2722                                            0);
2723           break;
2724 #endif
2725
2726 #if FFETARGET_okCHARACTER2
2727         case FFEINFO_kindtypeCHARACTER2:
2728           ptr.character2 = malloc_new_zkp (ffebld_constant_pool(),
2729                                            "ffebldConstantArray",
2730                                            size
2731                                            *= sizeof (ffetargetCharacterUnit2),
2732                                            0);
2733           break;
2734 #endif
2735
2736 #if FFETARGET_okCHARACTER3
2737         case FFEINFO_kindtypeCHARACTER3:
2738           ptr.character3 = malloc_new_zkp (ffebld_constant_pool(),
2739                                            "ffebldConstantArray",
2740                                            size
2741                                            *= sizeof (ffetargetCharacterUnit3),
2742                                            0);
2743           break;
2744 #endif
2745
2746 #if FFETARGET_okCHARACTER4
2747         case FFEINFO_kindtypeCHARACTER4:
2748           ptr.character4 = malloc_new_zkp (ffebld_constant_pool(),
2749                                            "ffebldConstantArray",
2750                                            size
2751                                            *= sizeof (ffetargetCharacterUnit4),
2752                                            0);
2753           break;
2754 #endif
2755
2756 #if FFETARGET_okCHARACTER5
2757         case FFEINFO_kindtypeCHARACTER5:
2758           ptr.character5 = malloc_new_zkp (ffebld_constant_pool(),
2759                                            "ffebldConstantArray",
2760                                            size
2761                                            *= sizeof (ffetargetCharacterUnit5),
2762                                            0);
2763           break;
2764 #endif
2765
2766 #if FFETARGET_okCHARACTER6
2767         case FFEINFO_kindtypeCHARACTER6:
2768           ptr.character6 = malloc_new_zkp (ffebld_constant_pool(),
2769                                            "ffebldConstantArray",
2770                                            size
2771                                            *= sizeof (ffetargetCharacterUnit6),
2772                                            0);
2773           break;
2774 #endif
2775
2776 #if FFETARGET_okCHARACTER7
2777         case FFEINFO_kindtypeCHARACTER7:
2778           ptr.character7 = malloc_new_zkp (ffebld_constant_pool(),
2779                                            "ffebldConstantArray",
2780                                            size
2781                                            *= sizeof (ffetargetCharacterUnit7),
2782                                            0);
2783           break;
2784 #endif
2785
2786 #if FFETARGET_okCHARACTER8
2787         case FFEINFO_kindtypeCHARACTER8:
2788           ptr.character8 = malloc_new_zkp (ffebld_constant_pool(),
2789                                            "ffebldConstantArray",
2790                                            size
2791                                            *= sizeof (ffetargetCharacterUnit8),
2792                                            0);
2793           break;
2794 #endif
2795
2796         default:
2797           assert ("bad CHARACTER kindtype" == NULL);
2798           break;
2799         }
2800       break;
2801
2802     default:
2803       assert ("bad basictype" == NULL);
2804       break;
2805     }
2806
2807   return ptr;
2808 }
2809
2810 /* ffebld_constantarray_preparray -- Prepare for copy between arrays
2811
2812    See prototype.
2813
2814    Like _prepare, but the source is an array instead of a single-value
2815    constant.  */
2816
2817 void
2818 ffebld_constantarray_preparray (void **aptr, void **cptr, size_t *size,
2819        ffebldConstantArray array, ffeinfoBasictype abt, ffeinfoKindtype akt,
2820                    ffetargetOffset offset, ffebldConstantArray source_array,
2821                                 ffeinfoBasictype cbt, ffeinfoKindtype ckt)
2822 {
2823   switch (abt)
2824     {
2825     case FFEINFO_basictypeINTEGER:
2826       switch (akt)
2827         {
2828 #if FFETARGET_okINTEGER1
2829         case FFEINFO_kindtypeINTEGER1:
2830           *aptr = array.integer1 + offset;
2831           break;
2832 #endif
2833
2834 #if FFETARGET_okINTEGER2
2835         case FFEINFO_kindtypeINTEGER2:
2836           *aptr = array.integer2 + offset;
2837           break;
2838 #endif
2839
2840 #if FFETARGET_okINTEGER3
2841         case FFEINFO_kindtypeINTEGER3:
2842           *aptr = array.integer3 + offset;
2843           break;
2844 #endif
2845
2846 #if FFETARGET_okINTEGER4
2847         case FFEINFO_kindtypeINTEGER4:
2848           *aptr = array.integer4 + offset;
2849           break;
2850 #endif
2851
2852 #if FFETARGET_okINTEGER5
2853         case FFEINFO_kindtypeINTEGER5:
2854           *aptr = array.integer5 + offset;
2855           break;
2856 #endif
2857
2858 #if FFETARGET_okINTEGER6
2859         case FFEINFO_kindtypeINTEGER6:
2860           *aptr = array.integer6 + offset;
2861           break;
2862 #endif
2863
2864 #if FFETARGET_okINTEGER7
2865         case FFEINFO_kindtypeINTEGER7:
2866           *aptr = array.integer7 + offset;
2867           break;
2868 #endif
2869
2870 #if FFETARGET_okINTEGER8
2871         case FFEINFO_kindtypeINTEGER8:
2872           *aptr = array.integer8 + offset;
2873           break;
2874 #endif
2875
2876         default:
2877           assert ("bad INTEGER akindtype" == NULL);
2878           break;
2879         }
2880       break;
2881
2882     case FFEINFO_basictypeLOGICAL:
2883       switch (akt)
2884         {
2885 #if FFETARGET_okLOGICAL1
2886         case FFEINFO_kindtypeLOGICAL1:
2887           *aptr = array.logical1 + offset;
2888           break;
2889 #endif
2890
2891 #if FFETARGET_okLOGICAL2
2892         case FFEINFO_kindtypeLOGICAL2:
2893           *aptr = array.logical2 + offset;
2894           break;
2895 #endif
2896
2897 #if FFETARGET_okLOGICAL3
2898         case FFEINFO_kindtypeLOGICAL3:
2899           *aptr = array.logical3 + offset;
2900           break;
2901 #endif
2902
2903 #if FFETARGET_okLOGICAL4
2904         case FFEINFO_kindtypeLOGICAL4:
2905           *aptr = array.logical4 + offset;
2906           break;
2907 #endif
2908
2909 #if FFETARGET_okLOGICAL5
2910         case FFEINFO_kindtypeLOGICAL5:
2911           *aptr = array.logical5 + offset;
2912           break;
2913 #endif
2914
2915 #if FFETARGET_okLOGICAL6
2916         case FFEINFO_kindtypeLOGICAL6:
2917           *aptr = array.logical6 + offset;
2918           break;
2919 #endif
2920
2921 #if FFETARGET_okLOGICAL7
2922         case FFEINFO_kindtypeLOGICAL7:
2923           *aptr = array.logical7 + offset;
2924           break;
2925 #endif
2926
2927 #if FFETARGET_okLOGICAL8
2928         case FFEINFO_kindtypeLOGICAL8:
2929           *aptr = array.logical8 + offset;
2930           break;
2931 #endif
2932
2933         default:
2934           assert ("bad LOGICAL akindtype" == NULL);
2935           break;
2936         }
2937       break;
2938
2939     case FFEINFO_basictypeREAL:
2940       switch (akt)
2941         {
2942 #if FFETARGET_okREAL1
2943         case FFEINFO_kindtypeREAL1:
2944           *aptr = array.real1 + offset;
2945           break;
2946 #endif
2947
2948 #if FFETARGET_okREAL2
2949         case FFEINFO_kindtypeREAL2:
2950           *aptr = array.real2 + offset;
2951           break;
2952 #endif
2953
2954 #if FFETARGET_okREAL3
2955         case FFEINFO_kindtypeREAL3:
2956           *aptr = array.real3 + offset;
2957           break;
2958 #endif
2959
2960 #if FFETARGET_okREAL4
2961         case FFEINFO_kindtypeREAL4:
2962           *aptr = array.real4 + offset;
2963           break;
2964 #endif
2965
2966 #if FFETARGET_okREAL5
2967         case FFEINFO_kindtypeREAL5:
2968           *aptr = array.real5 + offset;
2969           break;
2970 #endif
2971
2972 #if FFETARGET_okREAL6
2973         case FFEINFO_kindtypeREAL6:
2974           *aptr = array.real6 + offset;
2975           break;
2976 #endif
2977
2978 #if FFETARGET_okREAL7
2979         case FFEINFO_kindtypeREAL7:
2980           *aptr = array.real7 + offset;
2981           break;
2982 #endif
2983
2984 #if FFETARGET_okREAL8
2985         case FFEINFO_kindtypeREAL8:
2986           *aptr = array.real8 + offset;
2987           break;
2988 #endif
2989
2990         default:
2991           assert ("bad REAL akindtype" == NULL);
2992           break;
2993         }
2994       break;
2995
2996     case FFEINFO_basictypeCOMPLEX:
2997       switch (akt)
2998         {
2999 #if FFETARGET_okCOMPLEX1
3000         case FFEINFO_kindtypeREAL1:
3001           *aptr = array.complex1 + offset;
3002           break;
3003 #endif
3004
3005 #if FFETARGET_okCOMPLEX2
3006         case FFEINFO_kindtypeREAL2:
3007           *aptr = array.complex2 + offset;
3008           break;
3009 #endif
3010
3011 #if FFETARGET_okCOMPLEX3
3012         case FFEINFO_kindtypeREAL3:
3013           *aptr = array.complex3 + offset;
3014           break;
3015 #endif
3016
3017 #if FFETARGET_okCOMPLEX4
3018         case FFEINFO_kindtypeREAL4:
3019           *aptr = array.complex4 + offset;
3020           break;
3021 #endif
3022
3023 #if FFETARGET_okCOMPLEX5
3024         case FFEINFO_kindtypeREAL5:
3025           *aptr = array.complex5 + offset;
3026           break;
3027 #endif
3028
3029 #if FFETARGET_okCOMPLEX6
3030         case FFEINFO_kindtypeREAL6:
3031           *aptr = array.complex6 + offset;
3032           break;
3033 #endif
3034
3035 #if FFETARGET_okCOMPLEX7
3036         case FFEINFO_kindtypeREAL7:
3037           *aptr = array.complex7 + offset;
3038           break;
3039 #endif
3040
3041 #if FFETARGET_okCOMPLEX8
3042         case FFEINFO_kindtypeREAL8:
3043           *aptr = array.complex8 + offset;
3044           break;
3045 #endif
3046
3047         default:
3048           assert ("bad COMPLEX akindtype" == NULL);
3049           break;
3050         }
3051       break;
3052
3053     case FFEINFO_basictypeCHARACTER:
3054       switch (akt)
3055         {
3056 #if FFETARGET_okCHARACTER1
3057         case FFEINFO_kindtypeCHARACTER1:
3058           *aptr = array.character1 + offset;
3059           break;
3060 #endif
3061
3062 #if FFETARGET_okCHARACTER2
3063         case FFEINFO_kindtypeCHARACTER2:
3064           *aptr = array.character2 + offset;
3065           break;
3066 #endif
3067
3068 #if FFETARGET_okCHARACTER3
3069         case FFEINFO_kindtypeCHARACTER3:
3070           *aptr = array.character3 + offset;
3071           break;
3072 #endif
3073
3074 #if FFETARGET_okCHARACTER4
3075         case FFEINFO_kindtypeCHARACTER4:
3076           *aptr = array.character4 + offset;
3077           break;
3078 #endif
3079
3080 #if FFETARGET_okCHARACTER5
3081         case FFEINFO_kindtypeCHARACTER5:
3082           *aptr = array.character5 + offset;
3083           break;
3084 #endif
3085
3086 #if FFETARGET_okCHARACTER6
3087         case FFEINFO_kindtypeCHARACTER6:
3088           *aptr = array.character6 + offset;
3089           break;
3090 #endif
3091
3092 #if FFETARGET_okCHARACTER7
3093         case FFEINFO_kindtypeCHARACTER7:
3094           *aptr = array.character7 + offset;
3095           break;
3096 #endif
3097
3098 #if FFETARGET_okCHARACTER8
3099         case FFEINFO_kindtypeCHARACTER8:
3100           *aptr = array.character8 + offset;
3101           break;
3102 #endif
3103
3104         default:
3105           assert ("bad CHARACTER akindtype" == NULL);
3106           break;
3107         }
3108       break;
3109
3110     default:
3111       assert ("bad abasictype" == NULL);
3112       break;
3113     }
3114
3115   switch (cbt)
3116     {
3117     case FFEINFO_basictypeINTEGER:
3118       switch (ckt)
3119         {
3120 #if FFETARGET_okINTEGER1
3121         case FFEINFO_kindtypeINTEGER1:
3122           *cptr = source_array.integer1;
3123           *size = sizeof (*source_array.integer1);
3124           break;
3125 #endif
3126
3127 #if FFETARGET_okINTEGER2
3128         case FFEINFO_kindtypeINTEGER2:
3129           *cptr = source_array.integer2;
3130           *size = sizeof (*source_array.integer2);
3131           break;
3132 #endif
3133
3134 #if FFETARGET_okINTEGER3
3135         case FFEINFO_kindtypeINTEGER3:
3136           *cptr = source_array.integer3;
3137           *size = sizeof (*source_array.integer3);
3138           break;
3139 #endif
3140
3141 #if FFETARGET_okINTEGER4
3142         case FFEINFO_kindtypeINTEGER4:
3143           *cptr = source_array.integer4;
3144           *size = sizeof (*source_array.integer4);
3145           break;
3146 #endif
3147
3148 #if FFETARGET_okINTEGER5
3149         case FFEINFO_kindtypeINTEGER5:
3150           *cptr = source_array.integer5;
3151           *size = sizeof (*source_array.integer5);
3152           break;
3153 #endif
3154
3155 #if FFETARGET_okINTEGER6
3156         case FFEINFO_kindtypeINTEGER6:
3157           *cptr = source_array.integer6;
3158           *size = sizeof (*source_array.integer6);
3159           break;
3160 #endif
3161
3162 #if FFETARGET_okINTEGER7
3163         case FFEINFO_kindtypeINTEGER7:
3164           *cptr = source_array.integer7;
3165           *size = sizeof (*source_array.integer7);
3166           break;
3167 #endif
3168
3169 #if FFETARGET_okINTEGER8
3170         case FFEINFO_kindtypeINTEGER8:
3171           *cptr = source_array.integer8;
3172           *size = sizeof (*source_array.integer8);
3173           break;
3174 #endif
3175
3176         default:
3177           assert ("bad INTEGER ckindtype" == NULL);
3178           break;
3179         }
3180       break;
3181
3182     case FFEINFO_basictypeLOGICAL:
3183       switch (ckt)
3184         {
3185 #if FFETARGET_okLOGICAL1
3186         case FFEINFO_kindtypeLOGICAL1:
3187           *cptr = source_array.logical1;
3188           *size = sizeof (*source_array.logical1);
3189           break;
3190 #endif
3191
3192 #if FFETARGET_okLOGICAL2
3193         case FFEINFO_kindtypeLOGICAL2:
3194           *cptr = source_array.logical2;
3195           *size = sizeof (*source_array.logical2);
3196           break;
3197 #endif
3198
3199 #if FFETARGET_okLOGICAL3
3200         case FFEINFO_kindtypeLOGICAL3:
3201           *cptr = source_array.logical3;
3202           *size = sizeof (*source_array.logical3);
3203           break;
3204 #endif
3205
3206 #if FFETARGET_okLOGICAL4
3207         case FFEINFO_kindtypeLOGICAL4:
3208           *cptr = source_array.logical4;
3209           *size = sizeof (*source_array.logical4);
3210           break;
3211 #endif
3212
3213 #if FFETARGET_okLOGICAL5
3214         case FFEINFO_kindtypeLOGICAL5:
3215           *cptr = source_array.logical5;
3216           *size = sizeof (*source_array.logical5);
3217           break;
3218 #endif
3219
3220 #if FFETARGET_okLOGICAL6
3221         case FFEINFO_kindtypeLOGICAL6:
3222           *cptr = source_array.logical6;
3223           *size = sizeof (*source_array.logical6);
3224           break;
3225 #endif
3226
3227 #if FFETARGET_okLOGICAL7
3228         case FFEINFO_kindtypeLOGICAL7:
3229           *cptr = source_array.logical7;
3230           *size = sizeof (*source_array.logical7);
3231           break;
3232 #endif
3233
3234 #if FFETARGET_okLOGICAL8
3235         case FFEINFO_kindtypeLOGICAL8:
3236           *cptr = source_array.logical8;
3237           *size = sizeof (*source_array.logical8);
3238           break;
3239 #endif
3240
3241         default:
3242           assert ("bad LOGICAL ckindtype" == NULL);
3243           break;
3244         }
3245       break;
3246
3247     case FFEINFO_basictypeREAL:
3248       switch (ckt)
3249         {
3250 #if FFETARGET_okREAL1
3251         case FFEINFO_kindtypeREAL1:
3252           *cptr = source_array.real1;
3253           *size = sizeof (*source_array.real1);
3254           break;
3255 #endif
3256
3257 #if FFETARGET_okREAL2
3258         case FFEINFO_kindtypeREAL2:
3259           *cptr = source_array.real2;
3260           *size = sizeof (*source_array.real2);
3261           break;
3262 #endif
3263
3264 #if FFETARGET_okREAL3
3265         case FFEINFO_kindtypeREAL3:
3266           *cptr = source_array.real3;
3267           *size = sizeof (*source_array.real3);
3268           break;
3269 #endif
3270
3271 #if FFETARGET_okREAL4
3272         case FFEINFO_kindtypeREAL4:
3273           *cptr = source_array.real4;
3274           *size = sizeof (*source_array.real4);
3275           break;
3276 #endif
3277
3278 #if FFETARGET_okREAL5
3279         case FFEINFO_kindtypeREAL5:
3280           *cptr = source_array.real5;
3281           *size = sizeof (*source_array.real5);
3282           break;
3283 #endif
3284
3285 #if FFETARGET_okREAL6
3286         case FFEINFO_kindtypeREAL6:
3287           *cptr = source_array.real6;
3288           *size = sizeof (*source_array.real6);
3289           break;
3290 #endif
3291
3292 #if FFETARGET_okREAL7
3293         case FFEINFO_kindtypeREAL7:
3294           *cptr = source_array.real7;
3295           *size = sizeof (*source_array.real7);
3296           break;
3297 #endif
3298
3299 #if FFETARGET_okREAL8
3300         case FFEINFO_kindtypeREAL8:
3301           *cptr = source_array.real8;
3302           *size = sizeof (*source_array.real8);
3303           break;
3304 #endif
3305
3306         default:
3307           assert ("bad REAL ckindtype" == NULL);
3308           break;
3309         }
3310       break;
3311
3312     case FFEINFO_basictypeCOMPLEX:
3313       switch (ckt)
3314         {
3315 #if FFETARGET_okCOMPLEX1
3316         case FFEINFO_kindtypeREAL1:
3317           *cptr = source_array.complex1;
3318           *size = sizeof (*source_array.complex1);
3319           break;
3320 #endif
3321
3322 #if FFETARGET_okCOMPLEX2
3323         case FFEINFO_kindtypeREAL2:
3324           *cptr = source_array.complex2;
3325           *size = sizeof (*source_array.complex2);
3326           break;
3327 #endif
3328
3329 #if FFETARGET_okCOMPLEX3
3330         case FFEINFO_kindtypeREAL3:
3331           *cptr = source_array.complex3;
3332           *size = sizeof (*source_array.complex3);
3333           break;
3334 #endif
3335
3336 #if FFETARGET_okCOMPLEX4
3337         case FFEINFO_kindtypeREAL4:
3338           *cptr = source_array.complex4;
3339           *size = sizeof (*source_array.complex4);
3340           break;
3341 #endif
3342
3343 #if FFETARGET_okCOMPLEX5
3344         case FFEINFO_kindtypeREAL5:
3345           *cptr = source_array.complex5;
3346           *size = sizeof (*source_array.complex5);
3347           break;
3348 #endif
3349
3350 #if FFETARGET_okCOMPLEX6
3351         case FFEINFO_kindtypeREAL6:
3352           *cptr = source_array.complex6;
3353           *size = sizeof (*source_array.complex6);
3354           break;
3355 #endif
3356
3357 #if FFETARGET_okCOMPLEX7
3358         case FFEINFO_kindtypeREAL7:
3359           *cptr = source_array.complex7;
3360           *size = sizeof (*source_array.complex7);
3361           break;
3362 #endif
3363
3364 #if FFETARGET_okCOMPLEX8
3365         case FFEINFO_kindtypeREAL8:
3366           *cptr = source_array.complex8;
3367           *size = sizeof (*source_array.complex8);
3368           break;
3369 #endif
3370
3371         default:
3372           assert ("bad COMPLEX ckindtype" == NULL);
3373           break;
3374         }
3375       break;
3376
3377     case FFEINFO_basictypeCHARACTER:
3378       switch (ckt)
3379         {
3380 #if FFETARGET_okCHARACTER1
3381         case FFEINFO_kindtypeCHARACTER1:
3382           *cptr = source_array.character1;
3383           *size = sizeof (*source_array.character1);
3384           break;
3385 #endif
3386
3387 #if FFETARGET_okCHARACTER2
3388         case FFEINFO_kindtypeCHARACTER2:
3389           *cptr = source_array.character2;
3390           *size = sizeof (*source_array.character2);
3391           break;
3392 #endif
3393
3394 #if FFETARGET_okCHARACTER3
3395         case FFEINFO_kindtypeCHARACTER3:
3396           *cptr = source_array.character3;
3397           *size = sizeof (*source_array.character3);
3398           break;
3399 #endif
3400
3401 #if FFETARGET_okCHARACTER4
3402         case FFEINFO_kindtypeCHARACTER4:
3403           *cptr = source_array.character4;
3404           *size = sizeof (*source_array.character4);
3405           break;
3406 #endif
3407
3408 #if FFETARGET_okCHARACTER5
3409         case FFEINFO_kindtypeCHARACTER5:
3410           *cptr = source_array.character5;
3411           *size = sizeof (*source_array.character5);
3412           break;
3413 #endif
3414
3415 #if FFETARGET_okCHARACTER6
3416         case FFEINFO_kindtypeCHARACTER6:
3417           *cptr = source_array.character6;
3418           *size = sizeof (*source_array.character6);
3419           break;
3420 #endif
3421
3422 #if FFETARGET_okCHARACTER7
3423         case FFEINFO_kindtypeCHARACTER7:
3424           *cptr = source_array.character7;
3425           *size = sizeof (*source_array.character7);
3426           break;
3427 #endif
3428
3429 #if FFETARGET_okCHARACTER8
3430         case FFEINFO_kindtypeCHARACTER8:
3431           *cptr = source_array.character8;
3432           *size = sizeof (*source_array.character8);
3433           break;
3434 #endif
3435
3436         default:
3437           assert ("bad CHARACTER ckindtype" == NULL);
3438           break;
3439         }
3440       break;
3441
3442     default:
3443       assert ("bad cbasictype" == NULL);
3444       break;
3445     }
3446 }
3447
3448 /* ffebld_constantarray_prepare -- Prepare for copy between value and array
3449
3450    See prototype.
3451
3452    Like _put, but just returns the pointers to the beginnings of the
3453    array and the constant and returns the size (the amount of info to
3454    copy).  The idea is that the caller can use memcpy to accomplish the
3455    same thing as _put (though slower), or the caller can use a different
3456    function that swaps bytes, words, etc for a different target machine.
3457    Also, the type of the array may be different from the type of the
3458    constant; the array type is used to determine the meaning (scale) of
3459    the offset field (to calculate the array pointer), the constant type is
3460    used to determine the constant pointer and the size (amount of info to
3461    copy).  */
3462
3463 void
3464 ffebld_constantarray_prepare (void **aptr, void **cptr, size_t *size,
3465        ffebldConstantArray array, ffeinfoBasictype abt, ffeinfoKindtype akt,
3466                       ffetargetOffset offset, ffebldConstantUnion *constant,
3467                               ffeinfoBasictype cbt, ffeinfoKindtype ckt)
3468 {
3469   switch (abt)
3470     {
3471     case FFEINFO_basictypeINTEGER:
3472       switch (akt)
3473         {
3474 #if FFETARGET_okINTEGER1
3475         case FFEINFO_kindtypeINTEGER1:
3476           *aptr = array.integer1 + offset;
3477           break;
3478 #endif
3479
3480 #if FFETARGET_okINTEGER2
3481         case FFEINFO_kindtypeINTEGER2:
3482           *aptr = array.integer2 + offset;
3483           break;
3484 #endif
3485
3486 #if FFETARGET_okINTEGER3
3487         case FFEINFO_kindtypeINTEGER3:
3488           *aptr = array.integer3 + offset;
3489           break;
3490 #endif
3491
3492 #if FFETARGET_okINTEGER4
3493         case FFEINFO_kindtypeINTEGER4:
3494           *aptr = array.integer4 + offset;
3495           break;
3496 #endif
3497
3498 #if FFETARGET_okINTEGER5
3499         case FFEINFO_kindtypeINTEGER5:
3500           *aptr = array.integer5 + offset;
3501           break;
3502 #endif
3503
3504 #if FFETARGET_okINTEGER6
3505         case FFEINFO_kindtypeINTEGER6:
3506           *aptr = array.integer6 + offset;
3507           break;
3508 #endif
3509
3510 #if FFETARGET_okINTEGER7
3511         case FFEINFO_kindtypeINTEGER7:
3512           *aptr = array.integer7 + offset;
3513           break;
3514 #endif
3515
3516 #if FFETARGET_okINTEGER8
3517         case FFEINFO_kindtypeINTEGER8:
3518           *aptr = array.integer8 + offset;
3519           break;
3520 #endif
3521
3522         default:
3523           assert ("bad INTEGER akindtype" == NULL);
3524           break;
3525         }
3526       break;
3527
3528     case FFEINFO_basictypeLOGICAL:
3529       switch (akt)
3530         {
3531 #if FFETARGET_okLOGICAL1
3532         case FFEINFO_kindtypeLOGICAL1:
3533           *aptr = array.logical1 + offset;
3534           break;
3535 #endif
3536
3537 #if FFETARGET_okLOGICAL2
3538         case FFEINFO_kindtypeLOGICAL2:
3539           *aptr = array.logical2 + offset;
3540           break;
3541 #endif
3542
3543 #if FFETARGET_okLOGICAL3
3544         case FFEINFO_kindtypeLOGICAL3:
3545           *aptr = array.logical3 + offset;
3546           break;
3547 #endif
3548
3549 #if FFETARGET_okLOGICAL4
3550         case FFEINFO_kindtypeLOGICAL4:
3551           *aptr = array.logical4 + offset;
3552           break;
3553 #endif
3554
3555 #if FFETARGET_okLOGICAL5
3556         case FFEINFO_kindtypeLOGICAL5:
3557           *aptr = array.logical5 + offset;
3558           break;
3559 #endif
3560
3561 #if FFETARGET_okLOGICAL6
3562         case FFEINFO_kindtypeLOGICAL6:
3563           *aptr = array.logical6 + offset;
3564           break;
3565 #endif
3566
3567 #if FFETARGET_okLOGICAL7
3568         case FFEINFO_kindtypeLOGICAL7:
3569           *aptr = array.logical7 + offset;
3570           break;
3571 #endif
3572
3573 #if FFETARGET_okLOGICAL8
3574         case FFEINFO_kindtypeLOGICAL8:
3575           *aptr = array.logical8 + offset;
3576           break;
3577 #endif
3578
3579         default:
3580           assert ("bad LOGICAL akindtype" == NULL);
3581           break;
3582         }
3583       break;
3584
3585     case FFEINFO_basictypeREAL:
3586       switch (akt)
3587         {
3588 #if FFETARGET_okREAL1
3589         case FFEINFO_kindtypeREAL1:
3590           *aptr = array.real1 + offset;
3591           break;
3592 #endif
3593
3594 #if FFETARGET_okREAL2
3595         case FFEINFO_kindtypeREAL2:
3596           *aptr = array.real2 + offset;
3597           break;
3598 #endif
3599
3600 #if FFETARGET_okREAL3
3601         case FFEINFO_kindtypeREAL3:
3602           *aptr = array.real3 + offset;
3603           break;
3604 #endif
3605
3606 #if FFETARGET_okREAL4
3607         case FFEINFO_kindtypeREAL4:
3608           *aptr = array.real4 + offset;
3609           break;
3610 #endif
3611
3612 #if FFETARGET_okREAL5
3613         case FFEINFO_kindtypeREAL5:
3614           *aptr = array.real5 + offset;
3615           break;
3616 #endif
3617
3618 #if FFETARGET_okREAL6
3619         case FFEINFO_kindtypeREAL6:
3620           *aptr = array.real6 + offset;
3621           break;
3622 #endif
3623
3624 #if FFETARGET_okREAL7
3625         case FFEINFO_kindtypeREAL7:
3626           *aptr = array.real7 + offset;
3627           break;
3628 #endif
3629
3630 #if FFETARGET_okREAL8
3631         case FFEINFO_kindtypeREAL8:
3632           *aptr = array.real8 + offset;
3633           break;
3634 #endif
3635
3636         default:
3637           assert ("bad REAL akindtype" == NULL);
3638           break;
3639         }
3640       break;
3641
3642     case FFEINFO_basictypeCOMPLEX:
3643       switch (akt)
3644         {
3645 #if FFETARGET_okCOMPLEX1
3646         case FFEINFO_kindtypeREAL1:
3647           *aptr = array.complex1 + offset;
3648           break;
3649 #endif
3650
3651 #if FFETARGET_okCOMPLEX2
3652         case FFEINFO_kindtypeREAL2:
3653           *aptr = array.complex2 + offset;
3654           break;
3655 #endif
3656
3657 #if FFETARGET_okCOMPLEX3
3658         case FFEINFO_kindtypeREAL3:
3659           *aptr = array.complex3 + offset;
3660           break;
3661 #endif
3662
3663 #if FFETARGET_okCOMPLEX4
3664         case FFEINFO_kindtypeREAL4:
3665           *aptr = array.complex4 + offset;
3666           break;
3667 #endif
3668
3669 #if FFETARGET_okCOMPLEX5
3670         case FFEINFO_kindtypeREAL5:
3671           *aptr = array.complex5 + offset;
3672           break;
3673 #endif
3674
3675 #if FFETARGET_okCOMPLEX6
3676         case FFEINFO_kindtypeREAL6:
3677           *aptr = array.complex6 + offset;
3678           break;
3679 #endif
3680
3681 #if FFETARGET_okCOMPLEX7
3682         case FFEINFO_kindtypeREAL7:
3683           *aptr = array.complex7 + offset;
3684           break;
3685 #endif
3686
3687 #if FFETARGET_okCOMPLEX8
3688         case FFEINFO_kindtypeREAL8:
3689           *aptr = array.complex8 + offset;
3690           break;
3691 #endif
3692
3693         default:
3694           assert ("bad COMPLEX akindtype" == NULL);
3695           break;
3696         }
3697       break;
3698
3699     case FFEINFO_basictypeCHARACTER:
3700       switch (akt)
3701         {
3702 #if FFETARGET_okCHARACTER1
3703         case FFEINFO_kindtypeCHARACTER1:
3704           *aptr = array.character1 + offset;
3705           break;
3706 #endif
3707
3708 #if FFETARGET_okCHARACTER2
3709         case FFEINFO_kindtypeCHARACTER2:
3710           *aptr = array.character2 + offset;
3711           break;
3712 #endif
3713
3714 #if FFETARGET_okCHARACTER3
3715         case FFEINFO_kindtypeCHARACTER3:
3716           *aptr = array.character3 + offset;
3717           break;
3718 #endif
3719
3720 #if FFETARGET_okCHARACTER4
3721         case FFEINFO_kindtypeCHARACTER4:
3722           *aptr = array.character4 + offset;
3723           break;
3724 #endif
3725
3726 #if FFETARGET_okCHARACTER5
3727         case FFEINFO_kindtypeCHARACTER5:
3728           *aptr = array.character5 + offset;
3729           break;
3730 #endif
3731
3732 #if FFETARGET_okCHARACTER6
3733         case FFEINFO_kindtypeCHARACTER6:
3734           *aptr = array.character6 + offset;
3735           break;
3736 #endif
3737
3738 #if FFETARGET_okCHARACTER7
3739         case FFEINFO_kindtypeCHARACTER7:
3740           *aptr = array.character7 + offset;
3741           break;
3742 #endif
3743
3744 #if FFETARGET_okCHARACTER8
3745         case FFEINFO_kindtypeCHARACTER8:
3746           *aptr = array.character8 + offset;
3747           break;
3748 #endif
3749
3750         default:
3751           assert ("bad CHARACTER akindtype" == NULL);
3752           break;
3753         }
3754       break;
3755
3756     default:
3757       assert ("bad abasictype" == NULL);
3758       break;
3759     }
3760
3761   switch (cbt)
3762     {
3763     case FFEINFO_basictypeINTEGER:
3764       switch (ckt)
3765         {
3766 #if FFETARGET_okINTEGER1
3767         case FFEINFO_kindtypeINTEGER1:
3768           *cptr = &constant->integer1;
3769           *size = sizeof (constant->integer1);
3770           break;
3771 #endif
3772
3773 #if FFETARGET_okINTEGER2
3774         case FFEINFO_kindtypeINTEGER2:
3775           *cptr = &constant->integer2;
3776           *size = sizeof (constant->integer2);
3777           break;
3778 #endif
3779
3780 #if FFETARGET_okINTEGER3
3781         case FFEINFO_kindtypeINTEGER3:
3782           *cptr = &constant->integer3;
3783           *size = sizeof (constant->integer3);
3784           break;
3785 #endif
3786
3787 #if FFETARGET_okINTEGER4
3788         case FFEINFO_kindtypeINTEGER4:
3789           *cptr = &constant->integer4;
3790           *size = sizeof (constant->integer4);
3791           break;
3792 #endif
3793
3794 #if FFETARGET_okINTEGER5
3795         case FFEINFO_kindtypeINTEGER5:
3796           *cptr = &constant->integer5;
3797           *size = sizeof (constant->integer5);
3798           break;
3799 #endif
3800
3801 #if FFETARGET_okINTEGER6
3802         case FFEINFO_kindtypeINTEGER6:
3803           *cptr = &constant->integer6;
3804           *size = sizeof (constant->integer6);
3805           break;
3806 #endif
3807
3808 #if FFETARGET_okINTEGER7
3809         case FFEINFO_kindtypeINTEGER7:
3810           *cptr = &constant->integer7;
3811           *size = sizeof (constant->integer7);
3812           break;
3813 #endif
3814
3815 #if FFETARGET_okINTEGER8
3816         case FFEINFO_kindtypeINTEGER8:
3817           *cptr = &constant->integer8;
3818           *size = sizeof (constant->integer8);
3819           break;
3820 #endif
3821
3822         default:
3823           assert ("bad INTEGER ckindtype" == NULL);
3824           break;
3825         }
3826       break;
3827
3828     case FFEINFO_basictypeLOGICAL:
3829       switch (ckt)
3830         {
3831 #if FFETARGET_okLOGICAL1
3832         case FFEINFO_kindtypeLOGICAL1:
3833           *cptr = &constant->logical1;
3834           *size = sizeof (constant->logical1);
3835           break;
3836 #endif
3837
3838 #if FFETARGET_okLOGICAL2
3839         case FFEINFO_kindtypeLOGICAL2:
3840           *cptr = &constant->logical2;
3841           *size = sizeof (constant->logical2);
3842           break;
3843 #endif
3844
3845 #if FFETARGET_okLOGICAL3
3846         case FFEINFO_kindtypeLOGICAL3:
3847           *cptr = &constant->logical3;
3848           *size = sizeof (constant->logical3);
3849           break;
3850 #endif
3851
3852 #if FFETARGET_okLOGICAL4
3853         case FFEINFO_kindtypeLOGICAL4:
3854           *cptr = &constant->logical4;
3855           *size = sizeof (constant->logical4);
3856           break;
3857 #endif
3858
3859 #if FFETARGET_okLOGICAL5
3860         case FFEINFO_kindtypeLOGICAL5:
3861           *cptr = &constant->logical5;
3862           *size = sizeof (constant->logical5);
3863           break;
3864 #endif
3865
3866 #if FFETARGET_okLOGICAL6
3867         case FFEINFO_kindtypeLOGICAL6:
3868           *cptr = &constant->logical6;
3869           *size = sizeof (constant->logical6);
3870           break;
3871 #endif
3872
3873 #if FFETARGET_okLOGICAL7
3874         case FFEINFO_kindtypeLOGICAL7:
3875           *cptr = &constant->logical7;
3876           *size = sizeof (constant->logical7);
3877           break;
3878 #endif
3879
3880 #if FFETARGET_okLOGICAL8
3881         case FFEINFO_kindtypeLOGICAL8:
3882           *cptr = &constant->logical8;
3883           *size = sizeof (constant->logical8);
3884           break;
3885 #endif
3886
3887         default:
3888           assert ("bad LOGICAL ckindtype" == NULL);
3889           break;
3890         }
3891       break;
3892
3893     case FFEINFO_basictypeREAL:
3894       switch (ckt)
3895         {
3896 #if FFETARGET_okREAL1
3897         case FFEINFO_kindtypeREAL1:
3898           *cptr = &constant->real1;
3899           *size = sizeof (constant->real1);
3900           break;
3901 #endif
3902
3903 #if FFETARGET_okREAL2
3904         case FFEINFO_kindtypeREAL2:
3905           *cptr = &constant->real2;
3906           *size = sizeof (constant->real2);
3907           break;
3908 #endif
3909
3910 #if FFETARGET_okREAL3
3911         case FFEINFO_kindtypeREAL3:
3912           *cptr = &constant->real3;
3913           *size = sizeof (constant->real3);
3914           break;
3915 #endif
3916
3917 #if FFETARGET_okREAL4
3918         case FFEINFO_kindtypeREAL4:
3919           *cptr = &constant->real4;
3920           *size = sizeof (constant->real4);
3921           break;
3922 #endif
3923
3924 #if FFETARGET_okREAL5
3925         case FFEINFO_kindtypeREAL5:
3926           *cptr = &constant->real5;
3927           *size = sizeof (constant->real5);
3928           break;
3929 #endif
3930
3931 #if FFETARGET_okREAL6
3932         case FFEINFO_kindtypeREAL6:
3933           *cptr = &constant->real6;
3934           *size = sizeof (constant->real6);
3935           break;
3936 #endif
3937
3938 #if FFETARGET_okREAL7
3939         case FFEINFO_kindtypeREAL7:
3940           *cptr = &constant->real7;
3941           *size = sizeof (constant->real7);
3942           break;
3943 #endif
3944
3945 #if FFETARGET_okREAL8
3946         case FFEINFO_kindtypeREAL8:
3947           *cptr = &constant->real8;
3948           *size = sizeof (constant->real8);
3949           break;
3950 #endif
3951
3952         default:
3953           assert ("bad REAL ckindtype" == NULL);
3954           break;
3955         }
3956       break;
3957
3958     case FFEINFO_basictypeCOMPLEX:
3959       switch (ckt)
3960         {
3961 #if FFETARGET_okCOMPLEX1
3962         case FFEINFO_kindtypeREAL1:
3963           *cptr = &constant->complex1;
3964           *size = sizeof (constant->complex1);
3965           break;
3966 #endif
3967
3968 #if FFETARGET_okCOMPLEX2
3969         case FFEINFO_kindtypeREAL2:
3970           *cptr = &constant->complex2;
3971           *size = sizeof (constant->complex2);
3972           break;
3973 #endif
3974
3975 #if FFETARGET_okCOMPLEX3
3976         case FFEINFO_kindtypeREAL3:
3977           *cptr = &constant->complex3;
3978           *size = sizeof (constant->complex3);
3979           break;
3980 #endif
3981
3982 #if FFETARGET_okCOMPLEX4
3983         case FFEINFO_kindtypeREAL4:
3984           *cptr = &constant->complex4;
3985           *size = sizeof (constant->complex4);
3986           break;
3987 #endif
3988
3989 #if FFETARGET_okCOMPLEX5
3990         case FFEINFO_kindtypeREAL5:
3991           *cptr = &constant->complex5;
3992           *size = sizeof (constant->complex5);
3993           break;
3994 #endif
3995
3996 #if FFETARGET_okCOMPLEX6
3997         case FFEINFO_kindtypeREAL6:
3998           *cptr = &constant->complex6;
3999           *size = sizeof (constant->complex6);
4000           break;
4001 #endif
4002
4003 #if FFETARGET_okCOMPLEX7
4004         case FFEINFO_kindtypeREAL7:
4005           *cptr = &constant->complex7;
4006           *size = sizeof (constant->complex7);
4007           break;
4008 #endif
4009
4010 #if FFETARGET_okCOMPLEX8
4011         case FFEINFO_kindtypeREAL8:
4012           *cptr = &constant->complex8;
4013           *size = sizeof (constant->complex8);
4014           break;
4015 #endif
4016
4017         default:
4018           assert ("bad COMPLEX ckindtype" == NULL);
4019           break;
4020         }
4021       break;
4022
4023     case FFEINFO_basictypeCHARACTER:
4024       switch (ckt)
4025         {
4026 #if FFETARGET_okCHARACTER1
4027         case FFEINFO_kindtypeCHARACTER1:
4028           *cptr = ffetarget_text_character1 (constant->character1);
4029           *size = ffetarget_length_character1 (constant->character1);
4030           break;
4031 #endif
4032
4033 #if FFETARGET_okCHARACTER2
4034         case FFEINFO_kindtypeCHARACTER2:
4035           *cptr = ffetarget_text_character2 (constant->character2);
4036           *size = ffetarget_length_character2 (constant->character2);
4037           break;
4038 #endif
4039
4040 #if FFETARGET_okCHARACTER3
4041         case FFEINFO_kindtypeCHARACTER3:
4042           *cptr = ffetarget_text_character3 (constant->character3);
4043           *size = ffetarget_length_character3 (constant->character3);
4044           break;
4045 #endif
4046
4047 #if FFETARGET_okCHARACTER4
4048         case FFEINFO_kindtypeCHARACTER4:
4049           *cptr = ffetarget_text_character4 (constant->character4);
4050           *size = ffetarget_length_character4 (constant->character4);
4051           break;
4052 #endif
4053
4054 #if FFETARGET_okCHARACTER5
4055         case FFEINFO_kindtypeCHARACTER5:
4056           *cptr = ffetarget_text_character5 (constant->character5);
4057           *size = ffetarget_length_character5 (constant->character5);
4058           break;
4059 #endif
4060
4061 #if FFETARGET_okCHARACTER6
4062         case FFEINFO_kindtypeCHARACTER6:
4063           *cptr = ffetarget_text_character6 (constant->character6);
4064           *size = ffetarget_length_character6 (constant->character6);
4065           break;
4066 #endif
4067
4068 #if FFETARGET_okCHARACTER7
4069         case FFEINFO_kindtypeCHARACTER7:
4070           *cptr = ffetarget_text_character7 (constant->character7);
4071           *size = ffetarget_length_character7 (constant->character7);
4072           break;
4073 #endif
4074
4075 #if FFETARGET_okCHARACTER8
4076         case FFEINFO_kindtypeCHARACTER8:
4077           *cptr = ffetarget_text_character8 (constant->character8);
4078           *size = ffetarget_length_character8 (constant->character8);
4079           break;
4080 #endif
4081
4082         default:
4083           assert ("bad CHARACTER ckindtype" == NULL);
4084           break;
4085         }
4086       break;
4087
4088     default:
4089       assert ("bad cbasictype" == NULL);
4090       break;
4091     }
4092 }
4093
4094 /* ffebld_constantarray_put -- Put a value into an array of constants
4095
4096    See prototype.  */
4097
4098 void
4099 ffebld_constantarray_put (ffebldConstantArray array, ffeinfoBasictype bt,
4100    ffeinfoKindtype kt, ffetargetOffset offset, ffebldConstantUnion constant)
4101 {
4102   switch (bt)
4103     {
4104     case FFEINFO_basictypeINTEGER:
4105       switch (kt)
4106         {
4107 #if FFETARGET_okINTEGER1
4108         case FFEINFO_kindtypeINTEGER1:
4109           *(array.integer1 + offset) = constant.integer1;
4110           break;
4111 #endif
4112
4113 #if FFETARGET_okINTEGER2
4114         case FFEINFO_kindtypeINTEGER2:
4115           *(array.integer2 + offset) = constant.integer2;
4116           break;
4117 #endif
4118
4119 #if FFETARGET_okINTEGER3
4120         case FFEINFO_kindtypeINTEGER3:
4121           *(array.integer3 + offset) = constant.integer3;
4122           break;
4123 #endif
4124
4125 #if FFETARGET_okINTEGER4
4126         case FFEINFO_kindtypeINTEGER4:
4127           *(array.integer4 + offset) = constant.integer4;
4128           break;
4129 #endif
4130
4131 #if FFETARGET_okINTEGER5
4132         case FFEINFO_kindtypeINTEGER5:
4133           *(array.integer5 + offset) = constant.integer5;
4134           break;
4135 #endif
4136
4137 #if FFETARGET_okINTEGER6
4138         case FFEINFO_kindtypeINTEGER6:
4139           *(array.integer6 + offset) = constant.integer6;
4140           break;
4141 #endif
4142
4143 #if FFETARGET_okINTEGER7
4144         case FFEINFO_kindtypeINTEGER7:
4145           *(array.integer7 + offset) = constant.integer7;
4146           break;
4147 #endif
4148
4149 #if FFETARGET_okINTEGER8
4150         case FFEINFO_kindtypeINTEGER8:
4151           *(array.integer8 + offset) = constant.integer8;
4152           break;
4153 #endif
4154
4155         default:
4156           assert ("bad INTEGER kindtype" == NULL);
4157           break;
4158         }
4159       break;
4160
4161     case FFEINFO_basictypeLOGICAL:
4162       switch (kt)
4163         {
4164 #if FFETARGET_okLOGICAL1
4165         case FFEINFO_kindtypeLOGICAL1:
4166           *(array.logical1 + offset) = constant.logical1;
4167           break;
4168 #endif
4169
4170 #if FFETARGET_okLOGICAL2
4171         case FFEINFO_kindtypeLOGICAL2:
4172           *(array.logical2 + offset) = constant.logical2;
4173           break;
4174 #endif
4175
4176 #if FFETARGET_okLOGICAL3
4177         case FFEINFO_kindtypeLOGICAL3:
4178           *(array.logical3 + offset) = constant.logical3;
4179           break;
4180 #endif
4181
4182 #if FFETARGET_okLOGICAL4
4183         case FFEINFO_kindtypeLOGICAL4:
4184           *(array.logical4 + offset) = constant.logical4;
4185           break;
4186 #endif
4187
4188 #if FFETARGET_okLOGICAL5
4189         case FFEINFO_kindtypeLOGICAL5:
4190           *(array.logical5 + offset) = constant.logical5;
4191           break;
4192 #endif
4193
4194 #if FFETARGET_okLOGICAL6
4195         case FFEINFO_kindtypeLOGICAL6:
4196           *(array.logical6 + offset) = constant.logical6;
4197           break;
4198 #endif
4199
4200 #if FFETARGET_okLOGICAL7
4201         case FFEINFO_kindtypeLOGICAL7:
4202           *(array.logical7 + offset) = constant.logical7;
4203           break;
4204 #endif
4205
4206 #if FFETARGET_okLOGICAL8
4207         case FFEINFO_kindtypeLOGICAL8:
4208           *(array.logical8 + offset) = constant.logical8;
4209           break;
4210 #endif
4211
4212         default:
4213           assert ("bad LOGICAL kindtype" == NULL);
4214           break;
4215         }
4216       break;
4217
4218     case FFEINFO_basictypeREAL:
4219       switch (kt)
4220         {
4221 #if FFETARGET_okREAL1
4222         case FFEINFO_kindtypeREAL1:
4223           *(array.real1 + offset) = constant.real1;
4224           break;
4225 #endif
4226
4227 #if FFETARGET_okREAL2
4228         case FFEINFO_kindtypeREAL2:
4229           *(array.real2 + offset) = constant.real2;
4230           break;
4231 #endif
4232
4233 #if FFETARGET_okREAL3
4234         case FFEINFO_kindtypeREAL3:
4235           *(array.real3 + offset) = constant.real3;
4236           break;
4237 #endif
4238
4239 #if FFETARGET_okREAL4
4240         case FFEINFO_kindtypeREAL4:
4241           *(array.real4 + offset) = constant.real4;
4242           break;
4243 #endif
4244
4245 #if FFETARGET_okREAL5
4246         case FFEINFO_kindtypeREAL5:
4247           *(array.real5 + offset) = constant.real5;
4248           break;
4249 #endif
4250
4251 #if FFETARGET_okREAL6
4252         case FFEINFO_kindtypeREAL6:
4253           *(array.real6 + offset) = constant.real6;
4254           break;
4255 #endif
4256
4257 #if FFETARGET_okREAL7
4258         case FFEINFO_kindtypeREAL7:
4259           *(array.real7 + offset) = constant.real7;
4260           break;
4261 #endif
4262
4263 #if FFETARGET_okREAL8
4264         case FFEINFO_kindtypeREAL8:
4265           *(array.real8 + offset) = constant.real8;
4266           break;
4267 #endif
4268
4269         default:
4270           assert ("bad REAL kindtype" == NULL);
4271           break;
4272         }
4273       break;
4274
4275     case FFEINFO_basictypeCOMPLEX:
4276       switch (kt)
4277         {
4278 #if FFETARGET_okCOMPLEX1
4279         case FFEINFO_kindtypeREAL1:
4280           *(array.complex1 + offset) = constant.complex1;
4281           break;
4282 #endif
4283
4284 #if FFETARGET_okCOMPLEX2
4285         case FFEINFO_kindtypeREAL2:
4286           *(array.complex2 + offset) = constant.complex2;
4287           break;
4288 #endif
4289
4290 #if FFETARGET_okCOMPLEX3
4291         case FFEINFO_kindtypeREAL3:
4292           *(array.complex3 + offset) = constant.complex3;
4293           break;
4294 #endif
4295
4296 #if FFETARGET_okCOMPLEX4
4297         case FFEINFO_kindtypeREAL4:
4298           *(array.complex4 + offset) = constant.complex4;
4299           break;
4300 #endif
4301
4302 #if FFETARGET_okCOMPLEX5
4303         case FFEINFO_kindtypeREAL5:
4304           *(array.complex5 + offset) = constant.complex5;
4305           break;
4306 #endif
4307
4308 #if FFETARGET_okCOMPLEX6
4309         case FFEINFO_kindtypeREAL6:
4310           *(array.complex6 + offset) = constant.complex6;
4311           break;
4312 #endif
4313
4314 #if FFETARGET_okCOMPLEX7
4315         case FFEINFO_kindtypeREAL7:
4316           *(array.complex7 + offset) = constant.complex7;
4317           break;
4318 #endif
4319
4320 #if FFETARGET_okCOMPLEX8
4321         case FFEINFO_kindtypeREAL8:
4322           *(array.complex8 + offset) = constant.complex8;
4323           break;
4324 #endif
4325
4326         default:
4327           assert ("bad COMPLEX kindtype" == NULL);
4328           break;
4329         }
4330       break;
4331
4332     case FFEINFO_basictypeCHARACTER:
4333       switch (kt)
4334         {
4335 #if FFETARGET_okCHARACTER1
4336         case FFEINFO_kindtypeCHARACTER1:
4337           memcpy (array.character1 + offset,
4338                   ffetarget_text_character1 (constant.character1),
4339                   ffetarget_length_character1 (constant.character1));
4340           break;
4341 #endif
4342
4343 #if FFETARGET_okCHARACTER2
4344         case FFEINFO_kindtypeCHARACTER2:
4345           memcpy (array.character2 + offset,
4346                   ffetarget_text_character2 (constant.character2),
4347                   ffetarget_length_character2 (constant.character2));
4348           break;
4349 #endif
4350
4351 #if FFETARGET_okCHARACTER3
4352         case FFEINFO_kindtypeCHARACTER3:
4353           memcpy (array.character3 + offset,
4354                   ffetarget_text_character3 (constant.character3),
4355                   ffetarget_length_character3 (constant.character3));
4356           break;
4357 #endif
4358
4359 #if FFETARGET_okCHARACTER4
4360         case FFEINFO_kindtypeCHARACTER4:
4361           memcpy (array.character4 + offset,
4362                   ffetarget_text_character4 (constant.character4),
4363                   ffetarget_length_character4 (constant.character4));
4364           break;
4365 #endif
4366
4367 #if FFETARGET_okCHARACTER5
4368         case FFEINFO_kindtypeCHARACTER5:
4369           memcpy (array.character5 + offset,
4370                   ffetarget_text_character5 (constant.character5),
4371                   ffetarget_length_character5 (constant.character5));
4372           break;
4373 #endif
4374
4375 #if FFETARGET_okCHARACTER6
4376         case FFEINFO_kindtypeCHARACTER6:
4377           memcpy (array.character6 + offset,
4378                   ffetarget_text_character6 (constant.character6),
4379                   ffetarget_length_character6 (constant.character6));
4380           break;
4381 #endif
4382
4383 #if FFETARGET_okCHARACTER7
4384         case FFEINFO_kindtypeCHARACTER7:
4385           memcpy (array.character7 + offset,
4386                   ffetarget_text_character7 (constant.character7),
4387                   ffetarget_length_character7 (constant.character7));
4388           break;
4389 #endif
4390
4391 #if FFETARGET_okCHARACTER8
4392         case FFEINFO_kindtypeCHARACTER8:
4393           memcpy (array.character8 + offset,
4394                   ffetarget_text_character8 (constant.character8),
4395                   ffetarget_length_character8 (constant.character8));
4396           break;
4397 #endif
4398
4399         default:
4400           assert ("bad CHARACTER kindtype" == NULL);
4401           break;
4402         }
4403       break;
4404
4405     default:
4406       assert ("bad basictype" == NULL);
4407       break;
4408     }
4409 }
4410
4411 /* ffebld_constantunion_dump -- Dump a constant
4412
4413    See prototype.  */
4414
4415 #if FFECOM_targetCURRENT == FFECOM_targetFFE
4416 void
4417 ffebld_constantunion_dump (ffebldConstantUnion u, ffeinfoBasictype bt,
4418                            ffeinfoKindtype kt)
4419 {
4420   switch (bt)
4421     {
4422     case FFEINFO_basictypeINTEGER:
4423       switch (kt)
4424         {
4425 #if FFETARGET_okINTEGER1
4426         case FFEINFO_kindtypeINTEGER1:
4427           ffetarget_print_integer1 (dmpout, u.integer1);
4428           break;
4429 #endif
4430
4431 #if FFETARGET_okINTEGER2
4432         case FFEINFO_kindtypeINTEGER2:
4433           ffetarget_print_integer2 (dmpout, u.integer2);
4434           break;
4435 #endif
4436
4437 #if FFETARGET_okINTEGER3
4438         case FFEINFO_kindtypeINTEGER3:
4439           ffetarget_print_integer3 (dmpout, u.integer3);
4440           break;
4441 #endif
4442
4443 #if FFETARGET_okINTEGER4
4444         case FFEINFO_kindtypeINTEGER4:
4445           ffetarget_print_integer4 (dmpout, u.integer4);
4446           break;
4447 #endif
4448
4449 #if FFETARGET_okINTEGER5
4450         case FFEINFO_kindtypeINTEGER5:
4451           ffetarget_print_integer5 (dmpout, u.integer5);
4452           break;
4453 #endif
4454
4455 #if FFETARGET_okINTEGER6
4456         case FFEINFO_kindtypeINTEGER6:
4457           ffetarget_print_integer6 (dmpout, u.integer6);
4458           break;
4459 #endif
4460
4461 #if FFETARGET_okINTEGER7
4462         case FFEINFO_kindtypeINTEGER7:
4463           ffetarget_print_integer7 (dmpout, u.integer7);
4464           break;
4465 #endif
4466
4467 #if FFETARGET_okINTEGER8
4468         case FFEINFO_kindtypeINTEGER8:
4469           ffetarget_print_integer8 (dmpout, u.integer8);
4470           break;
4471 #endif
4472
4473         default:
4474           assert ("bad INTEGER kindtype" == NULL);
4475           break;
4476         }
4477       break;
4478
4479     case FFEINFO_basictypeLOGICAL:
4480       switch (kt)
4481         {
4482 #if FFETARGET_okLOGICAL1
4483         case FFEINFO_kindtypeLOGICAL1:
4484           ffetarget_print_logical1 (dmpout, u.logical1);
4485           break;
4486 #endif
4487
4488 #if FFETARGET_okLOGICAL2
4489         case FFEINFO_kindtypeLOGICAL2:
4490           ffetarget_print_logical2 (dmpout, u.logical2);
4491           break;
4492 #endif
4493
4494 #if FFETARGET_okLOGICAL3
4495         case FFEINFO_kindtypeLOGICAL3:
4496           ffetarget_print_logical3 (dmpout, u.logical3);
4497           break;
4498 #endif
4499
4500 #if FFETARGET_okLOGICAL4
4501         case FFEINFO_kindtypeLOGICAL4:
4502           ffetarget_print_logical4 (dmpout, u.logical4);
4503           break;
4504 #endif
4505
4506 #if FFETARGET_okLOGICAL5
4507         case FFEINFO_kindtypeLOGICAL5:
4508           ffetarget_print_logical5 (dmpout, u.logical5);
4509           break;
4510 #endif
4511
4512 #if FFETARGET_okLOGICAL6
4513         case FFEINFO_kindtypeLOGICAL6:
4514           ffetarget_print_logical6 (dmpout, u.logical6);
4515           break;
4516 #endif
4517
4518 #if FFETARGET_okLOGICAL7
4519         case FFEINFO_kindtypeLOGICAL7:
4520           ffetarget_print_logical7 (dmpout, u.logical7);
4521           break;
4522 #endif
4523
4524 #if FFETARGET_okLOGICAL8
4525         case FFEINFO_kindtypeLOGICAL8:
4526           ffetarget_print_logical8 (dmpout, u.logical8);
4527           break;
4528 #endif
4529
4530         default:
4531           assert ("bad LOGICAL kindtype" == NULL);
4532           break;
4533         }
4534       break;
4535
4536     case FFEINFO_basictypeREAL:
4537       switch (kt)
4538         {
4539 #if FFETARGET_okREAL1
4540         case FFEINFO_kindtypeREAL1:
4541           ffetarget_print_real1 (dmpout, u.real1);
4542           break;
4543 #endif
4544
4545 #if FFETARGET_okREAL2
4546         case FFEINFO_kindtypeREAL2:
4547           ffetarget_print_real2 (dmpout, u.real2);
4548           break;
4549 #endif
4550
4551 #if FFETARGET_okREAL3
4552         case FFEINFO_kindtypeREAL3:
4553           ffetarget_print_real3 (dmpout, u.real3);
4554           break;
4555 #endif
4556
4557 #if FFETARGET_okREAL4
4558         case FFEINFO_kindtypeREAL4:
4559           ffetarget_print_real4 (dmpout, u.real4);
4560           break;
4561 #endif
4562
4563 #if FFETARGET_okREAL5
4564         case FFEINFO_kindtypeREAL5:
4565           ffetarget_print_real5 (dmpout, u.real5);
4566           break;
4567 #endif
4568
4569 #if FFETARGET_okREAL6
4570         case FFEINFO_kindtypeREAL6:
4571           ffetarget_print_real6 (dmpout, u.real6);
4572           break;
4573 #endif
4574
4575 #if FFETARGET_okREAL7
4576         case FFEINFO_kindtypeREAL7:
4577           ffetarget_print_real7 (dmpout, u.real7);
4578           break;
4579 #endif
4580
4581 #if FFETARGET_okREAL8
4582         case FFEINFO_kindtypeREAL8:
4583           ffetarget_print_real8 (dmpout, u.real8);
4584           break;
4585 #endif
4586
4587         default:
4588           assert ("bad REAL kindtype" == NULL);
4589           break;
4590         }
4591       break;
4592
4593     case FFEINFO_basictypeCOMPLEX:
4594       switch (kt)
4595         {
4596 #if FFETARGET_okCOMPLEX1
4597         case FFEINFO_kindtypeREAL1:
4598           fprintf (dmpout, "(");
4599           ffetarget_print_real1 (dmpout, u.complex1.real);
4600           fprintf (dmpout, ",");
4601           ffetarget_print_real1 (dmpout, u.complex1.imaginary);
4602           fprintf (dmpout, ")");
4603           break;
4604 #endif
4605
4606 #if FFETARGET_okCOMPLEX2
4607         case FFEINFO_kindtypeREAL2:
4608           fprintf (dmpout, "(");
4609           ffetarget_print_real2 (dmpout, u.complex2.real);
4610           fprintf (dmpout, ",");
4611           ffetarget_print_real2 (dmpout, u.complex2.imaginary);
4612           fprintf (dmpout, ")");
4613           break;
4614 #endif
4615
4616 #if FFETARGET_okCOMPLEX3
4617         case FFEINFO_kindtypeREAL3:
4618           fprintf (dmpout, "(");
4619           ffetarget_print_real3 (dmpout, u.complex3.real);
4620           fprintf (dmpout, ",");
4621           ffetarget_print_real3 (dmpout, u.complex3.imaginary);
4622           fprintf (dmpout, ")");
4623           break;
4624 #endif
4625
4626 #if FFETARGET_okCOMPLEX4
4627         case FFEINFO_kindtypeREAL4:
4628           fprintf (dmpout, "(");
4629           ffetarget_print_real4 (dmpout, u.complex4.real);
4630           fprintf (dmpout, ",");
4631           ffetarget_print_real4 (dmpout, u.complex4.imaginary);
4632           fprintf (dmpout, ")");
4633           break;
4634 #endif
4635
4636 #if FFETARGET_okCOMPLEX5
4637         case FFEINFO_kindtypeREAL5:
4638           fprintf (dmpout, "(");
4639           ffetarget_print_real5 (dmpout, u.complex5.real);
4640           fprintf (dmpout, ",");
4641           ffetarget_print_real5 (dmpout, u.complex5.imaginary);
4642           fprintf (dmpout, ")");
4643           break;
4644 #endif
4645
4646 #if FFETARGET_okCOMPLEX6
4647         case FFEINFO_kindtypeREAL6:
4648           fprintf (dmpout, "(");
4649           ffetarget_print_real6 (dmpout, u.complex6.real);
4650           fprintf (dmpout, ",");
4651           ffetarget_print_real6 (dmpout, u.complex6.imaginary);
4652           fprintf (dmpout, ")");
4653           break;
4654 #endif
4655
4656 #if FFETARGET_okCOMPLEX7
4657         case FFEINFO_kindtypeREAL7:
4658           fprintf (dmpout, "(");
4659           ffetarget_print_real7 (dmpout, u.complex7.real);
4660           fprintf (dmpout, ",");
4661           ffetarget_print_real7 (dmpout, u.complex7.imaginary);
4662           fprintf (dmpout, ")");
4663           break;
4664 #endif
4665
4666 #if FFETARGET_okCOMPLEX8
4667         case FFEINFO_kindtypeREAL8:
4668           fprintf (dmpout, "(");
4669           ffetarget_print_real8 (dmpout, u.complex8.real);
4670           fprintf (dmpout, ",");
4671           ffetarget_print_real8 (dmpout, u.complex8.imaginary);
4672           fprintf (dmpout, ")");
4673           break;
4674 #endif
4675
4676         default:
4677           assert ("bad COMPLEX kindtype" == NULL);
4678           break;
4679         }
4680       break;
4681
4682     case FFEINFO_basictypeCHARACTER:
4683       switch (kt)
4684         {
4685 #if FFETARGET_okCHARACTER1
4686         case FFEINFO_kindtypeCHARACTER1:
4687           ffetarget_print_character1 (dmpout, u.character1);
4688           break;
4689 #endif
4690
4691 #if FFETARGET_okCHARACTER2
4692         case FFEINFO_kindtypeCHARACTER2:
4693           ffetarget_print_character2 (dmpout, u.character2);
4694           break;
4695 #endif
4696
4697 #if FFETARGET_okCHARACTER3
4698         case FFEINFO_kindtypeCHARACTER3:
4699           ffetarget_print_character3 (dmpout, u.character3);
4700           break;
4701 #endif
4702
4703 #if FFETARGET_okCHARACTER4
4704         case FFEINFO_kindtypeCHARACTER4:
4705           ffetarget_print_character4 (dmpout, u.character4);
4706           break;
4707 #endif
4708
4709 #if FFETARGET_okCHARACTER5
4710         case FFEINFO_kindtypeCHARACTER5:
4711           ffetarget_print_character5 (dmpout, u.character5);
4712           break;
4713 #endif
4714
4715 #if FFETARGET_okCHARACTER6
4716         case FFEINFO_kindtypeCHARACTER6:
4717           ffetarget_print_character6 (dmpout, u.character6);
4718           break;
4719 #endif
4720
4721 #if FFETARGET_okCHARACTER7
4722         case FFEINFO_kindtypeCHARACTER7:
4723           ffetarget_print_character7 (dmpout, u.character7);
4724           break;
4725 #endif
4726
4727 #if FFETARGET_okCHARACTER8
4728         case FFEINFO_kindtypeCHARACTER8:
4729           ffetarget_print_character8 (dmpout, u.character8);
4730           break;
4731 #endif
4732
4733         default:
4734           assert ("bad CHARACTER kindtype" == NULL);
4735           break;
4736         }
4737       break;
4738
4739     default:
4740       assert ("bad basictype" == NULL);
4741       break;
4742     }
4743 }
4744 #endif
4745
4746 /* ffebld_dump -- Dump expression tree in concise form
4747
4748    ffebld b;
4749    ffebld_dump(b);  */
4750
4751 #if FFECOM_targetCURRENT == FFECOM_targetFFE
4752 void
4753 ffebld_dump (ffebld b)
4754 {
4755   ffeinfoKind k;
4756   ffeinfoWhere w;
4757
4758   if (b == NULL)
4759     {
4760       fprintf (dmpout, "(null)");
4761       return;
4762     }
4763
4764   switch (ffebld_op (b))
4765     {
4766     case FFEBLD_opITEM:
4767       fputs ("[", dmpout);
4768       while (b != NULL)
4769         {
4770           ffebld_dump (ffebld_head (b));
4771           if ((b = ffebld_trail (b)) != NULL)
4772             fputs (",", dmpout);
4773         }
4774       fputs ("]", dmpout);
4775       return;
4776
4777     case FFEBLD_opSTAR:
4778     case FFEBLD_opBOUNDS:
4779     case FFEBLD_opREPEAT:
4780     case FFEBLD_opLABTER:
4781     case FFEBLD_opLABTOK:
4782     case FFEBLD_opIMPDO:
4783       fputs (ffebld_op_string (ffebld_op (b)), dmpout);
4784       break;
4785
4786     default:
4787       if (ffeinfo_size (ffebld_info (b)) != FFETARGET_charactersizeNONE)
4788         fprintf (dmpout, "%s%d%s%s*%" ffetargetCharacterSize_f "u",
4789                  ffebld_op_string (ffebld_op (b)),
4790                  (int) ffeinfo_rank (ffebld_info (b)),
4791              ffeinfo_basictype_string (ffeinfo_basictype (ffebld_info (b))),
4792                ffeinfo_kindtype_string (ffeinfo_kindtype (ffebld_info (b))),
4793                  ffeinfo_size (ffebld_info (b)));
4794       else
4795         fprintf (dmpout, "%s%d%s%s", ffebld_op_string (ffebld_op (b)),
4796                  (int) ffeinfo_rank (ffebld_info (b)),
4797              ffeinfo_basictype_string (ffeinfo_basictype (ffebld_info (b))),
4798               ffeinfo_kindtype_string (ffeinfo_kindtype (ffebld_info (b))));
4799       if ((k = ffeinfo_kind (ffebld_info (b))) != FFEINFO_kindNONE)
4800         fprintf (dmpout, "/%s", ffeinfo_kind_string (k));
4801       if ((w = ffeinfo_where (ffebld_info (b))) != FFEINFO_whereNONE)
4802         fprintf (dmpout, "@%s", ffeinfo_where_string (w));
4803       break;
4804     }
4805
4806   switch (ffebld_arity (b))
4807     {
4808     case 2:
4809       fputs ("(", dmpout);
4810       ffebld_dump (ffebld_left (b));
4811       fputs (",", dmpout);
4812       ffebld_dump (ffebld_right (b));
4813       fputs (")", dmpout);
4814       break;
4815
4816     case 1:
4817       fputs ("(", dmpout);
4818       ffebld_dump (ffebld_left (b));
4819       fputs (")", dmpout);
4820       break;
4821
4822     default:
4823       switch (ffebld_op (b))
4824         {
4825         case FFEBLD_opCONTER:
4826           fprintf (dmpout, "<");
4827           ffebld_constant_dump (b->u.conter.expr);
4828           fprintf (dmpout, ">");
4829           break;
4830
4831         case FFEBLD_opACCTER:
4832           fprintf (dmpout, "<");
4833           ffebld_constantarray_dump (b->u.accter.array,
4834                                      ffeinfo_basictype (ffebld_info (b)),
4835                                      ffeinfo_kindtype (ffebld_info (b)),
4836                           ffebit_size (b->u.accter.bits), b->u.accter.bits);
4837           fprintf (dmpout, ">");
4838           break;
4839
4840         case FFEBLD_opARRTER:
4841           fprintf (dmpout, "<");
4842           ffebld_constantarray_dump (b->u.arrter.array,
4843                                      ffeinfo_basictype (ffebld_info (b)),
4844                                      ffeinfo_kindtype (ffebld_info (b)),
4845                                      b->u.arrter.size, NULL);
4846           fprintf (dmpout, ">");
4847           break;
4848
4849         case FFEBLD_opLABTER:
4850           if (b->u.labter == NULL)
4851             fprintf (dmpout, "<>");
4852           else
4853             fprintf (dmpout, "<%" ffelabValue_f "u>", ffelab_value (b->u.labter));
4854           break;
4855
4856         case FFEBLD_opLABTOK:
4857           fprintf (dmpout, "<%s>", ffelex_token_text (b->u.labtok));
4858           break;
4859
4860         case FFEBLD_opSYMTER:
4861           fprintf (dmpout, "<");
4862           ffesymbol_dump (b->u.symter.symbol);
4863           if ((b->u.symter.generic != FFEINTRIN_genNONE)
4864               || (b->u.symter.specific != FFEINTRIN_specNONE))
4865             fprintf (dmpout, "{%s:%s:%s}",
4866                      ffeintrin_name_generic (b->u.symter.generic),
4867                      ffeintrin_name_specific (b->u.symter.specific),
4868                 ffeintrin_name_implementation (b->u.symter.implementation));
4869           if (b->u.symter.do_iter)
4870             fprintf (dmpout, "{/do-iter}");
4871           fprintf (dmpout, ">");
4872           break;
4873
4874         default:
4875           break;
4876         }
4877     }
4878 }
4879 #endif
4880
4881 /* ffebld_dump_prefix -- Dump the prefix for a constant of a given type
4882
4883    ffebld_dump_prefix(dmpout,FFEINFO_basictypeINTEGER,
4884          FFEINFO_kindtypeINTEGER1);  */
4885
4886 #if FFECOM_targetCURRENT == FFECOM_targetFFE
4887 void
4888 ffebld_dump_prefix (FILE *out, ffeinfoBasictype bt, ffeinfoKindtype kt)
4889 {
4890   switch (bt)
4891     {
4892     case FFEINFO_basictypeINTEGER:
4893       switch (kt)
4894         {
4895 #if FFETARGET_okINTEGER1
4896         case FFEINFO_kindtypeINTEGER1:
4897           fprintf (out, "I" STRX (FFETARGET_kindINTEGER1) "/");
4898           break;
4899 #endif
4900
4901 #if FFETARGET_okINTEGER2
4902         case FFEINFO_kindtypeINTEGER2:
4903           fprintf (out, "I" STRX (FFETARGET_kindINTEGER2) "/");
4904           break;
4905 #endif
4906
4907 #if FFETARGET_okINTEGER3
4908         case FFEINFO_kindtypeINTEGER3:
4909           fprintf (out, "I" STRX (FFETARGET_kindINTEGER3) "/");
4910           break;
4911 #endif
4912
4913 #if FFETARGET_okINTEGER4
4914         case FFEINFO_kindtypeINTEGER4:
4915           fprintf (out, "I" STRX (FFETARGET_kindINTEGER4) "/");
4916           break;
4917 #endif
4918
4919 #if FFETARGET_okINTEGER5
4920         case FFEINFO_kindtypeINTEGER5:
4921           fprintf (out, "I" STRX (FFETARGET_kindINTEGER5) "/");
4922           break;
4923 #endif
4924
4925 #if FFETARGET_okINTEGER6
4926         case FFEINFO_kindtypeINTEGER6:
4927           fprintf (out, "I" STRX (FFETARGET_kindINTEGER6) "/");
4928           break;
4929 #endif
4930
4931 #if FFETARGET_okINTEGER7
4932         case FFEINFO_kindtypeINTEGER7:
4933           fprintf (out, "I" STRX (FFETARGET_kindINTEGER7) "/");
4934           break;
4935 #endif
4936
4937 #if FFETARGET_okINTEGER8
4938         case FFEINFO_kindtypeINTEGER8:
4939           fprintf (out, "I" STRX (FFETARGET_kindINTEGER8) "/");
4940           break;
4941 #endif
4942
4943         default:
4944           assert ("bad INTEGER kindtype" == NULL);
4945           break;
4946         }
4947       break;
4948
4949     case FFEINFO_basictypeLOGICAL:
4950       switch (kt)
4951         {
4952 #if FFETARGET_okLOGICAL1
4953         case FFEINFO_kindtypeLOGICAL1:
4954           fprintf (out, "L" STRX (FFETARGET_kindLOGICAL1) "/");
4955           break;
4956 #endif
4957
4958 #if FFETARGET_okLOGICAL2
4959         case FFEINFO_kindtypeLOGICAL2:
4960           fprintf (out, "L" STRX (FFETARGET_kindLOGICAL2) "/");
4961           break;
4962 #endif
4963
4964 #if FFETARGET_okLOGICAL3
4965         case FFEINFO_kindtypeLOGICAL3:
4966           fprintf (out, "L" STRX (FFETARGET_kindLOGICAL3) "/");
4967           break;
4968 #endif
4969
4970 #if FFETARGET_okLOGICAL4
4971         case FFEINFO_kindtypeLOGICAL4:
4972           fprintf (out, "L" STRX (FFETARGET_kindLOGICAL4) "/");
4973           break;
4974 #endif
4975
4976 #if FFETARGET_okLOGICAL5
4977         case FFEINFO_kindtypeLOGICAL5:
4978           fprintf (out, "L" STRX (FFETARGET_kindLOGICAL5) "/");
4979           break;
4980 #endif
4981
4982 #if FFETARGET_okLOGICAL6
4983         case FFEINFO_kindtypeLOGICAL6:
4984           fprintf (out, "L" STRX (FFETARGET_kindLOGICAL6) "/");
4985           break;
4986 #endif
4987
4988 #if FFETARGET_okLOGICAL7
4989         case FFEINFO_kindtypeLOGICAL7:
4990           fprintf (out, "L" STRX (FFETARGET_kindLOGICAL7) "/");
4991           break;
4992 #endif
4993
4994 #if FFETARGET_okLOGICAL8
4995         case FFEINFO_kindtypeLOGICAL8:
4996           fprintf (out, "L" STRX (FFETARGET_kindLOGICAL8) "/");
4997           break;
4998 #endif
4999
5000         default:
5001           assert ("bad LOGICAL kindtype" == NULL);
5002           break;
5003         }
5004       break;
5005
5006     case FFEINFO_basictypeREAL:
5007       switch (kt)
5008         {
5009 #if FFETARGET_okREAL1
5010         case FFEINFO_kindtypeREAL1:
5011           fprintf (out, "R" STRX (FFETARGET_kindREAL1) "/");
5012           break;
5013 #endif
5014
5015 #if FFETARGET_okREAL2
5016         case FFEINFO_kindtypeREAL2:
5017           fprintf (out, "R" STRX (FFETARGET_kindREAL2) "/");
5018           break;
5019 #endif
5020
5021 #if FFETARGET_okREAL3
5022         case FFEINFO_kindtypeREAL3:
5023           fprintf (out, "R" STRX (FFETARGET_kindREAL3) "/");
5024           break;
5025 #endif
5026
5027 #if FFETARGET_okREAL4
5028         case FFEINFO_kindtypeREAL4:
5029           fprintf (out, "R" STRX (FFETARGET_kindREAL4) "/");
5030           break;
5031 #endif
5032
5033 #if FFETARGET_okREAL5
5034         case FFEINFO_kindtypeREAL5:
5035           fprintf (out, "R" STRX (FFETARGET_kindREAL5) "/");
5036           break;
5037 #endif
5038
5039 #if FFETARGET_okREAL6
5040         case FFEINFO_kindtypeREAL6:
5041           fprintf (out, "R" STRX (FFETARGET_kindREAL6) "/");
5042           break;
5043 #endif
5044
5045 #if FFETARGET_okREAL7
5046         case FFEINFO_kindtypeREAL7:
5047           fprintf (out, "R" STRX (FFETARGET_kindREAL7) "/");
5048           break;
5049 #endif
5050
5051 #if FFETARGET_okREAL8
5052         case FFEINFO_kindtypeREAL8:
5053           fprintf (out, "R" STRX (FFETARGET_kindREAL8) "/");
5054           break;
5055 #endif
5056
5057         default:
5058           assert ("bad REAL kindtype" == NULL);
5059           break;
5060         }
5061       break;
5062
5063     case FFEINFO_basictypeCOMPLEX:
5064       switch (kt)
5065         {
5066 #if FFETARGET_okCOMPLEX1
5067         case FFEINFO_kindtypeREAL1:
5068           fprintf (out, "C" STRX (FFETARGET_kindCOMPLEX1) "/");
5069           break;
5070 #endif
5071
5072 #if FFETARGET_okCOMPLEX2
5073         case FFEINFO_kindtypeREAL2:
5074           fprintf (out, "C" STRX (FFETARGET_kindCOMPLEX2) "/");
5075           break;
5076 #endif
5077
5078 #if FFETARGET_okCOMPLEX3
5079         case FFEINFO_kindtypeREAL3:
5080           fprintf (out, "C" STRX (FFETARGET_kindCOMPLEX3) "/");
5081           break;
5082 #endif
5083
5084 #if FFETARGET_okCOMPLEX4
5085         case FFEINFO_kindtypeREAL4:
5086           fprintf (out, "C" STRX (FFETARGET_kindCOMPLEX4) "/");
5087           break;
5088 #endif
5089
5090 #if FFETARGET_okCOMPLEX5
5091         case FFEINFO_kindtypeREAL5:
5092           fprintf (out, "C" STRX (FFETARGET_kindCOMPLEX5) "/");
5093           break;
5094 #endif
5095
5096 #if FFETARGET_okCOMPLEX6
5097         case FFEINFO_kindtypeREAL6:
5098           fprintf (out, "C" STRX (FFETARGET_kindCOMPLEX6) "/");
5099           break;
5100 #endif
5101
5102 #if FFETARGET_okCOMPLEX7
5103         case FFEINFO_kindtypeREAL7:
5104           fprintf (out, "C" STRX (FFETARGET_kindCOMPLEX7) "/");
5105           break;
5106 #endif
5107
5108 #if FFETARGET_okCOMPLEX8
5109         case FFEINFO_kindtypeREAL8:
5110           fprintf (out, "C" STRX (FFETARGET_kindCOMPLEX8) "/");
5111           break;
5112 #endif
5113
5114         default:
5115           assert ("bad COMPLEX kindtype" == NULL);
5116           break;
5117         }
5118       break;
5119
5120     case FFEINFO_basictypeCHARACTER:
5121       switch (kt)
5122         {
5123 #if FFETARGET_okCHARACTER1
5124         case FFEINFO_kindtypeCHARACTER1:
5125           fprintf (out, "A" STRX (FFETARGET_kindCHARACTER1) "/");
5126           break;
5127 #endif
5128
5129 #if FFETARGET_okCHARACTER2
5130         case FFEINFO_kindtypeCHARACTER2:
5131           fprintf (out, "A" STRX (FFETARGET_kindCHARACTER2) "/");
5132           break;
5133 #endif
5134
5135 #if FFETARGET_okCHARACTER3
5136         case FFEINFO_kindtypeCHARACTER3:
5137           fprintf (out, "A" STRX (FFETARGET_kindCHARACTER3) "/");
5138           break;
5139 #endif
5140
5141 #if FFETARGET_okCHARACTER4
5142         case FFEINFO_kindtypeCHARACTER4:
5143           fprintf (out, "A" STRX (FFETARGET_kindCHARACTER4) "/");
5144           break;
5145 #endif
5146
5147 #if FFETARGET_okCHARACTER5
5148         case FFEINFO_kindtypeCHARACTER5:
5149           fprintf (out, "A" STRX (FFETARGET_kindCHARACTER5) "/");
5150           break;
5151 #endif
5152
5153 #if FFETARGET_okCHARACTER6
5154         case FFEINFO_kindtypeCHARACTER6:
5155           fprintf (out, "A" STRX (FFETARGET_kindCHARACTER6) "/");
5156           break;
5157 #endif
5158
5159 #if FFETARGET_okCHARACTER7
5160         case FFEINFO_kindtypeCHARACTER7:
5161           fprintf (out, "A" STRX (FFETARGET_kindCHARACTER7) "/");
5162           break;
5163 #endif
5164
5165 #if FFETARGET_okCHARACTER8
5166         case FFEINFO_kindtypeCHARACTER8:
5167           fprintf (out, "A" STRX (FFETARGET_kindCHARACTER8) "/");
5168           break;
5169 #endif
5170
5171         default:
5172           assert ("bad CHARACTER kindtype" == NULL);
5173           break;
5174         }
5175       break;
5176
5177     default:
5178       assert ("bad basictype" == NULL);
5179       fprintf (out, "?/?");
5180       break;
5181     }
5182 }
5183 #endif
5184
5185 /* ffebld_init_0 -- Initialize the module
5186
5187    ffebld_init_0();  */
5188
5189 void
5190 ffebld_init_0 ()
5191 {
5192   assert (FFEBLD_op == ARRAY_SIZE (ffebld_op_string_));
5193   assert (FFEBLD_op == ARRAY_SIZE (ffebld_arity_op_));
5194 }
5195
5196 /* ffebld_init_1 -- Initialize the module for a file
5197
5198    ffebld_init_1();  */
5199
5200 void
5201 ffebld_init_1 ()
5202 {
5203 #if FFEBLD_whereconstCURRENT_ == FFEBLD_whereconstFILE_
5204   int i;
5205
5206 #if FFETARGET_okCHARACTER1
5207   ffebld_constant_character1_ = NULL;
5208 #endif
5209 #if FFETARGET_okCHARACTER2
5210   ffebld_constant_character2_ = NULL;
5211 #endif
5212 #if FFETARGET_okCHARACTER3
5213   ffebld_constant_character3_ = NULL;
5214 #endif
5215 #if FFETARGET_okCHARACTER4
5216   ffebld_constant_character4_ = NULL;
5217 #endif
5218 #if FFETARGET_okCHARACTER5
5219   ffebld_constant_character5_ = NULL;
5220 #endif
5221 #if FFETARGET_okCHARACTER6
5222   ffebld_constant_character6_ = NULL;
5223 #endif
5224 #if FFETARGET_okCHARACTER7
5225   ffebld_constant_character7_ = NULL;
5226 #endif
5227 #if FFETARGET_okCHARACTER8
5228   ffebld_constant_character8_ = NULL;
5229 #endif
5230 #if FFETARGET_okCOMPLEX1
5231   ffebld_constant_complex1_ = NULL;
5232 #endif
5233 #if FFETARGET_okCOMPLEX2
5234   ffebld_constant_complex2_ = NULL;
5235 #endif
5236 #if FFETARGET_okCOMPLEX3
5237   ffebld_constant_complex3_ = NULL;
5238 #endif
5239 #if FFETARGET_okCOMPLEX4
5240   ffebld_constant_complex4_ = NULL;
5241 #endif
5242 #if FFETARGET_okCOMPLEX5
5243   ffebld_constant_complex5_ = NULL;
5244 #endif
5245 #if FFETARGET_okCOMPLEX6
5246   ffebld_constant_complex6_ = NULL;
5247 #endif
5248 #if FFETARGET_okCOMPLEX7
5249   ffebld_constant_complex7_ = NULL;
5250 #endif
5251 #if FFETARGET_okCOMPLEX8
5252   ffebld_constant_complex8_ = NULL;
5253 #endif
5254 #if FFETARGET_okINTEGER1
5255   ffebld_constant_integer1_ = NULL;
5256 #endif
5257 #if FFETARGET_okINTEGER2
5258   ffebld_constant_integer2_ = NULL;
5259 #endif
5260 #if FFETARGET_okINTEGER3
5261   ffebld_constant_integer3_ = NULL;
5262 #endif
5263 #if FFETARGET_okINTEGER4
5264   ffebld_constant_integer4_ = NULL;
5265 #endif
5266 #if FFETARGET_okINTEGER5
5267   ffebld_constant_integer5_ = NULL;
5268 #endif
5269 #if FFETARGET_okINTEGER6
5270   ffebld_constant_integer6_ = NULL;
5271 #endif
5272 #if FFETARGET_okINTEGER7
5273   ffebld_constant_integer7_ = NULL;
5274 #endif
5275 #if FFETARGET_okINTEGER8
5276   ffebld_constant_integer8_ = NULL;
5277 #endif
5278 #if FFETARGET_okLOGICAL1
5279   ffebld_constant_logical1_ = NULL;
5280 #endif
5281 #if FFETARGET_okLOGICAL2
5282   ffebld_constant_logical2_ = NULL;
5283 #endif
5284 #if FFETARGET_okLOGICAL3
5285   ffebld_constant_logical3_ = NULL;
5286 #endif
5287 #if FFETARGET_okLOGICAL4
5288   ffebld_constant_logical4_ = NULL;
5289 #endif
5290 #if FFETARGET_okLOGICAL5
5291   ffebld_constant_logical5_ = NULL;
5292 #endif
5293 #if FFETARGET_okLOGICAL6
5294   ffebld_constant_logical6_ = NULL;
5295 #endif
5296 #if FFETARGET_okLOGICAL7
5297   ffebld_constant_logical7_ = NULL;
5298 #endif
5299 #if FFETARGET_okLOGICAL8
5300   ffebld_constant_logical8_ = NULL;
5301 #endif
5302 #if FFETARGET_okREAL1
5303   ffebld_constant_real1_ = NULL;
5304 #endif
5305 #if FFETARGET_okREAL2
5306   ffebld_constant_real2_ = NULL;
5307 #endif
5308 #if FFETARGET_okREAL3
5309   ffebld_constant_real3_ = NULL;
5310 #endif
5311 #if FFETARGET_okREAL4
5312   ffebld_constant_real4_ = NULL;
5313 #endif
5314 #if FFETARGET_okREAL5
5315   ffebld_constant_real5_ = NULL;
5316 #endif
5317 #if FFETARGET_okREAL6
5318   ffebld_constant_real6_ = NULL;
5319 #endif
5320 #if FFETARGET_okREAL7
5321   ffebld_constant_real7_ = NULL;
5322 #endif
5323 #if FFETARGET_okREAL8
5324   ffebld_constant_real8_ = NULL;
5325 #endif
5326   ffebld_constant_hollerith_ = NULL;
5327   for (i = FFEBLD_constTYPELESS_FIRST; i <= FFEBLD_constTYPELESS_LAST; ++i)
5328     ffebld_constant_typeless_[i - FFEBLD_constTYPELESS_FIRST] = NULL;
5329 #endif
5330 }
5331
5332 /* ffebld_init_2 -- Initialize the module
5333
5334    ffebld_init_2();  */
5335
5336 void
5337 ffebld_init_2 ()
5338 {
5339 #if FFEBLD_whereconstCURRENT_ == FFEBLD_whereconstPROGUNIT_
5340   int i;
5341 #endif
5342
5343   ffebld_pool_stack_.next = NULL;
5344   ffebld_pool_stack_.pool = ffe_pool_program_unit ();
5345 #if FFEBLD_whereconstCURRENT_ == FFEBLD_whereconstPROGUNIT_
5346 #if FFETARGET_okCHARACTER1
5347   ffebld_constant_character1_ = NULL;
5348 #endif
5349 #if FFETARGET_okCHARACTER2
5350   ffebld_constant_character2_ = NULL;
5351 #endif
5352 #if FFETARGET_okCHARACTER3
5353   ffebld_constant_character3_ = NULL;
5354 #endif
5355 #if FFETARGET_okCHARACTER4
5356   ffebld_constant_character4_ = NULL;
5357 #endif
5358 #if FFETARGET_okCHARACTER5
5359   ffebld_constant_character5_ = NULL;
5360 #endif
5361 #if FFETARGET_okCHARACTER6
5362   ffebld_constant_character6_ = NULL;
5363 #endif
5364 #if FFETARGET_okCHARACTER7
5365   ffebld_constant_character7_ = NULL;
5366 #endif
5367 #if FFETARGET_okCHARACTER8
5368   ffebld_constant_character8_ = NULL;
5369 #endif
5370 #if FFETARGET_okCOMPLEX1
5371   ffebld_constant_complex1_ = NULL;
5372 #endif
5373 #if FFETARGET_okCOMPLEX2
5374   ffebld_constant_complex2_ = NULL;
5375 #endif
5376 #if FFETARGET_okCOMPLEX3
5377   ffebld_constant_complex3_ = NULL;
5378 #endif
5379 #if FFETARGET_okCOMPLEX4
5380   ffebld_constant_complex4_ = NULL;
5381 #endif
5382 #if FFETARGET_okCOMPLEX5
5383   ffebld_constant_complex5_ = NULL;
5384 #endif
5385 #if FFETARGET_okCOMPLEX6
5386   ffebld_constant_complex6_ = NULL;
5387 #endif
5388 #if FFETARGET_okCOMPLEX7
5389   ffebld_constant_complex7_ = NULL;
5390 #endif
5391 #if FFETARGET_okCOMPLEX8
5392   ffebld_constant_complex8_ = NULL;
5393 #endif
5394 #if FFETARGET_okINTEGER1
5395   ffebld_constant_integer1_ = NULL;
5396 #endif
5397 #if FFETARGET_okINTEGER2
5398   ffebld_constant_integer2_ = NULL;
5399 #endif
5400 #if FFETARGET_okINTEGER3
5401   ffebld_constant_integer3_ = NULL;
5402 #endif
5403 #if FFETARGET_okINTEGER4
5404   ffebld_constant_integer4_ = NULL;
5405 #endif
5406 #if FFETARGET_okINTEGER5
5407   ffebld_constant_integer5_ = NULL;
5408 #endif
5409 #if FFETARGET_okINTEGER6
5410   ffebld_constant_integer6_ = NULL;
5411 #endif
5412 #if FFETARGET_okINTEGER7
5413   ffebld_constant_integer7_ = NULL;
5414 #endif
5415 #if FFETARGET_okINTEGER8
5416   ffebld_constant_integer8_ = NULL;
5417 #endif
5418 #if FFETARGET_okLOGICAL1
5419   ffebld_constant_logical1_ = NULL;
5420 #endif
5421 #if FFETARGET_okLOGICAL2
5422   ffebld_constant_logical2_ = NULL;
5423 #endif
5424 #if FFETARGET_okLOGICAL3
5425   ffebld_constant_logical3_ = NULL;
5426 #endif
5427 #if FFETARGET_okLOGICAL4
5428   ffebld_constant_logical4_ = NULL;
5429 #endif
5430 #if FFETARGET_okLOGICAL5
5431   ffebld_constant_logical5_ = NULL;
5432 #endif
5433 #if FFETARGET_okLOGICAL6
5434   ffebld_constant_logical6_ = NULL;
5435 #endif
5436 #if FFETARGET_okLOGICAL7
5437   ffebld_constant_logical7_ = NULL;
5438 #endif
5439 #if FFETARGET_okLOGICAL8
5440   ffebld_constant_logical8_ = NULL;
5441 #endif
5442 #if FFETARGET_okREAL1
5443   ffebld_constant_real1_ = NULL;
5444 #endif
5445 #if FFETARGET_okREAL2
5446   ffebld_constant_real2_ = NULL;
5447 #endif
5448 #if FFETARGET_okREAL3
5449   ffebld_constant_real3_ = NULL;
5450 #endif
5451 #if FFETARGET_okREAL4
5452   ffebld_constant_real4_ = NULL;
5453 #endif
5454 #if FFETARGET_okREAL5
5455   ffebld_constant_real5_ = NULL;
5456 #endif
5457 #if FFETARGET_okREAL6
5458   ffebld_constant_real6_ = NULL;
5459 #endif
5460 #if FFETARGET_okREAL7
5461   ffebld_constant_real7_ = NULL;
5462 #endif
5463 #if FFETARGET_okREAL8
5464   ffebld_constant_real8_ = NULL;
5465 #endif
5466   ffebld_constant_hollerith_ = NULL;
5467   for (i = FFEBLD_constTYPELESS_FIRST; i <= FFEBLD_constTYPELESS_LAST; ++i)
5468     ffebld_constant_typeless_[i - FFEBLD_constTYPELESS_FIRST] = NULL;
5469 #endif
5470 }
5471
5472 /* ffebld_list_length -- Return # of opITEMs in list
5473
5474    ffebld list;  // Must be NULL or opITEM
5475    ffebldListLength length;
5476    length = ffebld_list_length(list);
5477
5478    Returns 0 if list is NULL, 1 if it's ffebld_trail is NULL, and so on.  */
5479
5480 ffebldListLength
5481 ffebld_list_length (ffebld list)
5482 {
5483   ffebldListLength length;
5484
5485   for (length = 0; list != NULL; ++length, list = ffebld_trail (list))
5486     ;
5487
5488   return length;
5489 }
5490
5491 /* ffebld_new_accter -- Create an ffebld object that is an array
5492
5493    ffebld x;
5494    ffebldConstantArray a;
5495    ffebit b;
5496    x = ffebld_new_accter(a,b);  */
5497
5498 ffebld
5499 ffebld_new_accter (ffebldConstantArray a, ffebit b)
5500 {
5501   ffebld x;
5502
5503   x = ffebld_new ();
5504 #if FFEBLD_BLANK_
5505   *x = ffebld_blank_;
5506 #endif
5507   x->op = FFEBLD_opACCTER;
5508   x->u.accter.array = a;
5509   x->u.accter.bits = b;
5510   x->u.accter.pad = 0;
5511   return x;
5512 }
5513
5514 /* ffebld_new_arrter -- Create an ffebld object that is an array
5515
5516    ffebld x;
5517    ffebldConstantArray a;
5518    ffetargetOffset size;
5519    x = ffebld_new_arrter(a,size);  */
5520
5521 ffebld
5522 ffebld_new_arrter (ffebldConstantArray a, ffetargetOffset size)
5523 {
5524   ffebld x;
5525
5526   x = ffebld_new ();
5527 #if FFEBLD_BLANK_
5528   *x = ffebld_blank_;
5529 #endif
5530   x->op = FFEBLD_opARRTER;
5531   x->u.arrter.array = a;
5532   x->u.arrter.size = size;
5533   x->u.arrter.pad = 0;
5534   return x;
5535 }
5536
5537 /* ffebld_new_conter_with_orig -- Create an ffebld object that is a constant
5538
5539    ffebld x;
5540    ffebldConstant c;
5541    x = ffebld_new_conter_with_orig(c,NULL);  */
5542
5543 ffebld
5544 ffebld_new_conter_with_orig (ffebldConstant c, ffebld o)
5545 {
5546   ffebld x;
5547
5548   x = ffebld_new ();
5549 #if FFEBLD_BLANK_
5550   *x = ffebld_blank_;
5551 #endif
5552   x->op = FFEBLD_opCONTER;
5553   x->u.conter.expr = c;
5554   x->u.conter.orig = o;
5555   x->u.conter.pad = 0;
5556   return x;
5557 }
5558
5559 /* ffebld_new_item -- Create an ffebld item object
5560
5561    ffebld x,y,z;
5562    x = ffebld_new_item(y,z);  */
5563
5564 ffebld
5565 ffebld_new_item (ffebld head, ffebld trail)
5566 {
5567   ffebld x;
5568
5569   x = ffebld_new ();
5570 #if FFEBLD_BLANK_
5571   *x = ffebld_blank_;
5572 #endif
5573   x->op = FFEBLD_opITEM;
5574   x->u.item.head = head;
5575   x->u.item.trail = trail;
5576 #ifdef FFECOM_itemHOOK
5577   x->u.item.hook = FFECOM_itemNULL;
5578 #endif
5579   return x;
5580 }
5581
5582 /* ffebld_new_labter -- Create an ffebld object that is a label
5583
5584    ffebld x;
5585    ffelab l;
5586    x = ffebld_new_labter(c);  */
5587
5588 ffebld
5589 ffebld_new_labter (ffelab l)
5590 {
5591   ffebld x;
5592
5593   x = ffebld_new ();
5594 #if FFEBLD_BLANK_
5595   *x = ffebld_blank_;
5596 #endif
5597   x->op = FFEBLD_opLABTER;
5598   x->u.labter = l;
5599   return x;
5600 }
5601
5602 /* ffebld_new_labtok -- Create object that is a label's NUMBER token
5603
5604    ffebld x;
5605    ffelexToken t;
5606    x = ffebld_new_labter(c);
5607
5608    Like the other ffebld_new_ functions, the
5609    supplied argument is stored exactly as is: ffelex_token_use is NOT
5610    called, so the token is "consumed", if one is indeed supplied (it may
5611    be NULL).  */
5612
5613 ffebld
5614 ffebld_new_labtok (ffelexToken t)
5615 {
5616   ffebld x;
5617
5618   x = ffebld_new ();
5619 #if FFEBLD_BLANK_
5620   *x = ffebld_blank_;
5621 #endif
5622   x->op = FFEBLD_opLABTOK;
5623   x->u.labtok = t;
5624   return x;
5625 }
5626
5627 /* ffebld_new_none -- Create an ffebld object with no arguments
5628
5629    ffebld x;
5630    x = ffebld_new_none(FFEBLD_opWHATEVER);  */
5631
5632 ffebld
5633 ffebld_new_none (ffebldOp o)
5634 {
5635   ffebld x;
5636
5637   x = ffebld_new ();
5638 #if FFEBLD_BLANK_
5639   *x = ffebld_blank_;
5640 #endif
5641   x->op = o;
5642   return x;
5643 }
5644
5645 /* ffebld_new_one -- Create an ffebld object with one argument
5646
5647    ffebld x,y;
5648    x = ffebld_new_one(FFEBLD_opWHATEVER,y);  */
5649
5650 ffebld
5651 ffebld_new_one (ffebldOp o, ffebld left)
5652 {
5653   ffebld x;
5654
5655   x = ffebld_new ();
5656 #if FFEBLD_BLANK_
5657   *x = ffebld_blank_;
5658 #endif
5659   x->op = o;
5660   x->u.nonter.left = left;
5661 #ifdef FFECOM_nonterHOOK
5662   x->u.nonter.hook = FFECOM_nonterNULL;
5663 #endif
5664   return x;
5665 }
5666
5667 /* ffebld_new_symter -- Create an ffebld object that is a symbol
5668
5669    ffebld x;
5670    ffesymbol s;
5671    ffeintrinGen gen;    // Generic intrinsic id, if any
5672    ffeintrinSpec spec;  // Specific intrinsic id, if any
5673    ffeintrinImp imp;    // Implementation intrinsic id, if any
5674    x = ffebld_new_symter (s, gen, spec, imp);  */
5675
5676 ffebld
5677 ffebld_new_symter (ffesymbol s, ffeintrinGen gen, ffeintrinSpec spec,
5678                    ffeintrinImp imp)
5679 {
5680   ffebld x;
5681
5682   x = ffebld_new ();
5683 #if FFEBLD_BLANK_
5684   *x = ffebld_blank_;
5685 #endif
5686   x->op = FFEBLD_opSYMTER;
5687   x->u.symter.symbol = s;
5688   x->u.symter.generic = gen;
5689   x->u.symter.specific = spec;
5690   x->u.symter.implementation = imp;
5691   x->u.symter.do_iter = FALSE;
5692   return x;
5693 }
5694
5695 /* ffebld_new_two -- Create an ffebld object with two arguments
5696
5697    ffebld x,y,z;
5698    x = ffebld_new_two(FFEBLD_opWHATEVER,y,z);  */
5699
5700 ffebld
5701 ffebld_new_two (ffebldOp o, ffebld left, ffebld right)
5702 {
5703   ffebld x;
5704
5705   x = ffebld_new ();
5706 #if FFEBLD_BLANK_
5707   *x = ffebld_blank_;
5708 #endif
5709   x->op = o;
5710   x->u.nonter.left = left;
5711   x->u.nonter.right = right;
5712 #ifdef FFECOM_nonterHOOK
5713   x->u.nonter.hook = FFECOM_nonterNULL;
5714 #endif
5715   return x;
5716 }
5717
5718 /* ffebld_pool_pop -- Pop ffebld's pool stack
5719
5720    ffebld_pool_pop();  */
5721
5722 void
5723 ffebld_pool_pop ()
5724 {
5725   ffebldPoolstack_ ps;
5726
5727   assert (ffebld_pool_stack_.next != NULL);
5728   ps = ffebld_pool_stack_.next;
5729   ffebld_pool_stack_.next = ps->next;
5730   ffebld_pool_stack_.pool = ps->pool;
5731   malloc_kill_ks (malloc_pool_image (), ps, sizeof (*ps));
5732 }
5733
5734 /* ffebld_pool_push -- Push ffebld's pool stack
5735
5736    ffebld_pool_push();  */
5737
5738 void
5739 ffebld_pool_push (mallocPool pool)
5740 {
5741   ffebldPoolstack_ ps;
5742
5743   ps = malloc_new_ks (malloc_pool_image (), "Pool stack", sizeof (*ps));
5744   ps->next = ffebld_pool_stack_.next;
5745   ps->pool = ffebld_pool_stack_.pool;
5746   ffebld_pool_stack_.next = ps;
5747   ffebld_pool_stack_.pool = pool;
5748 }
5749
5750 /* ffebld_op_string -- Return short string describing op
5751
5752    ffebldOp o;
5753    ffebld_op_string(o);
5754
5755    Returns a short string (uppercase) containing the name of the op.  */
5756
5757 const char *
5758 ffebld_op_string (ffebldOp o)
5759 {
5760   if (o >= ARRAY_SIZE (ffebld_op_string_))
5761     return "?\?\?";
5762   return ffebld_op_string_[o];
5763 }
5764
5765 /* ffebld_size_max -- Return maximum possible size of CHARACTER-type expr
5766
5767    ffetargetCharacterSize sz;
5768    ffebld b;
5769    sz = ffebld_size_max (b);
5770
5771    Like ffebld_size_known, but if that would return NONE and the expression
5772    is opSUBSTR, opCONVERT, opPAREN, or opCONCATENATE, returns ffebld_size_max
5773    of the subexpression(s).  */
5774
5775 ffetargetCharacterSize
5776 ffebld_size_max (ffebld b)
5777 {
5778   ffetargetCharacterSize sz;
5779
5780 recurse:                        /* :::::::::::::::::::: */
5781
5782   sz = ffebld_size_known (b);
5783
5784   if (sz != FFETARGET_charactersizeNONE)
5785     return sz;
5786
5787   switch (ffebld_op (b))
5788     {
5789     case FFEBLD_opSUBSTR:
5790     case FFEBLD_opCONVERT:
5791     case FFEBLD_opPAREN:
5792       b = ffebld_left (b);
5793       goto recurse;             /* :::::::::::::::::::: */
5794
5795     case FFEBLD_opCONCATENATE:
5796       sz = ffebld_size_max (ffebld_left (b))
5797         + ffebld_size_max (ffebld_right (b));
5798       return sz;
5799
5800     default:
5801       return sz;
5802     }
5803 }