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 #include "real.h"
  47
  48 /* Externals defined here.  */
  49
  50 const ffebldArity ffebld_arity_op_[(int) FFEBLD_op]
  51 =
  52 {
  53 #define FFEBLD_OP(KWD,NAME,ARITY) ARITY,
  54 #include "bld-op.def"
  55 #undef FFEBLD_OP
  56 };
  57 struct _ffebld_pool_stack_ ffebld_pool_stack_;
  58
  59 /* Simple definitions and enumerations. */
  60
  61
  62 /* Internal typedefs. */
  63
  64
  65 /* Private include files. */
  66
  67
  68 /* Internal structure definitions. */
  69
  70
  71 /* Static objects accessed by functions in this module.  */
  72
  73 #if FFEBLD_BLANK_
  74 static struct _ffebld_ ffebld_blank_
  75 =
  76 {
  77   0,
  78   {FFEINFO_basictypeNONE, FFEINFO_kindtypeNONE, 0, FFEINFO_kindNONE,
  79    FFEINFO_whereNONE, FFETARGET_charactersizeNONE},
  80   {NULL, NULL}
  81 };
  82 #endif
  83 #if FFETARGET_okCHARACTER1
  84 static ffebldConstant ffebld_constant_character1_;
  85 #endif
  86 #if FFETARGET_okCHARACTER2
  87 static ffebldConstant ffebld_constant_character2_;
  88 #endif
  89 #if FFETARGET_okCHARACTER3
  90 static ffebldConstant ffebld_constant_character3_;
  91 #endif
  92 #if FFETARGET_okCHARACTER4
  93 static ffebldConstant ffebld_constant_character4_;
  94 #endif
  95 #if FFETARGET_okCHARACTER5
  96 static ffebldConstant ffebld_constant_character5_;
  97 #endif
  98 #if FFETARGET_okCHARACTER6
  99 static ffebldConstant ffebld_constant_character6_;
 100 #endif
 101 #if FFETARGET_okCHARACTER7
 102 static ffebldConstant ffebld_constant_character7_;
 103 #endif
 104 #if FFETARGET_okCHARACTER8
 105 static ffebldConstant ffebld_constant_character8_;
 106 #endif
 107 #if FFETARGET_okCOMPLEX1
 108 static ffebldConstant ffebld_constant_complex1_;
 109 #endif
 110 #if FFETARGET_okCOMPLEX2
 111 static ffebldConstant ffebld_constant_complex2_;
 112 #endif
 113 #if FFETARGET_okCOMPLEX3
 114 static ffebldConstant ffebld_constant_complex3_;
 115 #endif
 116 #if FFETARGET_okCOMPLEX4
 117 static ffebldConstant ffebld_constant_complex4_;
 118 #endif
 119 #if FFETARGET_okCOMPLEX5
 120 static ffebldConstant ffebld_constant_complex5_;
 121 #endif
 122 #if FFETARGET_okCOMPLEX6
 123 static ffebldConstant ffebld_constant_complex6_;
 124 #endif
 125 #if FFETARGET_okCOMPLEX7
 126 static ffebldConstant ffebld_constant_complex7_;
 127 #endif
 128 #if FFETARGET_okCOMPLEX8
 129 static ffebldConstant ffebld_constant_complex8_;
 130 #endif
 131 #if FFETARGET_okINTEGER1
 132 static ffebldConstant ffebld_constant_integer1_;
 133 #endif
 134 #if FFETARGET_okINTEGER2
 135 static ffebldConstant ffebld_constant_integer2_;
 136 #endif
 137 #if FFETARGET_okINTEGER3
 138 static ffebldConstant ffebld_constant_integer3_;
 139 #endif
 140 #if FFETARGET_okINTEGER4
 141 static ffebldConstant ffebld_constant_integer4_;
 142 #endif
 143 #if FFETARGET_okINTEGER5
 144 static ffebldConstant ffebld_constant_integer5_;
 145 #endif
 146 #if FFETARGET_okINTEGER6
 147 static ffebldConstant ffebld_constant_integer6_;
 148 #endif
 149 #if FFETARGET_okINTEGER7
 150 static ffebldConstant ffebld_constant_integer7_;
 151 #endif
 152 #if FFETARGET_okINTEGER8
 153 static ffebldConstant ffebld_constant_integer8_;
 154 #endif
 155 #if FFETARGET_okLOGICAL1
 156 static ffebldConstant ffebld_constant_logical1_;
 157 #endif
 158 #if FFETARGET_okLOGICAL2
 159 static ffebldConstant ffebld_constant_logical2_;
 160 #endif
 161 #if FFETARGET_okLOGICAL3
 162 static ffebldConstant ffebld_constant_logical3_;
 163 #endif
 164 #if FFETARGET_okLOGICAL4
 165 static ffebldConstant ffebld_constant_logical4_;
 166 #endif
 167 #if FFETARGET_okLOGICAL5
 168 static ffebldConstant ffebld_constant_logical5_;
 169 #endif
 170 #if FFETARGET_okLOGICAL6
 171 static ffebldConstant ffebld_constant_logical6_;
 172 #endif
 173 #if FFETARGET_okLOGICAL7
 174 static ffebldConstant ffebld_constant_logical7_;
 175 #endif
 176 #if FFETARGET_okLOGICAL8
 177 static ffebldConstant ffebld_constant_logical8_;
 178 #endif
 179 #if FFETARGET_okREAL1
 180 static ffebldConstant ffebld_constant_real1_;
 181 #endif
 182 #if FFETARGET_okREAL2
 183 static ffebldConstant ffebld_constant_real2_;
 184 #endif
 185 #if FFETARGET_okREAL3
 186 static ffebldConstant ffebld_constant_real3_;
 187 #endif
 188 #if FFETARGET_okREAL4
 189 static ffebldConstant ffebld_constant_real4_;
 190 #endif
 191 #if FFETARGET_okREAL5
 192 static ffebldConstant ffebld_constant_real5_;
 193 #endif
 194 #if FFETARGET_okREAL6
 195 static ffebldConstant ffebld_constant_real6_;
 196 #endif
 197 #if FFETARGET_okREAL7
 198 static ffebldConstant ffebld_constant_real7_;
 199 #endif
 200 #if FFETARGET_okREAL8
 201 static ffebldConstant ffebld_constant_real8_;
 202 #endif
 203 static ffebldConstant ffebld_constant_hollerith_;
 204 static ffebldConstant ffebld_constant_typeless_[FFEBLD_constTYPELESS_LAST
 205                                           - FFEBLD_constTYPELESS_FIRST + 1];
 206
 207 static const char *const ffebld_op_string_[]
 208 =
 209 {
 210 #define FFEBLD_OP(KWD,NAME,ARITY) NAME,
 211 #include "bld-op.def"
 212 #undef FFEBLD_OP
 213 };
 214
 215 /* Static functions (internal). */
 216
 217
 218 /* Internal macros. */
 219
 220 #define integerdefault_ CATX(integer,FFETARGET_ktINTEGERDEFAULT)
 221 #define logicaldefault_ CATX(logical,FFETARGET_ktLOGICALDEFAULT)
 222 #define realdefault_ CATX(real,FFETARGET_ktREALDEFAULT)
 223 #define realdouble_ CATX(real,FFETARGET_ktREALDOUBLE)
 224 #define realquad_ CATX(real,FFETARGET_ktREALQUAD)
 225 \f
 226 /* ffebld_constant_cmp -- Compare two constants a la strcmp
 227
 228    ffebldConstant c1, c2;
 229    if (ffebld_constant_cmp(c1,c2) == 0)
 230        // they're equal, else they're not.
 231
 232    Returns -1 if c1 < c2, 0 if c1 == c2, +1 if c1 == c2.  */
 233
 234 int
 235 ffebld_constant_cmp (ffebldConstant c1, ffebldConstant c2)
 236 {
 237   if (c1 == c2)
 238     return 0;
 239
 240   assert (ffebld_constant_type (c1) == ffebld_constant_type (c2));
 241
 242   switch (ffebld_constant_type (c1))
 243     {
 244 #if FFETARGET_okINTEGER1
 245     case FFEBLD_constINTEGER1:
 246       return ffetarget_cmp_integer1 (ffebld_constant_integer1 (c1),
 247                                      ffebld_constant_integer1 (c2));
 248 #endif
 249
 250 #if FFETARGET_okINTEGER2
 251     case FFEBLD_constINTEGER2:
 252       return ffetarget_cmp_integer2 (ffebld_constant_integer2 (c1),
 253                                      ffebld_constant_integer2 (c2));
 254 #endif
 255
 256 #if FFETARGET_okINTEGER3
 257     case FFEBLD_constINTEGER3:
 258       return ffetarget_cmp_integer3 (ffebld_constant_integer3 (c1),
 259                                      ffebld_constant_integer3 (c2));
 260 #endif
 261
 262 #if FFETARGET_okINTEGER4
 263     case FFEBLD_constINTEGER4:
 264       return ffetarget_cmp_integer4 (ffebld_constant_integer4 (c1),
 265                                      ffebld_constant_integer4 (c2));
 266 #endif
 267
 268 #if FFETARGET_okINTEGER5
 269     case FFEBLD_constINTEGER5:
 270       return ffetarget_cmp_integer5 (ffebld_constant_integer5 (c1),
 271                                      ffebld_constant_integer5 (c2));
 272 #endif
 273
 274 #if FFETARGET_okINTEGER6
 275     case FFEBLD_constINTEGER6:
 276       return ffetarget_cmp_integer6 (ffebld_constant_integer6 (c1),
 277                                      ffebld_constant_integer6 (c2));
 278 #endif
 279
 280 #if FFETARGET_okINTEGER7
 281     case FFEBLD_constINTEGER7:
 282       return ffetarget_cmp_integer7 (ffebld_constant_integer7 (c1),
 283                                      ffebld_constant_integer7 (c2));
 284 #endif
 285
 286 #if FFETARGET_okINTEGER8
 287     case FFEBLD_constINTEGER8:
 288       return ffetarget_cmp_integer8 (ffebld_constant_integer8 (c1),
 289                                      ffebld_constant_integer8 (c2));
 290 #endif
 291
 292 #if FFETARGET_okLOGICAL1
 293     case FFEBLD_constLOGICAL1:
 294       return ffetarget_cmp_logical1 (ffebld_constant_logical1 (c1),
 295                                      ffebld_constant_logical1 (c2));
 296 #endif
 297
 298 #if FFETARGET_okLOGICAL2
 299     case FFEBLD_constLOGICAL2:
 300       return ffetarget_cmp_logical2 (ffebld_constant_logical2 (c1),
 301                                      ffebld_constant_logical2 (c2));
 302 #endif
 303
 304 #if FFETARGET_okLOGICAL3
 305     case FFEBLD_constLOGICAL3:
 306       return ffetarget_cmp_logical3 (ffebld_constant_logical3 (c1),
 307                                      ffebld_constant_logical3 (c2));
 308 #endif
 309
 310 #if FFETARGET_okLOGICAL4
 311     case FFEBLD_constLOGICAL4:
 312       return ffetarget_cmp_logical4 (ffebld_constant_logical4 (c1),
 313                                      ffebld_constant_logical4 (c2));
 314 #endif
 315
 316 #if FFETARGET_okLOGICAL5
 317     case FFEBLD_constLOGICAL5:
 318       return ffetarget_cmp_logical5 (ffebld_constant_logical5 (c1),
 319                                      ffebld_constant_logical5 (c2));
 320 #endif
 321
 322 #if FFETARGET_okLOGICAL6
 323     case FFEBLD_constLOGICAL6:
 324       return ffetarget_cmp_logical6 (ffebld_constant_logical6 (c1),
 325                                      ffebld_constant_logical6 (c2));
 326 #endif
 327
 328 #if FFETARGET_okLOGICAL7
 329     case FFEBLD_constLOGICAL7:
 330       return ffetarget_cmp_logical7 (ffebld_constant_logical7 (c1),
 331                                      ffebld_constant_logical7 (c2));
 332 #endif
 333
 334 #if FFETARGET_okLOGICAL8
 335     case FFEBLD_constLOGICAL8:
 336       return ffetarget_cmp_logical8 (ffebld_constant_logical8 (c1),
 337                                      ffebld_constant_logical8 (c2));
 338 #endif
 339
 340 #if FFETARGET_okREAL1
 341     case FFEBLD_constREAL1:
 342       return ffetarget_cmp_real1 (ffebld_constant_real1 (c1),
 343                                   ffebld_constant_real1 (c2));
 344 #endif
 345
 346 #if FFETARGET_okREAL2
 347     case FFEBLD_constREAL2:
 348       return ffetarget_cmp_real2 (ffebld_constant_real2 (c1),
 349                                   ffebld_constant_real2 (c2));
 350 #endif
 351
 352 #if FFETARGET_okREAL3
 353     case FFEBLD_constREAL3:
 354       return ffetarget_cmp_real3 (ffebld_constant_real3 (c1),
 355                                   ffebld_constant_real3 (c2));
 356 #endif
 357
 358 #if FFETARGET_okREAL4
 359     case FFEBLD_constREAL4:
 360       return ffetarget_cmp_real4 (ffebld_constant_real4 (c1),
 361                                   ffebld_constant_real4 (c2));
 362 #endif
 363
 364 #if FFETARGET_okREAL5
 365     case FFEBLD_constREAL5:
 366       return ffetarget_cmp_real5 (ffebld_constant_real5 (c1),
 367                                   ffebld_constant_real5 (c2));
 368 #endif
 369
 370 #if FFETARGET_okREAL6
 371     case FFEBLD_constREAL6:
 372       return ffetarget_cmp_real6 (ffebld_constant_real6 (c1),
 373                                   ffebld_constant_real6 (c2));
 374 #endif
 375
 376 #if FFETARGET_okREAL7
 377     case FFEBLD_constREAL7:
 378       return ffetarget_cmp_real7 (ffebld_constant_real7 (c1),
 379                                   ffebld_constant_real7 (c2));
 380 #endif
 381
 382 #if FFETARGET_okREAL8
 383     case FFEBLD_constREAL8:
 384       return ffetarget_cmp_real8 (ffebld_constant_real8 (c1),
 385                                   ffebld_constant_real8 (c2));
 386 #endif
 387
 388 #if FFETARGET_okCHARACTER1
 389     case FFEBLD_constCHARACTER1:
 390       return ffetarget_cmp_character1 (ffebld_constant_character1 (c1),
 391                                        ffebld_constant_character1 (c2));
 392 #endif
 393
 394 #if FFETARGET_okCHARACTER2
 395     case FFEBLD_constCHARACTER2:
 396       return ffetarget_cmp_character2 (ffebld_constant_character2 (c1),
 397                                        ffebld_constant_character2 (c2));
 398 #endif
 399
 400 #if FFETARGET_okCHARACTER3
 401     case FFEBLD_constCHARACTER3:
 402       return ffetarget_cmp_character3 (ffebld_constant_character3 (c1),
 403                                        ffebld_constant_character3 (c2));
 404 #endif
 405
 406 #if FFETARGET_okCHARACTER4
 407     case FFEBLD_constCHARACTER4:
 408       return ffetarget_cmp_character4 (ffebld_constant_character4 (c1),
 409                                        ffebld_constant_character4 (c2));
 410 #endif
 411
 412 #if FFETARGET_okCHARACTER5
 413     case FFEBLD_constCHARACTER5:
 414       return ffetarget_cmp_character5 (ffebld_constant_character5 (c1),
 415                                        ffebld_constant_character5 (c2));
 416 #endif
 417
 418 #if FFETARGET_okCHARACTER6
 419     case FFEBLD_constCHARACTER6:
 420       return ffetarget_cmp_character6 (ffebld_constant_character6 (c1),
 421                                        ffebld_constant_character6 (c2));
 422 #endif
 423
 424 #if FFETARGET_okCHARACTER7
 425     case FFEBLD_constCHARACTER7:
 426       return ffetarget_cmp_character7 (ffebld_constant_character7 (c1),
 427                                        ffebld_constant_character7 (c2));
 428 #endif
 429
 430 #if FFETARGET_okCHARACTER8
 431     case FFEBLD_constCHARACTER8:
 432       return ffetarget_cmp_character8 (ffebld_constant_character8 (c1),
 433                                        ffebld_constant_character8 (c2));
 434 #endif
 435
 436     default:
 437       assert ("bad constant type" == NULL);
 438       return 0;
 439     }
 440 }
 441
 442 /* ffebld_constant_is_magical -- Determine if integer is "magical"
 443
 444    ffebldConstant c;
 445    if (ffebld_constant_is_magical(c))
 446        // it is 2**(n-1), where n is # bits in ffetargetIntegerDefault type
 447        // (this test is important for 2's-complement machines only).  */
 448
 449 bool
 450 ffebld_constant_is_magical (ffebldConstant c)
 451 {
 452   switch (ffebld_constant_type (c))
 453     {
 454     case FFEBLD_constINTEGERDEFAULT:
 455       return ffetarget_integerdefault_is_magical (ffebld_constant_integer1 (c));
 456
 457     default:
 458       return FALSE;
 459     }
 460 }
 461
 462 /* Determine if constant is zero.  Used to ensure step count
 463    for DO loops isn't zero, also to determine if values will
 464    be binary zeros, so not entirely portable at this point.  */
 465
 466 bool
 467 ffebld_constant_is_zero (ffebldConstant c)
 468 {
 469   switch (ffebld_constant_type (c))
 470     {
 471 #if FFETARGET_okINTEGER1
 472     case FFEBLD_constINTEGER1:
 473       return ffebld_constant_integer1 (c) == 0;
 474 #endif
 475
 476 #if FFETARGET_okINTEGER2
 477     case FFEBLD_constINTEGER2:
 478       return ffebld_constant_integer2 (c) == 0;
 479 #endif
 480
 481 #if FFETARGET_okINTEGER3
 482     case FFEBLD_constINTEGER3:
 483       return ffebld_constant_integer3 (c) == 0;
 484 #endif
 485
 486 #if FFETARGET_okINTEGER4
 487     case FFEBLD_constINTEGER4:
 488       return ffebld_constant_integer4 (c) == 0;
 489 #endif
 490
 491 #if FFETARGET_okINTEGER5
 492     case FFEBLD_constINTEGER5:
 493       return ffebld_constant_integer5 (c) == 0;
 494 #endif
 495
 496 #if FFETARGET_okINTEGER6
 497     case FFEBLD_constINTEGER6:
 498       return ffebld_constant_integer6 (c) == 0;
 499 #endif
 500
 501 #if FFETARGET_okINTEGER7
 502     case FFEBLD_constINTEGER7:
 503       return ffebld_constant_integer7 (c) == 0;
 504 #endif
 505
 506 #if FFETARGET_okINTEGER8
 507     case FFEBLD_constINTEGER8:
 508       return ffebld_constant_integer8 (c) == 0;
 509 #endif
 510
 511 #if FFETARGET_okLOGICAL1
 512     case FFEBLD_constLOGICAL1:
 513       return ffebld_constant_logical1 (c) == 0;
 514 #endif
 515
 516 #if FFETARGET_okLOGICAL2
 517     case FFEBLD_constLOGICAL2:
 518       return ffebld_constant_logical2 (c) == 0;
 519 #endif
 520
 521 #if FFETARGET_okLOGICAL3
 522     case FFEBLD_constLOGICAL3:
 523       return ffebld_constant_logical3 (c) == 0;
 524 #endif
 525
 526 #if FFETARGET_okLOGICAL4
 527     case FFEBLD_constLOGICAL4:
 528       return ffebld_constant_logical4 (c) == 0;
 529 #endif
 530
 531 #if FFETARGET_okLOGICAL5
 532     case FFEBLD_constLOGICAL5:
 533       return ffebld_constant_logical5 (c) == 0;
 534 #endif
 535
 536 #if FFETARGET_okLOGICAL6
 537     case FFEBLD_constLOGICAL6:
 538       return ffebld_constant_logical6 (c) == 0;
 539 #endif
 540
 541 #if FFETARGET_okLOGICAL7
 542     case FFEBLD_constLOGICAL7:
 543       return ffebld_constant_logical7 (c) == 0;
 544 #endif
 545
 546 #if FFETARGET_okLOGICAL8
 547     case FFEBLD_constLOGICAL8:
 548       return ffebld_constant_logical8 (c) == 0;
 549 #endif
 550
 551 #if FFETARGET_okREAL1
 552     case FFEBLD_constREAL1:
 553       return ffetarget_iszero_real1 (ffebld_constant_real1 (c));
 554 #endif
 555
 556 #if FFETARGET_okREAL2
 557     case FFEBLD_constREAL2:
 558       return ffetarget_iszero_real2 (ffebld_constant_real2 (c));
 559 #endif
 560
 561 #if FFETARGET_okREAL3
 562     case FFEBLD_constREAL3:
 563       return ffetarget_iszero_real3 (ffebld_constant_real3 (c));
 564 #endif
 565
 566 #if FFETARGET_okREAL4
 567     case FFEBLD_constREAL4:
 568       return ffetarget_iszero_real4 (ffebld_constant_real4 (c));
 569 #endif
 570
 571 #if FFETARGET_okREAL5
 572     case FFEBLD_constREAL5:
 573       return ffetarget_iszero_real5 (ffebld_constant_real5 (c));
 574 #endif
 575
 576 #if FFETARGET_okREAL6
 577     case FFEBLD_constREAL6:
 578       return ffetarget_iszero_real6 (ffebld_constant_real6 (c));
 579 #endif
 580
 581 #if FFETARGET_okREAL7
 582     case FFEBLD_constREAL7:
 583       return ffetarget_iszero_real7 (ffebld_constant_real7 (c));
 584 #endif
 585
 586 #if FFETARGET_okREAL8
 587     case FFEBLD_constREAL8:
 588       return ffetarget_iszero_real8 (ffebld_constant_real8 (c));
 589 #endif
 590
 591 #if FFETARGET_okCOMPLEX1
 592     case FFEBLD_constCOMPLEX1:
 593       return ffetarget_iszero_real1 (ffebld_constant_complex1 (c).real)
 594      && ffetarget_iszero_real1 (ffebld_constant_complex1 (c).imaginary);
 595 #endif
 596
 597 #if FFETARGET_okCOMPLEX2
 598     case FFEBLD_constCOMPLEX2:
 599       return ffetarget_iszero_real2 (ffebld_constant_complex2 (c).real)
 600      && ffetarget_iszero_real2 (ffebld_constant_complex2 (c).imaginary);
 601 #endif
 602
 603 #if FFETARGET_okCOMPLEX3
 604     case FFEBLD_constCOMPLEX3:
 605       return ffetarget_iszero_real3 (ffebld_constant_complex3 (c).real)
 606      && ffetarget_iszero_real3 (ffebld_constant_complex3 (c).imaginary);
 607 #endif
 608
 609 #if FFETARGET_okCOMPLEX4
 610     case FFEBLD_constCOMPLEX4:
 611       return ffetarget_iszero_real4 (ffebld_constant_complex4 (c).real)
 612      && ffetarget_iszero_real4 (ffebld_constant_complex4 (c).imaginary);
 613 #endif
 614
 615 #if FFETARGET_okCOMPLEX5
 616     case FFEBLD_constCOMPLEX5:
 617       return ffetarget_iszero_real5 (ffebld_constant_complex5 (c).real)
 618      && ffetarget_iszero_real5 (ffebld_constant_complex5 (c).imaginary);
 619 #endif
 620
 621 #if FFETARGET_okCOMPLEX6
 622     case FFEBLD_constCOMPLEX6:
 623       return ffetarget_iszero_real6 (ffebld_constant_complex6 (c).real)
 624      && ffetarget_iszero_real6 (ffebld_constant_complex6 (c).imaginary);
 625 #endif
 626
 627 #if FFETARGET_okCOMPLEX7
 628     case FFEBLD_constCOMPLEX7:
 629       return ffetarget_iszero_real7 (ffebld_constant_complex7 (c).real)
 630      && ffetarget_iszero_real7 (ffebld_constant_complex7 (c).imaginary);
 631 #endif
 632
 633 #if FFETARGET_okCOMPLEX8
 634     case FFEBLD_constCOMPLEX8:
 635       return ffetarget_iszero_real8 (ffebld_constant_complex8 (c).real)
 636      && ffetarget_iszero_real8 (ffebld_constant_complex8 (c).imaginary);
 637 #endif
 638
 639 #if FFETARGET_okCHARACTER1
 640     case FFEBLD_constCHARACTER1:
 641       return ffetarget_iszero_character1 (ffebld_constant_character1 (c));
 642 #endif
 643
 644 #if FFETARGET_okCHARACTER2 || FFETARGET_okCHARACTER3  /* ... */
 645 #error "no support for these!!"
 646 #endif
 647
 648     case FFEBLD_constHOLLERITH:
 649       return ffetarget_iszero_hollerith (ffebld_constant_hollerith (c));
 650
 651     case FFEBLD_constBINARY_MIL:
 652     case FFEBLD_constBINARY_VXT:
 653     case FFEBLD_constOCTAL_MIL:
 654     case FFEBLD_constOCTAL_VXT:
 655     case FFEBLD_constHEX_X_MIL:
 656     case FFEBLD_constHEX_X_VXT:
 657     case FFEBLD_constHEX_Z_MIL:
 658     case FFEBLD_constHEX_Z_VXT:
 659       return ffetarget_iszero_typeless (ffebld_constant_typeless (c));
 660
 661     default:
 662       return FALSE;
 663     }
 664 }
 665
 666 /* ffebld_constant_new_character1 -- Return character1 constant object from token
 667
 668    See prototype.  */
 669
 670 #if FFETARGET_okCHARACTER1
 671 ffebldConstant
 672 ffebld_constant_new_character1 (ffelexToken t)
 673 {
 674   ffetargetCharacter1 val;
 675
 676   ffetarget_character1 (&val, t, ffebld_constant_pool());
 677   return ffebld_constant_new_character1_val (val);
 678 }
 679
 680 #endif
 681 /* ffebld_constant_new_character1_val -- Return an character1 constant object
 682
 683    See prototype.  */
 684
 685 #if FFETARGET_okCHARACTER1
 686 ffebldConstant
 687 ffebld_constant_new_character1_val (ffetargetCharacter1 val)
 688 {
 689   ffebldConstant c;
 690   ffebldConstant nc;
 691   int cmp;
 692
 693   ffetarget_verify_character1 (ffebld_constant_pool(), val);
 694
 695   for (c = (ffebldConstant) &ffebld_constant_character1_;
 696        c->next != NULL;
 697        c = c->next)
 698     {
 699       malloc_verify_kp (ffebld_constant_pool(),
 700                         c->next,
 701                         sizeof (*(c->next)));
 702       ffetarget_verify_character1 (ffebld_constant_pool(),
 703                                    ffebld_constant_character1 (c->next));
 704       cmp = ffetarget_cmp_character1 (val,
 705                                       ffebld_constant_character1 (c->next));
 706       if (cmp == 0)
 707         return c->next;
 708       if (cmp > 0)
 709         break;
 710     }
 711
 712   nc = malloc_new_kp (ffebld_constant_pool(),
 713                       "FFEBLD_constCHARACTER1",
 714                       sizeof (*nc));
 715   nc->next = c->next;
 716   nc->consttype = FFEBLD_constCHARACTER1;
 717   nc->u.character1 = val;
 718 #ifdef FFECOM_constantHOOK
 719   nc->hook = FFECOM_constantNULL;
 720 #endif
 721   c->next = nc;
 722
 723   return nc;
 724 }
 725
 726 #endif
 727 /* ffebld_constant_new_complex1 -- Return complex1 constant object from token
 728
 729    See prototype.  */
 730
 731 #if FFETARGET_okCOMPLEX1
 732 ffebldConstant
 733 ffebld_constant_new_complex1 (ffebldConstant real,
 734                               ffebldConstant imaginary)
 735 {
 736   ffetargetComplex1 val;
 737
 738   val.real = ffebld_constant_real1 (real);
 739   val.imaginary = ffebld_constant_real1 (imaginary);
 740   return ffebld_constant_new_complex1_val (val);
 741 }
 742
 743 #endif
 744 /* ffebld_constant_new_complex1_val -- Return a complex1 constant object
 745
 746    See prototype.  */
 747
 748 #if FFETARGET_okCOMPLEX1
 749 ffebldConstant
 750 ffebld_constant_new_complex1_val (ffetargetComplex1 val)
 751 {
 752   ffebldConstant c;
 753   ffebldConstant nc;
 754   int cmp;
 755
 756   for (c = (ffebldConstant) &ffebld_constant_complex1_;
 757        c->next != NULL;
 758        c = c->next)
 759     {
 760       cmp = ffetarget_cmp_real1 (val.real, ffebld_constant_complex1 (c->next).real);
 761       if (cmp == 0)
 762         cmp = ffetarget_cmp_real1 (val.imaginary,
 763                               ffebld_constant_complex1 (c->next).imaginary);
 764       if (cmp == 0)
 765         return c->next;
 766       if (cmp > 0)
 767         break;
 768     }
 769
 770   nc = malloc_new_kp (ffebld_constant_pool(),
 771                       "FFEBLD_constCOMPLEX1",
 772                       sizeof (*nc));
 773   nc->next = c->next;
 774   nc->consttype = FFEBLD_constCOMPLEX1;
 775   nc->u.complex1 = val;
 776 #ifdef FFECOM_constantHOOK
 777   nc->hook = FFECOM_constantNULL;
 778 #endif
 779   c->next = nc;
 780
 781   return nc;
 782 }
 783
 784 #endif
 785 /* ffebld_constant_new_complex2 -- Return complex2 constant object from token
 786
 787    See prototype.  */
 788
 789 #if FFETARGET_okCOMPLEX2
 790 ffebldConstant
 791 ffebld_constant_new_complex2 (ffebldConstant real,
 792                               ffebldConstant imaginary)
 793 {
 794   ffetargetComplex2 val;
 795
 796   val.real = ffebld_constant_real2 (real);
 797   val.imaginary = ffebld_constant_real2 (imaginary);
 798   return ffebld_constant_new_complex2_val (val);
 799 }
 800
 801 #endif
 802 /* ffebld_constant_new_complex2_val -- Return a complex2 constant object
 803
 804    See prototype.  */
 805
 806 #if FFETARGET_okCOMPLEX2
 807 ffebldConstant
 808 ffebld_constant_new_complex2_val (ffetargetComplex2 val)
 809 {
 810   ffebldConstant c;
 811   ffebldConstant nc;
 812   int cmp;
 813
 814   for (c = (ffebldConstant) &ffebld_constant_complex2_;
 815        c->next != NULL;
 816        c = c->next)
 817     {
 818       cmp = ffetarget_cmp_real2 (val.real, ffebld_constant_complex2 (c->next).real);
 819       if (cmp == 0)
 820         cmp = ffetarget_cmp_real2 (val.imaginary,
 821                               ffebld_constant_complex2 (c->next).imaginary);
 822       if (cmp == 0)
 823         return c->next;
 824       if (cmp > 0)
 825         break;
 826     }
 827
 828   nc = malloc_new_kp (ffebld_constant_pool(),
 829                       "FFEBLD_constCOMPLEX2",
 830                       sizeof (*nc));
 831   nc->next = c->next;
 832   nc->consttype = FFEBLD_constCOMPLEX2;
 833   nc->u.complex2 = val;
 834 #ifdef FFECOM_constantHOOK
 835   nc->hook = FFECOM_constantNULL;
 836 #endif
 837   c->next = nc;
 838
 839   return nc;
 840 }
 841
 842 #endif
 843 /* ffebld_constant_new_hollerith -- Return hollerith constant object from token
 844
 845    See prototype.  */
 846
 847 ffebldConstant
 848 ffebld_constant_new_hollerith (ffelexToken t)
 849 {
 850   ffetargetHollerith val;
 851
 852   ffetarget_hollerith (&val, t, ffebld_constant_pool());
 853   return ffebld_constant_new_hollerith_val (val);
 854 }
 855
 856 /* ffebld_constant_new_hollerith_val -- Return an hollerith constant object
 857
 858    See prototype.  */
 859
 860 ffebldConstant
 861 ffebld_constant_new_hollerith_val (ffetargetHollerith val)
 862 {
 863   ffebldConstant c;
 864   ffebldConstant nc;
 865   int cmp;
 866
 867   for (c = (ffebldConstant) &ffebld_constant_hollerith_;
 868        c->next != NULL;
 869        c = c->next)
 870     {
 871       cmp = ffetarget_cmp_hollerith (val, ffebld_constant_hollerith (c->next));
 872       if (cmp == 0)
 873         return c->next;
 874       if (cmp > 0)
 875         break;
 876     }
 877
 878   nc = malloc_new_kp (ffebld_constant_pool(),
 879                       "FFEBLD_constHOLLERITH",
 880                       sizeof (*nc));
 881   nc->next = c->next;
 882   nc->consttype = FFEBLD_constHOLLERITH;
 883   nc->u.hollerith = val;
 884 #ifdef FFECOM_constantHOOK
 885   nc->hook = FFECOM_constantNULL;
 886 #endif
 887   c->next = nc;
 888
 889   return nc;
 890 }
 891
 892 /* ffebld_constant_new_integer1 -- Return integer1 constant object from token
 893
 894    See prototype.
 895
 896    Parses the token as a decimal integer constant, thus it must be an
 897    FFELEX_typeNUMBER.  */
 898
 899 #if FFETARGET_okINTEGER1
 900 ffebldConstant
 901 ffebld_constant_new_integer1 (ffelexToken t)
 902 {
 903   ffetargetInteger1 val;
 904
 905   assert (ffelex_token_type (t) == FFELEX_typeNUMBER);
 906
 907   ffetarget_integer1 (&val, t);
 908   return ffebld_constant_new_integer1_val (val);
 909 }
 910
 911 #endif
 912 /* ffebld_constant_new_integer1_val -- Return an integer1 constant object
 913
 914    See prototype.  */
 915
 916 #if FFETARGET_okINTEGER1
 917 ffebldConstant
 918 ffebld_constant_new_integer1_val (ffetargetInteger1 val)
 919 {
 920   ffebldConstant c;
 921   ffebldConstant nc;
 922   int cmp;
 923
 924   for (c = (ffebldConstant) &ffebld_constant_integer1_;
 925        c->next != NULL;
 926        c = c->next)
 927     {
 928       cmp = ffetarget_cmp_integer1 (val, ffebld_constant_integer1 (c->next));
 929       if (cmp == 0)
 930         return c->next;
 931       if (cmp > 0)
 932         break;
 933     }
 934
 935   nc = malloc_new_kp (ffebld_constant_pool(),
 936                       "FFEBLD_constINTEGER1",
 937                       sizeof (*nc));
 938   nc->next = c->next;
 939   nc->consttype = FFEBLD_constINTEGER1;
 940   nc->u.integer1 = val;
 941 #ifdef FFECOM_constantHOOK
 942   nc->hook = FFECOM_constantNULL;
 943 #endif
 944   c->next = nc;
 945
 946   return nc;
 947 }
 948
 949 #endif
 950 /* ffebld_constant_new_integer2_val -- Return an integer2 constant object
 951
 952    See prototype.  */
 953
 954 #if FFETARGET_okINTEGER2
 955 ffebldConstant
 956 ffebld_constant_new_integer2_val (ffetargetInteger2 val)
 957 {
 958   ffebldConstant c;
 959   ffebldConstant nc;
 960   int cmp;
 961
 962   for (c = (ffebldConstant) &ffebld_constant_integer2_;
 963        c->next != NULL;
 964        c = c->next)
 965     {
 966       cmp = ffetarget_cmp_integer2 (val, ffebld_constant_integer2 (c->next));
 967       if (cmp == 0)
 968         return c->next;
 969       if (cmp > 0)
 970         break;
 971     }
 972
 973   nc = malloc_new_kp (ffebld_constant_pool(),
 974                       "FFEBLD_constINTEGER2",
 975                       sizeof (*nc));
 976   nc->next = c->next;
 977   nc->consttype = FFEBLD_constINTEGER2;
 978   nc->u.integer2 = val;
 979 #ifdef FFECOM_constantHOOK
 980   nc->hook = FFECOM_constantNULL;
 981 #endif
 982   c->next = nc;
 983
 984   return nc;
 985 }
 986
 987 #endif
 988 /* ffebld_constant_new_integer3_val -- Return an integer3 constant object
 989
 990    See prototype.  */
 991
 992 #if FFETARGET_okINTEGER3
 993 ffebldConstant
 994 ffebld_constant_new_integer3_val (ffetargetInteger3 val)
 995 {
 996   ffebldConstant c;
 997   ffebldConstant nc;
 998   int cmp;
 999
1000   for (c = (ffebldConstant) &ffebld_constant_integer3_;
1001        c->next != NULL;
1002        c = c->next)
1003     {
1004       cmp = ffetarget_cmp_integer3 (val, ffebld_constant_integer3 (c->next));
1005       if (cmp == 0)
1006         return c->next;
1007       if (cmp > 0)
1008         break;
1009     }
1010
1011   nc = malloc_new_kp (ffebld_constant_pool(),
1012                       "FFEBLD_constINTEGER3",
1013                       sizeof (*nc));
1014   nc->next = c->next;
1015   nc->consttype = FFEBLD_constINTEGER3;
1016   nc->u.integer3 = val;
1017 #ifdef FFECOM_constantHOOK
1018   nc->hook = FFECOM_constantNULL;
1019 #endif
1020   c->next = nc;
1021
1022   return nc;
1023 }
1024
1025 #endif
1026 /* ffebld_constant_new_integer4_val -- Return an integer4 constant object
1027
1028    See prototype.  */
1029
1030 #if FFETARGET_okINTEGER4
1031 ffebldConstant
1032 ffebld_constant_new_integer4_val (ffetargetInteger4 val)
1033 {
1034   ffebldConstant c;
1035   ffebldConstant nc;
1036   int cmp;
1037
1038   for (c = (ffebldConstant) &ffebld_constant_integer4_;
1039        c->next != NULL;
1040        c = c->next)
1041     {
1042       cmp = ffetarget_cmp_integer4 (val, ffebld_constant_integer4 (c->next));
1043       if (cmp == 0)
1044         return c->next;
1045       if (cmp > 0)
1046         break;
1047     }
1048
1049   nc = malloc_new_kp (ffebld_constant_pool(),
1050                       "FFEBLD_constINTEGER4",
1051                       sizeof (*nc));
1052   nc->next = c->next;
1053   nc->consttype = FFEBLD_constINTEGER4;
1054   nc->u.integer4 = val;
1055 #ifdef FFECOM_constantHOOK
1056   nc->hook = FFECOM_constantNULL;
1057 #endif
1058   c->next = nc;
1059
1060   return nc;
1061 }
1062
1063 #endif
1064 /* ffebld_constant_new_integerbinary -- Return binary constant object from token
1065
1066    See prototype.
1067
1068    Parses the token as a binary integer constant, thus it must be an
1069    FFELEX_typeNUMBER.  */
1070
1071 ffebldConstant
1072 ffebld_constant_new_integerbinary (ffelexToken t)
1073 {
1074   ffetargetIntegerDefault val;
1075
1076   assert ((ffelex_token_type (t) == FFELEX_typeNAME)
1077           || (ffelex_token_type (t) == FFELEX_typeNUMBER));
1078
1079   ffetarget_integerbinary (&val, t);
1080   return ffebld_constant_new_integerdefault_val (val);
1081 }
1082
1083 /* ffebld_constant_new_integerhex -- Return hex constant object from token
1084
1085    See prototype.
1086
1087    Parses the token as a hex integer constant, thus it must be an
1088    FFELEX_typeNUMBER.  */
1089
1090 ffebldConstant
1091 ffebld_constant_new_integerhex (ffelexToken t)
1092 {
1093   ffetargetIntegerDefault val;
1094
1095   assert ((ffelex_token_type (t) == FFELEX_typeNAME)
1096           || (ffelex_token_type (t) == FFELEX_typeNUMBER));
1097
1098   ffetarget_integerhex (&val, t);
1099   return ffebld_constant_new_integerdefault_val (val);
1100 }
1101
1102 /* ffebld_constant_new_integeroctal -- Return octal constant object from token
1103
1104    See prototype.
1105
1106    Parses the token as a octal integer constant, thus it must be an
1107    FFELEX_typeNUMBER.  */
1108
1109 ffebldConstant
1110 ffebld_constant_new_integeroctal (ffelexToken t)
1111 {
1112   ffetargetIntegerDefault val;
1113
1114   assert ((ffelex_token_type (t) == FFELEX_typeNAME)
1115           || (ffelex_token_type (t) == FFELEX_typeNUMBER));
1116
1117   ffetarget_integeroctal (&val, t);
1118   return ffebld_constant_new_integerdefault_val (val);
1119 }
1120
1121 /* ffebld_constant_new_logical1 -- Return logical1 constant object from token
1122
1123    See prototype.
1124
1125    Parses the token as a decimal logical constant, thus it must be an
1126    FFELEX_typeNUMBER.  */
1127
1128 #if FFETARGET_okLOGICAL1
1129 ffebldConstant
1130 ffebld_constant_new_logical1 (bool truth)
1131 {
1132   ffetargetLogical1 val;
1133
1134   ffetarget_logical1 (&val, truth);
1135   return ffebld_constant_new_logical1_val (val);
1136 }
1137
1138 #endif
1139 /* ffebld_constant_new_logical1_val -- Return a logical1 constant object
1140
1141    See prototype.  */
1142
1143 #if FFETARGET_okLOGICAL1
1144 ffebldConstant
1145 ffebld_constant_new_logical1_val (ffetargetLogical1 val)
1146 {
1147   ffebldConstant c;
1148   ffebldConstant nc;
1149   int cmp;
1150
1151   for (c = (ffebldConstant) &ffebld_constant_logical1_;
1152        c->next != NULL;
1153        c = c->next)
1154     {
1155       cmp = ffetarget_cmp_logical1 (val, ffebld_constant_logical1 (c->next));
1156       if (cmp == 0)
1157         return c->next;
1158       if (cmp > 0)
1159         break;
1160     }
1161
1162   nc = malloc_new_kp (ffebld_constant_pool(),
1163                       "FFEBLD_constLOGICAL1",
1164                       sizeof (*nc));
1165   nc->next = c->next;
1166   nc->consttype = FFEBLD_constLOGICAL1;
1167   nc->u.logical1 = val;
1168 #ifdef FFECOM_constantHOOK
1169   nc->hook = FFECOM_constantNULL;
1170 #endif
1171   c->next = nc;
1172
1173   return nc;
1174 }
1175
1176 #endif
1177 /* ffebld_constant_new_logical2_val -- Return a logical2 constant object
1178
1179    See prototype.  */
1180
1181 #if FFETARGET_okLOGICAL2
1182 ffebldConstant
1183 ffebld_constant_new_logical2_val (ffetargetLogical2 val)
1184 {
1185   ffebldConstant c;
1186   ffebldConstant nc;
1187   int cmp;
1188
1189   for (c = (ffebldConstant) &ffebld_constant_logical2_;
1190        c->next != NULL;
1191        c = c->next)
1192     {
1193       cmp = ffetarget_cmp_logical2 (val, ffebld_constant_logical2 (c->next));
1194       if (cmp == 0)
1195         return c->next;
1196       if (cmp > 0)
1197         break;
1198     }
1199
1200   nc = malloc_new_kp (ffebld_constant_pool(),
1201                       "FFEBLD_constLOGICAL2",
1202                       sizeof (*nc));
1203   nc->next = c->next;
1204   nc->consttype = FFEBLD_constLOGICAL2;
1205   nc->u.logical2 = val;
1206 #ifdef FFECOM_constantHOOK
1207   nc->hook = FFECOM_constantNULL;
1208 #endif
1209   c->next = nc;
1210
1211   return nc;
1212 }
1213
1214 #endif
1215 /* ffebld_constant_new_logical3_val -- Return a logical3 constant object
1216
1217    See prototype.  */
1218
1219 #if FFETARGET_okLOGICAL3
1220 ffebldConstant
1221 ffebld_constant_new_logical3_val (ffetargetLogical3 val)
1222 {
1223   ffebldConstant c;
1224   ffebldConstant nc;
1225   int cmp;
1226
1227   for (c = (ffebldConstant) &ffebld_constant_logical3_;
1228        c->next != NULL;
1229        c = c->next)
1230     {
1231       cmp = ffetarget_cmp_logical3 (val, ffebld_constant_logical3 (c->next));
1232       if (cmp == 0)
1233         return c->next;
1234       if (cmp > 0)
1235         break;
1236     }
1237
1238   nc = malloc_new_kp (ffebld_constant_pool(),
1239                       "FFEBLD_constLOGICAL3",
1240                       sizeof (*nc));
1241   nc->next = c->next;
1242   nc->consttype = FFEBLD_constLOGICAL3;
1243   nc->u.logical3 = val;
1244 #ifdef FFECOM_constantHOOK
1245   nc->hook = FFECOM_constantNULL;
1246 #endif
1247   c->next = nc;
1248
1249   return nc;
1250 }
1251
1252 #endif
1253 /* ffebld_constant_new_logical4_val -- Return a logical4 constant object
1254
1255    See prototype.  */
1256
1257 #if FFETARGET_okLOGICAL4
1258 ffebldConstant
1259 ffebld_constant_new_logical4_val (ffetargetLogical4 val)
1260 {
1261   ffebldConstant c;
1262   ffebldConstant nc;
1263   int cmp;
1264
1265   for (c = (ffebldConstant) &ffebld_constant_logical4_;
1266        c->next != NULL;
1267        c = c->next)
1268     {
1269       cmp = ffetarget_cmp_logical4 (val, ffebld_constant_logical4 (c->next));
1270       if (cmp == 0)
1271         return c->next;
1272       if (cmp > 0)
1273         break;
1274     }
1275
1276   nc = malloc_new_kp (ffebld_constant_pool(),
1277                       "FFEBLD_constLOGICAL4",
1278                       sizeof (*nc));
1279   nc->next = c->next;
1280   nc->consttype = FFEBLD_constLOGICAL4;
1281   nc->u.logical4 = val;
1282 #ifdef FFECOM_constantHOOK
1283   nc->hook = FFECOM_constantNULL;
1284 #endif
1285   c->next = nc;
1286
1287   return nc;
1288 }
1289
1290 #endif
1291 /* ffebld_constant_new_real1 -- Return real1 constant object from token
1292
1293    See prototype.  */
1294
1295 #if FFETARGET_okREAL1
1296 ffebldConstant
1297 ffebld_constant_new_real1 (ffelexToken integer, ffelexToken decimal,
1298       ffelexToken fraction, ffelexToken exponent, ffelexToken exponent_sign,
1299                            ffelexToken exponent_digits)
1300 {
1301   ffetargetReal1 val;
1302
1303   ffetarget_real1 (&val,
1304       integer, decimal, fraction, exponent, exponent_sign, exponent_digits);
1305   return ffebld_constant_new_real1_val (val);
1306 }
1307
1308 #endif
1309 /* ffebld_constant_new_real1_val -- Return an real1 constant object
1310
1311    See prototype.  */
1312
1313 #if FFETARGET_okREAL1
1314 ffebldConstant
1315 ffebld_constant_new_real1_val (ffetargetReal1 val)
1316 {
1317   ffebldConstant c;
1318   ffebldConstant nc;
1319   int cmp;
1320
1321   for (c = (ffebldConstant) &ffebld_constant_real1_;
1322        c->next != NULL;
1323        c = c->next)
1324     {
1325       cmp = ffetarget_cmp_real1 (val, ffebld_constant_real1 (c->next));
1326       if (cmp == 0)
1327         return c->next;
1328       if (cmp > 0)
1329         break;
1330     }
1331
1332   nc = malloc_new_kp (ffebld_constant_pool(),
1333                       "FFEBLD_constREAL1",
1334                       sizeof (*nc));
1335   nc->next = c->next;
1336   nc->consttype = FFEBLD_constREAL1;
1337   nc->u.real1 = val;
1338 #ifdef FFECOM_constantHOOK
1339   nc->hook = FFECOM_constantNULL;
1340 #endif
1341   c->next = nc;
1342
1343   return nc;
1344 }
1345
1346 #endif
1347 /* ffebld_constant_new_real2 -- Return real2 constant object from token
1348
1349    See prototype.  */
1350
1351 #if FFETARGET_okREAL2
1352 ffebldConstant
1353 ffebld_constant_new_real2 (ffelexToken integer, ffelexToken decimal,
1354       ffelexToken fraction, ffelexToken exponent, ffelexToken exponent_sign,
1355                            ffelexToken exponent_digits)
1356 {
1357   ffetargetReal2 val;
1358
1359   ffetarget_real2 (&val,
1360       integer, decimal, fraction, exponent, exponent_sign, exponent_digits);
1361   return ffebld_constant_new_real2_val (val);
1362 }
1363
1364 #endif
1365 /* ffebld_constant_new_real2_val -- Return an real2 constant object
1366
1367    See prototype.  */
1368
1369 #if FFETARGET_okREAL2
1370 ffebldConstant
1371 ffebld_constant_new_real2_val (ffetargetReal2 val)
1372 {
1373   ffebldConstant c;
1374   ffebldConstant nc;
1375   int cmp;
1376
1377   for (c = (ffebldConstant) &ffebld_constant_real2_;
1378        c->next != NULL;
1379        c = c->next)
1380     {
1381       cmp = ffetarget_cmp_real2 (val, ffebld_constant_real2 (c->next));
1382       if (cmp == 0)
1383         return c->next;
1384       if (cmp > 0)
1385         break;
1386     }
1387
1388   nc = malloc_new_kp (ffebld_constant_pool(),
1389                       "FFEBLD_constREAL2",
1390                       sizeof (*nc));
1391   nc->next = c->next;
1392   nc->consttype = FFEBLD_constREAL2;
1393   nc->u.real2 = val;
1394 #ifdef FFECOM_constantHOOK
1395   nc->hook = FFECOM_constantNULL;
1396 #endif
1397   c->next = nc;
1398
1399   return nc;
1400 }
1401
1402 #endif
1403 /* ffebld_constant_new_typeless_bm -- Return typeless constant object from token
1404
1405    See prototype.
1406
1407    Parses the token as a decimal integer constant, thus it must be an
1408    FFELEX_typeNUMBER.  */
1409
1410 ffebldConstant
1411 ffebld_constant_new_typeless_bm (ffelexToken t)
1412 {
1413   ffetargetTypeless val;
1414
1415   ffetarget_binarymil (&val, t);
1416   return ffebld_constant_new_typeless_val (FFEBLD_constBINARY_MIL, val);
1417 }
1418
1419 /* ffebld_constant_new_typeless_bv -- Return typeless constant object from token
1420
1421    See prototype.
1422
1423    Parses the token as a decimal integer constant, thus it must be an
1424    FFELEX_typeNUMBER.  */
1425
1426 ffebldConstant
1427 ffebld_constant_new_typeless_bv (ffelexToken t)
1428 {
1429   ffetargetTypeless val;
1430
1431   ffetarget_binaryvxt (&val, t);
1432   return ffebld_constant_new_typeless_val (FFEBLD_constBINARY_VXT, val);
1433 }
1434
1435 /* ffebld_constant_new_typeless_hxm -- Return typeless constant object from token
1436
1437    See prototype.
1438
1439    Parses the token as a decimal integer constant, thus it must be an
1440    FFELEX_typeNUMBER.  */
1441
1442 ffebldConstant
1443 ffebld_constant_new_typeless_hxm (ffelexToken t)
1444 {
1445   ffetargetTypeless val;
1446
1447   ffetarget_hexxmil (&val, t);
1448   return ffebld_constant_new_typeless_val (FFEBLD_constHEX_X_MIL, val);
1449 }
1450
1451 /* ffebld_constant_new_typeless_hxv -- Return typeless constant object from token
1452
1453    See prototype.
1454
1455    Parses the token as a decimal integer constant, thus it must be an
1456    FFELEX_typeNUMBER.  */
1457
1458 ffebldConstant
1459 ffebld_constant_new_typeless_hxv (ffelexToken t)
1460 {
1461   ffetargetTypeless val;
1462
1463   ffetarget_hexxvxt (&val, t);
1464   return ffebld_constant_new_typeless_val (FFEBLD_constHEX_X_VXT, val);
1465 }
1466
1467 /* ffebld_constant_new_typeless_hzm -- Return typeless constant object from token
1468
1469    See prototype.
1470
1471    Parses the token as a decimal integer constant, thus it must be an
1472    FFELEX_typeNUMBER.  */
1473
1474 ffebldConstant
1475 ffebld_constant_new_typeless_hzm (ffelexToken t)
1476 {
1477   ffetargetTypeless val;
1478
1479   ffetarget_hexzmil (&val, t);
1480   return ffebld_constant_new_typeless_val (FFEBLD_constHEX_Z_MIL, val);
1481 }
1482
1483 /* ffebld_constant_new_typeless_hzv -- Return typeless constant object from token
1484
1485    See prototype.
1486
1487    Parses the token as a decimal integer constant, thus it must be an
1488    FFELEX_typeNUMBER.  */
1489
1490 ffebldConstant
1491 ffebld_constant_new_typeless_hzv (ffelexToken t)
1492 {
1493   ffetargetTypeless val;
1494
1495   ffetarget_hexzvxt (&val, t);
1496   return ffebld_constant_new_typeless_val (FFEBLD_constHEX_Z_VXT, val);
1497 }
1498
1499 /* ffebld_constant_new_typeless_om -- Return typeless constant object from token
1500
1501    See prototype.
1502
1503    Parses the token as a decimal integer constant, thus it must be an
1504    FFELEX_typeNUMBER.  */
1505
1506 ffebldConstant
1507 ffebld_constant_new_typeless_om (ffelexToken t)
1508 {
1509   ffetargetTypeless val;
1510
1511   ffetarget_octalmil (&val, t);
1512   return ffebld_constant_new_typeless_val (FFEBLD_constOCTAL_MIL, val);
1513 }
1514
1515 /* ffebld_constant_new_typeless_ov -- Return typeless constant object from token
1516
1517    See prototype.
1518
1519    Parses the token as a decimal integer constant, thus it must be an
1520    FFELEX_typeNUMBER.  */
1521
1522 ffebldConstant
1523 ffebld_constant_new_typeless_ov (ffelexToken t)
1524 {
1525   ffetargetTypeless val;
1526
1527   ffetarget_octalvxt (&val, t);
1528   return ffebld_constant_new_typeless_val (FFEBLD_constOCTAL_VXT, val);
1529 }
1530
1531 /* ffebld_constant_new_typeless_val -- Return a typeless constant object
1532
1533    See prototype.  */
1534
1535 ffebldConstant
1536 ffebld_constant_new_typeless_val (ffebldConst type, ffetargetTypeless val)
1537 {
1538   ffebldConstant c;
1539   ffebldConstant nc;
1540   int cmp;
1541
1542   for (c = (ffebldConstant) &ffebld_constant_typeless_[type
1543                                               - FFEBLD_constTYPELESS_FIRST];
1544        c->next != NULL;
1545        c = c->next)
1546     {
1547       cmp = ffetarget_cmp_typeless (val, ffebld_constant_typeless (c->next));
1548       if (cmp == 0)
1549         return c->next;
1550       if (cmp > 0)
1551         break;
1552     }
1553
1554   nc = malloc_new_kp (ffebld_constant_pool(),
1555                       "FFEBLD_constTYPELESS",
1556                       sizeof (*nc));
1557   nc->next = c->next;
1558   nc->consttype = type;
1559   nc->u.typeless = val;
1560 #ifdef FFECOM_constantHOOK
1561   nc->hook = FFECOM_constantNULL;
1562 #endif
1563   c->next = nc;
1564
1565   return nc;
1566 }
1567
1568 /* ffebld_constantarray_get -- Get a value from an array of constants
1569
1570    See prototype.  */
1571
1572 ffebldConstantUnion
1573 ffebld_constantarray_get (ffebldConstantArray array, ffeinfoBasictype bt,
1574                           ffeinfoKindtype kt, ffetargetOffset offset)
1575 {
1576   ffebldConstantUnion u;
1577
1578   switch (bt)
1579     {
1580     case FFEINFO_basictypeINTEGER:
1581       switch (kt)
1582         {
1583 #if FFETARGET_okINTEGER1
1584         case FFEINFO_kindtypeINTEGER1:
1585           u.integer1 = *(array.integer1 + offset);
1586           break;
1587 #endif
1588
1589 #if FFETARGET_okINTEGER2
1590         case FFEINFO_kindtypeINTEGER2:
1591           u.integer2 = *(array.integer2 + offset);
1592           break;
1593 #endif
1594
1595 #if FFETARGET_okINTEGER3
1596         case FFEINFO_kindtypeINTEGER3:
1597           u.integer3 = *(array.integer3 + offset);
1598           break;
1599 #endif
1600
1601 #if FFETARGET_okINTEGER4
1602         case FFEINFO_kindtypeINTEGER4:
1603           u.integer4 = *(array.integer4 + offset);
1604           break;
1605 #endif
1606
1607 #if FFETARGET_okINTEGER5
1608         case FFEINFO_kindtypeINTEGER5:
1609           u.integer5 = *(array.integer5 + offset);
1610           break;
1611 #endif
1612
1613 #if FFETARGET_okINTEGER6
1614         case FFEINFO_kindtypeINTEGER6:
1615           u.integer6 = *(array.integer6 + offset);
1616           break;
1617 #endif
1618
1619 #if FFETARGET_okINTEGER7
1620         case FFEINFO_kindtypeINTEGER7:
1621           u.integer7 = *(array.integer7 + offset);
1622           break;
1623 #endif
1624
1625 #if FFETARGET_okINTEGER8
1626         case FFEINFO_kindtypeINTEGER8:
1627           u.integer8 = *(array.integer8 + offset);
1628           break;
1629 #endif
1630
1631         default:
1632           assert ("bad INTEGER kindtype" == NULL);
1633           break;
1634         }
1635       break;
1636
1637     case FFEINFO_basictypeLOGICAL:
1638       switch (kt)
1639         {
1640 #if FFETARGET_okLOGICAL1
1641         case FFEINFO_kindtypeLOGICAL1:
1642           u.logical1 = *(array.logical1 + offset);
1643           break;
1644 #endif
1645
1646 #if FFETARGET_okLOGICAL2
1647         case FFEINFO_kindtypeLOGICAL2:
1648           u.logical2 = *(array.logical2 + offset);
1649           break;
1650 #endif
1651
1652 #if FFETARGET_okLOGICAL3
1653         case FFEINFO_kindtypeLOGICAL3:
1654           u.logical3 = *(array.logical3 + offset);
1655           break;
1656 #endif
1657
1658 #if FFETARGET_okLOGICAL4
1659         case FFEINFO_kindtypeLOGICAL4:
1660           u.logical4 = *(array.logical4 + offset);
1661           break;
1662 #endif
1663
1664 #if FFETARGET_okLOGICAL5
1665         case FFEINFO_kindtypeLOGICAL5:
1666           u.logical5 = *(array.logical5 + offset);
1667           break;
1668 #endif
1669
1670 #if FFETARGET_okLOGICAL6
1671         case FFEINFO_kindtypeLOGICAL6:
1672           u.logical6 = *(array.logical6 + offset);
1673           break;
1674 #endif
1675
1676 #if FFETARGET_okLOGICAL7
1677         case FFEINFO_kindtypeLOGICAL7:
1678           u.logical7 = *(array.logical7 + offset);
1679           break;
1680 #endif
1681
1682 #if FFETARGET_okLOGICAL8
1683         case FFEINFO_kindtypeLOGICAL8:
1684           u.logical8 = *(array.logical8 + offset);
1685           break;
1686 #endif
1687
1688         default:
1689           assert ("bad LOGICAL kindtype" == NULL);
1690           break;
1691         }
1692       break;
1693
1694     case FFEINFO_basictypeREAL:
1695       switch (kt)
1696         {
1697 #if FFETARGET_okREAL1
1698         case FFEINFO_kindtypeREAL1:
1699           u.real1 = *(array.real1 + offset);
1700           break;
1701 #endif
1702
1703 #if FFETARGET_okREAL2
1704         case FFEINFO_kindtypeREAL2:
1705           u.real2 = *(array.real2 + offset);
1706           break;
1707 #endif
1708
1709 #if FFETARGET_okREAL3
1710         case FFEINFO_kindtypeREAL3:
1711           u.real3 = *(array.real3 + offset);
1712           break;
1713 #endif
1714
1715 #if FFETARGET_okREAL4
1716         case FFEINFO_kindtypeREAL4:
1717           u.real4 = *(array.real4 + offset);
1718           break;
1719 #endif
1720
1721 #if FFETARGET_okREAL5
1722         case FFEINFO_kindtypeREAL5:
1723           u.real5 = *(array.real5 + offset);
1724           break;
1725 #endif
1726
1727 #if FFETARGET_okREAL6
1728         case FFEINFO_kindtypeREAL6:
1729           u.real6 = *(array.real6 + offset);
1730           break;
1731 #endif
1732
1733 #if FFETARGET_okREAL7
1734         case FFEINFO_kindtypeREAL7:
1735           u.real7 = *(array.real7 + offset);
1736           break;
1737 #endif
1738
1739 #if FFETARGET_okREAL8
1740         case FFEINFO_kindtypeREAL8:
1741           u.real8 = *(array.real8 + offset);
1742           break;
1743 #endif
1744
1745         default:
1746           assert ("bad REAL kindtype" == NULL);
1747           break;
1748         }
1749       break;
1750
1751     case FFEINFO_basictypeCOMPLEX:
1752       switch (kt)
1753         {
1754 #if FFETARGET_okCOMPLEX1
1755         case FFEINFO_kindtypeREAL1:
1756           u.complex1 = *(array.complex1 + offset);
1757           break;
1758 #endif
1759
1760 #if FFETARGET_okCOMPLEX2
1761         case FFEINFO_kindtypeREAL2:
1762           u.complex2 = *(array.complex2 + offset);
1763           break;
1764 #endif
1765
1766 #if FFETARGET_okCOMPLEX3
1767         case FFEINFO_kindtypeREAL3:
1768           u.complex3 = *(array.complex3 + offset);
1769           break;
1770 #endif
1771
1772 #if FFETARGET_okCOMPLEX4
1773         case FFEINFO_kindtypeREAL4:
1774           u.complex4 = *(array.complex4 + offset);
1775           break;
1776 #endif
1777
1778 #if FFETARGET_okCOMPLEX5
1779         case FFEINFO_kindtypeREAL5:
1780           u.complex5 = *(array.complex5 + offset);
1781           break;
1782 #endif
1783
1784 #if FFETARGET_okCOMPLEX6
1785         case FFEINFO_kindtypeREAL6:
1786           u.complex6 = *(array.complex6 + offset);
1787           break;
1788 #endif
1789
1790 #if FFETARGET_okCOMPLEX7
1791         case FFEINFO_kindtypeREAL7:
1792           u.complex7 = *(array.complex7 + offset);
1793           break;
1794 #endif
1795
1796 #if FFETARGET_okCOMPLEX8
1797         case FFEINFO_kindtypeREAL8:
1798           u.complex8 = *(array.complex8 + offset);
1799           break;
1800 #endif
1801
1802         default:
1803           assert ("bad COMPLEX kindtype" == NULL);
1804           break;
1805         }
1806       break;
1807
1808     case FFEINFO_basictypeCHARACTER:
1809       switch (kt)
1810         {
1811 #if FFETARGET_okCHARACTER1
1812         case FFEINFO_kindtypeCHARACTER1:
1813           u.character1.length = 1;
1814           u.character1.text = array.character1 + offset;
1815           break;
1816 #endif
1817
1818 #if FFETARGET_okCHARACTER2
1819         case FFEINFO_kindtypeCHARACTER2:
1820           u.character2.length = 1;
1821           u.character2.text = array.character2 + offset;
1822           break;
1823 #endif
1824
1825 #if FFETARGET_okCHARACTER3
1826         case FFEINFO_kindtypeCHARACTER3:
1827           u.character3.length = 1;
1828           u.character3.text = array.character3 + offset;
1829           break;
1830 #endif
1831
1832 #if FFETARGET_okCHARACTER4
1833         case FFEINFO_kindtypeCHARACTER4:
1834           u.character4.length = 1;
1835           u.character4.text = array.character4 + offset;
1836           break;
1837 #endif
1838
1839 #if FFETARGET_okCHARACTER5
1840         case FFEINFO_kindtypeCHARACTER5:
1841           u.character5.length = 1;
1842           u.character5.text = array.character5 + offset;
1843           break;
1844 #endif
1845
1846 #if FFETARGET_okCHARACTER6
1847         case FFEINFO_kindtypeCHARACTER6:
1848           u.character6.length = 1;
1849           u.character6.text = array.character6 + offset;
1850           break;
1851 #endif
1852
1853 #if FFETARGET_okCHARACTER7
1854         case FFEINFO_kindtypeCHARACTER7:
1855           u.character7.length = 1;
1856           u.character7.text = array.character7 + offset;
1857           break;
1858 #endif
1859
1860 #if FFETARGET_okCHARACTER8
1861         case FFEINFO_kindtypeCHARACTER8:
1862           u.character8.length = 1;
1863           u.character8.text = array.character8 + offset;
1864           break;
1865 #endif
1866
1867         default:
1868           assert ("bad CHARACTER kindtype" == NULL);
1869           break;
1870         }
1871       break;
1872
1873     default:
1874       assert ("bad basictype" == NULL);
1875       break;
1876     }
1877
1878   return u;
1879 }
1880
1881 /* ffebld_constantarray_new -- Make an array of constants
1882
1883    See prototype.  */
1884
1885 ffebldConstantArray
1886 ffebld_constantarray_new (ffeinfoBasictype bt,
1887                           ffeinfoKindtype kt, ffetargetOffset size)
1888 {
1889   ffebldConstantArray ptr;
1890
1891   switch (bt)
1892     {
1893     case FFEINFO_basictypeINTEGER:
1894       switch (kt)
1895         {
1896 #if FFETARGET_okINTEGER1
1897         case FFEINFO_kindtypeINTEGER1:
1898           ptr.integer1 = malloc_new_zkp (ffebld_constant_pool(),
1899                                          "ffebldConstantArray",
1900                                          size *= sizeof (ffetargetInteger1),
1901                                          0);
1902           break;
1903 #endif
1904
1905 #if FFETARGET_okINTEGER2
1906         case FFEINFO_kindtypeINTEGER2:
1907           ptr.integer2 = malloc_new_zkp (ffebld_constant_pool(),
1908                                          "ffebldConstantArray",
1909                                          size *= sizeof (ffetargetInteger2),
1910                                          0);
1911           break;
1912 #endif
1913
1914 #if FFETARGET_okINTEGER3
1915         case FFEINFO_kindtypeINTEGER3:
1916           ptr.integer3 = malloc_new_zkp (ffebld_constant_pool(),
1917                                          "ffebldConstantArray",
1918                                          size *= sizeof (ffetargetInteger3),
1919                                          0);
1920           break;
1921 #endif
1922
1923 #if FFETARGET_okINTEGER4
1924         case FFEINFO_kindtypeINTEGER4:
1925           ptr.integer4 = malloc_new_zkp (ffebld_constant_pool(),
1926                                          "ffebldConstantArray",
1927                                          size *= sizeof (ffetargetInteger4),
1928                                          0);
1929           break;
1930 #endif
1931
1932 #if FFETARGET_okINTEGER5
1933         case FFEINFO_kindtypeINTEGER5:
1934           ptr.integer5 = malloc_new_zkp (ffebld_constant_pool(),
1935                                          "ffebldConstantArray",
1936                                          size *= sizeof (ffetargetInteger5),
1937                                          0);
1938           break;
1939 #endif
1940
1941 #if FFETARGET_okINTEGER6
1942         case FFEINFO_kindtypeINTEGER6:
1943           ptr.integer6 = malloc_new_zkp (ffebld_constant_pool(),
1944                                          "ffebldConstantArray",
1945                                          size *= sizeof (ffetargetInteger6),
1946                                          0);
1947           break;
1948 #endif
1949
1950 #if FFETARGET_okINTEGER7
1951         case FFEINFO_kindtypeINTEGER7:
1952           ptr.integer7 = malloc_new_zkp (ffebld_constant_pool(),
1953                                          "ffebldConstantArray",
1954                                          size *= sizeof (ffetargetInteger7),
1955                                          0);
1956           break;
1957 #endif
1958
1959 #if FFETARGET_okINTEGER8
1960         case FFEINFO_kindtypeINTEGER8:
1961           ptr.integer8 = malloc_new_zkp (ffebld_constant_pool(),
1962                                          "ffebldConstantArray",
1963                                          size *= sizeof (ffetargetInteger8),
1964                                          0);
1965           break;
1966 #endif
1967
1968         default:
1969           assert ("bad INTEGER kindtype" == NULL);
1970           break;
1971         }
1972       break;
1973
1974     case FFEINFO_basictypeLOGICAL:
1975       switch (kt)
1976         {
1977 #if FFETARGET_okLOGICAL1
1978         case FFEINFO_kindtypeLOGICAL1:
1979           ptr.logical1 = malloc_new_zkp (ffebld_constant_pool(),
1980                                          "ffebldConstantArray",
1981                                          size *= sizeof (ffetargetLogical1),
1982                                          0);
1983           break;
1984 #endif
1985
1986 #if FFETARGET_okLOGICAL2
1987         case FFEINFO_kindtypeLOGICAL2:
1988           ptr.logical2 = malloc_new_zkp (ffebld_constant_pool(),
1989                                          "ffebldConstantArray",
1990                                          size *= sizeof (ffetargetLogical2),
1991                                          0);
1992           break;
1993 #endif
1994
1995 #if FFETARGET_okLOGICAL3
1996         case FFEINFO_kindtypeLOGICAL3:
1997           ptr.logical3 = malloc_new_zkp (ffebld_constant_pool(),
1998                                          "ffebldConstantArray",
1999                                          size *= sizeof (ffetargetLogical3),
2000                                          0);
2001           break;
2002 #endif
2003
2004 #if FFETARGET_okLOGICAL4
2005         case FFEINFO_kindtypeLOGICAL4:
2006           ptr.logical4 = malloc_new_zkp (ffebld_constant_pool(),
2007                                          "ffebldConstantArray",
2008                                          size *= sizeof (ffetargetLogical4),
2009                                          0);
2010           break;
2011 #endif
2012
2013 #if FFETARGET_okLOGICAL5
2014         case FFEINFO_kindtypeLOGICAL5:
2015           ptr.logical5 = malloc_new_zkp (ffebld_constant_pool(),
2016                                          "ffebldConstantArray",
2017                                          size *= sizeof (ffetargetLogical5),
2018                                          0);
2019           break;
2020 #endif
2021
2022 #if FFETARGET_okLOGICAL6
2023         case FFEINFO_kindtypeLOGICAL6:
2024           ptr.logical6 = malloc_new_zkp (ffebld_constant_pool(),
2025                                          "ffebldConstantArray",
2026                                          size *= sizeof (ffetargetLogical6),
2027                                          0);
2028           break;
2029 #endif
2030
2031 #if FFETARGET_okLOGICAL7
2032         case FFEINFO_kindtypeLOGICAL7:
2033           ptr.logical7 = malloc_new_zkp (ffebld_constant_pool(),
2034                                          "ffebldConstantArray",
2035                                          size *= sizeof (ffetargetLogical7),
2036                                          0);
2037           break;
2038 #endif
2039
2040 #if FFETARGET_okLOGICAL8
2041         case FFEINFO_kindtypeLOGICAL8:
2042           ptr.logical8 = malloc_new_zkp (ffebld_constant_pool(),
2043                                          "ffebldConstantArray",
2044                                          size *= sizeof (ffetargetLogical8),
2045                                          0);
2046           break;
2047 #endif
2048
2049         default:
2050           assert ("bad LOGICAL kindtype" == NULL);
2051           break;
2052         }
2053       break;
2054
2055     case FFEINFO_basictypeREAL:
2056       switch (kt)
2057         {
2058 #if FFETARGET_okREAL1
2059         case FFEINFO_kindtypeREAL1:
2060           ptr.real1 = malloc_new_zkp (ffebld_constant_pool(),
2061                                       "ffebldConstantArray",
2062                                       size *= sizeof (ffetargetReal1),
2063                                       0);
2064           break;
2065 #endif
2066
2067 #if FFETARGET_okREAL2
2068         case FFEINFO_kindtypeREAL2:
2069           ptr.real2 = malloc_new_zkp (ffebld_constant_pool(),
2070                                       "ffebldConstantArray",
2071                                       size *= sizeof (ffetargetReal2),
2072                                       0);
2073           break;
2074 #endif
2075
2076 #if FFETARGET_okREAL3
2077         case FFEINFO_kindtypeREAL3:
2078           ptr.real3 = malloc_new_zkp (ffebld_constant_pool(),
2079                                       "ffebldConstantArray",
2080                                       size *= sizeof (ffetargetReal3),
2081                                       0);
2082           break;
2083 #endif
2084
2085 #if FFETARGET_okREAL4
2086         case FFEINFO_kindtypeREAL4:
2087           ptr.real4 = malloc_new_zkp (ffebld_constant_pool(),
2088                                       "ffebldConstantArray",
2089                                       size *= sizeof (ffetargetReal4),
2090                                       0);
2091           break;
2092 #endif
2093
2094 #if FFETARGET_okREAL5
2095         case FFEINFO_kindtypeREAL5:
2096           ptr.real5 = malloc_new_zkp (ffebld_constant_pool(),
2097                                       "ffebldConstantArray",
2098                                       size *= sizeof (ffetargetReal5),
2099                                       0);
2100           break;
2101 #endif
2102
2103 #if FFETARGET_okREAL6
2104         case FFEINFO_kindtypeREAL6:
2105           ptr.real6 = malloc_new_zkp (ffebld_constant_pool(),
2106                                       "ffebldConstantArray",
2107                                       size *= sizeof (ffetargetReal6),
2108                                       0);
2109           break;
2110 #endif
2111
2112 #if FFETARGET_okREAL7
2113         case FFEINFO_kindtypeREAL7:
2114           ptr.real7 = malloc_new_zkp (ffebld_constant_pool(),
2115                                       "ffebldConstantArray",
2116                                       size *= sizeof (ffetargetReal7),
2117                                       0);
2118           break;
2119 #endif
2120
2121 #if FFETARGET_okREAL8
2122         case FFEINFO_kindtypeREAL8:
2123           ptr.real8 = malloc_new_zkp (ffebld_constant_pool(),
2124                                       "ffebldConstantArray",
2125                                       size *= sizeof (ffetargetReal8),
2126                                       0);
2127           break;
2128 #endif
2129
2130         default:
2131           assert ("bad REAL kindtype" == NULL);
2132           break;
2133         }
2134       break;
2135
2136     case FFEINFO_basictypeCOMPLEX:
2137       switch (kt)
2138         {
2139 #if FFETARGET_okCOMPLEX1
2140         case FFEINFO_kindtypeREAL1:
2141           ptr.complex1 = malloc_new_zkp (ffebld_constant_pool(),
2142                                          "ffebldConstantArray",
2143                                          size *= sizeof (ffetargetComplex1),
2144                                          0);
2145           break;
2146 #endif
2147
2148 #if FFETARGET_okCOMPLEX2
2149         case FFEINFO_kindtypeREAL2:
2150           ptr.complex2 = malloc_new_zkp (ffebld_constant_pool(),
2151                                          "ffebldConstantArray",
2152                                          size *= sizeof (ffetargetComplex2),
2153                                          0);
2154           break;
2155 #endif
2156
2157 #if FFETARGET_okCOMPLEX3
2158         case FFEINFO_kindtypeREAL3:
2159           ptr.complex3 = malloc_new_zkp (ffebld_constant_pool(),
2160                                          "ffebldConstantArray",
2161                                          size *= sizeof (ffetargetComplex3),
2162                                          0);
2163           break;
2164 #endif
2165
2166 #if FFETARGET_okCOMPLEX4
2167         case FFEINFO_kindtypeREAL4:
2168           ptr.complex4 = malloc_new_zkp (ffebld_constant_pool(),
2169                                          "ffebldConstantArray",
2170                                          size *= sizeof (ffetargetComplex4),
2171                                          0);
2172           break;
2173 #endif
2174
2175 #if FFETARGET_okCOMPLEX5
2176         case FFEINFO_kindtypeREAL5:
2177           ptr.complex5 = malloc_new_zkp (ffebld_constant_pool(),
2178                                          "ffebldConstantArray",
2179                                          size *= sizeof (ffetargetComplex5),
2180                                          0);
2181           break;
2182 #endif
2183
2184 #if FFETARGET_okCOMPLEX6
2185         case FFEINFO_kindtypeREAL6:
2186           ptr.complex6 = malloc_new_zkp (ffebld_constant_pool(),
2187                                          "ffebldConstantArray",
2188                                          size *= sizeof (ffetargetComplex6),
2189                                          0);
2190           break;
2191 #endif
2192
2193 #if FFETARGET_okCOMPLEX7
2194         case FFEINFO_kindtypeREAL7:
2195           ptr.complex7 = malloc_new_zkp (ffebld_constant_pool(),
2196                                          "ffebldConstantArray",
2197                                          size *= sizeof (ffetargetComplex7),
2198                                          0);
2199           break;
2200 #endif
2201
2202 #if FFETARGET_okCOMPLEX8
2203         case FFEINFO_kindtypeREAL8:
2204           ptr.complex8 = malloc_new_zkp (ffebld_constant_pool(),
2205                                          "ffebldConstantArray",
2206                                          size *= sizeof (ffetargetComplex8),
2207                                          0);
2208           break;
2209 #endif
2210
2211         default:
2212           assert ("bad COMPLEX kindtype" == NULL);
2213           break;
2214         }
2215       break;
2216
2217     case FFEINFO_basictypeCHARACTER:
2218       switch (kt)
2219         {
2220 #if FFETARGET_okCHARACTER1
2221         case FFEINFO_kindtypeCHARACTER1:
2222           ptr.character1 = malloc_new_zkp (ffebld_constant_pool(),
2223                                            "ffebldConstantArray",
2224                                            size
2225                                            *= sizeof (ffetargetCharacterUnit1),
2226                                            0);
2227           break;
2228 #endif
2229
2230 #if FFETARGET_okCHARACTER2
2231         case FFEINFO_kindtypeCHARACTER2:
2232           ptr.character2 = malloc_new_zkp (ffebld_constant_pool(),
2233                                            "ffebldConstantArray",
2234                                            size
2235                                            *= sizeof (ffetargetCharacterUnit2),
2236                                            0);
2237           break;
2238 #endif
2239
2240 #if FFETARGET_okCHARACTER3
2241         case FFEINFO_kindtypeCHARACTER3:
2242           ptr.character3 = malloc_new_zkp (ffebld_constant_pool(),
2243                                            "ffebldConstantArray",
2244                                            size
2245                                            *= sizeof (ffetargetCharacterUnit3),
2246                                            0);
2247           break;
2248 #endif
2249
2250 #if FFETARGET_okCHARACTER4
2251         case FFEINFO_kindtypeCHARACTER4:
2252           ptr.character4 = malloc_new_zkp (ffebld_constant_pool(),
2253                                            "ffebldConstantArray",
2254                                            size
2255                                            *= sizeof (ffetargetCharacterUnit4),
2256                                            0);
2257           break;
2258 #endif
2259
2260 #if FFETARGET_okCHARACTER5
2261         case FFEINFO_kindtypeCHARACTER5:
2262           ptr.character5 = malloc_new_zkp (ffebld_constant_pool(),
2263                                            "ffebldConstantArray",
2264                                            size
2265                                            *= sizeof (ffetargetCharacterUnit5),
2266                                            0);
2267           break;
2268 #endif
2269
2270 #if FFETARGET_okCHARACTER6
2271         case FFEINFO_kindtypeCHARACTER6:
2272           ptr.character6 = malloc_new_zkp (ffebld_constant_pool(),
2273                                            "ffebldConstantArray",
2274                                            size
2275                                            *= sizeof (ffetargetCharacterUnit6),
2276                                            0);
2277           break;
2278 #endif
2279
2280 #if FFETARGET_okCHARACTER7
2281         case FFEINFO_kindtypeCHARACTER7:
2282           ptr.character7 = malloc_new_zkp (ffebld_constant_pool(),
2283                                            "ffebldConstantArray",
2284                                            size
2285                                            *= sizeof (ffetargetCharacterUnit7),
2286                                            0);
2287           break;
2288 #endif
2289
2290 #if FFETARGET_okCHARACTER8
2291         case FFEINFO_kindtypeCHARACTER8:
2292           ptr.character8 = malloc_new_zkp (ffebld_constant_pool(),
2293                                            "ffebldConstantArray",
2294                                            size
2295                                            *= sizeof (ffetargetCharacterUnit8),
2296                                            0);
2297           break;
2298 #endif
2299
2300         default:
2301           assert ("bad CHARACTER kindtype" == NULL);
2302           break;
2303         }
2304       break;
2305
2306     default:
2307       assert ("bad basictype" == NULL);
2308       break;
2309     }
2310
2311   return ptr;
2312 }
2313
2314 /* ffebld_constantarray_preparray -- Prepare for copy between arrays
2315
2316    See prototype.
2317
2318    Like _prepare, but the source is an array instead of a single-value
2319    constant.  */
2320
2321 void
2322 ffebld_constantarray_preparray (void **aptr, void **cptr, size_t *size,
2323        ffebldConstantArray array, ffeinfoBasictype abt, ffeinfoKindtype akt,
2324                    ffetargetOffset offset, ffebldConstantArray source_array,
2325                                 ffeinfoBasictype cbt, ffeinfoKindtype ckt)
2326 {
2327   switch (abt)
2328     {
2329     case FFEINFO_basictypeINTEGER:
2330       switch (akt)
2331         {
2332 #if FFETARGET_okINTEGER1
2333         case FFEINFO_kindtypeINTEGER1:
2334           *aptr = array.integer1 + offset;
2335           break;
2336 #endif
2337
2338 #if FFETARGET_okINTEGER2
2339         case FFEINFO_kindtypeINTEGER2:
2340           *aptr = array.integer2 + offset;
2341           break;
2342 #endif
2343
2344 #if FFETARGET_okINTEGER3
2345         case FFEINFO_kindtypeINTEGER3:
2346           *aptr = array.integer3 + offset;
2347           break;
2348 #endif
2349
2350 #if FFETARGET_okINTEGER4
2351         case FFEINFO_kindtypeINTEGER4:
2352           *aptr = array.integer4 + offset;
2353           break;
2354 #endif
2355
2356 #if FFETARGET_okINTEGER5
2357         case FFEINFO_kindtypeINTEGER5:
2358           *aptr = array.integer5 + offset;
2359           break;
2360 #endif
2361
2362 #if FFETARGET_okINTEGER6
2363         case FFEINFO_kindtypeINTEGER6:
2364           *aptr = array.integer6 + offset;
2365           break;
2366 #endif
2367
2368 #if FFETARGET_okINTEGER7
2369         case FFEINFO_kindtypeINTEGER7:
2370           *aptr = array.integer7 + offset;
2371           break;
2372 #endif
2373
2374 #if FFETARGET_okINTEGER8
2375         case FFEINFO_kindtypeINTEGER8:
2376           *aptr = array.integer8 + offset;
2377           break;
2378 #endif
2379
2380         default:
2381           assert ("bad INTEGER akindtype" == NULL);
2382           break;
2383         }
2384       break;
2385
2386     case FFEINFO_basictypeLOGICAL:
2387       switch (akt)
2388         {
2389 #if FFETARGET_okLOGICAL1
2390         case FFEINFO_kindtypeLOGICAL1:
2391           *aptr = array.logical1 + offset;
2392           break;
2393 #endif
2394
2395 #if FFETARGET_okLOGICAL2
2396         case FFEINFO_kindtypeLOGICAL2:
2397           *aptr = array.logical2 + offset;
2398           break;
2399 #endif
2400
2401 #if FFETARGET_okLOGICAL3
2402         case FFEINFO_kindtypeLOGICAL3:
2403           *aptr = array.logical3 + offset;
2404           break;
2405 #endif
2406
2407 #if FFETARGET_okLOGICAL4
2408         case FFEINFO_kindtypeLOGICAL4:
2409           *aptr = array.logical4 + offset;
2410           break;
2411 #endif
2412
2413 #if FFETARGET_okLOGICAL5
2414         case FFEINFO_kindtypeLOGICAL5:
2415           *aptr = array.logical5 + offset;
2416           break;
2417 #endif
2418
2419 #if FFETARGET_okLOGICAL6
2420         case FFEINFO_kindtypeLOGICAL6:
2421           *aptr = array.logical6 + offset;
2422           break;
2423 #endif
2424
2425 #if FFETARGET_okLOGICAL7
2426         case FFEINFO_kindtypeLOGICAL7:
2427           *aptr = array.logical7 + offset;
2428           break;
2429 #endif
2430
2431 #if FFETARGET_okLOGICAL8
2432         case FFEINFO_kindtypeLOGICAL8:
2433           *aptr = array.logical8 + offset;
2434           break;
2435 #endif
2436
2437         default:
2438           assert ("bad LOGICAL akindtype" == NULL);
2439           break;
2440         }
2441       break;
2442
2443     case FFEINFO_basictypeREAL:
2444       switch (akt)
2445         {
2446 #if FFETARGET_okREAL1
2447         case FFEINFO_kindtypeREAL1:
2448           *aptr = array.real1 + offset;
2449           break;
2450 #endif
2451
2452 #if FFETARGET_okREAL2
2453         case FFEINFO_kindtypeREAL2:
2454           *aptr = array.real2 + offset;
2455           break;
2456 #endif
2457
2458 #if FFETARGET_okREAL3
2459         case FFEINFO_kindtypeREAL3:
2460           *aptr = array.real3 + offset;
2461           break;
2462 #endif
2463
2464 #if FFETARGET_okREAL4
2465         case FFEINFO_kindtypeREAL4:
2466           *aptr = array.real4 + offset;
2467           break;
2468 #endif
2469
2470 #if FFETARGET_okREAL5
2471         case FFEINFO_kindtypeREAL5:
2472           *aptr = array.real5 + offset;
2473           break;
2474 #endif
2475
2476 #if FFETARGET_okREAL6
2477         case FFEINFO_kindtypeREAL6:
2478           *aptr = array.real6 + offset;
2479           break;
2480 #endif
2481
2482 #if FFETARGET_okREAL7
2483         case FFEINFO_kindtypeREAL7:
2484           *aptr = array.real7 + offset;
2485           break;
2486 #endif
2487
2488 #if FFETARGET_okREAL8
2489         case FFEINFO_kindtypeREAL8:
2490           *aptr = array.real8 + offset;
2491           break;
2492 #endif
2493
2494         default:
2495           assert ("bad REAL akindtype" == NULL);
2496           break;
2497         }
2498       break;
2499
2500     case FFEINFO_basictypeCOMPLEX:
2501       switch (akt)
2502         {
2503 #if FFETARGET_okCOMPLEX1
2504         case FFEINFO_kindtypeREAL1:
2505           *aptr = array.complex1 + offset;
2506           break;
2507 #endif
2508
2509 #if FFETARGET_okCOMPLEX2
2510         case FFEINFO_kindtypeREAL2:
2511           *aptr = array.complex2 + offset;
2512           break;
2513 #endif
2514
2515 #if FFETARGET_okCOMPLEX3
2516         case FFEINFO_kindtypeREAL3:
2517           *aptr = array.complex3 + offset;
2518           break;
2519 #endif
2520
2521 #if FFETARGET_okCOMPLEX4
2522         case FFEINFO_kindtypeREAL4:
2523           *aptr = array.complex4 + offset;
2524           break;
2525 #endif
2526
2527 #if FFETARGET_okCOMPLEX5
2528         case FFEINFO_kindtypeREAL5:
2529           *aptr = array.complex5 + offset;
2530           break;
2531 #endif
2532
2533 #if FFETARGET_okCOMPLEX6
2534         case FFEINFO_kindtypeREAL6:
2535           *aptr = array.complex6 + offset;
2536           break;
2537 #endif
2538
2539 #if FFETARGET_okCOMPLEX7
2540         case FFEINFO_kindtypeREAL7:
2541           *aptr = array.complex7 + offset;
2542           break;
2543 #endif
2544
2545 #if FFETARGET_okCOMPLEX8
2546         case FFEINFO_kindtypeREAL8:
2547           *aptr = array.complex8 + offset;
2548           break;
2549 #endif
2550
2551         default:
2552           assert ("bad COMPLEX akindtype" == NULL);
2553           break;
2554         }
2555       break;
2556
2557     case FFEINFO_basictypeCHARACTER:
2558       switch (akt)
2559         {
2560 #if FFETARGET_okCHARACTER1
2561         case FFEINFO_kindtypeCHARACTER1:
2562           *aptr = array.character1 + offset;
2563           break;
2564 #endif
2565
2566 #if FFETARGET_okCHARACTER2
2567         case FFEINFO_kindtypeCHARACTER2:
2568           *aptr = array.character2 + offset;
2569           break;
2570 #endif
2571
2572 #if FFETARGET_okCHARACTER3
2573         case FFEINFO_kindtypeCHARACTER3:
2574           *aptr = array.character3 + offset;
2575           break;
2576 #endif
2577
2578 #if FFETARGET_okCHARACTER4
2579         case FFEINFO_kindtypeCHARACTER4:
2580           *aptr = array.character4 + offset;
2581           break;
2582 #endif
2583
2584 #if FFETARGET_okCHARACTER5
2585         case FFEINFO_kindtypeCHARACTER5:
2586           *aptr = array.character5 + offset;
2587           break;
2588 #endif
2589
2590 #if FFETARGET_okCHARACTER6
2591         case FFEINFO_kindtypeCHARACTER6:
2592           *aptr = array.character6 + offset;
2593           break;
2594 #endif
2595
2596 #if FFETARGET_okCHARACTER7
2597         case FFEINFO_kindtypeCHARACTER7:
2598           *aptr = array.character7 + offset;
2599           break;
2600 #endif
2601
2602 #if FFETARGET_okCHARACTER8
2603         case FFEINFO_kindtypeCHARACTER8:
2604           *aptr = array.character8 + offset;
2605           break;
2606 #endif
2607
2608         default:
2609           assert ("bad CHARACTER akindtype" == NULL);
2610           break;
2611         }
2612       break;
2613
2614     default:
2615       assert ("bad abasictype" == NULL);
2616       break;
2617     }
2618
2619   switch (cbt)
2620     {
2621     case FFEINFO_basictypeINTEGER:
2622       switch (ckt)
2623         {
2624 #if FFETARGET_okINTEGER1
2625         case FFEINFO_kindtypeINTEGER1:
2626           *cptr = source_array.integer1;
2627           *size = sizeof (*source_array.integer1);
2628           break;
2629 #endif
2630
2631 #if FFETARGET_okINTEGER2
2632         case FFEINFO_kindtypeINTEGER2:
2633           *cptr = source_array.integer2;
2634           *size = sizeof (*source_array.integer2);
2635           break;
2636 #endif
2637
2638 #if FFETARGET_okINTEGER3
2639         case FFEINFO_kindtypeINTEGER3:
2640           *cptr = source_array.integer3;
2641           *size = sizeof (*source_array.integer3);
2642           break;
2643 #endif
2644
2645 #if FFETARGET_okINTEGER4
2646         case FFEINFO_kindtypeINTEGER4:
2647           *cptr = source_array.integer4;
2648           *size = sizeof (*source_array.integer4);
2649           break;
2650 #endif
2651
2652 #if FFETARGET_okINTEGER5
2653         case FFEINFO_kindtypeINTEGER5:
2654           *cptr = source_array.integer5;
2655           *size = sizeof (*source_array.integer5);
2656           break;
2657 #endif
2658
2659 #if FFETARGET_okINTEGER6
2660         case FFEINFO_kindtypeINTEGER6:
2661           *cptr = source_array.integer6;
2662           *size = sizeof (*source_array.integer6);
2663           break;
2664 #endif
2665
2666 #if FFETARGET_okINTEGER7
2667         case FFEINFO_kindtypeINTEGER7:
2668           *cptr = source_array.integer7;
2669           *size = sizeof (*source_array.integer7);
2670           break;
2671 #endif
2672
2673 #if FFETARGET_okINTEGER8
2674         case FFEINFO_kindtypeINTEGER8:
2675           *cptr = source_array.integer8;
2676           *size = sizeof (*source_array.integer8);
2677           break;
2678 #endif
2679
2680         default:
2681           assert ("bad INTEGER ckindtype" == NULL);
2682           break;
2683         }
2684       break;
2685
2686     case FFEINFO_basictypeLOGICAL:
2687       switch (ckt)
2688         {
2689 #if FFETARGET_okLOGICAL1
2690         case FFEINFO_kindtypeLOGICAL1:
2691           *cptr = source_array.logical1;
2692           *size = sizeof (*source_array.logical1);
2693           break;
2694 #endif
2695
2696 #if FFETARGET_okLOGICAL2
2697         case FFEINFO_kindtypeLOGICAL2:
2698           *cptr = source_array.logical2;
2699           *size = sizeof (*source_array.logical2);
2700           break;
2701 #endif
2702
2703 #if FFETARGET_okLOGICAL3
2704         case FFEINFO_kindtypeLOGICAL3:
2705           *cptr = source_array.logical3;
2706           *size = sizeof (*source_array.logical3);
2707           break;
2708 #endif
2709
2710 #if FFETARGET_okLOGICAL4
2711         case FFEINFO_kindtypeLOGICAL4:
2712           *cptr = source_array.logical4;
2713           *size = sizeof (*source_array.logical4);
2714           break;
2715 #endif
2716
2717 #if FFETARGET_okLOGICAL5
2718         case FFEINFO_kindtypeLOGICAL5:
2719           *cptr = source_array.logical5;
2720           *size = sizeof (*source_array.logical5);
2721           break;
2722 #endif
2723
2724 #if FFETARGET_okLOGICAL6
2725         case FFEINFO_kindtypeLOGICAL6:
2726           *cptr = source_array.logical6;
2727           *size = sizeof (*source_array.logical6);
2728           break;
2729 #endif
2730
2731 #if FFETARGET_okLOGICAL7
2732         case FFEINFO_kindtypeLOGICAL7:
2733           *cptr = source_array.logical7;
2734           *size = sizeof (*source_array.logical7);
2735           break;
2736 #endif
2737
2738 #if FFETARGET_okLOGICAL8
2739         case FFEINFO_kindtypeLOGICAL8:
2740           *cptr = source_array.logical8;
2741           *size = sizeof (*source_array.logical8);
2742           break;
2743 #endif
2744
2745         default:
2746           assert ("bad LOGICAL ckindtype" == NULL);
2747           break;
2748         }
2749       break;
2750
2751     case FFEINFO_basictypeREAL:
2752       switch (ckt)
2753         {
2754 #if FFETARGET_okREAL1
2755         case FFEINFO_kindtypeREAL1:
2756           *cptr = source_array.real1;
2757           *size = sizeof (*source_array.real1);
2758           break;
2759 #endif
2760
2761 #if FFETARGET_okREAL2
2762         case FFEINFO_kindtypeREAL2:
2763           *cptr = source_array.real2;
2764           *size = sizeof (*source_array.real2);
2765           break;
2766 #endif
2767
2768 #if FFETARGET_okREAL3
2769         case FFEINFO_kindtypeREAL3:
2770           *cptr = source_array.real3;
2771           *size = sizeof (*source_array.real3);
2772           break;
2773 #endif
2774
2775 #if FFETARGET_okREAL4
2776         case FFEINFO_kindtypeREAL4:
2777           *cptr = source_array.real4;
2778           *size = sizeof (*source_array.real4);
2779           break;
2780 #endif
2781
2782 #if FFETARGET_okREAL5
2783         case FFEINFO_kindtypeREAL5:
2784           *cptr = source_array.real5;
2785           *size = sizeof (*source_array.real5);
2786           break;
2787 #endif
2788
2789 #if FFETARGET_okREAL6
2790         case FFEINFO_kindtypeREAL6:
2791           *cptr = source_array.real6;
2792           *size = sizeof (*source_array.real6);
2793           break;
2794 #endif
2795
2796 #if FFETARGET_okREAL7
2797         case FFEINFO_kindtypeREAL7:
2798           *cptr = source_array.real7;
2799           *size = sizeof (*source_array.real7);
2800           break;
2801 #endif
2802
2803 #if FFETARGET_okREAL8
2804         case FFEINFO_kindtypeREAL8:
2805           *cptr = source_array.real8;
2806           *size = sizeof (*source_array.real8);
2807           break;
2808 #endif
2809
2810         default:
2811           assert ("bad REAL ckindtype" == NULL);
2812           break;
2813         }
2814       break;
2815
2816     case FFEINFO_basictypeCOMPLEX:
2817       switch (ckt)
2818         {
2819 #if FFETARGET_okCOMPLEX1
2820         case FFEINFO_kindtypeREAL1:
2821           *cptr = source_array.complex1;
2822           *size = sizeof (*source_array.complex1);
2823           break;
2824 #endif
2825
2826 #if FFETARGET_okCOMPLEX2
2827         case FFEINFO_kindtypeREAL2:
2828           *cptr = source_array.complex2;
2829           *size = sizeof (*source_array.complex2);
2830           break;
2831 #endif
2832
2833 #if FFETARGET_okCOMPLEX3
2834         case FFEINFO_kindtypeREAL3:
2835           *cptr = source_array.complex3;
2836           *size = sizeof (*source_array.complex3);
2837           break;
2838 #endif
2839
2840 #if FFETARGET_okCOMPLEX4
2841         case FFEINFO_kindtypeREAL4:
2842           *cptr = source_array.complex4;
2843           *size = sizeof (*source_array.complex4);
2844           break;
2845 #endif
2846
2847 #if FFETARGET_okCOMPLEX5
2848         case FFEINFO_kindtypeREAL5:
2849           *cptr = source_array.complex5;
2850           *size = sizeof (*source_array.complex5);
2851           break;
2852 #endif
2853
2854 #if FFETARGET_okCOMPLEX6
2855         case FFEINFO_kindtypeREAL6:
2856           *cptr = source_array.complex6;
2857           *size = sizeof (*source_array.complex6);
2858           break;
2859 #endif
2860
2861 #if FFETARGET_okCOMPLEX7
2862         case FFEINFO_kindtypeREAL7:
2863           *cptr = source_array.complex7;
2864           *size = sizeof (*source_array.complex7);
2865           break;
2866 #endif
2867
2868 #if FFETARGET_okCOMPLEX8
2869         case FFEINFO_kindtypeREAL8:
2870           *cptr = source_array.complex8;
2871           *size = sizeof (*source_array.complex8);
2872           break;
2873 #endif
2874
2875         default:
2876           assert ("bad COMPLEX ckindtype" == NULL);
2877           break;
2878         }
2879       break;
2880
2881     case FFEINFO_basictypeCHARACTER:
2882       switch (ckt)
2883         {
2884 #if FFETARGET_okCHARACTER1
2885         case FFEINFO_kindtypeCHARACTER1:
2886           *cptr = source_array.character1;
2887           *size = sizeof (*source_array.character1);
2888           break;
2889 #endif
2890
2891 #if FFETARGET_okCHARACTER2
2892         case FFEINFO_kindtypeCHARACTER2:
2893           *cptr = source_array.character2;
2894           *size = sizeof (*source_array.character2);
2895           break;
2896 #endif
2897
2898 #if FFETARGET_okCHARACTER3
2899         case FFEINFO_kindtypeCHARACTER3:
2900           *cptr = source_array.character3;
2901           *size = sizeof (*source_array.character3);
2902           break;
2903 #endif
2904
2905 #if FFETARGET_okCHARACTER4
2906         case FFEINFO_kindtypeCHARACTER4:
2907           *cptr = source_array.character4;
2908           *size = sizeof (*source_array.character4);
2909           break;
2910 #endif
2911
2912 #if FFETARGET_okCHARACTER5
2913         case FFEINFO_kindtypeCHARACTER5:
2914           *cptr = source_array.character5;
2915           *size = sizeof (*source_array.character5);
2916           break;
2917 #endif
2918
2919 #if FFETARGET_okCHARACTER6
2920         case FFEINFO_kindtypeCHARACTER6:
2921           *cptr = source_array.character6;
2922           *size = sizeof (*source_array.character6);
2923           break;
2924 #endif
2925
2926 #if FFETARGET_okCHARACTER7
2927         case FFEINFO_kindtypeCHARACTER7:
2928           *cptr = source_array.character7;
2929           *size = sizeof (*source_array.character7);
2930           break;
2931 #endif
2932
2933 #if FFETARGET_okCHARACTER8
2934         case FFEINFO_kindtypeCHARACTER8:
2935           *cptr = source_array.character8;
2936           *size = sizeof (*source_array.character8);
2937           break;
2938 #endif
2939
2940         default:
2941           assert ("bad CHARACTER ckindtype" == NULL);
2942           break;
2943         }
2944       break;
2945
2946     default:
2947       assert ("bad cbasictype" == NULL);
2948       break;
2949     }
2950 }
2951
2952 /* ffebld_constantarray_prepare -- Prepare for copy between value and array
2953
2954    See prototype.
2955
2956    Like _put, but just returns the pointers to the beginnings of the
2957    array and the constant and returns the size (the amount of info to
2958    copy).  The idea is that the caller can use memcpy to accomplish the
2959    same thing as _put (though slower), or the caller can use a different
2960    function that swaps bytes, words, etc for a different target machine.
2961    Also, the type of the array may be different from the type of the
2962    constant; the array type is used to determine the meaning (scale) of
2963    the offset field (to calculate the array pointer), the constant type is
2964    used to determine the constant pointer and the size (amount of info to
2965    copy).  */
2966
2967 void
2968 ffebld_constantarray_prepare (void **aptr, void **cptr, size_t *size,
2969        ffebldConstantArray array, ffeinfoBasictype abt, ffeinfoKindtype akt,
2970                       ffetargetOffset offset, ffebldConstantUnion *constant,
2971                               ffeinfoBasictype cbt, ffeinfoKindtype ckt)
2972 {
2973   switch (abt)
2974     {
2975     case FFEINFO_basictypeINTEGER:
2976       switch (akt)
2977         {
2978 #if FFETARGET_okINTEGER1
2979         case FFEINFO_kindtypeINTEGER1:
2980           *aptr = array.integer1 + offset;
2981           break;
2982 #endif
2983
2984 #if FFETARGET_okINTEGER2
2985         case FFEINFO_kindtypeINTEGER2:
2986           *aptr = array.integer2 + offset;
2987           break;
2988 #endif
2989
2990 #if FFETARGET_okINTEGER3
2991         case FFEINFO_kindtypeINTEGER3:
2992           *aptr = array.integer3 + offset;
2993           break;
2994 #endif
2995
2996 #if FFETARGET_okINTEGER4
2997         case FFEINFO_kindtypeINTEGER4:
2998           *aptr = array.integer4 + offset;
2999           break;
3000 #endif
3001
3002 #if FFETARGET_okINTEGER5
3003         case FFEINFO_kindtypeINTEGER5:
3004           *aptr = array.integer5 + offset;
3005           break;
3006 #endif
3007
3008 #if FFETARGET_okINTEGER6
3009         case FFEINFO_kindtypeINTEGER6:
3010           *aptr = array.integer6 + offset;
3011           break;
3012 #endif
3013
3014 #if FFETARGET_okINTEGER7
3015         case FFEINFO_kindtypeINTEGER7:
3016           *aptr = array.integer7 + offset;
3017           break;
3018 #endif
3019
3020 #if FFETARGET_okINTEGER8
3021         case FFEINFO_kindtypeINTEGER8:
3022           *aptr = array.integer8 + offset;
3023           break;
3024 #endif
3025
3026         default:
3027           assert ("bad INTEGER akindtype" == NULL);
3028           break;
3029         }
3030       break;
3031
3032     case FFEINFO_basictypeLOGICAL:
3033       switch (akt)
3034         {
3035 #if FFETARGET_okLOGICAL1
3036         case FFEINFO_kindtypeLOGICAL1:
3037           *aptr = array.logical1 + offset;
3038           break;
3039 #endif
3040
3041 #if FFETARGET_okLOGICAL2
3042         case FFEINFO_kindtypeLOGICAL2:
3043           *aptr = array.logical2 + offset;
3044           break;
3045 #endif
3046
3047 #if FFETARGET_okLOGICAL3
3048         case FFEINFO_kindtypeLOGICAL3:
3049           *aptr = array.logical3 + offset;
3050           break;
3051 #endif
3052
3053 #if FFETARGET_okLOGICAL4
3054         case FFEINFO_kindtypeLOGICAL4:
3055           *aptr = array.logical4 + offset;
3056           break;
3057 #endif
3058
3059 #if FFETARGET_okLOGICAL5
3060         case FFEINFO_kindtypeLOGICAL5:
3061           *aptr = array.logical5 + offset;
3062           break;
3063 #endif
3064
3065 #if FFETARGET_okLOGICAL6
3066         case FFEINFO_kindtypeLOGICAL6:
3067           *aptr = array.logical6 + offset;
3068           break;
3069 #endif
3070
3071 #if FFETARGET_okLOGICAL7
3072         case FFEINFO_kindtypeLOGICAL7:
3073           *aptr = array.logical7 + offset;
3074           break;
3075 #endif
3076
3077 #if FFETARGET_okLOGICAL8
3078         case FFEINFO_kindtypeLOGICAL8:
3079           *aptr = array.logical8 + offset;
3080           break;
3081 #endif
3082
3083         default:
3084           assert ("bad LOGICAL akindtype" == NULL);
3085           break;
3086         }
3087       break;
3088
3089     case FFEINFO_basictypeREAL:
3090       switch (akt)
3091         {
3092 #if FFETARGET_okREAL1
3093         case FFEINFO_kindtypeREAL1:
3094           *aptr = array.real1 + offset;
3095           break;
3096 #endif
3097
3098 #if FFETARGET_okREAL2
3099         case FFEINFO_kindtypeREAL2:
3100           *aptr = array.real2 + offset;
3101           break;
3102 #endif
3103
3104 #if FFETARGET_okREAL3
3105         case FFEINFO_kindtypeREAL3:
3106           *aptr = array.real3 + offset;
3107           break;
3108 #endif
3109
3110 #if FFETARGET_okREAL4
3111         case FFEINFO_kindtypeREAL4:
3112           *aptr = array.real4 + offset;
3113           break;
3114 #endif
3115
3116 #if FFETARGET_okREAL5
3117         case FFEINFO_kindtypeREAL5:
3118           *aptr = array.real5 + offset;
3119           break;
3120 #endif
3121
3122 #if FFETARGET_okREAL6
3123         case FFEINFO_kindtypeREAL6:
3124           *aptr = array.real6 + offset;
3125           break;
3126 #endif
3127
3128 #if FFETARGET_okREAL7
3129         case FFEINFO_kindtypeREAL7:
3130           *aptr = array.real7 + offset;
3131           break;
3132 #endif
3133
3134 #if FFETARGET_okREAL8
3135         case FFEINFO_kindtypeREAL8:
3136           *aptr = array.real8 + offset;
3137           break;
3138 #endif
3139
3140         default:
3141           assert ("bad REAL akindtype" == NULL);
3142           break;
3143         }
3144       break;
3145
3146     case FFEINFO_basictypeCOMPLEX:
3147       switch (akt)
3148         {
3149 #if FFETARGET_okCOMPLEX1
3150         case FFEINFO_kindtypeREAL1:
3151           *aptr = array.complex1 + offset;
3152           break;
3153 #endif
3154
3155 #if FFETARGET_okCOMPLEX2
3156         case FFEINFO_kindtypeREAL2:
3157           *aptr = array.complex2 + offset;
3158           break;
3159 #endif
3160
3161 #if FFETARGET_okCOMPLEX3
3162         case FFEINFO_kindtypeREAL3:
3163           *aptr = array.complex3 + offset;
3164           break;
3165 #endif
3166
3167 #if FFETARGET_okCOMPLEX4
3168         case FFEINFO_kindtypeREAL4:
3169           *aptr = array.complex4 + offset;
3170           break;
3171 #endif
3172
3173 #if FFETARGET_okCOMPLEX5
3174         case FFEINFO_kindtypeREAL5:
3175           *aptr = array.complex5 + offset;
3176           break;
3177 #endif
3178
3179 #if FFETARGET_okCOMPLEX6
3180         case FFEINFO_kindtypeREAL6:
3181           *aptr = array.complex6 + offset;
3182           break;
3183 #endif
3184
3185 #if FFETARGET_okCOMPLEX7
3186         case FFEINFO_kindtypeREAL7:
3187           *aptr = array.complex7 + offset;
3188           break;
3189 #endif
3190
3191 #if FFETARGET_okCOMPLEX8
3192         case FFEINFO_kindtypeREAL8:
3193           *aptr = array.complex8 + offset;
3194           break;
3195 #endif
3196
3197         default:
3198           assert ("bad COMPLEX akindtype" == NULL);
3199           break;
3200         }
3201       break;
3202
3203     case FFEINFO_basictypeCHARACTER:
3204       switch (akt)
3205         {
3206 #if FFETARGET_okCHARACTER1
3207         case FFEINFO_kindtypeCHARACTER1:
3208           *aptr = array.character1 + offset;
3209           break;
3210 #endif
3211
3212 #if FFETARGET_okCHARACTER2
3213         case FFEINFO_kindtypeCHARACTER2:
3214           *aptr = array.character2 + offset;
3215           break;
3216 #endif
3217
3218 #if FFETARGET_okCHARACTER3
3219         case FFEINFO_kindtypeCHARACTER3:
3220           *aptr = array.character3 + offset;
3221           break;
3222 #endif
3223
3224 #if FFETARGET_okCHARACTER4
3225         case FFEINFO_kindtypeCHARACTER4:
3226           *aptr = array.character4 + offset;
3227           break;
3228 #endif
3229
3230 #if FFETARGET_okCHARACTER5
3231         case FFEINFO_kindtypeCHARACTER5:
3232           *aptr = array.character5 + offset;
3233           break;
3234 #endif
3235
3236 #if FFETARGET_okCHARACTER6
3237         case FFEINFO_kindtypeCHARACTER6:
3238           *aptr = array.character6 + offset;
3239           break;
3240 #endif
3241
3242 #if FFETARGET_okCHARACTER7
3243         case FFEINFO_kindtypeCHARACTER7:
3244           *aptr = array.character7 + offset;
3245           break;
3246 #endif
3247
3248 #if FFETARGET_okCHARACTER8
3249         case FFEINFO_kindtypeCHARACTER8:
3250           *aptr = array.character8 + offset;
3251           break;
3252 #endif
3253
3254         default:
3255           assert ("bad CHARACTER akindtype" == NULL);
3256           break;
3257         }
3258       break;
3259
3260     default:
3261       assert ("bad abasictype" == NULL);
3262       break;
3263     }
3264
3265   switch (cbt)
3266     {
3267     case FFEINFO_basictypeINTEGER:
3268       switch (ckt)
3269         {
3270 #if FFETARGET_okINTEGER1
3271         case FFEINFO_kindtypeINTEGER1:
3272           *cptr = &constant->integer1;
3273           *size = sizeof (constant->integer1);
3274           break;
3275 #endif
3276
3277 #if FFETARGET_okINTEGER2
3278         case FFEINFO_kindtypeINTEGER2:
3279           *cptr = &constant->integer2;
3280           *size = sizeof (constant->integer2);
3281           break;
3282 #endif
3283
3284 #if FFETARGET_okINTEGER3
3285         case FFEINFO_kindtypeINTEGER3:
3286           *cptr = &constant->integer3;
3287           *size = sizeof (constant->integer3);
3288           break;
3289 #endif
3290
3291 #if FFETARGET_okINTEGER4
3292         case FFEINFO_kindtypeINTEGER4:
3293           *cptr = &constant->integer4;
3294           *size = sizeof (constant->integer4);
3295           break;
3296 #endif
3297
3298 #if FFETARGET_okINTEGER5
3299         case FFEINFO_kindtypeINTEGER5:
3300           *cptr = &constant->integer5;
3301           *size = sizeof (constant->integer5);
3302           break;
3303 #endif
3304
3305 #if FFETARGET_okINTEGER6
3306         case FFEINFO_kindtypeINTEGER6:
3307           *cptr = &constant->integer6;
3308           *size = sizeof (constant->integer6);
3309           break;
3310 #endif
3311
3312 #if FFETARGET_okINTEGER7
3313         case FFEINFO_kindtypeINTEGER7:
3314           *cptr = &constant->integer7;
3315           *size = sizeof (constant->integer7);
3316           break;
3317 #endif
3318
3319 #if FFETARGET_okINTEGER8
3320         case FFEINFO_kindtypeINTEGER8:
3321           *cptr = &constant->integer8;
3322           *size = sizeof (constant->integer8);
3323           break;
3324 #endif
3325
3326         default:
3327           assert ("bad INTEGER ckindtype" == NULL);
3328           break;
3329         }
3330       break;
3331
3332     case FFEINFO_basictypeLOGICAL:
3333       switch (ckt)
3334         {
3335 #if FFETARGET_okLOGICAL1
3336         case FFEINFO_kindtypeLOGICAL1:
3337           *cptr = &constant->logical1;
3338           *size = sizeof (constant->logical1);
3339           break;
3340 #endif
3341
3342 #if FFETARGET_okLOGICAL2
3343         case FFEINFO_kindtypeLOGICAL2:
3344           *cptr = &constant->logical2;
3345           *size = sizeof (constant->logical2);
3346           break;
3347 #endif
3348
3349 #if FFETARGET_okLOGICAL3
3350         case FFEINFO_kindtypeLOGICAL3:
3351           *cptr = &constant->logical3;
3352           *size = sizeof (constant->logical3);
3353           break;
3354 #endif
3355
3356 #if FFETARGET_okLOGICAL4
3357         case FFEINFO_kindtypeLOGICAL4:
3358           *cptr = &constant->logical4;
3359           *size = sizeof (constant->logical4);
3360           break;
3361 #endif
3362
3363 #if FFETARGET_okLOGICAL5
3364         case FFEINFO_kindtypeLOGICAL5:
3365           *cptr = &constant->logical5;
3366           *size = sizeof (constant->logical5);
3367           break;
3368 #endif
3369
3370 #if FFETARGET_okLOGICAL6
3371         case FFEINFO_kindtypeLOGICAL6:
3372           *cptr = &constant->logical6;
3373           *size = sizeof (constant->logical6);
3374           break;
3375 #endif
3376
3377 #if FFETARGET_okLOGICAL7
3378         case FFEINFO_kindtypeLOGICAL7:
3379           *cptr = &constant->logical7;
3380           *size = sizeof (constant->logical7);
3381           break;
3382 #endif
3383
3384 #if FFETARGET_okLOGICAL8
3385         case FFEINFO_kindtypeLOGICAL8:
3386           *cptr = &constant->logical8;
3387           *size = sizeof (constant->logical8);
3388           break;
3389 #endif
3390
3391         default:
3392           assert ("bad LOGICAL ckindtype" == NULL);
3393           break;
3394         }
3395       break;
3396
3397     case FFEINFO_basictypeREAL:
3398       switch (ckt)
3399         {
3400 #if FFETARGET_okREAL1
3401         case FFEINFO_kindtypeREAL1:
3402           *cptr = &constant->real1;
3403           *size = sizeof (constant->real1);
3404           break;
3405 #endif
3406
3407 #if FFETARGET_okREAL2
3408         case FFEINFO_kindtypeREAL2:
3409           *cptr = &constant->real2;
3410           *size = sizeof (constant->real2);
3411           break;
3412 #endif
3413
3414 #if FFETARGET_okREAL3
3415         case FFEINFO_kindtypeREAL3:
3416           *cptr = &constant->real3;
3417           *size = sizeof (constant->real3);
3418           break;
3419 #endif
3420
3421 #if FFETARGET_okREAL4
3422         case FFEINFO_kindtypeREAL4:
3423           *cptr = &constant->real4;
3424           *size = sizeof (constant->real4);
3425           break;
3426 #endif
3427
3428 #if FFETARGET_okREAL5
3429         case FFEINFO_kindtypeREAL5:
3430           *cptr = &constant->real5;
3431           *size = sizeof (constant->real5);
3432           break;
3433 #endif
3434
3435 #if FFETARGET_okREAL6
3436         case FFEINFO_kindtypeREAL6:
3437           *cptr = &constant->real6;
3438           *size = sizeof (constant->real6);
3439           break;
3440 #endif
3441
3442 #if FFETARGET_okREAL7
3443         case FFEINFO_kindtypeREAL7:
3444           *cptr = &constant->real7;
3445           *size = sizeof (constant->real7);
3446           break;
3447 #endif
3448
3449 #if FFETARGET_okREAL8
3450         case FFEINFO_kindtypeREAL8:
3451           *cptr = &constant->real8;
3452           *size = sizeof (constant->real8);
3453           break;
3454 #endif
3455
3456         default:
3457           assert ("bad REAL ckindtype" == NULL);
3458           break;
3459         }
3460       break;
3461
3462     case FFEINFO_basictypeCOMPLEX:
3463       switch (ckt)
3464         {
3465 #if FFETARGET_okCOMPLEX1
3466         case FFEINFO_kindtypeREAL1:
3467           *cptr = &constant->complex1;
3468           *size = sizeof (constant->complex1);
3469           break;
3470 #endif
3471
3472 #if FFETARGET_okCOMPLEX2
3473         case FFEINFO_kindtypeREAL2:
3474           *cptr = &constant->complex2;
3475           *size = sizeof (constant->complex2);
3476           break;
3477 #endif
3478
3479 #if FFETARGET_okCOMPLEX3
3480         case FFEINFO_kindtypeREAL3:
3481           *cptr = &constant->complex3;
3482           *size = sizeof (constant->complex3);
3483           break;
3484 #endif
3485
3486 #if FFETARGET_okCOMPLEX4
3487         case FFEINFO_kindtypeREAL4:
3488           *cptr = &constant->complex4;
3489           *size = sizeof (constant->complex4);
3490           break;
3491 #endif
3492
3493 #if FFETARGET_okCOMPLEX5
3494         case FFEINFO_kindtypeREAL5:
3495           *cptr = &constant->complex5;
3496           *size = sizeof (constant->complex5);
3497           break;
3498 #endif
3499
3500 #if FFETARGET_okCOMPLEX6
3501         case FFEINFO_kindtypeREAL6:
3502           *cptr = &constant->complex6;
3503           *size = sizeof (constant->complex6);
3504           break;
3505 #endif
3506
3507 #if FFETARGET_okCOMPLEX7
3508         case FFEINFO_kindtypeREAL7:
3509           *cptr = &constant->complex7;
3510           *size = sizeof (constant->complex7);
3511           break;
3512 #endif
3513
3514 #if FFETARGET_okCOMPLEX8
3515         case FFEINFO_kindtypeREAL8:
3516           *cptr = &constant->complex8;
3517           *size = sizeof (constant->complex8);
3518           break;
3519 #endif
3520
3521         default:
3522           assert ("bad COMPLEX ckindtype" == NULL);
3523           break;
3524         }
3525       break;
3526
3527     case FFEINFO_basictypeCHARACTER:
3528       switch (ckt)
3529         {
3530 #if FFETARGET_okCHARACTER1
3531         case FFEINFO_kindtypeCHARACTER1:
3532           *cptr = ffetarget_text_character1 (constant->character1);
3533           *size = ffetarget_length_character1 (constant->character1);
3534           break;
3535 #endif
3536
3537 #if FFETARGET_okCHARACTER2
3538         case FFEINFO_kindtypeCHARACTER2:
3539           *cptr = ffetarget_text_character2 (constant->character2);
3540           *size = ffetarget_length_character2 (constant->character2);
3541           break;
3542 #endif
3543
3544 #if FFETARGET_okCHARACTER3
3545         case FFEINFO_kindtypeCHARACTER3:
3546           *cptr = ffetarget_text_character3 (constant->character3);
3547           *size = ffetarget_length_character3 (constant->character3);
3548           break;
3549 #endif
3550
3551 #if FFETARGET_okCHARACTER4
3552         case FFEINFO_kindtypeCHARACTER4:
3553           *cptr = ffetarget_text_character4 (constant->character4);
3554           *size = ffetarget_length_character4 (constant->character4);
3555           break;
3556 #endif
3557
3558 #if FFETARGET_okCHARACTER5
3559         case FFEINFO_kindtypeCHARACTER5:
3560           *cptr = ffetarget_text_character5 (constant->character5);
3561           *size = ffetarget_length_character5 (constant->character5);
3562           break;
3563 #endif
3564
3565 #if FFETARGET_okCHARACTER6
3566         case FFEINFO_kindtypeCHARACTER6:
3567           *cptr = ffetarget_text_character6 (constant->character6);
3568           *size = ffetarget_length_character6 (constant->character6);
3569           break;
3570 #endif
3571
3572 #if FFETARGET_okCHARACTER7
3573         case FFEINFO_kindtypeCHARACTER7:
3574           *cptr = ffetarget_text_character7 (constant->character7);
3575           *size = ffetarget_length_character7 (constant->character7);
3576           break;
3577 #endif
3578
3579 #if FFETARGET_okCHARACTER8
3580         case FFEINFO_kindtypeCHARACTER8:
3581           *cptr = ffetarget_text_character8 (constant->character8);
3582           *size = ffetarget_length_character8 (constant->character8);
3583           break;
3584 #endif
3585
3586         default:
3587           assert ("bad CHARACTER ckindtype" == NULL);
3588           break;
3589         }
3590       break;
3591
3592     default:
3593       assert ("bad cbasictype" == NULL);
3594       break;
3595     }
3596 }
3597
3598 /* ffebld_constantarray_put -- Put a value into an array of constants
3599
3600    See prototype.  */
3601
3602 void
3603 ffebld_constantarray_put (ffebldConstantArray array, ffeinfoBasictype bt,
3604    ffeinfoKindtype kt, ffetargetOffset offset, ffebldConstantUnion constant)
3605 {
3606   switch (bt)
3607     {
3608     case FFEINFO_basictypeINTEGER:
3609       switch (kt)
3610         {
3611 #if FFETARGET_okINTEGER1
3612         case FFEINFO_kindtypeINTEGER1:
3613           *(array.integer1 + offset) = constant.integer1;
3614           break;
3615 #endif
3616
3617 #if FFETARGET_okINTEGER2
3618         case FFEINFO_kindtypeINTEGER2:
3619           *(array.integer2 + offset) = constant.integer2;
3620           break;
3621 #endif
3622
3623 #if FFETARGET_okINTEGER3
3624         case FFEINFO_kindtypeINTEGER3:
3625           *(array.integer3 + offset) = constant.integer3;
3626           break;
3627 #endif
3628
3629 #if FFETARGET_okINTEGER4
3630         case FFEINFO_kindtypeINTEGER4:
3631           *(array.integer4 + offset) = constant.integer4;
3632           break;
3633 #endif
3634
3635 #if FFETARGET_okINTEGER5
3636         case FFEINFO_kindtypeINTEGER5:
3637           *(array.integer5 + offset) = constant.integer5;
3638           break;
3639 #endif
3640
3641 #if FFETARGET_okINTEGER6
3642         case FFEINFO_kindtypeINTEGER6:
3643           *(array.integer6 + offset) = constant.integer6;
3644           break;
3645 #endif
3646
3647 #if FFETARGET_okINTEGER7
3648         case FFEINFO_kindtypeINTEGER7:
3649           *(array.integer7 + offset) = constant.integer7;
3650           break;
3651 #endif
3652
3653 #if FFETARGET_okINTEGER8
3654         case FFEINFO_kindtypeINTEGER8:
3655           *(array.integer8 + offset) = constant.integer8;
3656           break;
3657 #endif
3658
3659         default:
3660           assert ("bad INTEGER kindtype" == NULL);
3661           break;
3662         }
3663       break;
3664
3665     case FFEINFO_basictypeLOGICAL:
3666       switch (kt)
3667         {
3668 #if FFETARGET_okLOGICAL1
3669         case FFEINFO_kindtypeLOGICAL1:
3670           *(array.logical1 + offset) = constant.logical1;
3671           break;
3672 #endif
3673
3674 #if FFETARGET_okLOGICAL2
3675         case FFEINFO_kindtypeLOGICAL2:
3676           *(array.logical2 + offset) = constant.logical2;
3677           break;
3678 #endif
3679
3680 #if FFETARGET_okLOGICAL3
3681         case FFEINFO_kindtypeLOGICAL3:
3682           *(array.logical3 + offset) = constant.logical3;
3683           break;
3684 #endif
3685
3686 #if FFETARGET_okLOGICAL4
3687         case FFEINFO_kindtypeLOGICAL4:
3688           *(array.logical4 + offset) = constant.logical4;
3689           break;
3690 #endif
3691
3692 #if FFETARGET_okLOGICAL5
3693         case FFEINFO_kindtypeLOGICAL5:
3694           *(array.logical5 + offset) = constant.logical5;
3695           break;
3696 #endif
3697
3698 #if FFETARGET_okLOGICAL6
3699         case FFEINFO_kindtypeLOGICAL6:
3700           *(array.logical6 + offset) = constant.logical6;
3701           break;
3702 #endif
3703
3704 #if FFETARGET_okLOGICAL7
3705         case FFEINFO_kindtypeLOGICAL7:
3706           *(array.logical7 + offset) = constant.logical7;
3707           break;
3708 #endif
3709
3710 #if FFETARGET_okLOGICAL8
3711         case FFEINFO_kindtypeLOGICAL8:
3712           *(array.logical8 + offset) = constant.logical8;
3713           break;
3714 #endif
3715
3716         default:
3717           assert ("bad LOGICAL kindtype" == NULL);
3718           break;
3719         }
3720       break;
3721
3722     case FFEINFO_basictypeREAL:
3723       switch (kt)
3724         {
3725 #if FFETARGET_okREAL1
3726         case FFEINFO_kindtypeREAL1:
3727           *(array.real1 + offset) = constant.real1;
3728           break;
3729 #endif
3730
3731 #if FFETARGET_okREAL2
3732         case FFEINFO_kindtypeREAL2:
3733           *(array.real2 + offset) = constant.real2;
3734           break;
3735 #endif
3736
3737 #if FFETARGET_okREAL3
3738         case FFEINFO_kindtypeREAL3:
3739           *(array.real3 + offset) = constant.real3;
3740           break;
3741 #endif
3742
3743 #if FFETARGET_okREAL4
3744         case FFEINFO_kindtypeREAL4:
3745           *(array.real4 + offset) = constant.real4;
3746           break;
3747 #endif
3748
3749 #if FFETARGET_okREAL5
3750         case FFEINFO_kindtypeREAL5:
3751           *(array.real5 + offset) = constant.real5;
3752           break;
3753 #endif
3754
3755 #if FFETARGET_okREAL6
3756         case FFEINFO_kindtypeREAL6:
3757           *(array.real6 + offset) = constant.real6;
3758           break;
3759 #endif
3760
3761 #if FFETARGET_okREAL7
3762         case FFEINFO_kindtypeREAL7:
3763           *(array.real7 + offset) = constant.real7;
3764           break;
3765 #endif
3766
3767 #if FFETARGET_okREAL8
3768         case FFEINFO_kindtypeREAL8:
3769           *(array.real8 + offset) = constant.real8;
3770           break;
3771 #endif
3772
3773         default:
3774           assert ("bad REAL kindtype" == NULL);
3775           break;
3776         }
3777       break;
3778
3779     case FFEINFO_basictypeCOMPLEX:
3780       switch (kt)
3781         {
3782 #if FFETARGET_okCOMPLEX1
3783         case FFEINFO_kindtypeREAL1:
3784           *(array.complex1 + offset) = constant.complex1;
3785           break;
3786 #endif
3787
3788 #if FFETARGET_okCOMPLEX2
3789         case FFEINFO_kindtypeREAL2:
3790           *(array.complex2 + offset) = constant.complex2;
3791           break;
3792 #endif
3793
3794 #if FFETARGET_okCOMPLEX3
3795         case FFEINFO_kindtypeREAL3:
3796           *(array.complex3 + offset) = constant.complex3;
3797           break;
3798 #endif
3799
3800 #if FFETARGET_okCOMPLEX4
3801         case FFEINFO_kindtypeREAL4:
3802           *(array.complex4 + offset) = constant.complex4;
3803           break;
3804 #endif
3805
3806 #if FFETARGET_okCOMPLEX5
3807         case FFEINFO_kindtypeREAL5:
3808           *(array.complex5 + offset) = constant.complex5;
3809           break;
3810 #endif
3811
3812 #if FFETARGET_okCOMPLEX6
3813         case FFEINFO_kindtypeREAL6:
3814           *(array.complex6 + offset) = constant.complex6;
3815           break;
3816 #endif
3817
3818 #if FFETARGET_okCOMPLEX7
3819         case FFEINFO_kindtypeREAL7:
3820           *(array.complex7 + offset) = constant.complex7;
3821           break;
3822 #endif
3823
3824 #if FFETARGET_okCOMPLEX8
3825         case FFEINFO_kindtypeREAL8:
3826           *(array.complex8 + offset) = constant.complex8;
3827           break;
3828 #endif
3829
3830         default:
3831           assert ("bad COMPLEX kindtype" == NULL);
3832           break;
3833         }
3834       break;
3835
3836     case FFEINFO_basictypeCHARACTER:
3837       switch (kt)
3838         {
3839 #if FFETARGET_okCHARACTER1
3840         case FFEINFO_kindtypeCHARACTER1:
3841           memcpy (array.character1 + offset,
3842                   ffetarget_text_character1 (constant.character1),
3843                   ffetarget_length_character1 (constant.character1));
3844           break;
3845 #endif
3846
3847 #if FFETARGET_okCHARACTER2
3848         case FFEINFO_kindtypeCHARACTER2:
3849           memcpy (array.character2 + offset,
3850                   ffetarget_text_character2 (constant.character2),
3851                   ffetarget_length_character2 (constant.character2));
3852           break;
3853 #endif
3854
3855 #if FFETARGET_okCHARACTER3
3856         case FFEINFO_kindtypeCHARACTER3:
3857           memcpy (array.character3 + offset,
3858                   ffetarget_text_character3 (constant.character3),
3859                   ffetarget_length_character3 (constant.character3));
3860           break;
3861 #endif
3862
3863 #if FFETARGET_okCHARACTER4
3864         case FFEINFO_kindtypeCHARACTER4:
3865           memcpy (array.character4 + offset,
3866                   ffetarget_text_character4 (constant.character4),
3867                   ffetarget_length_character4 (constant.character4));
3868           break;
3869 #endif
3870
3871 #if FFETARGET_okCHARACTER5
3872         case FFEINFO_kindtypeCHARACTER5:
3873           memcpy (array.character5 + offset,
3874                   ffetarget_text_character5 (constant.character5),
3875                   ffetarget_length_character5 (constant.character5));
3876           break;
3877 #endif
3878
3879 #if FFETARGET_okCHARACTER6
3880         case FFEINFO_kindtypeCHARACTER6:
3881           memcpy (array.character6 + offset,
3882                   ffetarget_text_character6 (constant.character6),
3883                   ffetarget_length_character6 (constant.character6));
3884           break;
3885 #endif
3886
3887 #if FFETARGET_okCHARACTER7
3888         case FFEINFO_kindtypeCHARACTER7:
3889           memcpy (array.character7 + offset,
3890                   ffetarget_text_character7 (constant.character7),
3891                   ffetarget_length_character7 (constant.character7));
3892           break;
3893 #endif
3894
3895 #if FFETARGET_okCHARACTER8
3896         case FFEINFO_kindtypeCHARACTER8:
3897           memcpy (array.character8 + offset,
3898                   ffetarget_text_character8 (constant.character8),
3899                   ffetarget_length_character8 (constant.character8));
3900           break;
3901 #endif
3902
3903         default:
3904           assert ("bad CHARACTER kindtype" == NULL);
3905           break;
3906         }
3907       break;
3908
3909     default:
3910       assert ("bad basictype" == NULL);
3911       break;
3912     }
3913 }
3914
3915 /* ffebld_init_0 -- Initialize the module
3916
3917    ffebld_init_0();  */
3918
3919 void
3920 ffebld_init_0 ()
3921 {
3922   assert (FFEBLD_op == ARRAY_SIZE (ffebld_op_string_));
3923   assert (FFEBLD_op == ARRAY_SIZE (ffebld_arity_op_));
3924 }
3925
3926 /* ffebld_init_1 -- Initialize the module for a file
3927
3928    ffebld_init_1();  */
3929
3930 void
3931 ffebld_init_1 ()
3932 {
3933 #if FFEBLD_whereconstCURRENT_ == FFEBLD_whereconstFILE_
3934   int i;
3935
3936 #if FFETARGET_okCHARACTER1
3937   ffebld_constant_character1_ = NULL;
3938 #endif
3939 #if FFETARGET_okCHARACTER2
3940   ffebld_constant_character2_ = NULL;
3941 #endif
3942 #if FFETARGET_okCHARACTER3
3943   ffebld_constant_character3_ = NULL;
3944 #endif
3945 #if FFETARGET_okCHARACTER4
3946   ffebld_constant_character4_ = NULL;
3947 #endif
3948 #if FFETARGET_okCHARACTER5
3949   ffebld_constant_character5_ = NULL;
3950 #endif
3951 #if FFETARGET_okCHARACTER6
3952   ffebld_constant_character6_ = NULL;
3953 #endif
3954 #if FFETARGET_okCHARACTER7
3955   ffebld_constant_character7_ = NULL;
3956 #endif
3957 #if FFETARGET_okCHARACTER8
3958   ffebld_constant_character8_ = NULL;
3959 #endif
3960 #if FFETARGET_okCOMPLEX1
3961   ffebld_constant_complex1_ = NULL;
3962 #endif
3963 #if FFETARGET_okCOMPLEX2
3964   ffebld_constant_complex2_ = NULL;
3965 #endif
3966 #if FFETARGET_okCOMPLEX3
3967   ffebld_constant_complex3_ = NULL;
3968 #endif
3969 #if FFETARGET_okCOMPLEX4
3970   ffebld_constant_complex4_ = NULL;
3971 #endif
3972 #if FFETARGET_okCOMPLEX5
3973   ffebld_constant_complex5_ = NULL;
3974 #endif
3975 #if FFETARGET_okCOMPLEX6
3976   ffebld_constant_complex6_ = NULL;
3977 #endif
3978 #if FFETARGET_okCOMPLEX7
3979   ffebld_constant_complex7_ = NULL;
3980 #endif
3981 #if FFETARGET_okCOMPLEX8
3982   ffebld_constant_complex8_ = NULL;
3983 #endif
3984 #if FFETARGET_okINTEGER1
3985   ffebld_constant_integer1_ = NULL;
3986 #endif
3987 #if FFETARGET_okINTEGER2
3988   ffebld_constant_integer2_ = NULL;
3989 #endif
3990 #if FFETARGET_okINTEGER3
3991   ffebld_constant_integer3_ = NULL;
3992 #endif
3993 #if FFETARGET_okINTEGER4
3994   ffebld_constant_integer4_ = NULL;
3995 #endif
3996 #if FFETARGET_okINTEGER5
3997   ffebld_constant_integer5_ = NULL;
3998 #endif
3999 #if FFETARGET_okINTEGER6
4000   ffebld_constant_integer6_ = NULL;
4001 #endif
4002 #if FFETARGET_okINTEGER7
4003   ffebld_constant_integer7_ = NULL;
4004 #endif
4005 #if FFETARGET_okINTEGER8
4006   ffebld_constant_integer8_ = NULL;
4007 #endif
4008 #if FFETARGET_okLOGICAL1
4009   ffebld_constant_logical1_ = NULL;
4010 #endif
4011 #if FFETARGET_okLOGICAL2
4012   ffebld_constant_logical2_ = NULL;
4013 #endif
4014 #if FFETARGET_okLOGICAL3
4015   ffebld_constant_logical3_ = NULL;
4016 #endif
4017 #if FFETARGET_okLOGICAL4
4018   ffebld_constant_logical4_ = NULL;
4019 #endif
4020 #if FFETARGET_okLOGICAL5
4021   ffebld_constant_logical5_ = NULL;
4022 #endif
4023 #if FFETARGET_okLOGICAL6
4024   ffebld_constant_logical6_ = NULL;
4025 #endif
4026 #if FFETARGET_okLOGICAL7
4027   ffebld_constant_logical7_ = NULL;
4028 #endif
4029 #if FFETARGET_okLOGICAL8
4030   ffebld_constant_logical8_ = NULL;
4031 #endif
4032 #if FFETARGET_okREAL1
4033   ffebld_constant_real1_ = NULL;
4034 #endif
4035 #if FFETARGET_okREAL2
4036   ffebld_constant_real2_ = NULL;
4037 #endif
4038 #if FFETARGET_okREAL3
4039   ffebld_constant_real3_ = NULL;
4040 #endif
4041 #if FFETARGET_okREAL4
4042   ffebld_constant_real4_ = NULL;
4043 #endif
4044 #if FFETARGET_okREAL5
4045   ffebld_constant_real5_ = NULL;
4046 #endif
4047 #if FFETARGET_okREAL6
4048   ffebld_constant_real6_ = NULL;
4049 #endif
4050 #if FFETARGET_okREAL7
4051   ffebld_constant_real7_ = NULL;
4052 #endif
4053 #if FFETARGET_okREAL8
4054   ffebld_constant_real8_ = NULL;
4055 #endif
4056   ffebld_constant_hollerith_ = NULL;
4057   for (i = FFEBLD_constTYPELESS_FIRST; i <= FFEBLD_constTYPELESS_LAST; ++i)
4058     ffebld_constant_typeless_[i - FFEBLD_constTYPELESS_FIRST] = NULL;
4059 #endif
4060 }
4061
4062 /* ffebld_init_2 -- Initialize the module
4063
4064    ffebld_init_2();  */
4065
4066 void
4067 ffebld_init_2 ()
4068 {
4069 #if FFEBLD_whereconstCURRENT_ == FFEBLD_whereconstPROGUNIT_
4070   int i;
4071 #endif
4072
4073   ffebld_pool_stack_.next = NULL;
4074   ffebld_pool_stack_.pool = ffe_pool_program_unit ();
4075 #if FFEBLD_whereconstCURRENT_ == FFEBLD_whereconstPROGUNIT_
4076 #if FFETARGET_okCHARACTER1
4077   ffebld_constant_character1_ = NULL;
4078 #endif
4079 #if FFETARGET_okCHARACTER2
4080   ffebld_constant_character2_ = NULL;
4081 #endif
4082 #if FFETARGET_okCHARACTER3
4083   ffebld_constant_character3_ = NULL;
4084 #endif
4085 #if FFETARGET_okCHARACTER4
4086   ffebld_constant_character4_ = NULL;
4087 #endif
4088 #if FFETARGET_okCHARACTER5
4089   ffebld_constant_character5_ = NULL;
4090 #endif
4091 #if FFETARGET_okCHARACTER6
4092   ffebld_constant_character6_ = NULL;
4093 #endif
4094 #if FFETARGET_okCHARACTER7
4095   ffebld_constant_character7_ = NULL;
4096 #endif
4097 #if FFETARGET_okCHARACTER8
4098   ffebld_constant_character8_ = NULL;
4099 #endif
4100 #if FFETARGET_okCOMPLEX1
4101   ffebld_constant_complex1_ = NULL;
4102 #endif
4103 #if FFETARGET_okCOMPLEX2
4104   ffebld_constant_complex2_ = NULL;
4105 #endif
4106 #if FFETARGET_okCOMPLEX3
4107   ffebld_constant_complex3_ = NULL;
4108 #endif
4109 #if FFETARGET_okCOMPLEX4
4110   ffebld_constant_complex4_ = NULL;
4111 #endif
4112 #if FFETARGET_okCOMPLEX5
4113   ffebld_constant_complex5_ = NULL;
4114 #endif
4115 #if FFETARGET_okCOMPLEX6
4116   ffebld_constant_complex6_ = NULL;
4117 #endif
4118 #if FFETARGET_okCOMPLEX7
4119   ffebld_constant_complex7_ = NULL;
4120 #endif
4121 #if FFETARGET_okCOMPLEX8
4122   ffebld_constant_complex8_ = NULL;
4123 #endif
4124 #if FFETARGET_okINTEGER1
4125   ffebld_constant_integer1_ = NULL;
4126 #endif
4127 #if FFETARGET_okINTEGER2
4128   ffebld_constant_integer2_ = NULL;
4129 #endif
4130 #if FFETARGET_okINTEGER3
4131   ffebld_constant_integer3_ = NULL;
4132 #endif
4133 #if FFETARGET_okINTEGER4
4134   ffebld_constant_integer4_ = NULL;
4135 #endif
4136 #if FFETARGET_okINTEGER5
4137   ffebld_constant_integer5_ = NULL;
4138 #endif
4139 #if FFETARGET_okINTEGER6
4140   ffebld_constant_integer6_ = NULL;
4141 #endif
4142 #if FFETARGET_okINTEGER7
4143   ffebld_constant_integer7_ = NULL;
4144 #endif
4145 #if FFETARGET_okINTEGER8
4146   ffebld_constant_integer8_ = NULL;
4147 #endif
4148 #if FFETARGET_okLOGICAL1
4149   ffebld_constant_logical1_ = NULL;
4150 #endif
4151 #if FFETARGET_okLOGICAL2
4152   ffebld_constant_logical2_ = NULL;
4153 #endif
4154 #if FFETARGET_okLOGICAL3
4155   ffebld_constant_logical3_ = NULL;
4156 #endif
4157 #if FFETARGET_okLOGICAL4
4158   ffebld_constant_logical4_ = NULL;
4159 #endif
4160 #if FFETARGET_okLOGICAL5
4161   ffebld_constant_logical5_ = NULL;
4162 #endif
4163 #if FFETARGET_okLOGICAL6
4164   ffebld_constant_logical6_ = NULL;
4165 #endif
4166 #if FFETARGET_okLOGICAL7
4167   ffebld_constant_logical7_ = NULL;
4168 #endif
4169 #if FFETARGET_okLOGICAL8
4170   ffebld_constant_logical8_ = NULL;
4171 #endif
4172 #if FFETARGET_okREAL1
4173   ffebld_constant_real1_ = NULL;
4174 #endif
4175 #if FFETARGET_okREAL2
4176   ffebld_constant_real2_ = NULL;
4177 #endif
4178 #if FFETARGET_okREAL3
4179   ffebld_constant_real3_ = NULL;
4180 #endif
4181 #if FFETARGET_okREAL4
4182   ffebld_constant_real4_ = NULL;
4183 #endif
4184 #if FFETARGET_okREAL5
4185   ffebld_constant_real5_ = NULL;
4186 #endif
4187 #if FFETARGET_okREAL6
4188   ffebld_constant_real6_ = NULL;
4189 #endif
4190 #if FFETARGET_okREAL7
4191   ffebld_constant_real7_ = NULL;
4192 #endif
4193 #if FFETARGET_okREAL8
4194   ffebld_constant_real8_ = NULL;
4195 #endif
4196   ffebld_constant_hollerith_ = NULL;
4197   for (i = FFEBLD_constTYPELESS_FIRST; i <= FFEBLD_constTYPELESS_LAST; ++i)
4198     ffebld_constant_typeless_[i - FFEBLD_constTYPELESS_FIRST] = NULL;
4199 #endif
4200 }
4201
4202 /* ffebld_list_length -- Return # of opITEMs in list
4203
4204    ffebld list;  // Must be NULL or opITEM
4205    ffebldListLength length;
4206    length = ffebld_list_length(list);
4207
4208    Returns 0 if list is NULL, 1 if it's ffebld_trail is NULL, and so on.  */
4209
4210 ffebldListLength
4211 ffebld_list_length (ffebld list)
4212 {
4213   ffebldListLength length;
4214
4215   for (length = 0; list != NULL; ++length, list = ffebld_trail (list))
4216     ;
4217
4218   return length;
4219 }
4220
4221 /* ffebld_new_accter -- Create an ffebld object that is an array
4222
4223    ffebld x;
4224    ffebldConstantArray a;
4225    ffebit b;
4226    x = ffebld_new_accter(a,b);  */
4227
4228 ffebld
4229 ffebld_new_accter (ffebldConstantArray a, ffebit b)
4230 {
4231   ffebld x;
4232
4233   x = ffebld_new ();
4234 #if FFEBLD_BLANK_
4235   *x = ffebld_blank_;
4236 #endif
4237   x->op = FFEBLD_opACCTER;
4238   x->u.accter.array = a;
4239   x->u.accter.bits = b;
4240   x->u.accter.pad = 0;
4241   return x;
4242 }
4243
4244 /* ffebld_new_arrter -- Create an ffebld object that is an array
4245
4246    ffebld x;
4247    ffebldConstantArray a;
4248    ffetargetOffset size;
4249    x = ffebld_new_arrter(a,size);  */
4250
4251 ffebld
4252 ffebld_new_arrter (ffebldConstantArray a, ffetargetOffset size)
4253 {
4254   ffebld x;
4255
4256   x = ffebld_new ();
4257 #if FFEBLD_BLANK_
4258   *x = ffebld_blank_;
4259 #endif
4260   x->op = FFEBLD_opARRTER;
4261   x->u.arrter.array = a;
4262   x->u.arrter.size = size;
4263   x->u.arrter.pad = 0;
4264   return x;
4265 }
4266
4267 /* ffebld_new_conter_with_orig -- Create an ffebld object that is a constant
4268
4269    ffebld x;
4270    ffebldConstant c;
4271    x = ffebld_new_conter_with_orig(c,NULL);  */
4272
4273 ffebld
4274 ffebld_new_conter_with_orig (ffebldConstant c, ffebld o)
4275 {
4276   ffebld x;
4277
4278   x = ffebld_new ();
4279 #if FFEBLD_BLANK_
4280   *x = ffebld_blank_;
4281 #endif
4282   x->op = FFEBLD_opCONTER;
4283   x->u.conter.expr = c;
4284   x->u.conter.orig = o;
4285   x->u.conter.pad = 0;
4286   return x;
4287 }
4288
4289 /* ffebld_new_item -- Create an ffebld item object
4290
4291    ffebld x,y,z;
4292    x = ffebld_new_item(y,z);  */
4293
4294 ffebld
4295 ffebld_new_item (ffebld head, ffebld trail)
4296 {
4297   ffebld x;
4298
4299   x = ffebld_new ();
4300 #if FFEBLD_BLANK_
4301   *x = ffebld_blank_;
4302 #endif
4303   x->op = FFEBLD_opITEM;
4304   x->u.item.head = head;
4305   x->u.item.trail = trail;
4306 #ifdef FFECOM_itemHOOK
4307   x->u.item.hook = FFECOM_itemNULL;
4308 #endif
4309   return x;
4310 }
4311
4312 /* ffebld_new_labter -- Create an ffebld object that is a label
4313
4314    ffebld x;
4315    ffelab l;
4316    x = ffebld_new_labter(c);  */
4317
4318 ffebld
4319 ffebld_new_labter (ffelab l)
4320 {
4321   ffebld x;
4322
4323   x = ffebld_new ();
4324 #if FFEBLD_BLANK_
4325   *x = ffebld_blank_;
4326 #endif
4327   x->op = FFEBLD_opLABTER;
4328   x->u.labter = l;
4329   return x;
4330 }
4331
4332 /* ffebld_new_labtok -- Create object that is a label's NUMBER token
4333
4334    ffebld x;
4335    ffelexToken t;
4336    x = ffebld_new_labter(c);
4337
4338    Like the other ffebld_new_ functions, the
4339    supplied argument is stored exactly as is: ffelex_token_use is NOT
4340    called, so the token is "consumed", if one is indeed supplied (it may
4341    be NULL).  */
4342
4343 ffebld
4344 ffebld_new_labtok (ffelexToken t)
4345 {
4346   ffebld x;
4347
4348   x = ffebld_new ();
4349 #if FFEBLD_BLANK_
4350   *x = ffebld_blank_;
4351 #endif
4352   x->op = FFEBLD_opLABTOK;
4353   x->u.labtok = t;
4354   return x;
4355 }
4356
4357 /* ffebld_new_none -- Create an ffebld object with no arguments
4358
4359    ffebld x;
4360    x = ffebld_new_none(FFEBLD_opWHATEVER);  */
4361
4362 ffebld
4363 ffebld_new_none (ffebldOp o)
4364 {
4365   ffebld x;
4366
4367   x = ffebld_new ();
4368 #if FFEBLD_BLANK_
4369   *x = ffebld_blank_;
4370 #endif
4371   x->op = o;
4372   return x;
4373 }
4374
4375 /* ffebld_new_one -- Create an ffebld object with one argument
4376
4377    ffebld x,y;
4378    x = ffebld_new_one(FFEBLD_opWHATEVER,y);  */
4379
4380 ffebld
4381 ffebld_new_one (ffebldOp o, ffebld left)
4382 {
4383   ffebld x;
4384
4385   x = ffebld_new ();
4386 #if FFEBLD_BLANK_
4387   *x = ffebld_blank_;
4388 #endif
4389   x->op = o;
4390   x->u.nonter.left = left;
4391 #ifdef FFECOM_nonterHOOK
4392   x->u.nonter.hook = FFECOM_nonterNULL;
4393 #endif
4394   return x;
4395 }
4396
4397 /* ffebld_new_symter -- Create an ffebld object that is a symbol
4398
4399    ffebld x;
4400    ffesymbol s;
4401    ffeintrinGen gen;    // Generic intrinsic id, if any
4402    ffeintrinSpec spec;  // Specific intrinsic id, if any
4403    ffeintrinImp imp;    // Implementation intrinsic id, if any
4404    x = ffebld_new_symter (s, gen, spec, imp);  */
4405
4406 ffebld
4407 ffebld_new_symter (ffesymbol s, ffeintrinGen gen, ffeintrinSpec spec,
4408                    ffeintrinImp imp)
4409 {
4410   ffebld x;
4411
4412   x = ffebld_new ();
4413 #if FFEBLD_BLANK_
4414   *x = ffebld_blank_;
4415 #endif
4416   x->op = FFEBLD_opSYMTER;
4417   x->u.symter.symbol = s;
4418   x->u.symter.generic = gen;
4419   x->u.symter.specific = spec;
4420   x->u.symter.implementation = imp;
4421   x->u.symter.do_iter = FALSE;
4422   return x;
4423 }
4424
4425 /* ffebld_new_two -- Create an ffebld object with two arguments
4426
4427    ffebld x,y,z;
4428    x = ffebld_new_two(FFEBLD_opWHATEVER,y,z);  */
4429
4430 ffebld
4431 ffebld_new_two (ffebldOp o, ffebld left, ffebld right)
4432 {
4433   ffebld x;
4434
4435   x = ffebld_new ();
4436 #if FFEBLD_BLANK_
4437   *x = ffebld_blank_;
4438 #endif
4439   x->op = o;
4440   x->u.nonter.left = left;
4441   x->u.nonter.right = right;
4442 #ifdef FFECOM_nonterHOOK
4443   x->u.nonter.hook = FFECOM_nonterNULL;
4444 #endif
4445   return x;
4446 }
4447
4448 /* ffebld_pool_pop -- Pop ffebld's pool stack
4449
4450    ffebld_pool_pop();  */
4451
4452 void
4453 ffebld_pool_pop ()
4454 {
4455   ffebldPoolstack_ ps;
4456
4457   assert (ffebld_pool_stack_.next != NULL);
4458   ps = ffebld_pool_stack_.next;
4459   ffebld_pool_stack_.next = ps->next;
4460   ffebld_pool_stack_.pool = ps->pool;
4461   malloc_kill_ks (malloc_pool_image (), ps, sizeof (*ps));
4462 }
4463
4464 /* ffebld_pool_push -- Push ffebld's pool stack
4465
4466    ffebld_pool_push();  */
4467
4468 void
4469 ffebld_pool_push (mallocPool pool)
4470 {
4471   ffebldPoolstack_ ps;
4472
4473   ps = malloc_new_ks (malloc_pool_image (), "Pool stack", sizeof (*ps));
4474   ps->next = ffebld_pool_stack_.next;
4475   ps->pool = ffebld_pool_stack_.pool;
4476   ffebld_pool_stack_.next = ps;
4477   ffebld_pool_stack_.pool = pool;
4478 }
4479
4480 /* ffebld_op_string -- Return short string describing op
4481
4482    ffebldOp o;
4483    ffebld_op_string(o);
4484
4485    Returns a short string (uppercase) containing the name of the op.  */
4486
4487 const char *
4488 ffebld_op_string (ffebldOp o)
4489 {
4490   if (o >= ARRAY_SIZE (ffebld_op_string_))
4491     return "?\?\?";
4492   return ffebld_op_string_[o];
4493 }
4494
4495 /* ffebld_size_max -- Return maximum possible size of CHARACTER-type expr
4496
4497    ffetargetCharacterSize sz;
4498    ffebld b;
4499    sz = ffebld_size_max (b);
4500
4501    Like ffebld_size_known, but if that would return NONE and the expression
4502    is opSUBSTR, opCONVERT, opPAREN, or opCONCATENATE, returns ffebld_size_max
4503    of the subexpression(s).  */
4504
4505 ffetargetCharacterSize
4506 ffebld_size_max (ffebld b)
4507 {
4508   ffetargetCharacterSize sz;
4509
4510 recurse:                        /* :::::::::::::::::::: */
4511
4512   sz = ffebld_size_known (b);
4513
4514   if (sz != FFETARGET_charactersizeNONE)
4515     return sz;
4516
4517   switch (ffebld_op (b))
4518     {
4519     case FFEBLD_opSUBSTR:
4520     case FFEBLD_opCONVERT:
4521     case FFEBLD_opPAREN:
4522       b = ffebld_left (b);
4523       goto recurse;             /* :::::::::::::::::::: */
4524
4525     case FFEBLD_opCONCATENATE:
4526       sz = ffebld_size_max (ffebld_left (b))
4527         + ffebld_size_max (ffebld_right (b));
4528       return sz;
4529
4530     default:
4531       return sz;
4532     }
4533 }