gcc/f/bld.c

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