gcc/f/bld.c

   1 /* bld.c -- Implementation File (module.c template V1.0)
   2    Copyright (C) 1995, 1996, 2003 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 FFETARGET_okCHARACTER1
  74 static ffebldConstant ffebld_constant_character1_;
  75 #endif
  76 #if FFETARGET_okCOMPLEX1
  77 static ffebldConstant ffebld_constant_complex1_;
  78 #endif
  79 #if FFETARGET_okCOMPLEX2
  80 static ffebldConstant ffebld_constant_complex2_;
  81 #endif
  82 #if FFETARGET_okCOMPLEX3
  83 static ffebldConstant ffebld_constant_complex3_;
  84 #endif
  85 #if FFETARGET_okINTEGER1
  86 static ffebldConstant ffebld_constant_integer1_;
  87 #endif
  88 #if FFETARGET_okINTEGER2
  89 static ffebldConstant ffebld_constant_integer2_;
  90 #endif
  91 #if FFETARGET_okINTEGER3
  92 static ffebldConstant ffebld_constant_integer3_;
  93 #endif
  94 #if FFETARGET_okINTEGER4
  95 static ffebldConstant ffebld_constant_integer4_;
  96 #endif
  97 #if FFETARGET_okLOGICAL1
  98 static ffebldConstant ffebld_constant_logical1_;
  99 #endif
 100 #if FFETARGET_okLOGICAL2
 101 static ffebldConstant ffebld_constant_logical2_;
 102 #endif
 103 #if FFETARGET_okLOGICAL3
 104 static ffebldConstant ffebld_constant_logical3_;
 105 #endif
 106 #if FFETARGET_okLOGICAL4
 107 static ffebldConstant ffebld_constant_logical4_;
 108 #endif
 109 #if FFETARGET_okREAL1
 110 static ffebldConstant ffebld_constant_real1_;
 111 #endif
 112 #if FFETARGET_okREAL2
 113 static ffebldConstant ffebld_constant_real2_;
 114 #endif
 115 #if FFETARGET_okREAL3
 116 static ffebldConstant ffebld_constant_real3_;
 117 #endif
 118 static ffebldConstant ffebld_constant_hollerith_;
 119 static ffebldConstant ffebld_constant_typeless_[FFEBLD_constTYPELESS_LAST
 120                                           - FFEBLD_constTYPELESS_FIRST + 1];
 121
 122 static const char *const ffebld_op_string_[]
 123 =
 124 {
 125 #define FFEBLD_OP(KWD,NAME,ARITY) NAME,
 126 #include "bld-op.def"
 127 #undef FFEBLD_OP
 128 };
 129
 130 /* Static functions (internal). */
 131
 132
 133 /* Internal macros. */
 134
 135 #define integerdefault_ CATX(integer,FFETARGET_ktINTEGERDEFAULT)
 136 #define logicaldefault_ CATX(logical,FFETARGET_ktLOGICALDEFAULT)
 137 #define realdefault_ CATX(real,FFETARGET_ktREALDEFAULT)
 138 #define realdouble_ CATX(real,FFETARGET_ktREALDOUBLE)
 139 #define realquad_ CATX(real,FFETARGET_ktREALQUAD)
 140 \f
 141 /* ffebld_constant_cmp -- Compare two constants a la strcmp
 142
 143    ffebldConstant c1, c2;
 144    if (ffebld_constant_cmp(c1,c2) == 0)
 145        // they're equal, else they're not.
 146
 147    Returns -1 if c1 < c2, 0 if c1 == c2, +1 if c1 == c2.  */
 148
 149 int
 150 ffebld_constant_cmp (ffebldConstant c1, ffebldConstant c2)
 151 {
 152   if (c1 == c2)
 153     return 0;
 154
 155   assert (ffebld_constant_type (c1) == ffebld_constant_type (c2));
 156
 157   switch (ffebld_constant_type (c1))
 158     {
 159 #if FFETARGET_okINTEGER1
 160     case FFEBLD_constINTEGER1:
 161       return ffetarget_cmp_integer1 (ffebld_constant_integer1 (c1),
 162                                      ffebld_constant_integer1 (c2));
 163 #endif
 164
 165 #if FFETARGET_okINTEGER2
 166     case FFEBLD_constINTEGER2:
 167       return ffetarget_cmp_integer2 (ffebld_constant_integer2 (c1),
 168                                      ffebld_constant_integer2 (c2));
 169 #endif
 170
 171 #if FFETARGET_okINTEGER3
 172     case FFEBLD_constINTEGER3:
 173       return ffetarget_cmp_integer3 (ffebld_constant_integer3 (c1),
 174                                      ffebld_constant_integer3 (c2));
 175 #endif
 176
 177 #if FFETARGET_okINTEGER4
 178     case FFEBLD_constINTEGER4:
 179       return ffetarget_cmp_integer4 (ffebld_constant_integer4 (c1),
 180                                      ffebld_constant_integer4 (c2));
 181 #endif
 182
 183 #if FFETARGET_okLOGICAL1
 184     case FFEBLD_constLOGICAL1:
 185       return ffetarget_cmp_logical1 (ffebld_constant_logical1 (c1),
 186                                      ffebld_constant_logical1 (c2));
 187 #endif
 188
 189 #if FFETARGET_okLOGICAL2
 190     case FFEBLD_constLOGICAL2:
 191       return ffetarget_cmp_logical2 (ffebld_constant_logical2 (c1),
 192                                      ffebld_constant_logical2 (c2));
 193 #endif
 194
 195 #if FFETARGET_okLOGICAL3
 196     case FFEBLD_constLOGICAL3:
 197       return ffetarget_cmp_logical3 (ffebld_constant_logical3 (c1),
 198                                      ffebld_constant_logical3 (c2));
 199 #endif
 200
 201 #if FFETARGET_okLOGICAL4
 202     case FFEBLD_constLOGICAL4:
 203       return ffetarget_cmp_logical4 (ffebld_constant_logical4 (c1),
 204                                      ffebld_constant_logical4 (c2));
 205 #endif
 206
 207 #if FFETARGET_okREAL1
 208     case FFEBLD_constREAL1:
 209       return ffetarget_cmp_real1 (ffebld_constant_real1 (c1),
 210                                   ffebld_constant_real1 (c2));
 211 #endif
 212
 213 #if FFETARGET_okREAL2
 214     case FFEBLD_constREAL2:
 215       return ffetarget_cmp_real2 (ffebld_constant_real2 (c1),
 216                                   ffebld_constant_real2 (c2));
 217 #endif
 218
 219 #if FFETARGET_okREAL3
 220     case FFEBLD_constREAL3:
 221       return ffetarget_cmp_real3 (ffebld_constant_real3 (c1),
 222                                   ffebld_constant_real3 (c2));
 223 #endif
 224
 225 #if FFETARGET_okCHARACTER1
 226     case FFEBLD_constCHARACTER1:
 227       return ffetarget_cmp_character1 (ffebld_constant_character1 (c1),
 228                                        ffebld_constant_character1 (c2));
 229 #endif
 230
 231     default:
 232       assert ("bad constant type" == NULL);
 233       return 0;
 234     }
 235 }
 236
 237 /* ffebld_constant_is_magical -- Determine if integer is "magical"
 238
 239    ffebldConstant c;
 240    if (ffebld_constant_is_magical(c))
 241        // it is 2**(n-1), where n is # bits in ffetargetIntegerDefault type
 242        // (this test is important for 2's-complement machines only).  */
 243
 244 bool
 245 ffebld_constant_is_magical (ffebldConstant c)
 246 {
 247   switch (ffebld_constant_type (c))
 248     {
 249     case FFEBLD_constINTEGERDEFAULT:
 250       return ffetarget_integerdefault_is_magical (ffebld_constant_integer1 (c));
 251
 252     default:
 253       return FALSE;
 254     }
 255 }
 256
 257 /* Determine if constant is zero.  Used to ensure step count
 258    for DO loops isn't zero, also to determine if values will
 259    be binary zeros, so not entirely portable at this point.  */
 260
 261 bool
 262 ffebld_constant_is_zero (ffebldConstant c)
 263 {
 264   switch (ffebld_constant_type (c))
 265     {
 266 #if FFETARGET_okINTEGER1
 267     case FFEBLD_constINTEGER1:
 268       return ffebld_constant_integer1 (c) == 0;
 269 #endif
 270
 271 #if FFETARGET_okINTEGER2
 272     case FFEBLD_constINTEGER2:
 273       return ffebld_constant_integer2 (c) == 0;
 274 #endif
 275
 276 #if FFETARGET_okINTEGER3
 277     case FFEBLD_constINTEGER3:
 278       return ffebld_constant_integer3 (c) == 0;
 279 #endif
 280
 281 #if FFETARGET_okINTEGER4
 282     case FFEBLD_constINTEGER4:
 283       return ffebld_constant_integer4 (c) == 0;
 284 #endif
 285
 286 #if FFETARGET_okLOGICAL1
 287     case FFEBLD_constLOGICAL1:
 288       return ffebld_constant_logical1 (c) == 0;
 289 #endif
 290
 291 #if FFETARGET_okLOGICAL2
 292     case FFEBLD_constLOGICAL2:
 293       return ffebld_constant_logical2 (c) == 0;
 294 #endif
 295
 296 #if FFETARGET_okLOGICAL3
 297     case FFEBLD_constLOGICAL3:
 298       return ffebld_constant_logical3 (c) == 0;
 299 #endif
 300
 301 #if FFETARGET_okLOGICAL4
 302     case FFEBLD_constLOGICAL4:
 303       return ffebld_constant_logical4 (c) == 0;
 304 #endif
 305
 306 #if FFETARGET_okREAL1
 307     case FFEBLD_constREAL1:
 308       return ffetarget_iszero_real1 (ffebld_constant_real1 (c));
 309 #endif
 310
 311 #if FFETARGET_okREAL2
 312     case FFEBLD_constREAL2:
 313       return ffetarget_iszero_real2 (ffebld_constant_real2 (c));
 314 #endif
 315
 316 #if FFETARGET_okREAL3
 317     case FFEBLD_constREAL3:
 318       return ffetarget_iszero_real3 (ffebld_constant_real3 (c));
 319 #endif
 320
 321 #if FFETARGET_okCOMPLEX1
 322     case FFEBLD_constCOMPLEX1:
 323       return ffetarget_iszero_real1 (ffebld_constant_complex1 (c).real)
 324      && ffetarget_iszero_real1 (ffebld_constant_complex1 (c).imaginary);
 325 #endif
 326
 327 #if FFETARGET_okCOMPLEX2
 328     case FFEBLD_constCOMPLEX2:
 329       return ffetarget_iszero_real2 (ffebld_constant_complex2 (c).real)
 330      && ffetarget_iszero_real2 (ffebld_constant_complex2 (c).imaginary);
 331 #endif
 332
 333 #if FFETARGET_okCOMPLEX3
 334     case FFEBLD_constCOMPLEX3:
 335       return ffetarget_iszero_real3 (ffebld_constant_complex3 (c).real)
 336      && ffetarget_iszero_real3 (ffebld_constant_complex3 (c).imaginary);
 337 #endif
 338
 339 #if FFETARGET_okCHARACTER1
 340     case FFEBLD_constCHARACTER1:
 341       return ffetarget_iszero_character1 (ffebld_constant_character1 (c));
 342 #endif
 343
 344     case FFEBLD_constHOLLERITH:
 345       return ffetarget_iszero_hollerith (ffebld_constant_hollerith (c));
 346
 347     case FFEBLD_constBINARY_MIL:
 348     case FFEBLD_constBINARY_VXT:
 349     case FFEBLD_constOCTAL_MIL:
 350     case FFEBLD_constOCTAL_VXT:
 351     case FFEBLD_constHEX_X_MIL:
 352     case FFEBLD_constHEX_X_VXT:
 353     case FFEBLD_constHEX_Z_MIL:
 354     case FFEBLD_constHEX_Z_VXT:
 355       return ffetarget_iszero_typeless (ffebld_constant_typeless (c));
 356
 357     default:
 358       return FALSE;
 359     }
 360 }
 361
 362 /* ffebld_constant_new_character1 -- Return character1 constant object from token
 363
 364    See prototype.  */
 365
 366 #if FFETARGET_okCHARACTER1
 367 ffebldConstant
 368 ffebld_constant_new_character1 (ffelexToken t)
 369 {
 370   ffetargetCharacter1 val;
 371
 372   ffetarget_character1 (&val, t, ffebld_constant_pool());
 373   return ffebld_constant_new_character1_val (val);
 374 }
 375
 376 #endif
 377 /* ffebld_constant_new_character1_val -- Return an character1 constant object
 378
 379    See prototype.  */
 380
 381 #if FFETARGET_okCHARACTER1
 382 ffebldConstant
 383 ffebld_constant_new_character1_val (ffetargetCharacter1 val)
 384 {
 385   ffebldConstant c;
 386   ffebldConstant nc;
 387   int cmp;
 388
 389   ffetarget_verify_character1 (ffebld_constant_pool(), val);
 390
 391   for (c = (ffebldConstant) &ffebld_constant_character1_;
 392        c->next != NULL;
 393        c = c->next)
 394     {
 395       malloc_verify_kp (ffebld_constant_pool(),
 396                         c->next,
 397                         sizeof (*(c->next)));
 398       ffetarget_verify_character1 (ffebld_constant_pool(),
 399                                    ffebld_constant_character1 (c->next));
 400       cmp = ffetarget_cmp_character1 (val,
 401                                       ffebld_constant_character1 (c->next));
 402       if (cmp == 0)
 403         return c->next;
 404       if (cmp > 0)
 405         break;
 406     }
 407
 408   nc = malloc_new_kp (ffebld_constant_pool(),
 409                       "FFEBLD_constCHARACTER1",
 410                       sizeof (*nc));
 411   nc->next = c->next;
 412   nc->consttype = FFEBLD_constCHARACTER1;
 413   nc->u.character1 = val;
 414   nc->hook = FFECOM_constantNULL;
 415   c->next = nc;
 416
 417   return nc;
 418 }
 419
 420 #endif
 421 /* ffebld_constant_new_complex1 -- Return complex1 constant object from token
 422
 423    See prototype.  */
 424
 425 #if FFETARGET_okCOMPLEX1
 426 ffebldConstant
 427 ffebld_constant_new_complex1 (ffebldConstant real,
 428                               ffebldConstant imaginary)
 429 {
 430   ffetargetComplex1 val;
 431
 432   val.real = ffebld_constant_real1 (real);
 433   val.imaginary = ffebld_constant_real1 (imaginary);
 434   return ffebld_constant_new_complex1_val (val);
 435 }
 436
 437 #endif
 438 /* ffebld_constant_new_complex1_val -- Return a complex1 constant object
 439
 440    See prototype.  */
 441
 442 #if FFETARGET_okCOMPLEX1
 443 ffebldConstant
 444 ffebld_constant_new_complex1_val (ffetargetComplex1 val)
 445 {
 446   ffebldConstant c;
 447   ffebldConstant nc;
 448   int cmp;
 449
 450   for (c = (ffebldConstant) &ffebld_constant_complex1_;
 451        c->next != NULL;
 452        c = c->next)
 453     {
 454       cmp = ffetarget_cmp_real1 (val.real, ffebld_constant_complex1 (c->next).real);
 455       if (cmp == 0)
 456         cmp = ffetarget_cmp_real1 (val.imaginary,
 457                               ffebld_constant_complex1 (c->next).imaginary);
 458       if (cmp == 0)
 459         return c->next;
 460       if (cmp > 0)
 461         break;
 462     }
 463
 464   nc = malloc_new_kp (ffebld_constant_pool(),
 465                       "FFEBLD_constCOMPLEX1",
 466                       sizeof (*nc));
 467   nc->next = c->next;
 468   nc->consttype = FFEBLD_constCOMPLEX1;
 469   nc->u.complex1 = val;
 470   nc->hook = FFECOM_constantNULL;
 471   c->next = nc;
 472
 473   return nc;
 474 }
 475
 476 #endif
 477 /* ffebld_constant_new_complex2 -- Return complex2 constant object from token
 478
 479    See prototype.  */
 480
 481 #if FFETARGET_okCOMPLEX2
 482 ffebldConstant
 483 ffebld_constant_new_complex2 (ffebldConstant real,
 484                               ffebldConstant imaginary)
 485 {
 486   ffetargetComplex2 val;
 487
 488   val.real = ffebld_constant_real2 (real);
 489   val.imaginary = ffebld_constant_real2 (imaginary);
 490   return ffebld_constant_new_complex2_val (val);
 491 }
 492
 493 #endif
 494 /* ffebld_constant_new_complex2_val -- Return a complex2 constant object
 495
 496    See prototype.  */
 497
 498 #if FFETARGET_okCOMPLEX2
 499 ffebldConstant
 500 ffebld_constant_new_complex2_val (ffetargetComplex2 val)
 501 {
 502   ffebldConstant c;
 503   ffebldConstant nc;
 504   int cmp;
 505
 506   for (c = (ffebldConstant) &ffebld_constant_complex2_;
 507        c->next != NULL;
 508        c = c->next)
 509     {
 510       cmp = ffetarget_cmp_real2 (val.real, ffebld_constant_complex2 (c->next).real);
 511       if (cmp == 0)
 512         cmp = ffetarget_cmp_real2 (val.imaginary,
 513                               ffebld_constant_complex2 (c->next).imaginary);
 514       if (cmp == 0)
 515         return c->next;
 516       if (cmp > 0)
 517         break;
 518     }
 519
 520   nc = malloc_new_kp (ffebld_constant_pool(),
 521                       "FFEBLD_constCOMPLEX2",
 522                       sizeof (*nc));
 523   nc->next = c->next;
 524   nc->consttype = FFEBLD_constCOMPLEX2;
 525   nc->u.complex2 = val;
 526   nc->hook = FFECOM_constantNULL;
 527   c->next = nc;
 528
 529   return nc;
 530 }
 531
 532 #endif
 533 /* ffebld_constant_new_hollerith -- Return hollerith constant object from token
 534
 535    See prototype.  */
 536
 537 ffebldConstant
 538 ffebld_constant_new_hollerith (ffelexToken t)
 539 {
 540   ffetargetHollerith val;
 541
 542   ffetarget_hollerith (&val, t, ffebld_constant_pool());
 543   return ffebld_constant_new_hollerith_val (val);
 544 }
 545
 546 /* ffebld_constant_new_hollerith_val -- Return an hollerith constant object
 547
 548    See prototype.  */
 549
 550 ffebldConstant
 551 ffebld_constant_new_hollerith_val (ffetargetHollerith val)
 552 {
 553   ffebldConstant c;
 554   ffebldConstant nc;
 555   int cmp;
 556
 557   for (c = (ffebldConstant) &ffebld_constant_hollerith_;
 558        c->next != NULL;
 559        c = c->next)
 560     {
 561       cmp = ffetarget_cmp_hollerith (val, ffebld_constant_hollerith (c->next));
 562       if (cmp == 0)
 563         return c->next;
 564       if (cmp > 0)
 565         break;
 566     }
 567
 568   nc = malloc_new_kp (ffebld_constant_pool(),
 569                       "FFEBLD_constHOLLERITH",
 570                       sizeof (*nc));
 571   nc->next = c->next;
 572   nc->consttype = FFEBLD_constHOLLERITH;
 573   nc->u.hollerith = val;
 574   nc->hook = FFECOM_constantNULL;
 575   c->next = nc;
 576
 577   return nc;
 578 }
 579
 580 /* ffebld_constant_new_integer1 -- Return integer1 constant object from token
 581
 582    See prototype.
 583
 584    Parses the token as a decimal integer constant, thus it must be an
 585    FFELEX_typeNUMBER.  */
 586
 587 #if FFETARGET_okINTEGER1
 588 ffebldConstant
 589 ffebld_constant_new_integer1 (ffelexToken t)
 590 {
 591   ffetargetInteger1 val;
 592
 593   assert (ffelex_token_type (t) == FFELEX_typeNUMBER);
 594
 595   ffetarget_integer1 (&val, t);
 596   return ffebld_constant_new_integer1_val (val);
 597 }
 598
 599 #endif
 600 /* ffebld_constant_new_integer1_val -- Return an integer1 constant object
 601
 602    See prototype.  */
 603
 604 #if FFETARGET_okINTEGER1
 605 ffebldConstant
 606 ffebld_constant_new_integer1_val (ffetargetInteger1 val)
 607 {
 608   ffebldConstant c;
 609   ffebldConstant nc;
 610   int cmp;
 611
 612   for (c = (ffebldConstant) &ffebld_constant_integer1_;
 613        c->next != NULL;
 614        c = c->next)
 615     {
 616       cmp = ffetarget_cmp_integer1 (val, ffebld_constant_integer1 (c->next));
 617       if (cmp == 0)
 618         return c->next;
 619       if (cmp > 0)
 620         break;
 621     }
 622
 623   nc = malloc_new_kp (ffebld_constant_pool(),
 624                       "FFEBLD_constINTEGER1",
 625                       sizeof (*nc));
 626   nc->next = c->next;
 627   nc->consttype = FFEBLD_constINTEGER1;
 628   nc->u.integer1 = val;
 629   nc->hook = FFECOM_constantNULL;
 630   c->next = nc;
 631
 632   return nc;
 633 }
 634
 635 #endif
 636 /* ffebld_constant_new_integer2_val -- Return an integer2 constant object
 637
 638    See prototype.  */
 639
 640 #if FFETARGET_okINTEGER2
 641 ffebldConstant
 642 ffebld_constant_new_integer2_val (ffetargetInteger2 val)
 643 {
 644   ffebldConstant c;
 645   ffebldConstant nc;
 646   int cmp;
 647
 648   for (c = (ffebldConstant) &ffebld_constant_integer2_;
 649        c->next != NULL;
 650        c = c->next)
 651     {
 652       cmp = ffetarget_cmp_integer2 (val, ffebld_constant_integer2 (c->next));
 653       if (cmp == 0)
 654         return c->next;
 655       if (cmp > 0)
 656         break;
 657     }
 658
 659   nc = malloc_new_kp (ffebld_constant_pool(),
 660                       "FFEBLD_constINTEGER2",
 661                       sizeof (*nc));
 662   nc->next = c->next;
 663   nc->consttype = FFEBLD_constINTEGER2;
 664   nc->u.integer2 = val;
 665   nc->hook = FFECOM_constantNULL;
 666   c->next = nc;
 667
 668   return nc;
 669 }
 670
 671 #endif
 672 /* ffebld_constant_new_integer3_val -- Return an integer3 constant object
 673
 674    See prototype.  */
 675
 676 #if FFETARGET_okINTEGER3
 677 ffebldConstant
 678 ffebld_constant_new_integer3_val (ffetargetInteger3 val)
 679 {
 680   ffebldConstant c;
 681   ffebldConstant nc;
 682   int cmp;
 683
 684   for (c = (ffebldConstant) &ffebld_constant_integer3_;
 685        c->next != NULL;
 686        c = c->next)
 687     {
 688       cmp = ffetarget_cmp_integer3 (val, ffebld_constant_integer3 (c->next));
 689       if (cmp == 0)
 690         return c->next;
 691       if (cmp > 0)
 692         break;
 693     }
 694
 695   nc = malloc_new_kp (ffebld_constant_pool(),
 696                       "FFEBLD_constINTEGER3",
 697                       sizeof (*nc));
 698   nc->next = c->next;
 699   nc->consttype = FFEBLD_constINTEGER3;
 700   nc->u.integer3 = val;
 701   nc->hook = FFECOM_constantNULL;
 702   c->next = nc;
 703
 704   return nc;
 705 }
 706
 707 #endif
 708 /* ffebld_constant_new_integer4_val -- Return an integer4 constant object
 709
 710    See prototype.  */
 711
 712 #if FFETARGET_okINTEGER4
 713 ffebldConstant
 714 ffebld_constant_new_integer4_val (ffetargetInteger4 val)
 715 {
 716   ffebldConstant c;
 717   ffebldConstant nc;
 718   int cmp;
 719
 720   for (c = (ffebldConstant) &ffebld_constant_integer4_;
 721        c->next != NULL;
 722        c = c->next)
 723     {
 724       cmp = ffetarget_cmp_integer4 (val, ffebld_constant_integer4 (c->next));
 725       if (cmp == 0)
 726         return c->next;
 727       if (cmp > 0)
 728         break;
 729     }
 730
 731   nc = malloc_new_kp (ffebld_constant_pool(),
 732                       "FFEBLD_constINTEGER4",
 733                       sizeof (*nc));
 734   nc->next = c->next;
 735   nc->consttype = FFEBLD_constINTEGER4;
 736   nc->u.integer4 = val;
 737   nc->hook = FFECOM_constantNULL;
 738   c->next = nc;
 739
 740   return nc;
 741 }
 742
 743 #endif
 744 /* ffebld_constant_new_integerbinary -- Return binary constant object from token
 745
 746    See prototype.
 747
 748    Parses the token as a binary integer constant, thus it must be an
 749    FFELEX_typeNUMBER.  */
 750
 751 ffebldConstant
 752 ffebld_constant_new_integerbinary (ffelexToken t)
 753 {
 754   ffetargetIntegerDefault val;
 755
 756   assert ((ffelex_token_type (t) == FFELEX_typeNAME)
 757           || (ffelex_token_type (t) == FFELEX_typeNUMBER));
 758
 759   ffetarget_integerbinary (&val, t);
 760   return ffebld_constant_new_integerdefault_val (val);
 761 }
 762
 763 /* ffebld_constant_new_integerhex -- Return hex constant object from token
 764
 765    See prototype.
 766
 767    Parses the token as a hex integer constant, thus it must be an
 768    FFELEX_typeNUMBER.  */
 769
 770 ffebldConstant
 771 ffebld_constant_new_integerhex (ffelexToken t)
 772 {
 773   ffetargetIntegerDefault val;
 774
 775   assert ((ffelex_token_type (t) == FFELEX_typeNAME)
 776           || (ffelex_token_type (t) == FFELEX_typeNUMBER));
 777
 778   ffetarget_integerhex (&val, t);
 779   return ffebld_constant_new_integerdefault_val (val);
 780 }
 781
 782 /* ffebld_constant_new_integeroctal -- Return octal constant object from token
 783
 784    See prototype.
 785
 786    Parses the token as a octal integer constant, thus it must be an
 787    FFELEX_typeNUMBER.  */
 788
 789 ffebldConstant
 790 ffebld_constant_new_integeroctal (ffelexToken t)
 791 {
 792   ffetargetIntegerDefault val;
 793
 794   assert ((ffelex_token_type (t) == FFELEX_typeNAME)
 795           || (ffelex_token_type (t) == FFELEX_typeNUMBER));
 796
 797   ffetarget_integeroctal (&val, t);
 798   return ffebld_constant_new_integerdefault_val (val);
 799 }
 800
 801 /* ffebld_constant_new_logical1 -- Return logical1 constant object from token
 802
 803    See prototype.
 804
 805    Parses the token as a decimal logical constant, thus it must be an
 806    FFELEX_typeNUMBER.  */
 807
 808 #if FFETARGET_okLOGICAL1
 809 ffebldConstant
 810 ffebld_constant_new_logical1 (bool truth)
 811 {
 812   ffetargetLogical1 val;
 813
 814   ffetarget_logical1 (&val, truth);
 815   return ffebld_constant_new_logical1_val (val);
 816 }
 817
 818 #endif
 819 /* ffebld_constant_new_logical1_val -- Return a logical1 constant object
 820
 821    See prototype.  */
 822
 823 #if FFETARGET_okLOGICAL1
 824 ffebldConstant
 825 ffebld_constant_new_logical1_val (ffetargetLogical1 val)
 826 {
 827   ffebldConstant c;
 828   ffebldConstant nc;
 829   int cmp;
 830
 831   for (c = (ffebldConstant) &ffebld_constant_logical1_;
 832        c->next != NULL;
 833        c = c->next)
 834     {
 835       cmp = ffetarget_cmp_logical1 (val, ffebld_constant_logical1 (c->next));
 836       if (cmp == 0)
 837         return c->next;
 838       if (cmp > 0)
 839         break;
 840     }
 841
 842   nc = malloc_new_kp (ffebld_constant_pool(),
 843                       "FFEBLD_constLOGICAL1",
 844                       sizeof (*nc));
 845   nc->next = c->next;
 846   nc->consttype = FFEBLD_constLOGICAL1;
 847   nc->u.logical1 = val;
 848   nc->hook = FFECOM_constantNULL;
 849   c->next = nc;
 850
 851   return nc;
 852 }
 853
 854 #endif
 855 /* ffebld_constant_new_logical2_val -- Return a logical2 constant object
 856
 857    See prototype.  */
 858
 859 #if FFETARGET_okLOGICAL2
 860 ffebldConstant
 861 ffebld_constant_new_logical2_val (ffetargetLogical2 val)
 862 {
 863   ffebldConstant c;
 864   ffebldConstant nc;
 865   int cmp;
 866
 867   for (c = (ffebldConstant) &ffebld_constant_logical2_;
 868        c->next != NULL;
 869        c = c->next)
 870     {
 871       cmp = ffetarget_cmp_logical2 (val, ffebld_constant_logical2 (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_constLOGICAL2",
 880                       sizeof (*nc));
 881   nc->next = c->next;
 882   nc->consttype = FFEBLD_constLOGICAL2;
 883   nc->u.logical2 = val;
 884   nc->hook = FFECOM_constantNULL;
 885   c->next = nc;
 886
 887   return nc;
 888 }
 889
 890 #endif
 891 /* ffebld_constant_new_logical3_val -- Return a logical3 constant object
 892
 893    See prototype.  */
 894
 895 #if FFETARGET_okLOGICAL3
 896 ffebldConstant
 897 ffebld_constant_new_logical3_val (ffetargetLogical3 val)
 898 {
 899   ffebldConstant c;
 900   ffebldConstant nc;
 901   int cmp;
 902
 903   for (c = (ffebldConstant) &ffebld_constant_logical3_;
 904        c->next != NULL;
 905        c = c->next)
 906     {
 907       cmp = ffetarget_cmp_logical3 (val, ffebld_constant_logical3 (c->next));
 908       if (cmp == 0)
 909         return c->next;
 910       if (cmp > 0)
 911         break;
 912     }
 913
 914   nc = malloc_new_kp (ffebld_constant_pool(),
 915                       "FFEBLD_constLOGICAL3",
 916                       sizeof (*nc));
 917   nc->next = c->next;
 918   nc->consttype = FFEBLD_constLOGICAL3;
 919   nc->u.logical3 = val;
 920   nc->hook = FFECOM_constantNULL;
 921   c->next = nc;
 922
 923   return nc;
 924 }
 925
 926 #endif
 927 /* ffebld_constant_new_logical4_val -- Return a logical4 constant object
 928
 929    See prototype.  */
 930
 931 #if FFETARGET_okLOGICAL4
 932 ffebldConstant
 933 ffebld_constant_new_logical4_val (ffetargetLogical4 val)
 934 {
 935   ffebldConstant c;
 936   ffebldConstant nc;
 937   int cmp;
 938
 939   for (c = (ffebldConstant) &ffebld_constant_logical4_;
 940        c->next != NULL;
 941        c = c->next)
 942     {
 943       cmp = ffetarget_cmp_logical4 (val, ffebld_constant_logical4 (c->next));
 944       if (cmp == 0)
 945         return c->next;
 946       if (cmp > 0)
 947         break;
 948     }
 949
 950   nc = malloc_new_kp (ffebld_constant_pool(),
 951                       "FFEBLD_constLOGICAL4",
 952                       sizeof (*nc));
 953   nc->next = c->next;
 954   nc->consttype = FFEBLD_constLOGICAL4;
 955   nc->u.logical4 = val;
 956   nc->hook = FFECOM_constantNULL;
 957   c->next = nc;
 958
 959   return nc;
 960 }
 961
 962 #endif
 963 /* ffebld_constant_new_real1 -- Return real1 constant object from token
 964
 965    See prototype.  */
 966
 967 #if FFETARGET_okREAL1
 968 ffebldConstant
 969 ffebld_constant_new_real1 (ffelexToken integer, ffelexToken decimal,
 970       ffelexToken fraction, ffelexToken exponent, ffelexToken exponent_sign,
 971                            ffelexToken exponent_digits)
 972 {
 973   ffetargetReal1 val;
 974
 975   ffetarget_real1 (&val,
 976       integer, decimal, fraction, exponent, exponent_sign, exponent_digits);
 977   return ffebld_constant_new_real1_val (val);
 978 }
 979
 980 #endif
 981 /* ffebld_constant_new_real1_val -- Return an real1 constant object
 982
 983    See prototype.  */
 984
 985 #if FFETARGET_okREAL1
 986 ffebldConstant
 987 ffebld_constant_new_real1_val (ffetargetReal1 val)
 988 {
 989   ffebldConstant c;
 990   ffebldConstant nc;
 991   int cmp;
 992
 993   for (c = (ffebldConstant) &ffebld_constant_real1_;
 994        c->next != NULL;
 995        c = c->next)
 996     {
 997       cmp = ffetarget_cmp_real1 (val, ffebld_constant_real1 (c->next));
 998       if (cmp == 0)
 999         return c->next;
1000       if (cmp > 0)
1001         break;
1002     }
1003
1004   nc = malloc_new_kp (ffebld_constant_pool(),
1005                       "FFEBLD_constREAL1",
1006                       sizeof (*nc));
1007   nc->next = c->next;
1008   nc->consttype = FFEBLD_constREAL1;
1009   nc->u.real1 = val;
1010   nc->hook = FFECOM_constantNULL;
1011   c->next = nc;
1012
1013   return nc;
1014 }
1015
1016 #endif
1017 /* ffebld_constant_new_real2 -- Return real2 constant object from token
1018
1019    See prototype.  */
1020
1021 #if FFETARGET_okREAL2
1022 ffebldConstant
1023 ffebld_constant_new_real2 (ffelexToken integer, ffelexToken decimal,
1024       ffelexToken fraction, ffelexToken exponent, ffelexToken exponent_sign,
1025                            ffelexToken exponent_digits)
1026 {
1027   ffetargetReal2 val;
1028
1029   ffetarget_real2 (&val,
1030       integer, decimal, fraction, exponent, exponent_sign, exponent_digits);
1031   return ffebld_constant_new_real2_val (val);
1032 }
1033
1034 #endif
1035 /* ffebld_constant_new_real2_val -- Return an real2 constant object
1036
1037    See prototype.  */
1038
1039 #if FFETARGET_okREAL2
1040 ffebldConstant
1041 ffebld_constant_new_real2_val (ffetargetReal2 val)
1042 {
1043   ffebldConstant c;
1044   ffebldConstant nc;
1045   int cmp;
1046
1047   for (c = (ffebldConstant) &ffebld_constant_real2_;
1048        c->next != NULL;
1049        c = c->next)
1050     {
1051       cmp = ffetarget_cmp_real2 (val, ffebld_constant_real2 (c->next));
1052       if (cmp == 0)
1053         return c->next;
1054       if (cmp > 0)
1055         break;
1056     }
1057
1058   nc = malloc_new_kp (ffebld_constant_pool(),
1059                       "FFEBLD_constREAL2",
1060                       sizeof (*nc));
1061   nc->next = c->next;
1062   nc->consttype = FFEBLD_constREAL2;
1063   nc->u.real2 = val;
1064   nc->hook = FFECOM_constantNULL;
1065   c->next = nc;
1066
1067   return nc;
1068 }
1069
1070 #endif
1071 /* ffebld_constant_new_typeless_bm -- Return typeless constant object from token
1072
1073    See prototype.
1074
1075    Parses the token as a decimal integer constant, thus it must be an
1076    FFELEX_typeNUMBER.  */
1077
1078 ffebldConstant
1079 ffebld_constant_new_typeless_bm (ffelexToken t)
1080 {
1081   ffetargetTypeless val;
1082
1083   ffetarget_binarymil (&val, t);
1084   return ffebld_constant_new_typeless_val (FFEBLD_constBINARY_MIL, val);
1085 }
1086
1087 /* ffebld_constant_new_typeless_bv -- Return typeless constant object from token
1088
1089    See prototype.
1090
1091    Parses the token as a decimal integer constant, thus it must be an
1092    FFELEX_typeNUMBER.  */
1093
1094 ffebldConstant
1095 ffebld_constant_new_typeless_bv (ffelexToken t)
1096 {
1097   ffetargetTypeless val;
1098
1099   ffetarget_binaryvxt (&val, t);
1100   return ffebld_constant_new_typeless_val (FFEBLD_constBINARY_VXT, val);
1101 }
1102
1103 /* ffebld_constant_new_typeless_hxm -- Return typeless constant object from token
1104
1105    See prototype.
1106
1107    Parses the token as a decimal integer constant, thus it must be an
1108    FFELEX_typeNUMBER.  */
1109
1110 ffebldConstant
1111 ffebld_constant_new_typeless_hxm (ffelexToken t)
1112 {
1113   ffetargetTypeless val;
1114
1115   ffetarget_hexxmil (&val, t);
1116   return ffebld_constant_new_typeless_val (FFEBLD_constHEX_X_MIL, val);
1117 }
1118
1119 /* ffebld_constant_new_typeless_hxv -- Return typeless constant object from token
1120
1121    See prototype.
1122
1123    Parses the token as a decimal integer constant, thus it must be an
1124    FFELEX_typeNUMBER.  */
1125
1126 ffebldConstant
1127 ffebld_constant_new_typeless_hxv (ffelexToken t)
1128 {
1129   ffetargetTypeless val;
1130
1131   ffetarget_hexxvxt (&val, t);
1132   return ffebld_constant_new_typeless_val (FFEBLD_constHEX_X_VXT, val);
1133 }
1134
1135 /* ffebld_constant_new_typeless_hzm -- Return typeless constant object from token
1136
1137    See prototype.
1138
1139    Parses the token as a decimal integer constant, thus it must be an
1140    FFELEX_typeNUMBER.  */
1141
1142 ffebldConstant
1143 ffebld_constant_new_typeless_hzm (ffelexToken t)
1144 {
1145   ffetargetTypeless val;
1146
1147   ffetarget_hexzmil (&val, t);
1148   return ffebld_constant_new_typeless_val (FFEBLD_constHEX_Z_MIL, val);
1149 }
1150
1151 /* ffebld_constant_new_typeless_hzv -- Return typeless constant object from token
1152
1153    See prototype.
1154
1155    Parses the token as a decimal integer constant, thus it must be an
1156    FFELEX_typeNUMBER.  */
1157
1158 ffebldConstant
1159 ffebld_constant_new_typeless_hzv (ffelexToken t)
1160 {
1161   ffetargetTypeless val;
1162
1163   ffetarget_hexzvxt (&val, t);
1164   return ffebld_constant_new_typeless_val (FFEBLD_constHEX_Z_VXT, val);
1165 }
1166
1167 /* ffebld_constant_new_typeless_om -- Return typeless constant object from token
1168
1169    See prototype.
1170
1171    Parses the token as a decimal integer constant, thus it must be an
1172    FFELEX_typeNUMBER.  */
1173
1174 ffebldConstant
1175 ffebld_constant_new_typeless_om (ffelexToken t)
1176 {
1177   ffetargetTypeless val;
1178
1179   ffetarget_octalmil (&val, t);
1180   return ffebld_constant_new_typeless_val (FFEBLD_constOCTAL_MIL, val);
1181 }
1182
1183 /* ffebld_constant_new_typeless_ov -- Return typeless constant object from token
1184
1185    See prototype.
1186
1187    Parses the token as a decimal integer constant, thus it must be an
1188    FFELEX_typeNUMBER.  */
1189
1190 ffebldConstant
1191 ffebld_constant_new_typeless_ov (ffelexToken t)
1192 {
1193   ffetargetTypeless val;
1194
1195   ffetarget_octalvxt (&val, t);
1196   return ffebld_constant_new_typeless_val (FFEBLD_constOCTAL_VXT, val);
1197 }
1198
1199 /* ffebld_constant_new_typeless_val -- Return a typeless constant object
1200
1201    See prototype.  */
1202
1203 ffebldConstant
1204 ffebld_constant_new_typeless_val (ffebldConst type, ffetargetTypeless val)
1205 {
1206   ffebldConstant c;
1207   ffebldConstant nc;
1208   int cmp;
1209
1210   for (c = (ffebldConstant) &ffebld_constant_typeless_[type
1211                                               - FFEBLD_constTYPELESS_FIRST];
1212        c->next != NULL;
1213        c = c->next)
1214     {
1215       cmp = ffetarget_cmp_typeless (val, ffebld_constant_typeless (c->next));
1216       if (cmp == 0)
1217         return c->next;
1218       if (cmp > 0)
1219         break;
1220     }
1221
1222   nc = malloc_new_kp (ffebld_constant_pool(),
1223                       "FFEBLD_constTYPELESS",
1224                       sizeof (*nc));
1225   nc->next = c->next;
1226   nc->consttype = type;
1227   nc->u.typeless = val;
1228   nc->hook = FFECOM_constantNULL;
1229   c->next = nc;
1230
1231   return nc;
1232 }
1233
1234 /* ffebld_constantarray_get -- Get a value from an array of constants
1235
1236    See prototype.  */
1237
1238 ffebldConstantUnion
1239 ffebld_constantarray_get (ffebldConstantArray array, ffeinfoBasictype bt,
1240                           ffeinfoKindtype kt, ffetargetOffset offset)
1241 {
1242   ffebldConstantUnion u;
1243
1244   switch (bt)
1245     {
1246     case FFEINFO_basictypeINTEGER:
1247       switch (kt)
1248         {
1249 #if FFETARGET_okINTEGER1
1250         case FFEINFO_kindtypeINTEGER1:
1251           u.integer1 = *(array.integer1 + offset);
1252           break;
1253 #endif
1254
1255 #if FFETARGET_okINTEGER2
1256         case FFEINFO_kindtypeINTEGER2:
1257           u.integer2 = *(array.integer2 + offset);
1258           break;
1259 #endif
1260
1261 #if FFETARGET_okINTEGER3
1262         case FFEINFO_kindtypeINTEGER3:
1263           u.integer3 = *(array.integer3 + offset);
1264           break;
1265 #endif
1266
1267 #if FFETARGET_okINTEGER4
1268         case FFEINFO_kindtypeINTEGER4:
1269           u.integer4 = *(array.integer4 + offset);
1270           break;
1271 #endif
1272
1273         default:
1274           assert ("bad INTEGER kindtype" == NULL);
1275           break;
1276         }
1277       break;
1278
1279     case FFEINFO_basictypeLOGICAL:
1280       switch (kt)
1281         {
1282 #if FFETARGET_okLOGICAL1
1283         case FFEINFO_kindtypeLOGICAL1:
1284           u.logical1 = *(array.logical1 + offset);
1285           break;
1286 #endif
1287
1288 #if FFETARGET_okLOGICAL2
1289         case FFEINFO_kindtypeLOGICAL2:
1290           u.logical2 = *(array.logical2 + offset);
1291           break;
1292 #endif
1293
1294 #if FFETARGET_okLOGICAL3
1295         case FFEINFO_kindtypeLOGICAL3:
1296           u.logical3 = *(array.logical3 + offset);
1297           break;
1298 #endif
1299
1300 #if FFETARGET_okLOGICAL4
1301         case FFEINFO_kindtypeLOGICAL4:
1302           u.logical4 = *(array.logical4 + offset);
1303           break;
1304 #endif
1305
1306         default:
1307           assert ("bad LOGICAL kindtype" == NULL);
1308           break;
1309         }
1310       break;
1311
1312     case FFEINFO_basictypeREAL:
1313       switch (kt)
1314         {
1315 #if FFETARGET_okREAL1
1316         case FFEINFO_kindtypeREAL1:
1317           u.real1 = *(array.real1 + offset);
1318           break;
1319 #endif
1320
1321 #if FFETARGET_okREAL2
1322         case FFEINFO_kindtypeREAL2:
1323           u.real2 = *(array.real2 + offset);
1324           break;
1325 #endif
1326
1327 #if FFETARGET_okREAL3
1328         case FFEINFO_kindtypeREAL3:
1329           u.real3 = *(array.real3 + offset);
1330           break;
1331 #endif
1332
1333         default:
1334           assert ("bad REAL kindtype" == NULL);
1335           break;
1336         }
1337       break;
1338
1339     case FFEINFO_basictypeCOMPLEX:
1340       switch (kt)
1341         {
1342 #if FFETARGET_okCOMPLEX1
1343         case FFEINFO_kindtypeREAL1:
1344           u.complex1 = *(array.complex1 + offset);
1345           break;
1346 #endif
1347
1348 #if FFETARGET_okCOMPLEX2
1349         case FFEINFO_kindtypeREAL2:
1350           u.complex2 = *(array.complex2 + offset);
1351           break;
1352 #endif
1353
1354 #if FFETARGET_okCOMPLEX3
1355         case FFEINFO_kindtypeREAL3:
1356           u.complex3 = *(array.complex3 + offset);
1357           break;
1358 #endif
1359
1360         default:
1361           assert ("bad COMPLEX kindtype" == NULL);
1362           break;
1363         }
1364       break;
1365
1366     case FFEINFO_basictypeCHARACTER:
1367       switch (kt)
1368         {
1369 #if FFETARGET_okCHARACTER1
1370         case FFEINFO_kindtypeCHARACTER1:
1371           u.character1.length = 1;
1372           u.character1.text = array.character1 + offset;
1373           break;
1374 #endif
1375
1376         default:
1377           assert ("bad CHARACTER kindtype" == NULL);
1378           break;
1379         }
1380       break;
1381
1382     default:
1383       assert ("bad basictype" == NULL);
1384       break;
1385     }
1386
1387   return u;
1388 }
1389
1390 /* ffebld_constantarray_new -- Make an array of constants
1391
1392    See prototype.  */
1393
1394 ffebldConstantArray
1395 ffebld_constantarray_new (ffeinfoBasictype bt,
1396                           ffeinfoKindtype kt, ffetargetOffset size)
1397 {
1398   ffebldConstantArray ptr;
1399
1400   switch (bt)
1401     {
1402     case FFEINFO_basictypeINTEGER:
1403       switch (kt)
1404         {
1405 #if FFETARGET_okINTEGER1
1406         case FFEINFO_kindtypeINTEGER1:
1407           ptr.integer1 = malloc_new_zkp (ffebld_constant_pool(),
1408                                          "ffebldConstantArray",
1409                                          size *= sizeof (ffetargetInteger1),
1410                                          0);
1411           break;
1412 #endif
1413
1414 #if FFETARGET_okINTEGER2
1415         case FFEINFO_kindtypeINTEGER2:
1416           ptr.integer2 = malloc_new_zkp (ffebld_constant_pool(),
1417                                          "ffebldConstantArray",
1418                                          size *= sizeof (ffetargetInteger2),
1419                                          0);
1420           break;
1421 #endif
1422
1423 #if FFETARGET_okINTEGER3
1424         case FFEINFO_kindtypeINTEGER3:
1425           ptr.integer3 = malloc_new_zkp (ffebld_constant_pool(),
1426                                          "ffebldConstantArray",
1427                                          size *= sizeof (ffetargetInteger3),
1428                                          0);
1429           break;
1430 #endif
1431
1432 #if FFETARGET_okINTEGER4
1433         case FFEINFO_kindtypeINTEGER4:
1434           ptr.integer4 = malloc_new_zkp (ffebld_constant_pool(),
1435                                          "ffebldConstantArray",
1436                                          size *= sizeof (ffetargetInteger4),
1437                                          0);
1438           break;
1439 #endif
1440
1441         default:
1442           assert ("bad INTEGER kindtype" == NULL);
1443           break;
1444         }
1445       break;
1446
1447     case FFEINFO_basictypeLOGICAL:
1448       switch (kt)
1449         {
1450 #if FFETARGET_okLOGICAL1
1451         case FFEINFO_kindtypeLOGICAL1:
1452           ptr.logical1 = malloc_new_zkp (ffebld_constant_pool(),
1453                                          "ffebldConstantArray",
1454                                          size *= sizeof (ffetargetLogical1),
1455                                          0);
1456           break;
1457 #endif
1458
1459 #if FFETARGET_okLOGICAL2
1460         case FFEINFO_kindtypeLOGICAL2:
1461           ptr.logical2 = malloc_new_zkp (ffebld_constant_pool(),
1462                                          "ffebldConstantArray",
1463                                          size *= sizeof (ffetargetLogical2),
1464                                          0);
1465           break;
1466 #endif
1467
1468 #if FFETARGET_okLOGICAL3
1469         case FFEINFO_kindtypeLOGICAL3:
1470           ptr.logical3 = malloc_new_zkp (ffebld_constant_pool(),
1471                                          "ffebldConstantArray",
1472                                          size *= sizeof (ffetargetLogical3),
1473                                          0);
1474           break;
1475 #endif
1476
1477 #if FFETARGET_okLOGICAL4
1478         case FFEINFO_kindtypeLOGICAL4:
1479           ptr.logical4 = malloc_new_zkp (ffebld_constant_pool(),
1480                                          "ffebldConstantArray",
1481                                          size *= sizeof (ffetargetLogical4),
1482                                          0);
1483           break;
1484 #endif
1485
1486         default:
1487           assert ("bad LOGICAL kindtype" == NULL);
1488           break;
1489         }
1490       break;
1491
1492     case FFEINFO_basictypeREAL:
1493       switch (kt)
1494         {
1495 #if FFETARGET_okREAL1
1496         case FFEINFO_kindtypeREAL1:
1497           ptr.real1 = malloc_new_zkp (ffebld_constant_pool(),
1498                                       "ffebldConstantArray",
1499                                       size *= sizeof (ffetargetReal1),
1500                                       0);
1501           break;
1502 #endif
1503
1504 #if FFETARGET_okREAL2
1505         case FFEINFO_kindtypeREAL2:
1506           ptr.real2 = malloc_new_zkp (ffebld_constant_pool(),
1507                                       "ffebldConstantArray",
1508                                       size *= sizeof (ffetargetReal2),
1509                                       0);
1510           break;
1511 #endif
1512
1513 #if FFETARGET_okREAL3
1514         case FFEINFO_kindtypeREAL3:
1515           ptr.real3 = malloc_new_zkp (ffebld_constant_pool(),
1516                                       "ffebldConstantArray",
1517                                       size *= sizeof (ffetargetReal3),
1518                                       0);
1519           break;
1520 #endif
1521
1522         default:
1523           assert ("bad REAL kindtype" == NULL);
1524           break;
1525         }
1526       break;
1527
1528     case FFEINFO_basictypeCOMPLEX:
1529       switch (kt)
1530         {
1531 #if FFETARGET_okCOMPLEX1
1532         case FFEINFO_kindtypeREAL1:
1533           ptr.complex1 = malloc_new_zkp (ffebld_constant_pool(),
1534                                          "ffebldConstantArray",
1535                                          size *= sizeof (ffetargetComplex1),
1536                                          0);
1537           break;
1538 #endif
1539
1540 #if FFETARGET_okCOMPLEX2
1541         case FFEINFO_kindtypeREAL2:
1542           ptr.complex2 = malloc_new_zkp (ffebld_constant_pool(),
1543                                          "ffebldConstantArray",
1544                                          size *= sizeof (ffetargetComplex2),
1545                                          0);
1546           break;
1547 #endif
1548
1549 #if FFETARGET_okCOMPLEX3
1550         case FFEINFO_kindtypeREAL3:
1551           ptr.complex3 = malloc_new_zkp (ffebld_constant_pool(),
1552                                          "ffebldConstantArray",
1553                                          size *= sizeof (ffetargetComplex3),
1554                                          0);
1555           break;
1556 #endif
1557
1558         default:
1559           assert ("bad COMPLEX kindtype" == NULL);
1560           break;
1561         }
1562       break;
1563
1564     case FFEINFO_basictypeCHARACTER:
1565       switch (kt)
1566         {
1567 #if FFETARGET_okCHARACTER1
1568         case FFEINFO_kindtypeCHARACTER1:
1569           ptr.character1 = malloc_new_zkp (ffebld_constant_pool(),
1570                                            "ffebldConstantArray",
1571                                            size
1572                                            *= sizeof (ffetargetCharacterUnit1),
1573                                            0);
1574           break;
1575 #endif
1576
1577         default:
1578           assert ("bad CHARACTER kindtype" == NULL);
1579           break;
1580         }
1581       break;
1582
1583     default:
1584       assert ("bad basictype" == NULL);
1585       break;
1586     }
1587
1588   return ptr;
1589 }
1590
1591 /* ffebld_constantarray_preparray -- Prepare for copy between arrays
1592
1593    See prototype.
1594
1595    Like _prepare, but the source is an array instead of a single-value
1596    constant.  */
1597
1598 void
1599 ffebld_constantarray_preparray (void **aptr, void **cptr, size_t *size,
1600        ffebldConstantArray array, ffeinfoBasictype abt, ffeinfoKindtype akt,
1601                    ffetargetOffset offset, ffebldConstantArray source_array,
1602                                 ffeinfoBasictype cbt, ffeinfoKindtype ckt)
1603 {
1604   switch (abt)
1605     {
1606     case FFEINFO_basictypeINTEGER:
1607       switch (akt)
1608         {
1609 #if FFETARGET_okINTEGER1
1610         case FFEINFO_kindtypeINTEGER1:
1611           *aptr = array.integer1 + offset;
1612           break;
1613 #endif
1614
1615 #if FFETARGET_okINTEGER2
1616         case FFEINFO_kindtypeINTEGER2:
1617           *aptr = array.integer2 + offset;
1618           break;
1619 #endif
1620
1621 #if FFETARGET_okINTEGER3
1622         case FFEINFO_kindtypeINTEGER3:
1623           *aptr = array.integer3 + offset;
1624           break;
1625 #endif
1626
1627 #if FFETARGET_okINTEGER4
1628         case FFEINFO_kindtypeINTEGER4:
1629           *aptr = array.integer4 + offset;
1630           break;
1631 #endif
1632
1633         default:
1634           assert ("bad INTEGER akindtype" == NULL);
1635           break;
1636         }
1637       break;
1638
1639     case FFEINFO_basictypeLOGICAL:
1640       switch (akt)
1641         {
1642 #if FFETARGET_okLOGICAL1
1643         case FFEINFO_kindtypeLOGICAL1:
1644           *aptr = array.logical1 + offset;
1645           break;
1646 #endif
1647
1648 #if FFETARGET_okLOGICAL2
1649         case FFEINFO_kindtypeLOGICAL2:
1650           *aptr = array.logical2 + offset;
1651           break;
1652 #endif
1653
1654 #if FFETARGET_okLOGICAL3
1655         case FFEINFO_kindtypeLOGICAL3:
1656           *aptr = array.logical3 + offset;
1657           break;
1658 #endif
1659
1660 #if FFETARGET_okLOGICAL4
1661         case FFEINFO_kindtypeLOGICAL4:
1662           *aptr = array.logical4 + offset;
1663           break;
1664 #endif
1665
1666         default:
1667           assert ("bad LOGICAL akindtype" == NULL);
1668           break;
1669         }
1670       break;
1671
1672     case FFEINFO_basictypeREAL:
1673       switch (akt)
1674         {
1675 #if FFETARGET_okREAL1
1676         case FFEINFO_kindtypeREAL1:
1677           *aptr = array.real1 + offset;
1678           break;
1679 #endif
1680
1681 #if FFETARGET_okREAL2
1682         case FFEINFO_kindtypeREAL2:
1683           *aptr = array.real2 + offset;
1684           break;
1685 #endif
1686
1687 #if FFETARGET_okREAL3
1688         case FFEINFO_kindtypeREAL3:
1689           *aptr = array.real3 + offset;
1690           break;
1691 #endif
1692
1693         default:
1694           assert ("bad REAL akindtype" == NULL);
1695           break;
1696         }
1697       break;
1698
1699     case FFEINFO_basictypeCOMPLEX:
1700       switch (akt)
1701         {
1702 #if FFETARGET_okCOMPLEX1
1703         case FFEINFO_kindtypeREAL1:
1704           *aptr = array.complex1 + offset;
1705           break;
1706 #endif
1707
1708 #if FFETARGET_okCOMPLEX2
1709         case FFEINFO_kindtypeREAL2:
1710           *aptr = array.complex2 + offset;
1711           break;
1712 #endif
1713
1714 #if FFETARGET_okCOMPLEX3
1715         case FFEINFO_kindtypeREAL3:
1716           *aptr = array.complex3 + offset;
1717           break;
1718 #endif
1719
1720         default:
1721           assert ("bad COMPLEX akindtype" == NULL);
1722           break;
1723         }
1724       break;
1725
1726     case FFEINFO_basictypeCHARACTER:
1727       switch (akt)
1728         {
1729 #if FFETARGET_okCHARACTER1
1730         case FFEINFO_kindtypeCHARACTER1:
1731           *aptr = array.character1 + offset;
1732           break;
1733 #endif
1734
1735         default:
1736           assert ("bad CHARACTER akindtype" == NULL);
1737           break;
1738         }
1739       break;
1740
1741     default:
1742       assert ("bad abasictype" == NULL);
1743       break;
1744     }
1745
1746   switch (cbt)
1747     {
1748     case FFEINFO_basictypeINTEGER:
1749       switch (ckt)
1750         {
1751 #if FFETARGET_okINTEGER1
1752         case FFEINFO_kindtypeINTEGER1:
1753           *cptr = source_array.integer1;
1754           *size = sizeof (*source_array.integer1);
1755           break;
1756 #endif
1757
1758 #if FFETARGET_okINTEGER2
1759         case FFEINFO_kindtypeINTEGER2:
1760           *cptr = source_array.integer2;
1761           *size = sizeof (*source_array.integer2);
1762           break;
1763 #endif
1764
1765 #if FFETARGET_okINTEGER3
1766         case FFEINFO_kindtypeINTEGER3:
1767           *cptr = source_array.integer3;
1768           *size = sizeof (*source_array.integer3);
1769           break;
1770 #endif
1771
1772 #if FFETARGET_okINTEGER4
1773         case FFEINFO_kindtypeINTEGER4:
1774           *cptr = source_array.integer4;
1775           *size = sizeof (*source_array.integer4);
1776           break;
1777 #endif
1778
1779         default:
1780           assert ("bad INTEGER ckindtype" == NULL);
1781           break;
1782         }
1783       break;
1784
1785     case FFEINFO_basictypeLOGICAL:
1786       switch (ckt)
1787         {
1788 #if FFETARGET_okLOGICAL1
1789         case FFEINFO_kindtypeLOGICAL1:
1790           *cptr = source_array.logical1;
1791           *size = sizeof (*source_array.logical1);
1792           break;
1793 #endif
1794
1795 #if FFETARGET_okLOGICAL2
1796         case FFEINFO_kindtypeLOGICAL2:
1797           *cptr = source_array.logical2;
1798           *size = sizeof (*source_array.logical2);
1799           break;
1800 #endif
1801
1802 #if FFETARGET_okLOGICAL3
1803         case FFEINFO_kindtypeLOGICAL3:
1804           *cptr = source_array.logical3;
1805           *size = sizeof (*source_array.logical3);
1806           break;
1807 #endif
1808
1809 #if FFETARGET_okLOGICAL4
1810         case FFEINFO_kindtypeLOGICAL4:
1811           *cptr = source_array.logical4;
1812           *size = sizeof (*source_array.logical4);
1813           break;
1814 #endif
1815
1816         default:
1817           assert ("bad LOGICAL ckindtype" == NULL);
1818           break;
1819         }
1820       break;
1821
1822     case FFEINFO_basictypeREAL:
1823       switch (ckt)
1824         {
1825 #if FFETARGET_okREAL1
1826         case FFEINFO_kindtypeREAL1:
1827           *cptr = source_array.real1;
1828           *size = sizeof (*source_array.real1);
1829           break;
1830 #endif
1831
1832 #if FFETARGET_okREAL2
1833         case FFEINFO_kindtypeREAL2:
1834           *cptr = source_array.real2;
1835           *size = sizeof (*source_array.real2);
1836           break;
1837 #endif
1838
1839 #if FFETARGET_okREAL3
1840         case FFEINFO_kindtypeREAL3:
1841           *cptr = source_array.real3;
1842           *size = sizeof (*source_array.real3);
1843           break;
1844 #endif
1845
1846         default:
1847           assert ("bad REAL ckindtype" == NULL);
1848           break;
1849         }
1850       break;
1851
1852     case FFEINFO_basictypeCOMPLEX:
1853       switch (ckt)
1854         {
1855 #if FFETARGET_okCOMPLEX1
1856         case FFEINFO_kindtypeREAL1:
1857           *cptr = source_array.complex1;
1858           *size = sizeof (*source_array.complex1);
1859           break;
1860 #endif
1861
1862 #if FFETARGET_okCOMPLEX2
1863         case FFEINFO_kindtypeREAL2:
1864           *cptr = source_array.complex2;
1865           *size = sizeof (*source_array.complex2);
1866           break;
1867 #endif
1868
1869 #if FFETARGET_okCOMPLEX3
1870         case FFEINFO_kindtypeREAL3:
1871           *cptr = source_array.complex3;
1872           *size = sizeof (*source_array.complex3);
1873           break;
1874 #endif
1875
1876         default:
1877           assert ("bad COMPLEX ckindtype" == NULL);
1878           break;
1879         }
1880       break;
1881
1882     case FFEINFO_basictypeCHARACTER:
1883       switch (ckt)
1884         {
1885 #if FFETARGET_okCHARACTER1
1886         case FFEINFO_kindtypeCHARACTER1:
1887           *cptr = source_array.character1;
1888           *size = sizeof (*source_array.character1);
1889           break;
1890 #endif
1891
1892         default:
1893           assert ("bad CHARACTER ckindtype" == NULL);
1894           break;
1895         }
1896       break;
1897
1898     default:
1899       assert ("bad cbasictype" == NULL);
1900       break;
1901     }
1902 }
1903
1904 /* ffebld_constantarray_prepare -- Prepare for copy between value and array
1905
1906    See prototype.
1907
1908    Like _put, but just returns the pointers to the beginnings of the
1909    array and the constant and returns the size (the amount of info to
1910    copy).  The idea is that the caller can use memcpy to accomplish the
1911    same thing as _put (though slower), or the caller can use a different
1912    function that swaps bytes, words, etc for a different target machine.
1913    Also, the type of the array may be different from the type of the
1914    constant; the array type is used to determine the meaning (scale) of
1915    the offset field (to calculate the array pointer), the constant type is
1916    used to determine the constant pointer and the size (amount of info to
1917    copy).  */
1918
1919 void
1920 ffebld_constantarray_prepare (void **aptr, void **cptr, size_t *size,
1921        ffebldConstantArray array, ffeinfoBasictype abt, ffeinfoKindtype akt,
1922                       ffetargetOffset offset, ffebldConstantUnion *constant,
1923                               ffeinfoBasictype cbt, ffeinfoKindtype ckt)
1924 {
1925   switch (abt)
1926     {
1927     case FFEINFO_basictypeINTEGER:
1928       switch (akt)
1929         {
1930 #if FFETARGET_okINTEGER1
1931         case FFEINFO_kindtypeINTEGER1:
1932           *aptr = array.integer1 + offset;
1933           break;
1934 #endif
1935
1936 #if FFETARGET_okINTEGER2
1937         case FFEINFO_kindtypeINTEGER2:
1938           *aptr = array.integer2 + offset;
1939           break;
1940 #endif
1941
1942 #if FFETARGET_okINTEGER3
1943         case FFEINFO_kindtypeINTEGER3:
1944           *aptr = array.integer3 + offset;
1945           break;
1946 #endif
1947
1948 #if FFETARGET_okINTEGER4
1949         case FFEINFO_kindtypeINTEGER4:
1950           *aptr = array.integer4 + offset;
1951           break;
1952 #endif
1953
1954         default:
1955           assert ("bad INTEGER akindtype" == NULL);
1956           break;
1957         }
1958       break;
1959
1960     case FFEINFO_basictypeLOGICAL:
1961       switch (akt)
1962         {
1963 #if FFETARGET_okLOGICAL1
1964         case FFEINFO_kindtypeLOGICAL1:
1965           *aptr = array.logical1 + offset;
1966           break;
1967 #endif
1968
1969 #if FFETARGET_okLOGICAL2
1970         case FFEINFO_kindtypeLOGICAL2:
1971           *aptr = array.logical2 + offset;
1972           break;
1973 #endif
1974
1975 #if FFETARGET_okLOGICAL3
1976         case FFEINFO_kindtypeLOGICAL3:
1977           *aptr = array.logical3 + offset;
1978           break;
1979 #endif
1980
1981 #if FFETARGET_okLOGICAL4
1982         case FFEINFO_kindtypeLOGICAL4:
1983           *aptr = array.logical4 + offset;
1984           break;
1985 #endif
1986
1987         default:
1988           assert ("bad LOGICAL akindtype" == NULL);
1989           break;
1990         }
1991       break;
1992
1993     case FFEINFO_basictypeREAL:
1994       switch (akt)
1995         {
1996 #if FFETARGET_okREAL1
1997         case FFEINFO_kindtypeREAL1:
1998           *aptr = array.real1 + offset;
1999           break;
2000 #endif
2001
2002 #if FFETARGET_okREAL2
2003         case FFEINFO_kindtypeREAL2:
2004           *aptr = array.real2 + offset;
2005           break;
2006 #endif
2007
2008 #if FFETARGET_okREAL3
2009         case FFEINFO_kindtypeREAL3:
2010           *aptr = array.real3 + offset;
2011           break;
2012 #endif
2013
2014         default:
2015           assert ("bad REAL akindtype" == NULL);
2016           break;
2017         }
2018       break;
2019
2020     case FFEINFO_basictypeCOMPLEX:
2021       switch (akt)
2022         {
2023 #if FFETARGET_okCOMPLEX1
2024         case FFEINFO_kindtypeREAL1:
2025           *aptr = array.complex1 + offset;
2026           break;
2027 #endif
2028
2029 #if FFETARGET_okCOMPLEX2
2030         case FFEINFO_kindtypeREAL2:
2031           *aptr = array.complex2 + offset;
2032           break;
2033 #endif
2034
2035 #if FFETARGET_okCOMPLEX3
2036         case FFEINFO_kindtypeREAL3:
2037           *aptr = array.complex3 + offset;
2038           break;
2039 #endif
2040
2041         default:
2042           assert ("bad COMPLEX akindtype" == NULL);
2043           break;
2044         }
2045       break;
2046
2047     case FFEINFO_basictypeCHARACTER:
2048       switch (akt)
2049         {
2050 #if FFETARGET_okCHARACTER1
2051         case FFEINFO_kindtypeCHARACTER1:
2052           *aptr = array.character1 + offset;
2053           break;
2054 #endif
2055
2056         default:
2057           assert ("bad CHARACTER akindtype" == NULL);
2058           break;
2059         }
2060       break;
2061
2062     default:
2063       assert ("bad abasictype" == NULL);
2064       break;
2065     }
2066
2067   switch (cbt)
2068     {
2069     case FFEINFO_basictypeINTEGER:
2070       switch (ckt)
2071         {
2072 #if FFETARGET_okINTEGER1
2073         case FFEINFO_kindtypeINTEGER1:
2074           *cptr = &constant->integer1;
2075           *size = sizeof (constant->integer1);
2076           break;
2077 #endif
2078
2079 #if FFETARGET_okINTEGER2
2080         case FFEINFO_kindtypeINTEGER2:
2081           *cptr = &constant->integer2;
2082           *size = sizeof (constant->integer2);
2083           break;
2084 #endif
2085
2086 #if FFETARGET_okINTEGER3
2087         case FFEINFO_kindtypeINTEGER3:
2088           *cptr = &constant->integer3;
2089           *size = sizeof (constant->integer3);
2090           break;
2091 #endif
2092
2093 #if FFETARGET_okINTEGER4
2094         case FFEINFO_kindtypeINTEGER4:
2095           *cptr = &constant->integer4;
2096           *size = sizeof (constant->integer4);
2097           break;
2098 #endif
2099
2100         default:
2101           assert ("bad INTEGER ckindtype" == NULL);
2102           break;
2103         }
2104       break;
2105
2106     case FFEINFO_basictypeLOGICAL:
2107       switch (ckt)
2108         {
2109 #if FFETARGET_okLOGICAL1
2110         case FFEINFO_kindtypeLOGICAL1:
2111           *cptr = &constant->logical1;
2112           *size = sizeof (constant->logical1);
2113           break;
2114 #endif
2115
2116 #if FFETARGET_okLOGICAL2
2117         case FFEINFO_kindtypeLOGICAL2:
2118           *cptr = &constant->logical2;
2119           *size = sizeof (constant->logical2);
2120           break;
2121 #endif
2122
2123 #if FFETARGET_okLOGICAL3
2124         case FFEINFO_kindtypeLOGICAL3:
2125           *cptr = &constant->logical3;
2126           *size = sizeof (constant->logical3);
2127           break;
2128 #endif
2129
2130 #if FFETARGET_okLOGICAL4
2131         case FFEINFO_kindtypeLOGICAL4:
2132           *cptr = &constant->logical4;
2133           *size = sizeof (constant->logical4);
2134           break;
2135 #endif
2136
2137         default:
2138           assert ("bad LOGICAL ckindtype" == NULL);
2139           break;
2140         }
2141       break;
2142
2143     case FFEINFO_basictypeREAL:
2144       switch (ckt)
2145         {
2146 #if FFETARGET_okREAL1
2147         case FFEINFO_kindtypeREAL1:
2148           *cptr = &constant->real1;
2149           *size = sizeof (constant->real1);
2150           break;
2151 #endif
2152
2153 #if FFETARGET_okREAL2
2154         case FFEINFO_kindtypeREAL2:
2155           *cptr = &constant->real2;
2156           *size = sizeof (constant->real2);
2157           break;
2158 #endif
2159
2160 #if FFETARGET_okREAL3
2161         case FFEINFO_kindtypeREAL3:
2162           *cptr = &constant->real3;
2163           *size = sizeof (constant->real3);
2164           break;
2165 #endif
2166
2167         default:
2168           assert ("bad REAL ckindtype" == NULL);
2169           break;
2170         }
2171       break;
2172
2173     case FFEINFO_basictypeCOMPLEX:
2174       switch (ckt)
2175         {
2176 #if FFETARGET_okCOMPLEX1
2177         case FFEINFO_kindtypeREAL1:
2178           *cptr = &constant->complex1;
2179           *size = sizeof (constant->complex1);
2180           break;
2181 #endif
2182
2183 #if FFETARGET_okCOMPLEX2
2184         case FFEINFO_kindtypeREAL2:
2185           *cptr = &constant->complex2;
2186           *size = sizeof (constant->complex2);
2187           break;
2188 #endif
2189
2190 #if FFETARGET_okCOMPLEX3
2191         case FFEINFO_kindtypeREAL3:
2192           *cptr = &constant->complex3;
2193           *size = sizeof (constant->complex3);
2194           break;
2195 #endif
2196
2197         default:
2198           assert ("bad COMPLEX ckindtype" == NULL);
2199           break;
2200         }
2201       break;
2202
2203     case FFEINFO_basictypeCHARACTER:
2204       switch (ckt)
2205         {
2206 #if FFETARGET_okCHARACTER1
2207         case FFEINFO_kindtypeCHARACTER1:
2208           *cptr = ffetarget_text_character1 (constant->character1);
2209           *size = ffetarget_length_character1 (constant->character1);
2210           break;
2211 #endif
2212
2213         default:
2214           assert ("bad CHARACTER ckindtype" == NULL);
2215           break;
2216         }
2217       break;
2218
2219     default:
2220       assert ("bad cbasictype" == NULL);
2221       break;
2222     }
2223 }
2224
2225 /* ffebld_constantarray_put -- Put a value into an array of constants
2226
2227    See prototype.  */
2228
2229 void
2230 ffebld_constantarray_put (ffebldConstantArray array, ffeinfoBasictype bt,
2231    ffeinfoKindtype kt, ffetargetOffset offset, ffebldConstantUnion constant)
2232 {
2233   switch (bt)
2234     {
2235     case FFEINFO_basictypeINTEGER:
2236       switch (kt)
2237         {
2238 #if FFETARGET_okINTEGER1
2239         case FFEINFO_kindtypeINTEGER1:
2240           *(array.integer1 + offset) = constant.integer1;
2241           break;
2242 #endif
2243
2244 #if FFETARGET_okINTEGER2
2245         case FFEINFO_kindtypeINTEGER2:
2246           *(array.integer2 + offset) = constant.integer2;
2247           break;
2248 #endif
2249
2250 #if FFETARGET_okINTEGER3
2251         case FFEINFO_kindtypeINTEGER3:
2252           *(array.integer3 + offset) = constant.integer3;
2253           break;
2254 #endif
2255
2256 #if FFETARGET_okINTEGER4
2257         case FFEINFO_kindtypeINTEGER4:
2258           *(array.integer4 + offset) = constant.integer4;
2259           break;
2260 #endif
2261
2262         default:
2263           assert ("bad INTEGER kindtype" == NULL);
2264           break;
2265         }
2266       break;
2267
2268     case FFEINFO_basictypeLOGICAL:
2269       switch (kt)
2270         {
2271 #if FFETARGET_okLOGICAL1
2272         case FFEINFO_kindtypeLOGICAL1:
2273           *(array.logical1 + offset) = constant.logical1;
2274           break;
2275 #endif
2276
2277 #if FFETARGET_okLOGICAL2
2278         case FFEINFO_kindtypeLOGICAL2:
2279           *(array.logical2 + offset) = constant.logical2;
2280           break;
2281 #endif
2282
2283 #if FFETARGET_okLOGICAL3
2284         case FFEINFO_kindtypeLOGICAL3:
2285           *(array.logical3 + offset) = constant.logical3;
2286           break;
2287 #endif
2288
2289 #if FFETARGET_okLOGICAL4
2290         case FFEINFO_kindtypeLOGICAL4:
2291           *(array.logical4 + offset) = constant.logical4;
2292           break;
2293 #endif
2294
2295         default:
2296           assert ("bad LOGICAL kindtype" == NULL);
2297           break;
2298         }
2299       break;
2300
2301     case FFEINFO_basictypeREAL:
2302       switch (kt)
2303         {
2304 #if FFETARGET_okREAL1
2305         case FFEINFO_kindtypeREAL1:
2306           *(array.real1 + offset) = constant.real1;
2307           break;
2308 #endif
2309
2310 #if FFETARGET_okREAL2
2311         case FFEINFO_kindtypeREAL2:
2312           *(array.real2 + offset) = constant.real2;
2313           break;
2314 #endif
2315
2316 #if FFETARGET_okREAL3
2317         case FFEINFO_kindtypeREAL3:
2318           *(array.real3 + offset) = constant.real3;
2319           break;
2320 #endif
2321
2322         default:
2323           assert ("bad REAL kindtype" == NULL);
2324           break;
2325         }
2326       break;
2327
2328     case FFEINFO_basictypeCOMPLEX:
2329       switch (kt)
2330         {
2331 #if FFETARGET_okCOMPLEX1
2332         case FFEINFO_kindtypeREAL1:
2333           *(array.complex1 + offset) = constant.complex1;
2334           break;
2335 #endif
2336
2337 #if FFETARGET_okCOMPLEX2
2338         case FFEINFO_kindtypeREAL2:
2339           *(array.complex2 + offset) = constant.complex2;
2340           break;
2341 #endif
2342
2343 #if FFETARGET_okCOMPLEX3
2344         case FFEINFO_kindtypeREAL3:
2345           *(array.complex3 + offset) = constant.complex3;
2346           break;
2347 #endif
2348
2349         default:
2350           assert ("bad COMPLEX kindtype" == NULL);
2351           break;
2352         }
2353       break;
2354
2355     case FFEINFO_basictypeCHARACTER:
2356       switch (kt)
2357         {
2358 #if FFETARGET_okCHARACTER1
2359         case FFEINFO_kindtypeCHARACTER1:
2360           memcpy (array.character1 + offset,
2361                   ffetarget_text_character1 (constant.character1),
2362                   ffetarget_length_character1 (constant.character1));
2363           break;
2364 #endif
2365
2366         default:
2367           assert ("bad CHARACTER kindtype" == NULL);
2368           break;
2369         }
2370       break;
2371
2372     default:
2373       assert ("bad basictype" == NULL);
2374       break;
2375     }
2376 }
2377
2378 /* ffebld_init_0 -- Initialize the module
2379
2380    ffebld_init_0();  */
2381
2382 void
2383 ffebld_init_0 (void)
2384 {
2385   assert (FFEBLD_op == ARRAY_SIZE (ffebld_op_string_));
2386   assert (FFEBLD_op == ARRAY_SIZE (ffebld_arity_op_));
2387 }
2388
2389 /* ffebld_init_1 -- Initialize the module for a file
2390
2391    ffebld_init_1();  */
2392
2393 void
2394 ffebld_init_1 (void)
2395 {
2396 #if FFEBLD_whereconstCURRENT_ == FFEBLD_whereconstFILE_
2397   int i;
2398
2399 #if FFETARGET_okCHARACTER1
2400   ffebld_constant_character1_ = NULL;
2401 #endif
2402 #if FFETARGET_okCOMPLEX1
2403   ffebld_constant_complex1_ = NULL;
2404 #endif
2405 #if FFETARGET_okCOMPLEX2
2406   ffebld_constant_complex2_ = NULL;
2407 #endif
2408 #if FFETARGET_okCOMPLEX3
2409   ffebld_constant_complex3_ = NULL;
2410 #endif
2411 #if FFETARGET_okINTEGER1
2412   ffebld_constant_integer1_ = NULL;
2413 #endif
2414 #if FFETARGET_okINTEGER2
2415   ffebld_constant_integer2_ = NULL;
2416 #endif
2417 #if FFETARGET_okINTEGER3
2418   ffebld_constant_integer3_ = NULL;
2419 #endif
2420 #if FFETARGET_okINTEGER4
2421   ffebld_constant_integer4_ = NULL;
2422 #endif
2423 #if FFETARGET_okLOGICAL1
2424   ffebld_constant_logical1_ = NULL;
2425 #endif
2426 #if FFETARGET_okLOGICAL2
2427   ffebld_constant_logical2_ = NULL;
2428 #endif
2429 #if FFETARGET_okLOGICAL3
2430   ffebld_constant_logical3_ = NULL;
2431 #endif
2432 #if FFETARGET_okLOGICAL4
2433   ffebld_constant_logical4_ = NULL;
2434 #endif
2435 #if FFETARGET_okREAL1
2436   ffebld_constant_real1_ = NULL;
2437 #endif
2438 #if FFETARGET_okREAL2
2439   ffebld_constant_real2_ = NULL;
2440 #endif
2441 #if FFETARGET_okREAL3
2442   ffebld_constant_real3_ = NULL;
2443 #endif
2444   ffebld_constant_hollerith_ = NULL;
2445   for (i = FFEBLD_constTYPELESS_FIRST; i <= FFEBLD_constTYPELESS_LAST; ++i)
2446     ffebld_constant_typeless_[i - FFEBLD_constTYPELESS_FIRST] = NULL;
2447 #endif
2448 }
2449
2450 /* ffebld_init_2 -- Initialize the module
2451
2452    ffebld_init_2();  */
2453
2454 void
2455 ffebld_init_2 (void)
2456 {
2457 #if FFEBLD_whereconstCURRENT_ == FFEBLD_whereconstPROGUNIT_
2458   int i;
2459 #endif
2460
2461   ffebld_pool_stack_.next = NULL;
2462   ffebld_pool_stack_.pool = ffe_pool_program_unit ();
2463 #if FFEBLD_whereconstCURRENT_ == FFEBLD_whereconstPROGUNIT_
2464 #if FFETARGET_okCHARACTER1
2465   ffebld_constant_character1_ = NULL;
2466 #endif
2467 #if FFETARGET_okCOMPLEX1
2468   ffebld_constant_complex1_ = NULL;
2469 #endif
2470 #if FFETARGET_okCOMPLEX2
2471   ffebld_constant_complex2_ = NULL;
2472 #endif
2473 #if FFETARGET_okCOMPLEX3
2474   ffebld_constant_complex3_ = NULL;
2475 #endif
2476 #if FFETARGET_okINTEGER1
2477   ffebld_constant_integer1_ = NULL;
2478 #endif
2479 #if FFETARGET_okINTEGER2
2480   ffebld_constant_integer2_ = NULL;
2481 #endif
2482 #if FFETARGET_okINTEGER3
2483   ffebld_constant_integer3_ = NULL;
2484 #endif
2485 #if FFETARGET_okINTEGER4
2486   ffebld_constant_integer4_ = NULL;
2487 #endif
2488 #if FFETARGET_okLOGICAL1
2489   ffebld_constant_logical1_ = NULL;
2490 #endif
2491 #if FFETARGET_okLOGICAL2
2492   ffebld_constant_logical2_ = NULL;
2493 #endif
2494 #if FFETARGET_okLOGICAL3
2495   ffebld_constant_logical3_ = NULL;
2496 #endif
2497 #if FFETARGET_okLOGICAL4
2498   ffebld_constant_logical4_ = NULL;
2499 #endif
2500 #if FFETARGET_okREAL1
2501   ffebld_constant_real1_ = NULL;
2502 #endif
2503 #if FFETARGET_okREAL2
2504   ffebld_constant_real2_ = NULL;
2505 #endif
2506 #if FFETARGET_okREAL3
2507   ffebld_constant_real3_ = NULL;
2508 #endif
2509   ffebld_constant_hollerith_ = NULL;
2510   for (i = FFEBLD_constTYPELESS_FIRST; i <= FFEBLD_constTYPELESS_LAST; ++i)
2511     ffebld_constant_typeless_[i - FFEBLD_constTYPELESS_FIRST] = NULL;
2512 #endif
2513 }
2514
2515 /* ffebld_list_length -- Return # of opITEMs in list
2516
2517    ffebld list;  // Must be NULL or opITEM
2518    ffebldListLength length;
2519    length = ffebld_list_length(list);
2520
2521    Returns 0 if list is NULL, 1 if it's ffebld_trail is NULL, and so on.  */
2522
2523 ffebldListLength
2524 ffebld_list_length (ffebld list)
2525 {
2526   ffebldListLength length;
2527
2528   for (length = 0; list != NULL; ++length, list = ffebld_trail (list))
2529     ;
2530
2531   return length;
2532 }
2533
2534 /* ffebld_new_accter -- Create an ffebld object that is an array
2535
2536    ffebld x;
2537    ffebldConstantArray a;
2538    ffebit b;
2539    x = ffebld_new_accter(a,b);  */
2540
2541 ffebld
2542 ffebld_new_accter (ffebldConstantArray a, ffebit b)
2543 {
2544   ffebld x;
2545
2546   x = ffebld_new ();
2547   x->op = FFEBLD_opACCTER;
2548   x->u.accter.array = a;
2549   x->u.accter.bits = b;
2550   x->u.accter.pad = 0;
2551   return x;
2552 }
2553
2554 /* ffebld_new_arrter -- Create an ffebld object that is an array
2555
2556    ffebld x;
2557    ffebldConstantArray a;
2558    ffetargetOffset size;
2559    x = ffebld_new_arrter(a,size);  */
2560
2561 ffebld
2562 ffebld_new_arrter (ffebldConstantArray a, ffetargetOffset size)
2563 {
2564   ffebld x;
2565
2566   x = ffebld_new ();
2567   x->op = FFEBLD_opARRTER;
2568   x->u.arrter.array = a;
2569   x->u.arrter.size = size;
2570   x->u.arrter.pad = 0;
2571   return x;
2572 }
2573
2574 /* ffebld_new_conter_with_orig -- Create an ffebld object that is a constant
2575
2576    ffebld x;
2577    ffebldConstant c;
2578    x = ffebld_new_conter_with_orig(c,NULL);  */
2579
2580 ffebld
2581 ffebld_new_conter_with_orig (ffebldConstant c, ffebld o)
2582 {
2583   ffebld x;
2584
2585   x = ffebld_new ();
2586   x->op = FFEBLD_opCONTER;
2587   x->u.conter.expr = c;
2588   x->u.conter.orig = o;
2589   x->u.conter.pad = 0;
2590   return x;
2591 }
2592
2593 /* ffebld_new_item -- Create an ffebld item object
2594
2595    ffebld x,y,z;
2596    x = ffebld_new_item(y,z);  */
2597
2598 ffebld
2599 ffebld_new_item (ffebld head, ffebld trail)
2600 {
2601   ffebld x;
2602
2603   x = ffebld_new ();
2604   x->op = FFEBLD_opITEM;
2605   x->u.item.head = head;
2606   x->u.item.trail = trail;
2607   return x;
2608 }
2609
2610 /* ffebld_new_labter -- Create an ffebld object that is a label
2611
2612    ffebld x;
2613    ffelab l;
2614    x = ffebld_new_labter(c);  */
2615
2616 ffebld
2617 ffebld_new_labter (ffelab l)
2618 {
2619   ffebld x;
2620
2621   x = ffebld_new ();
2622   x->op = FFEBLD_opLABTER;
2623   x->u.labter = l;
2624   return x;
2625 }
2626
2627 /* ffebld_new_labtok -- Create object that is a label's NUMBER token
2628
2629    ffebld x;
2630    ffelexToken t;
2631    x = ffebld_new_labter(c);
2632
2633    Like the other ffebld_new_ functions, the
2634    supplied argument is stored exactly as is: ffelex_token_use is NOT
2635    called, so the token is "consumed", if one is indeed supplied (it may
2636    be NULL).  */
2637
2638 ffebld
2639 ffebld_new_labtok (ffelexToken t)
2640 {
2641   ffebld x;
2642
2643   x = ffebld_new ();
2644   x->op = FFEBLD_opLABTOK;
2645   x->u.labtok = t;
2646   return x;
2647 }
2648
2649 /* ffebld_new_none -- Create an ffebld object with no arguments
2650
2651    ffebld x;
2652    x = ffebld_new_none(FFEBLD_opWHATEVER);  */
2653
2654 ffebld
2655 ffebld_new_none (ffebldOp o)
2656 {
2657   ffebld x;
2658
2659   x = ffebld_new ();
2660   x->op = o;
2661   return x;
2662 }
2663
2664 /* ffebld_new_one -- Create an ffebld object with one argument
2665
2666    ffebld x,y;
2667    x = ffebld_new_one(FFEBLD_opWHATEVER,y);  */
2668
2669 ffebld
2670 ffebld_new_one (ffebldOp o, ffebld left)
2671 {
2672   ffebld x;
2673
2674   x = ffebld_new ();
2675   x->op = o;
2676   x->u.nonter.left = left;
2677   x->u.nonter.hook = FFECOM_nonterNULL;
2678   return x;
2679 }
2680
2681 /* ffebld_new_symter -- Create an ffebld object that is a symbol
2682
2683    ffebld x;
2684    ffesymbol s;
2685    ffeintrinGen gen;    // Generic intrinsic id, if any
2686    ffeintrinSpec spec;  // Specific intrinsic id, if any
2687    ffeintrinImp imp;    // Implementation intrinsic id, if any
2688    x = ffebld_new_symter (s, gen, spec, imp);  */
2689
2690 ffebld
2691 ffebld_new_symter (ffesymbol s, ffeintrinGen gen, ffeintrinSpec spec,
2692                    ffeintrinImp imp)
2693 {
2694   ffebld x;
2695
2696   x = ffebld_new ();
2697   x->op = FFEBLD_opSYMTER;
2698   x->u.symter.symbol = s;
2699   x->u.symter.generic = gen;
2700   x->u.symter.specific = spec;
2701   x->u.symter.implementation = imp;
2702   x->u.symter.do_iter = FALSE;
2703   return x;
2704 }
2705
2706 /* ffebld_new_two -- Create an ffebld object with two arguments
2707
2708    ffebld x,y,z;
2709    x = ffebld_new_two(FFEBLD_opWHATEVER,y,z);  */
2710
2711 ffebld
2712 ffebld_new_two (ffebldOp o, ffebld left, ffebld right)
2713 {
2714   ffebld x;
2715
2716   x = ffebld_new ();
2717   x->op = o;
2718   x->u.nonter.left = left;
2719   x->u.nonter.right = right;
2720   x->u.nonter.hook = FFECOM_nonterNULL;
2721   return x;
2722 }
2723
2724 /* ffebld_pool_pop -- Pop ffebld's pool stack
2725
2726    ffebld_pool_pop();  */
2727
2728 void
2729 ffebld_pool_pop (void)
2730 {
2731   ffebldPoolstack_ ps;
2732
2733   assert (ffebld_pool_stack_.next != NULL);
2734   ps = ffebld_pool_stack_.next;
2735   ffebld_pool_stack_.next = ps->next;
2736   ffebld_pool_stack_.pool = ps->pool;
2737   malloc_kill_ks (malloc_pool_image (), ps, sizeof (*ps));
2738 }
2739
2740 /* ffebld_pool_push -- Push ffebld's pool stack
2741
2742    ffebld_pool_push();  */
2743
2744 void
2745 ffebld_pool_push (mallocPool pool)
2746 {
2747   ffebldPoolstack_ ps;
2748
2749   ps = malloc_new_ks (malloc_pool_image (), "Pool stack", sizeof (*ps));
2750   ps->next = ffebld_pool_stack_.next;
2751   ps->pool = ffebld_pool_stack_.pool;
2752   ffebld_pool_stack_.next = ps;
2753   ffebld_pool_stack_.pool = pool;
2754 }
2755
2756 /* ffebld_op_string -- Return short string describing op
2757
2758    ffebldOp o;
2759    ffebld_op_string(o);
2760
2761    Returns a short string (uppercase) containing the name of the op.  */
2762
2763 const char *
2764 ffebld_op_string (ffebldOp o)
2765 {
2766   if (o >= ARRAY_SIZE (ffebld_op_string_))
2767     return "?\?\?";
2768   return ffebld_op_string_[o];
2769 }
2770
2771 /* ffebld_size_max -- Return maximum possible size of CHARACTER-type expr
2772
2773    ffetargetCharacterSize sz;
2774    ffebld b;
2775    sz = ffebld_size_max (b);
2776
2777    Like ffebld_size_known, but if that would return NONE and the expression
2778    is opSUBSTR, opCONVERT, opPAREN, or opCONCATENATE, returns ffebld_size_max
2779    of the subexpression(s).  */
2780
2781 ffetargetCharacterSize
2782 ffebld_size_max (ffebld b)
2783 {
2784   ffetargetCharacterSize sz;
2785
2786 recurse:                        /* :::::::::::::::::::: */
2787
2788   sz = ffebld_size_known (b);
2789
2790   if (sz != FFETARGET_charactersizeNONE)
2791     return sz;
2792
2793   switch (ffebld_op (b))
2794     {
2795     case FFEBLD_opSUBSTR:
2796     case FFEBLD_opCONVERT:
2797     case FFEBLD_opPAREN:
2798       b = ffebld_left (b);
2799       goto recurse;             /* :::::::::::::::::::: */
2800
2801     case FFEBLD_opCONCATENATE:
2802       sz = ffebld_size_max (ffebld_left (b))
2803         + ffebld_size_max (ffebld_right (b));
2804       return sz;
2805
2806     default:
2807       return sz;
2808     }
2809 }