contrib/gcc-3.4/gcc/f/bld.c

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