gcc/f/target.c

   1 /* target.c -- Implementation File (module.c template V1.0)
   2    Copyright (C) 1995, 1996, 1997, 1998 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       Implements conversion of lexer tokens to machine-dependent numerical
  27       form and accordingly issues diagnostic messages when necessary.
  28
  29       Also, this module, especially its .h file, provides nearly all of the
  30       information on the target machine's data type, kind type, and length
  31       type capabilities.  The idea is that by carefully going through
  32       target.h and changing things properly, one can accomplish much
  33       towards the porting of the FFE to a new machine.  There are limits
  34       to how much this can accomplish towards that end, however.  For one
  35       thing, the ffeexpr_collapse_convert function doesn't contain all the
  36       conversion cases necessary, because the text file would be
  37       enormous (even though most of the function would be cut during the
  38       cpp phase because of the absence of the types), so when adding to
  39       the number of supported kind types for a given type, one must look
  40       to see if ffeexpr_collapse_convert needs modification in this area,
  41       in addition to providing the appropriate macros and functions in
  42       ffetarget.  Note that if combinatorial explosion actually becomes a
  43       problem for a given machine, one might have to modify the way conversion
  44       expressions are built so that instead of just one conversion expr, a
  45       series of conversion exprs are built to make a path from one type to
  46       another that is not a "near neighbor".  For now, however, with a handful
  47       of each of the numeric types and only one character type, things appear
  48       manageable.
  49
  50       A nonobvious change to ffetarget would be if the target machine was
  51       not a 2's-complement machine.  Any item with the word "magical" (case-
  52       insensitive) in the FFE's source code (at least) indicates an assumption
  53       that a 2's-complement machine is the target, and thus that there exists
  54       a magnitude that can be represented as a negative number but not as
  55       a positive number.  It is possible that this situation can be dealt
  56       with by changing only ffetarget, for example, on a 1's-complement
  57       machine, perhaps #defineing ffetarget_constant_is_magical to simply
  58       FALSE along with making the appropriate changes in ffetarget's number
  59       parsing functions would be sufficient to effectively "comment out" code
  60       in places like ffeexpr that do certain magical checks.  But it is
  61       possible there are other 2's-complement dependencies lurking in the
  62       FFE (as possibly is true of any large program); if you find any, please
  63       report them so we can replace them with dependencies on ffetarget
  64       instead.
  65
  66    Modifications:
  67 */
  68
  69 /* Include files. */
  70
  71 #include "proj.h"
  72 #include "glimits.h"
  73 #include "target.h"
  74 #include "bad.h"
  75 #include "info.h"
  76 #include "lex.h"
  77 #include "malloc.h"
  78
  79 /* Externals defined here. */
  80
  81 char ffetarget_string_[40];     /* Temp for ascii-to-double (atof). */
  82 HOST_WIDE_INT ffetarget_long_val_;
  83 HOST_WIDE_INT ffetarget_long_junk_;
  84
  85 /* Simple definitions and enumerations. */
  86
  87
  88 /* Internal typedefs. */
  89
  90
  91 /* Private include files. */
  92
  93
  94 /* Internal structure definitions. */
  95
  96
  97 /* Static objects accessed by functions in this module. */
  98
  99
 100 /* Static functions (internal). */
 101
 102 static void ffetarget_print_char_ (FILE *f, unsigned char c);
 103
 104 /* Internal macros. */
 105
 106 #ifdef REAL_VALUE_ATOF
 107 #define FFETARGET_ATOF_(p,m) REAL_VALUE_ATOF ((p),(m))
 108 #else
 109 #define FFETARGET_ATOF_(p,m) atof ((p))
 110 #endif
 111 \f
 112
 113 /* ffetarget_print_char_ -- Print a single character (in apostrophe context)
 114
 115    See prototype.
 116
 117    Outputs char so it prints or is escaped C style.  */
 118
 119 static void
 120 ffetarget_print_char_ (FILE *f, unsigned char c)
 121 {
 122   switch (c)
 123     {
 124     case '\\':
 125       fputs ("\\\\", f);
 126       break;
 127
 128     case '\'':
 129       fputs ("\\\'", f);
 130       break;
 131
 132     default:
 133       if (ISPRINT (c))
 134         fputc (c, f);
 135       else
 136         fprintf (f, "\\%03o", (unsigned int) c);
 137       break;
 138     }
 139 }
 140
 141 /* ffetarget_aggregate_info -- Determine type for aggregate storage area
 142
 143    See prototype.
 144
 145    If aggregate type is distinct, just return it.  Else return a type
 146    representing a common denominator for the nondistinct type (for now,
 147    just return default character, since that'll work on almost all target
 148    machines).
 149
 150    The rules for abt/akt are (as implemented by ffestorag_update):
 151
 152    abt == FFEINFO_basictypeANY (akt == FFEINFO_kindtypeANY also, by
 153    definition): CHARACTER and non-CHARACTER types mixed.
 154
 155    abt == FFEINFO_basictypeNONE (akt == FFEINFO_kindtypeNONE also, by
 156    definition): More than one non-CHARACTER type mixed, but no CHARACTER
 157    types mixed in.
 158
 159    abt some other value, akt == FFEINFO_kindtypeNONE: abt indicates the
 160    only basic type mixed in, but more than one kind type is mixed in.
 161
 162    abt some other value, akt some other value: abt and akt indicate the
 163    only type represented in the aggregation.  */
 164
 165 void
 166 ffetarget_aggregate_info (ffeinfoBasictype *ebt, ffeinfoKindtype *ekt,
 167                           ffetargetAlign *units, ffeinfoBasictype abt,
 168                           ffeinfoKindtype akt)
 169 {
 170   ffetype type;
 171
 172   if ((abt == FFEINFO_basictypeNONE) || (abt == FFEINFO_basictypeANY)
 173       || (akt == FFEINFO_kindtypeNONE))
 174     {
 175       *ebt = FFEINFO_basictypeCHARACTER;
 176       *ekt = FFEINFO_kindtypeCHARACTERDEFAULT;
 177     }
 178   else
 179     {
 180       *ebt = abt;
 181       *ekt = akt;
 182     }
 183
 184   type = ffeinfo_type (*ebt, *ekt);
 185   assert (type != NULL);
 186
 187   *units = ffetype_size (type);
 188 }
 189
 190 /* ffetarget_align -- Align one storage area to superordinate, update super
 191
 192    See prototype.
 193
 194    updated_alignment/updated_modulo contain the already existing
 195    alignment requirements for the storage area at whose offset the
 196    object with alignment requirements alignment/modulo is to be placed.
 197    Find the smallest pad such that the requirements are maintained and
 198    return it, but only after updating the updated_alignment/_modulo
 199    requirements as necessary to indicate the placement of the new object.  */
 200
 201 ffetargetAlign
 202 ffetarget_align (ffetargetAlign *updated_alignment,
 203                  ffetargetAlign *updated_modulo, ffetargetOffset offset,
 204                  ffetargetAlign alignment, ffetargetAlign modulo)
 205 {
 206   ffetargetAlign pad;
 207   ffetargetAlign min_pad;       /* Minimum amount of padding needed. */
 208   ffetargetAlign min_m = 0;     /* Minimum-padding m. */
 209   ffetargetAlign ua;            /* Updated alignment. */
 210   ffetargetAlign um;            /* Updated modulo. */
 211   ffetargetAlign ucnt;          /* Multiplier applied to ua. */
 212   ffetargetAlign m;             /* Copy of modulo. */
 213   ffetargetAlign cnt;           /* Multiplier applied to alignment. */
 214   ffetargetAlign i;
 215   ffetargetAlign j;
 216
 217   assert (alignment > 0);
 218   assert (*updated_alignment > 0);
 219
 220   assert (*updated_modulo < *updated_alignment);
 221   assert (modulo < alignment);
 222
 223   /* The easy case: similar alignment requirements.  */
 224   if (*updated_alignment == alignment)
 225     {
 226       if (modulo > *updated_modulo)
 227         pad = alignment - (modulo - *updated_modulo);
 228       else
 229         pad = *updated_modulo - modulo;
 230       if (offset < 0)
 231         /* De-negatize offset, since % wouldn't do the expected thing.  */
 232         offset = alignment - ((- offset) % alignment);
 233       pad = (offset + pad) % alignment;
 234       if (pad != 0)
 235         pad = alignment - pad;
 236       return pad;
 237     }
 238
 239   /* Sigh, find LCM (Least Common Multiple) for the two alignment factors. */
 240
 241   for (ua = *updated_alignment, ucnt = 1;
 242        ua % alignment != 0;
 243        ua += *updated_alignment)
 244     ++ucnt;
 245
 246   cnt = ua / alignment;
 247
 248   if (offset < 0)
 249     /* De-negatize offset, since % wouldn't do the expected thing.  */
 250     offset = ua - ((- offset) % ua);
 251
 252   /* Set to largest value.  */
 253   min_pad = ~(ffetargetAlign) 0;
 254
 255   /* Find all combinations of modulo values the two alignment requirements
 256      have; pick the combination that results in the smallest padding
 257      requirement.  Of course, if a zero-pad requirement is encountered, just
 258      use that one. */
 259
 260   for (um = *updated_modulo, i = 0; i < ucnt; um += *updated_alignment, ++i)
 261     {
 262       for (m = modulo, j = 0; j < cnt; m += alignment, ++j)
 263         {
 264           /* This code is similar to the "easy case" code above. */
 265           if (m > um)
 266             pad = ua - (m - um);
 267           else
 268             pad = um - m;
 269           pad = (offset + pad) % ua;
 270           if (pad == 0)
 271             {
 272               /* A zero pad means we've got something useful.  */
 273               *updated_alignment = ua;
 274               *updated_modulo = um;
 275               return 0;
 276             }
 277           pad = ua - pad;
 278           if (pad < min_pad)
 279             {                   /* New minimum padding value. */
 280               min_pad = pad;
 281               min_m = um;
 282             }
 283         }
 284     }
 285
 286   *updated_alignment = ua;
 287   *updated_modulo = min_m;
 288   return min_pad;
 289 }
 290
 291 /* Always append a null byte to the end, in case this is wanted in
 292    a special case such as passing a string as a FORMAT or %REF.
 293    Done to save a bit of hassle, nothing more, but it's a kludge anyway,
 294    because it isn't a "feature" that is self-documenting.  Use the
 295    string "FFETARGET-NULL-KLUDGE" to flag anyplace you use this feature
 296    in the code.  */
 297
 298 #if FFETARGET_okCHARACTER1
 299 bool
 300 ffetarget_character1 (ffetargetCharacter1 *val, ffelexToken character,
 301                       mallocPool pool)
 302 {
 303   val->length = ffelex_token_length (character);
 304   if (val->length == 0)
 305     val->text = NULL;
 306   else
 307     {
 308       val->text = malloc_new_kp (pool, "ffetargetCharacter1", val->length + 1);
 309       memcpy (val->text, ffelex_token_text (character), val->length);
 310       val->text[val->length] = '\0';
 311     }
 312
 313   return TRUE;
 314 }
 315
 316 #endif
 317 /* Produce orderable comparison between two constants
 318
 319    Compare lengths, if equal then use memcmp.  */
 320
 321 #if FFETARGET_okCHARACTER1
 322 int
 323 ffetarget_cmp_character1 (ffetargetCharacter1 l, ffetargetCharacter1 r)
 324 {
 325   if (l.length < r.length)
 326     return -1;
 327   if (l.length > r.length)
 328     return 1;
 329   if (l.length == 0)
 330     return 0;
 331   return memcmp (l.text, r.text, l.length);
 332 }
 333
 334 #endif
 335 /* ffetarget_concatenate_character1 -- Perform CONCAT op on two constants
 336
 337    Always append a null byte to the end, in case this is wanted in
 338    a special case such as passing a string as a FORMAT or %REF.
 339    Done to save a bit of hassle, nothing more, but it's a kludge anyway,
 340    because it isn't a "feature" that is self-documenting.  Use the
 341    string "FFETARGET-NULL-KLUDGE" to flag anyplace you use this feature
 342    in the code.  */
 343
 344 #if FFETARGET_okCHARACTER1
 345 ffebad
 346 ffetarget_concatenate_character1 (ffetargetCharacter1 *res,
 347               ffetargetCharacter1 l, ffetargetCharacter1 r, mallocPool pool,
 348                                   ffetargetCharacterSize *len)
 349 {
 350   res->length = *len = l.length + r.length;
 351   if (*len == 0)
 352     res->text = NULL;
 353   else
 354     {
 355       res->text = malloc_new_kp (pool, "ffetargetCharacter1(CONCAT)", *len + 1);
 356       if (l.length != 0)
 357         memcpy (res->text, l.text, l.length);
 358       if (r.length != 0)
 359         memcpy (res->text + l.length, r.text, r.length);
 360       res->text[*len] = '\0';
 361     }
 362
 363   return FFEBAD;
 364 }
 365
 366 #endif
 367 /* ffetarget_eq_character1 -- Perform relational comparison on char constants
 368
 369    Compare lengths, if equal then use memcmp.  */
 370
 371 #if FFETARGET_okCHARACTER1
 372 ffebad
 373 ffetarget_eq_character1 (bool *res, ffetargetCharacter1 l,
 374                          ffetargetCharacter1 r)
 375 {
 376   assert (l.length == r.length);
 377   *res = (memcmp (l.text, r.text, l.length) == 0);
 378   return FFEBAD;
 379 }
 380
 381 #endif
 382 /* ffetarget_le_character1 -- Perform relational comparison on char constants
 383
 384    Compare lengths, if equal then use memcmp.  */
 385
 386 #if FFETARGET_okCHARACTER1
 387 ffebad
 388 ffetarget_le_character1 (bool *res, ffetargetCharacter1 l,
 389                          ffetargetCharacter1 r)
 390 {
 391   assert (l.length == r.length);
 392   *res = (memcmp (l.text, r.text, l.length) <= 0);
 393   return FFEBAD;
 394 }
 395
 396 #endif
 397 /* ffetarget_lt_character1 -- Perform relational comparison on char constants
 398
 399    Compare lengths, if equal then use memcmp.  */
 400
 401 #if FFETARGET_okCHARACTER1
 402 ffebad
 403 ffetarget_lt_character1 (bool *res, ffetargetCharacter1 l,
 404                          ffetargetCharacter1 r)
 405 {
 406   assert (l.length == r.length);
 407   *res = (memcmp (l.text, r.text, l.length) < 0);
 408   return FFEBAD;
 409 }
 410
 411 #endif
 412 /* ffetarget_ge_character1 -- Perform relational comparison on char constants
 413
 414    Compare lengths, if equal then use memcmp.  */
 415
 416 #if FFETARGET_okCHARACTER1
 417 ffebad
 418 ffetarget_ge_character1 (bool *res, ffetargetCharacter1 l,
 419                          ffetargetCharacter1 r)
 420 {
 421   assert (l.length == r.length);
 422   *res = (memcmp (l.text, r.text, l.length) >= 0);
 423   return FFEBAD;
 424 }
 425
 426 #endif
 427 /* ffetarget_gt_character1 -- Perform relational comparison on char constants
 428
 429    Compare lengths, if equal then use memcmp.  */
 430
 431 #if FFETARGET_okCHARACTER1
 432 ffebad
 433 ffetarget_gt_character1 (bool *res, ffetargetCharacter1 l,
 434                          ffetargetCharacter1 r)
 435 {
 436   assert (l.length == r.length);
 437   *res = (memcmp (l.text, r.text, l.length) > 0);
 438   return FFEBAD;
 439 }
 440 #endif
 441
 442 #if FFETARGET_okCHARACTER1
 443 bool
 444 ffetarget_iszero_character1 (ffetargetCharacter1 constant)
 445 {
 446   ffetargetCharacterSize i;
 447
 448   for (i = 0; i < constant.length; ++i)
 449     if (constant.text[i] != 0)
 450       return FALSE;
 451   return TRUE;
 452 }
 453 #endif
 454
 455 bool
 456 ffetarget_iszero_hollerith (ffetargetHollerith constant)
 457 {
 458   ffetargetHollerithSize i;
 459
 460   for (i = 0; i < constant.length; ++i)
 461     if (constant.text[i] != 0)
 462       return FALSE;
 463   return TRUE;
 464 }
 465
 466 /* ffetarget_layout -- Do storage requirement analysis for entity
 467
 468    Return the alignment/modulo requirements along with the size, given the
 469    data type info and the number of elements an array (1 for a scalar).  */
 470
 471 void
 472 ffetarget_layout (const char *error_text UNUSED, ffetargetAlign *alignment,
 473                   ffetargetAlign *modulo, ffetargetOffset *size,
 474                   ffeinfoBasictype bt, ffeinfoKindtype kt,
 475                   ffetargetCharacterSize charsize,
 476                   ffetargetIntegerDefault num_elements)
 477 {
 478   bool ok;                      /* For character type. */
 479   ffetargetOffset numele;       /* Converted from num_elements. */
 480   ffetype type;
 481
 482   type = ffeinfo_type (bt, kt);
 483   assert (type != NULL);
 484
 485   *alignment = ffetype_alignment (type);
 486   *modulo = ffetype_modulo (type);
 487   if (bt == FFEINFO_basictypeCHARACTER)
 488     {
 489       ok = ffetarget_offset_charsize (size, charsize, ffetype_size (type));
 490 #ifdef ffetarget_offset_overflow
 491       if (!ok)
 492         ffetarget_offset_overflow (error_text);
 493 #endif
 494     }
 495   else
 496     *size = ffetype_size (type);
 497
 498   if ((num_elements < 0)
 499       || !ffetarget_offset (&numele, num_elements)
 500       || !ffetarget_offset_multiply (size, *size, numele))
 501     {
 502       ffetarget_offset_overflow (error_text);
 503       *alignment = 1;
 504       *modulo = 0;
 505       *size = 0;
 506     }
 507 }
 508
 509 /* ffetarget_ne_character1 -- Perform relational comparison on char constants
 510
 511    Compare lengths, if equal then use memcmp.  */
 512
 513 #if FFETARGET_okCHARACTER1
 514 ffebad
 515 ffetarget_ne_character1 (bool *res, ffetargetCharacter1 l,
 516                          ffetargetCharacter1 r)
 517 {
 518   assert (l.length == r.length);
 519   *res = (memcmp (l.text, r.text, l.length) != 0);
 520   return FFEBAD;
 521 }
 522
 523 #endif
 524 /* ffetarget_substr_character1 -- Perform SUBSTR op on three constants
 525
 526    Always append a null byte to the end, in case this is wanted in
 527    a special case such as passing a string as a FORMAT or %REF.
 528    Done to save a bit of hassle, nothing more, but it's a kludge anyway,
 529    because it isn't a "feature" that is self-documenting.  Use the
 530    string "FFETARGET-NULL-KLUDGE" to flag anyplace you use this feature
 531    in the code.  */
 532
 533 #if FFETARGET_okCHARACTER1
 534 ffebad
 535 ffetarget_substr_character1 (ffetargetCharacter1 *res,
 536                              ffetargetCharacter1 l,
 537                              ffetargetCharacterSize first,
 538                              ffetargetCharacterSize last, mallocPool pool,
 539                              ffetargetCharacterSize *len)
 540 {
 541   if (last < first)
 542     {
 543       res->length = *len = 0;
 544       res->text = NULL;
 545     }
 546   else
 547     {
 548       res->length = *len = last - first + 1;
 549       res->text = malloc_new_kp (pool, "ffetargetCharacter1(SUBSTR)", *len + 1);
 550       memcpy (res->text, l.text + first - 1, *len);
 551       res->text[*len] = '\0';
 552     }
 553
 554   return FFEBAD;
 555 }
 556
 557 #endif
 558 /* ffetarget_cmp_hollerith -- Produce orderable comparison between two
 559    constants
 560
 561    Compare lengths, if equal then use memcmp.  */
 562
 563 int
 564 ffetarget_cmp_hollerith (ffetargetHollerith l, ffetargetHollerith r)
 565 {
 566   if (l.length < r.length)
 567     return -1;
 568   if (l.length > r.length)
 569     return 1;
 570   return memcmp (l.text, r.text, l.length);
 571 }
 572
 573 ffebad
 574 ffetarget_convert_any_character1_ (char *res, size_t size,
 575                                    ffetargetCharacter1 l)
 576 {
 577   if (size <= (size_t) l.length)
 578     {
 579       char *p;
 580       ffetargetCharacterSize i;
 581
 582       memcpy (res, l.text, size);
 583       for (p = &l.text[0] + size, i = l.length - size;
 584            i > 0;
 585            ++p, --i)
 586         if (*p != ' ')
 587           return FFEBAD_TRUNCATING_CHARACTER;
 588     }
 589   else
 590     {
 591       memcpy (res, l.text, size);
 592       memset (res + l.length, ' ', size - l.length);
 593     }
 594
 595   return FFEBAD;
 596 }
 597
 598 ffebad
 599 ffetarget_convert_any_hollerith_ (char *res, size_t size,
 600                                   ffetargetHollerith l)
 601 {
 602   if (size <= (size_t) l.length)
 603     {
 604       char *p;
 605       ffetargetCharacterSize i;
 606
 607       memcpy (res, l.text, size);
 608       for (p = &l.text[0] + size, i = l.length - size;
 609            i > 0;
 610            ++p, --i)
 611         if (*p != ' ')
 612           return FFEBAD_TRUNCATING_HOLLERITH;
 613     }
 614   else
 615     {
 616       memcpy (res, l.text, size);
 617       memset (res + l.length, ' ', size - l.length);
 618     }
 619
 620   return FFEBAD;
 621 }
 622
 623 ffebad
 624 ffetarget_convert_any_typeless_ (char *res, size_t size,
 625                                  ffetargetTypeless l)
 626 {
 627   unsigned long long int l1;
 628   unsigned long int l2;
 629   unsigned int l3;
 630   unsigned short int l4;
 631   unsigned char l5;
 632   size_t size_of;
 633   char *p;
 634
 635   if (size >= sizeof (l1))
 636     {
 637       l1 = l;
 638       p = (char *) &l1;
 639       size_of = sizeof (l1);
 640     }
 641   else if (size >= sizeof (l2))
 642     {
 643       l2 = l;
 644       p = (char *) &l2;
 645       size_of = sizeof (l2);
 646       l1 = l2;
 647     }
 648   else if (size >= sizeof (l3))
 649     {
 650       l3 = l;
 651       p = (char *) &l3;
 652       size_of = sizeof (l3);
 653       l1 = l3;
 654     }
 655   else if (size >= sizeof (l4))
 656     {
 657       l4 = l;
 658       p = (char *) &l4;
 659       size_of = sizeof (l4);
 660       l1 = l4;
 661     }
 662   else if (size >= sizeof (l5))
 663     {
 664       l5 = l;
 665       p = (char *) &l5;
 666       size_of = sizeof (l5);
 667       l1 = l5;
 668     }
 669   else
 670     {
 671       assert ("stumped by conversion from typeless!" == NULL);
 672       abort ();
 673     }
 674
 675   if (size <= size_of)
 676     {
 677       int i = size_of - size;
 678
 679       memcpy (res, p + i, size);
 680       for (; i > 0; ++p, --i)
 681         if (*p != '\0')
 682           return FFEBAD_TRUNCATING_TYPELESS;
 683     }
 684   else
 685     {
 686       int i = size - size_of;
 687
 688       memset (res, 0, i);
 689       memcpy (res + i, p, size_of);
 690     }
 691
 692   if (l1 != l)
 693     return FFEBAD_TRUNCATING_TYPELESS;
 694   return FFEBAD;
 695 }
 696
 697 /* Always append a null byte to the end, in case this is wanted in
 698    a special case such as passing a string as a FORMAT or %REF.
 699    Done to save a bit of hassle, nothing more, but it's a kludge anyway,
 700    because it isn't a "feature" that is self-documenting.  Use the
 701    string "FFETARGET-NULL-KLUDGE" to flag anyplace you use this feature
 702    in the code.  */
 703
 704 #if FFETARGET_okCHARACTER1
 705 ffebad
 706 ffetarget_convert_character1_character1 (ffetargetCharacter1 *res,
 707                                          ffetargetCharacterSize size,
 708                                          ffetargetCharacter1 l,
 709                                          mallocPool pool)
 710 {
 711   res->length = size;
 712   if (size == 0)
 713     res->text = NULL;
 714   else
 715     {
 716       res->text = malloc_new_kp (pool, "FFETARGET cvt char1", size + 1);
 717       if (size <= l.length)
 718         memcpy (res->text, l.text, size);
 719       else
 720         {
 721           memcpy (res->text, l.text, l.length);
 722           memset (res->text + l.length, ' ', size - l.length);
 723         }
 724       res->text[size] = '\0';
 725     }
 726
 727   return FFEBAD;
 728 }
 729
 730 #endif
 731
 732 /* Always append a null byte to the end, in case this is wanted in
 733    a special case such as passing a string as a FORMAT or %REF.
 734    Done to save a bit of hassle, nothing more, but it's a kludge anyway,
 735    because it isn't a "feature" that is self-documenting.  Use the
 736    string "FFETARGET-NULL-KLUDGE" to flag anyplace you use this feature
 737    in the code.  */
 738
 739 #if FFETARGET_okCHARACTER1
 740 ffebad
 741 ffetarget_convert_character1_hollerith (ffetargetCharacter1 *res,
 742                                         ffetargetCharacterSize size,
 743                                         ffetargetHollerith l, mallocPool pool)
 744 {
 745   res->length = size;
 746   if (size == 0)
 747     res->text = NULL;
 748   else
 749     {
 750       res->text = malloc_new_kp (pool, "FFETARGET cvt char1", size + 1);
 751       res->text[size] = '\0';
 752       if (size <= l.length)
 753         {
 754           char *p;
 755           ffetargetCharacterSize i;
 756
 757           memcpy (res->text, l.text, size);
 758           for (p = &l.text[0] + size, i = l.length - size;
 759                i > 0;
 760                ++p, --i)
 761             if (*p != ' ')
 762               return FFEBAD_TRUNCATING_HOLLERITH;
 763         }
 764       else
 765         {
 766           memcpy (res->text, l.text, l.length);
 767           memset (res->text + l.length, ' ', size - l.length);
 768         }
 769     }
 770
 771   return FFEBAD;
 772 }
 773
 774 #endif
 775 /* ffetarget_convert_character1_integer4 -- Raw conversion.
 776
 777    Always append a null byte to the end, in case this is wanted in
 778    a special case such as passing a string as a FORMAT or %REF.
 779    Done to save a bit of hassle, nothing more, but it's a kludge anyway,
 780    because it isn't a "feature" that is self-documenting.  Use the
 781    string "FFETARGET-NULL-KLUDGE" to flag anyplace you use this feature
 782    in the code.  */
 783
 784 #if FFETARGET_okCHARACTER1
 785 ffebad
 786 ffetarget_convert_character1_integer4 (ffetargetCharacter1 *res,
 787                                        ffetargetCharacterSize size,
 788                                        ffetargetInteger4 l, mallocPool pool)
 789 {
 790   long long int l1;
 791   long int l2;
 792   int l3;
 793   short int l4;
 794   char l5;
 795   size_t size_of;
 796   char *p;
 797
 798   if (((size_t) size) >= sizeof (l1))
 799     {
 800       l1 = l;
 801       p = (char *) &l1;
 802       size_of = sizeof (l1);
 803     }
 804   else if (((size_t) size) >= sizeof (l2))
 805     {
 806       l2 = l;
 807       p = (char *) &l2;
 808       size_of = sizeof (l2);
 809       l1 = l2;
 810     }
 811   else if (((size_t) size) >= sizeof (l3))
 812     {
 813       l3 = l;
 814       p = (char *) &l3;
 815       size_of = sizeof (l3);
 816       l1 = l3;
 817     }
 818   else if (((size_t) size) >= sizeof (l4))
 819     {
 820       l4 = l;
 821       p = (char *) &l4;
 822       size_of = sizeof (l4);
 823       l1 = l4;
 824     }
 825   else if (((size_t) size) >= sizeof (l5))
 826     {
 827       l5 = l;
 828       p = (char *) &l5;
 829       size_of = sizeof (l5);
 830       l1 = l5;
 831     }
 832   else
 833     {
 834       assert ("stumped by conversion from integer1!" == NULL);
 835       abort ();
 836     }
 837
 838   res->length = size;
 839   if (size == 0)
 840     res->text = NULL;
 841   else
 842     {
 843       res->text = malloc_new_kp (pool, "FFETARGET cvt char1", size + 1);
 844       res->text[size] = '\0';
 845       if (((size_t) size) <= size_of)
 846         {
 847           int i = size_of - size;
 848
 849           memcpy (res->text, p + i, size);
 850           for (; i > 0; ++p, --i)
 851             if (*p != 0)
 852               return FFEBAD_TRUNCATING_NUMERIC;
 853         }
 854       else
 855         {
 856           int i = size - size_of;
 857
 858           memset (res->text, 0, i);
 859           memcpy (res->text + i, p, size_of);
 860         }
 861     }
 862
 863   if (l1 != l)
 864     return FFEBAD_TRUNCATING_NUMERIC;
 865   return FFEBAD;
 866 }
 867
 868 #endif
 869 /* ffetarget_convert_character1_logical4 -- Raw conversion.
 870
 871    Always append a null byte to the end, in case this is wanted in
 872    a special case such as passing a string as a FORMAT or %REF.
 873    Done to save a bit of hassle, nothing more, but it's a kludge anyway,
 874    because it isn't a "feature" that is self-documenting.  Use the
 875    string "FFETARGET-NULL-KLUDGE" to flag anyplace you use this feature
 876    in the code.  */
 877
 878 #if FFETARGET_okCHARACTER1
 879 ffebad
 880 ffetarget_convert_character1_logical4 (ffetargetCharacter1 *res,
 881                                        ffetargetCharacterSize size,
 882                                        ffetargetLogical4 l, mallocPool pool)
 883 {
 884   long long int l1;
 885   long int l2;
 886   int l3;
 887   short int l4;
 888   char l5;
 889   size_t size_of;
 890   char *p;
 891
 892   if (((size_t) size) >= sizeof (l1))
 893     {
 894       l1 = l;
 895       p = (char *) &l1;
 896       size_of = sizeof (l1);
 897     }
 898   else if (((size_t) size) >= sizeof (l2))
 899     {
 900       l2 = l;
 901       p = (char *) &l2;
 902       size_of = sizeof (l2);
 903       l1 = l2;
 904     }
 905   else if (((size_t) size) >= sizeof (l3))
 906     {
 907       l3 = l;
 908       p = (char *) &l3;
 909       size_of = sizeof (l3);
 910       l1 = l3;
 911     }
 912   else if (((size_t) size) >= sizeof (l4))
 913     {
 914       l4 = l;
 915       p = (char *) &l4;
 916       size_of = sizeof (l4);
 917       l1 = l4;
 918     }
 919   else if (((size_t) size) >= sizeof (l5))
 920     {
 921       l5 = l;
 922       p = (char *) &l5;
 923       size_of = sizeof (l5);
 924       l1 = l5;
 925     }
 926   else
 927     {
 928       assert ("stumped by conversion from logical1!" == NULL);
 929       abort ();
 930     }
 931
 932   res->length = size;
 933   if (size == 0)
 934     res->text = NULL;
 935   else
 936     {
 937       res->text = malloc_new_kp (pool, "FFETARGET cvt char1", size + 1);
 938       res->text[size] = '\0';
 939       if (((size_t) size) <= size_of)
 940         {
 941           int i = size_of - size;
 942
 943           memcpy (res->text, p + i, size);
 944           for (; i > 0; ++p, --i)
 945             if (*p != 0)
 946               return FFEBAD_TRUNCATING_NUMERIC;
 947         }
 948       else
 949         {
 950           int i = size - size_of;
 951
 952           memset (res->text, 0, i);
 953           memcpy (res->text + i, p, size_of);
 954         }
 955     }
 956
 957   if (l1 != l)
 958     return FFEBAD_TRUNCATING_NUMERIC;
 959   return FFEBAD;
 960 }
 961
 962 #endif
 963 /* ffetarget_convert_character1_typeless -- Raw conversion.
 964
 965    Always append a null byte to the end, in case this is wanted in
 966    a special case such as passing a string as a FORMAT or %REF.
 967    Done to save a bit of hassle, nothing more, but it's a kludge anyway,
 968    because it isn't a "feature" that is self-documenting.  Use the
 969    string "FFETARGET-NULL-KLUDGE" to flag anyplace you use this feature
 970    in the code.  */
 971
 972 #if FFETARGET_okCHARACTER1
 973 ffebad
 974 ffetarget_convert_character1_typeless (ffetargetCharacter1 *res,
 975                                        ffetargetCharacterSize size,
 976                                        ffetargetTypeless l, mallocPool pool)
 977 {
 978   unsigned long long int l1;
 979   unsigned long int l2;
 980   unsigned int l3;
 981   unsigned short int l4;
 982   unsigned char l5;
 983   size_t size_of;
 984   char *p;
 985
 986   if (((size_t) size) >= sizeof (l1))
 987     {
 988       l1 = l;
 989       p = (char *) &l1;
 990       size_of = sizeof (l1);
 991     }
 992   else if (((size_t) size) >= sizeof (l2))
 993     {
 994       l2 = l;
 995       p = (char *) &l2;
 996       size_of = sizeof (l2);
 997       l1 = l2;
 998     }
 999   else if (((size_t) size) >= sizeof (l3))
1000     {
1001       l3 = l;
1002       p = (char *) &l3;
1003       size_of = sizeof (l3);
1004       l1 = l3;
1005     }
1006   else if (((size_t) size) >= sizeof (l4))
1007     {
1008       l4 = l;
1009       p = (char *) &l4;
1010       size_of = sizeof (l4);
1011       l1 = l4;
1012     }
1013   else if (((size_t) size) >= sizeof (l5))
1014     {
1015       l5 = l;
1016       p = (char *) &l5;
1017       size_of = sizeof (l5);
1018       l1 = l5;
1019     }
1020   else
1021     {
1022       assert ("stumped by conversion from typeless!" == NULL);
1023       abort ();
1024     }
1025
1026   res->length = size;
1027   if (size == 0)
1028     res->text = NULL;
1029   else
1030     {
1031       res->text = malloc_new_kp (pool, "FFETARGET cvt char1", size + 1);
1032       res->text[size] = '\0';
1033       if (((size_t) size) <= size_of)
1034         {
1035           int i = size_of - size;
1036
1037           memcpy (res->text, p + i, size);
1038           for (; i > 0; ++p, --i)
1039             if (*p != 0)
1040               return FFEBAD_TRUNCATING_TYPELESS;
1041         }
1042       else
1043         {
1044           int i = size - size_of;
1045
1046           memset (res->text, 0, i);
1047           memcpy (res->text + i, p, size_of);
1048         }
1049     }
1050
1051   if (l1 != l)
1052     return FFEBAD_TRUNCATING_TYPELESS;
1053   return FFEBAD;
1054 }
1055
1056 #endif
1057 /* ffetarget_divide_complex1 -- Divide function
1058
1059    See prototype.  */
1060
1061 #if FFETARGET_okCOMPLEX1
1062 ffebad
1063 ffetarget_divide_complex1 (ffetargetComplex1 *res, ffetargetComplex1 l,
1064                            ffetargetComplex1 r)
1065 {
1066   ffebad bad;
1067   ffetargetReal1 tmp1, tmp2, tmp3, tmp4;
1068
1069   bad = ffetarget_multiply_real1 (&tmp1, r.real, r.real);
1070   if (bad != FFEBAD)
1071     return bad;
1072   bad = ffetarget_multiply_real1 (&tmp2, r.imaginary, r.imaginary);
1073   if (bad != FFEBAD)
1074     return bad;
1075   bad = ffetarget_add_real1 (&tmp3, tmp1, tmp2);
1076   if (bad != FFEBAD)
1077     return bad;
1078
1079   if (ffetarget_iszero_real1 (tmp3))
1080     {
1081       ffetarget_real1_zero (&(res)->real);
1082       ffetarget_real1_zero (&(res)->imaginary);
1083       return FFEBAD_DIV_BY_ZERO;
1084     }
1085
1086   bad = ffetarget_multiply_real1 (&tmp1, l.real, r.real);
1087   if (bad != FFEBAD)
1088     return bad;
1089   bad = ffetarget_multiply_real1 (&tmp2, l.imaginary, r.imaginary);
1090   if (bad != FFEBAD)
1091     return bad;
1092   bad = ffetarget_add_real1 (&tmp4, tmp1, tmp2);
1093   if (bad != FFEBAD)
1094     return bad;
1095   bad = ffetarget_divide_real1 (&res->real, tmp4, tmp3);
1096   if (bad != FFEBAD)
1097     return bad;
1098
1099   bad = ffetarget_multiply_real1 (&tmp1, r.real, l.imaginary);
1100   if (bad != FFEBAD)
1101     return bad;
1102   bad = ffetarget_multiply_real1 (&tmp2, l.real, r.imaginary);
1103   if (bad != FFEBAD)
1104     return bad;
1105   bad = ffetarget_subtract_real1 (&tmp4, tmp1, tmp2);
1106   if (bad != FFEBAD)
1107     return bad;
1108   bad = ffetarget_divide_real1 (&res->imaginary, tmp4, tmp3);
1109
1110   return FFEBAD;
1111 }
1112
1113 #endif
1114 /* ffetarget_divide_complex2 -- Divide function
1115
1116    See prototype.  */
1117
1118 #if FFETARGET_okCOMPLEX2
1119 ffebad
1120 ffetarget_divide_complex2 (ffetargetComplex2 *res, ffetargetComplex2 l,
1121                            ffetargetComplex2 r)
1122 {
1123   ffebad bad;
1124   ffetargetReal2 tmp1, tmp2, tmp3, tmp4;
1125
1126   bad = ffetarget_multiply_real2 (&tmp1, r.real, r.real);
1127   if (bad != FFEBAD)
1128     return bad;
1129   bad = ffetarget_multiply_real2 (&tmp2, r.imaginary, r.imaginary);
1130   if (bad != FFEBAD)
1131     return bad;
1132   bad = ffetarget_add_real2 (&tmp3, tmp1, tmp2);
1133   if (bad != FFEBAD)
1134     return bad;
1135
1136   if (ffetarget_iszero_real2 (tmp3))
1137     {
1138       ffetarget_real2_zero (&(res)->real);
1139       ffetarget_real2_zero (&(res)->imaginary);
1140       return FFEBAD_DIV_BY_ZERO;
1141     }
1142
1143   bad = ffetarget_multiply_real2 (&tmp1, l.real, r.real);
1144   if (bad != FFEBAD)
1145     return bad;
1146   bad = ffetarget_multiply_real2 (&tmp2, l.imaginary, r.imaginary);
1147   if (bad != FFEBAD)
1148     return bad;
1149   bad = ffetarget_add_real2 (&tmp4, tmp1, tmp2);
1150   if (bad != FFEBAD)
1151     return bad;
1152   bad = ffetarget_divide_real2 (&res->real, tmp4, tmp3);
1153   if (bad != FFEBAD)
1154     return bad;
1155
1156   bad = ffetarget_multiply_real2 (&tmp1, r.real, l.imaginary);
1157   if (bad != FFEBAD)
1158     return bad;
1159   bad = ffetarget_multiply_real2 (&tmp2, l.real, r.imaginary);
1160   if (bad != FFEBAD)
1161     return bad;
1162   bad = ffetarget_subtract_real2 (&tmp4, tmp1, tmp2);
1163   if (bad != FFEBAD)
1164     return bad;
1165   bad = ffetarget_divide_real2 (&res->imaginary, tmp4, tmp3);
1166
1167   return FFEBAD;
1168 }
1169
1170 #endif
1171 /* ffetarget_hollerith -- Convert token to a hollerith constant
1172
1173    Always append a null byte to the end, in case this is wanted in
1174    a special case such as passing a string as a FORMAT or %REF.
1175    Done to save a bit of hassle, nothing more, but it's a kludge anyway,
1176    because it isn't a "feature" that is self-documenting.  Use the
1177    string "FFETARGET-NULL-KLUDGE" to flag anyplace you use this feature
1178    in the code.  */
1179
1180 bool
1181 ffetarget_hollerith (ffetargetHollerith *val, ffelexToken integer,
1182                      mallocPool pool)
1183 {
1184   val->length = ffelex_token_length (integer);
1185   val->text = malloc_new_kp (pool, "ffetargetHollerith", val->length + 1);
1186   memcpy (val->text, ffelex_token_text (integer), val->length);
1187   val->text[val->length] = '\0';
1188
1189   return TRUE;
1190 }
1191
1192 /* ffetarget_integer_bad_magical -- Complain about a magical number
1193
1194    Just calls ffebad with the arguments.  */
1195
1196 void
1197 ffetarget_integer_bad_magical (ffelexToken t)
1198 {
1199   ffebad_start (FFEBAD_BAD_MAGICAL);
1200   ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
1201   ffebad_finish ();
1202 }
1203
1204 /* ffetarget_integer_bad_magical_binary -- Complain about a magical number
1205
1206    Just calls ffebad with the arguments.  */
1207
1208 void
1209 ffetarget_integer_bad_magical_binary (ffelexToken integer,
1210                                       ffelexToken minus)
1211 {
1212   ffebad_start (FFEBAD_BAD_MAGICAL_BINARY);
1213   ffebad_here (0, ffelex_token_where_line (integer),
1214                ffelex_token_where_column (integer));
1215   ffebad_here (1, ffelex_token_where_line (minus),
1216                ffelex_token_where_column (minus));
1217   ffebad_finish ();
1218 }
1219
1220 /* ffetarget_integer_bad_magical_precedence -- Complain about a magical
1221                                                    number
1222
1223    Just calls ffebad with the arguments.  */
1224
1225 void
1226 ffetarget_integer_bad_magical_precedence (ffelexToken integer,
1227                                           ffelexToken uminus,
1228                                           ffelexToken higher_op)
1229 {
1230   ffebad_start (FFEBAD_BAD_MAGICAL_PRECEDENCE);
1231   ffebad_here (0, ffelex_token_where_line (integer),
1232                ffelex_token_where_column (integer));
1233   ffebad_here (1, ffelex_token_where_line (uminus),
1234                ffelex_token_where_column (uminus));
1235   ffebad_here (2, ffelex_token_where_line (higher_op),
1236                ffelex_token_where_column (higher_op));
1237   ffebad_finish ();
1238 }
1239
1240 /* ffetarget_integer_bad_magical_precedence_binary -- Complain...
1241
1242    Just calls ffebad with the arguments.  */
1243
1244 void
1245 ffetarget_integer_bad_magical_precedence_binary (ffelexToken integer,
1246                                                  ffelexToken minus,
1247                                                  ffelexToken higher_op)
1248 {
1249   ffebad_start (FFEBAD_BAD_MAGICAL_PRECEDENCE_BINARY);
1250   ffebad_here (0, ffelex_token_where_line (integer),
1251                ffelex_token_where_column (integer));
1252   ffebad_here (1, ffelex_token_where_line (minus),
1253                ffelex_token_where_column (minus));
1254   ffebad_here (2, ffelex_token_where_line (higher_op),
1255                ffelex_token_where_column (higher_op));
1256   ffebad_finish ();
1257 }
1258
1259 /* ffetarget_integer1 -- Convert token to an integer
1260
1261    See prototype.
1262
1263    Token use count not affected overall.  */
1264
1265 #if FFETARGET_okINTEGER1
1266 bool
1267 ffetarget_integer1 (ffetargetInteger1 *val, ffelexToken integer)
1268 {
1269   ffetargetInteger1 x;
1270   char *p;
1271   char c;
1272
1273   assert (ffelex_token_type (integer) == FFELEX_typeNUMBER);
1274
1275   p = ffelex_token_text (integer);
1276   x = 0;
1277
1278   /* Skip past leading zeros. */
1279
1280   while (((c = *p) != '\0') && (c == '0'))
1281     ++p;
1282
1283   /* Interpret rest of number. */
1284
1285   while (c != '\0')
1286     {
1287       if ((x == FFETARGET_integerALMOST_BIG_MAGICAL)
1288           && (c == '0' + FFETARGET_integerFINISH_BIG_MAGICAL)
1289           && (*(p + 1) == '\0'))
1290         {
1291           *val = (ffetargetInteger1) FFETARGET_integerBIG_MAGICAL;
1292           return TRUE;
1293         }
1294       else if (x == FFETARGET_integerALMOST_BIG_MAGICAL)
1295         {
1296           if ((c > '0' + FFETARGET_integerFINISH_BIG_MAGICAL)
1297               || (*(p + 1) != '\0'))
1298             {
1299               ffebad_start (FFEBAD_INTEGER_TOO_LARGE);
1300               ffebad_here (0, ffelex_token_where_line (integer),
1301                            ffelex_token_where_column (integer));
1302               ffebad_finish ();
1303               *val = 0;
1304               return FALSE;
1305             }
1306         }
1307       else if (x > FFETARGET_integerALMOST_BIG_MAGICAL)
1308         {
1309           ffebad_start (FFEBAD_INTEGER_TOO_LARGE);
1310           ffebad_here (0, ffelex_token_where_line (integer),
1311                        ffelex_token_where_column (integer));
1312           ffebad_finish ();
1313           *val = 0;
1314           return FALSE;
1315         }
1316       x = x * 10 + c - '0';
1317       c = *(++p);
1318     };
1319
1320   *val = x;
1321   return TRUE;
1322 }
1323
1324 #endif
1325 /* ffetarget_integerbinary -- Convert token to a binary integer
1326
1327    ffetarget_integerbinary x;
1328    if (ffetarget_integerdefault_8(&x,integer_token))
1329        // conversion ok.
1330
1331    Token use count not affected overall.  */
1332
1333 bool
1334 ffetarget_integerbinary (ffetargetIntegerDefault *val, ffelexToken integer)
1335 {
1336   ffetargetIntegerDefault x;
1337   char *p;
1338   char c;
1339   bool bad_digit;
1340
1341   assert ((ffelex_token_type (integer) == FFELEX_typeNAME)
1342           || (ffelex_token_type (integer) == FFELEX_typeNUMBER));
1343
1344   p = ffelex_token_text (integer);
1345   x = 0;
1346
1347   /* Skip past leading zeros. */
1348
1349   while (((c = *p) != '\0') && (c == '0'))
1350     ++p;
1351
1352   /* Interpret rest of number. */
1353
1354   bad_digit = FALSE;
1355   while (c != '\0')
1356     {
1357       if ((c >= '0') && (c <= '1'))
1358         c -= '0';
1359       else
1360         {
1361           bad_digit = TRUE;
1362           c = 0;
1363         }
1364
1365 #if 0                           /* Don't complain about signed overflow; just
1366                                    unsigned overflow. */
1367       if ((x == FFETARGET_integerALMOST_BIG_OVERFLOW_BINARY)
1368           && (c == FFETARGET_integerFINISH_BIG_OVERFLOW_BINARY)
1369           && (*(p + 1) == '\0'))
1370         {
1371           *val = FFETARGET_integerBIG_OVERFLOW_BINARY;
1372           return TRUE;
1373         }
1374       else
1375 #endif
1376 #if FFETARGET_integerFINISH_BIG_OVERFLOW_BINARY == 0
1377       if ((x & FFETARGET_integerALMOST_BIG_OVERFLOW_BINARY) != 0)
1378 #else
1379       if (x == FFETARGET_integerALMOST_BIG_OVERFLOW_BINARY)
1380         {
1381           if ((c > FFETARGET_integerFINISH_BIG_OVERFLOW_BINARY)
1382               || (*(p + 1) != '\0'))
1383             {
1384               ffebad_start (FFEBAD_INTEGER_TOO_LARGE);
1385               ffebad_here (0, ffelex_token_where_line (integer),
1386                            ffelex_token_where_column (integer));
1387               ffebad_finish ();
1388               *val = 0;
1389               return FALSE;
1390             }
1391         }
1392       else if (x > FFETARGET_integerALMOST_BIG_OVERFLOW_BINARY)
1393 #endif
1394         {
1395           ffebad_start (FFEBAD_INTEGER_TOO_LARGE);
1396           ffebad_here (0, ffelex_token_where_line (integer),
1397                        ffelex_token_where_column (integer));
1398           ffebad_finish ();
1399           *val = 0;
1400           return FALSE;
1401         }
1402       x = (x << 1) + c;
1403       c = *(++p);
1404     };
1405
1406   if (bad_digit)
1407     {
1408       ffebad_start (FFEBAD_INVALID_BINARY_DIGIT);
1409       ffebad_here (0, ffelex_token_where_line (integer),
1410                    ffelex_token_where_column (integer));
1411       ffebad_finish ();
1412     }
1413
1414   *val = x;
1415   return !bad_digit;
1416 }
1417
1418 /* ffetarget_integerhex -- Convert token to a hex integer
1419
1420    ffetarget_integerhex x;
1421    if (ffetarget_integerdefault_8(&x,integer_token))
1422        // conversion ok.
1423
1424    Token use count not affected overall.  */
1425
1426 bool
1427 ffetarget_integerhex (ffetargetIntegerDefault *val, ffelexToken integer)
1428 {
1429   ffetargetIntegerDefault x;
1430   char *p;
1431   char c;
1432   bool bad_digit;
1433
1434   assert ((ffelex_token_type (integer) == FFELEX_typeNAME)
1435           || (ffelex_token_type (integer) == FFELEX_typeNUMBER));
1436
1437   p = ffelex_token_text (integer);
1438   x = 0;
1439
1440   /* Skip past leading zeros. */
1441
1442   while (((c = *p) != '\0') && (c == '0'))
1443     ++p;
1444
1445   /* Interpret rest of number. */
1446
1447   bad_digit = FALSE;
1448   while (c != '\0')
1449     {
1450       if (hex_p (c))
1451         c = hex_value (c);
1452       else
1453         {
1454           bad_digit = TRUE;
1455           c = 0;
1456         }
1457
1458 #if 0                           /* Don't complain about signed overflow; just
1459                                    unsigned overflow. */
1460       if ((x == FFETARGET_integerALMOST_BIG_OVERFLOW_HEX)
1461           && (c == FFETARGET_integerFINISH_BIG_OVERFLOW_HEX)
1462           && (*(p + 1) == '\0'))
1463         {
1464           *val = FFETARGET_integerBIG_OVERFLOW_HEX;
1465           return TRUE;
1466         }
1467       else
1468 #endif
1469 #if FFETARGET_integerFINISH_BIG_OVERFLOW_HEX == 0
1470       if (x >= FFETARGET_integerALMOST_BIG_OVERFLOW_HEX)
1471 #else
1472       if (x == FFETARGET_integerALMOST_BIG_OVERFLOW_HEX)
1473         {
1474           if ((c > FFETARGET_integerFINISH_BIG_OVERFLOW_HEX)
1475               || (*(p + 1) != '\0'))
1476             {
1477               ffebad_start (FFEBAD_INTEGER_TOO_LARGE);
1478               ffebad_here (0, ffelex_token_where_line (integer),
1479                            ffelex_token_where_column (integer));
1480               ffebad_finish ();
1481               *val = 0;
1482               return FALSE;
1483             }
1484         }
1485       else if (x > FFETARGET_integerALMOST_BIG_OVERFLOW_HEX)
1486 #endif
1487         {
1488           ffebad_start (FFEBAD_INTEGER_TOO_LARGE);
1489           ffebad_here (0, ffelex_token_where_line (integer),
1490                        ffelex_token_where_column (integer));
1491           ffebad_finish ();
1492           *val = 0;
1493           return FALSE;
1494         }
1495       x = (x << 4) + c;
1496       c = *(++p);
1497     };
1498
1499   if (bad_digit)
1500     {
1501       ffebad_start (FFEBAD_INVALID_HEX_DIGIT);
1502       ffebad_here (0, ffelex_token_where_line (integer),
1503                    ffelex_token_where_column (integer));
1504       ffebad_finish ();
1505     }
1506
1507   *val = x;
1508   return !bad_digit;
1509 }
1510
1511 /* ffetarget_integeroctal -- Convert token to an octal integer
1512
1513    ffetarget_integeroctal x;
1514    if (ffetarget_integerdefault_8(&x,integer_token))
1515        // conversion ok.
1516
1517    Token use count not affected overall.  */
1518
1519 bool
1520 ffetarget_integeroctal (ffetargetIntegerDefault *val, ffelexToken integer)
1521 {
1522   ffetargetIntegerDefault x;
1523   char *p;
1524   char c;
1525   bool bad_digit;
1526
1527   assert ((ffelex_token_type (integer) == FFELEX_typeNAME)
1528           || (ffelex_token_type (integer) == FFELEX_typeNUMBER));
1529
1530   p = ffelex_token_text (integer);
1531   x = 0;
1532
1533   /* Skip past leading zeros. */
1534
1535   while (((c = *p) != '\0') && (c == '0'))
1536     ++p;
1537
1538   /* Interpret rest of number. */
1539
1540   bad_digit = FALSE;
1541   while (c != '\0')
1542     {
1543       if ((c >= '0') && (c <= '7'))
1544         c -= '0';
1545       else
1546         {
1547           bad_digit = TRUE;
1548           c = 0;
1549         }
1550
1551 #if 0                           /* Don't complain about signed overflow; just
1552                                    unsigned overflow. */
1553       if ((x == FFETARGET_integerALMOST_BIG_OVERFLOW_OCTAL)
1554           && (c == FFETARGET_integerFINISH_BIG_OVERFLOW_OCTAL)
1555           && (*(p + 1) == '\0'))
1556         {
1557           *val = FFETARGET_integerBIG_OVERFLOW_OCTAL;
1558           return TRUE;
1559         }
1560       else
1561 #endif
1562 #if FFETARGET_integerFINISH_BIG_OVERFLOW_OCTAL == 0
1563       if (x >= FFETARGET_integerALMOST_BIG_OVERFLOW_OCTAL)
1564 #else
1565       if (x == FFETARGET_integerALMOST_BIG_OVERFLOW_OCTAL)
1566         {
1567           if ((c > FFETARGET_integerFINISH_BIG_OVERFLOW_OCTAL)
1568               || (*(p + 1) != '\0'))
1569             {
1570               ffebad_start (FFEBAD_INTEGER_TOO_LARGE);
1571               ffebad_here (0, ffelex_token_where_line (integer),
1572                            ffelex_token_where_column (integer));
1573               ffebad_finish ();
1574               *val = 0;
1575               return FALSE;
1576             }
1577         }
1578       else if (x > FFETARGET_integerALMOST_BIG_OVERFLOW_OCTAL)
1579 #endif
1580         {
1581           ffebad_start (FFEBAD_INTEGER_TOO_LARGE);
1582           ffebad_here (0, ffelex_token_where_line (integer),
1583                        ffelex_token_where_column (integer));
1584           ffebad_finish ();
1585           *val = 0;
1586           return FALSE;
1587         }
1588       x = (x << 3) + c;
1589       c = *(++p);
1590     };
1591
1592   if (bad_digit)
1593     {
1594       ffebad_start (FFEBAD_INVALID_OCTAL_DIGIT);
1595       ffebad_here (0, ffelex_token_where_line (integer),
1596                    ffelex_token_where_column (integer));
1597       ffebad_finish ();
1598     }
1599
1600   *val = x;
1601   return !bad_digit;
1602 }
1603
1604 /* ffetarget_multiply_complex1 -- Multiply function
1605
1606    See prototype.  */
1607
1608 #if FFETARGET_okCOMPLEX1
1609 ffebad
1610 ffetarget_multiply_complex1 (ffetargetComplex1 *res, ffetargetComplex1 l,
1611                              ffetargetComplex1 r)
1612 {
1613   ffebad bad;
1614   ffetargetReal1 tmp1, tmp2;
1615
1616   bad = ffetarget_multiply_real1 (&tmp1, l.real, r.real);
1617   if (bad != FFEBAD)
1618     return bad;
1619   bad = ffetarget_multiply_real1 (&tmp2, l.imaginary, r.imaginary);
1620   if (bad != FFEBAD)
1621     return bad;
1622   bad = ffetarget_subtract_real1 (&res->real, tmp1, tmp2);
1623   if (bad != FFEBAD)
1624     return bad;
1625   bad = ffetarget_multiply_real1 (&tmp1, l.imaginary, r.real);
1626   if (bad != FFEBAD)
1627     return bad;
1628   bad = ffetarget_multiply_real1 (&tmp2, l.real, r.imaginary);
1629   if (bad != FFEBAD)
1630     return bad;
1631   bad = ffetarget_add_real1 (&res->imaginary, tmp1, tmp2);
1632
1633   return bad;
1634 }
1635
1636 #endif
1637 /* ffetarget_multiply_complex2 -- Multiply function
1638
1639    See prototype.  */
1640
1641 #if FFETARGET_okCOMPLEX2
1642 ffebad
1643 ffetarget_multiply_complex2 (ffetargetComplex2 *res, ffetargetComplex2 l,
1644                              ffetargetComplex2 r)
1645 {
1646   ffebad bad;
1647   ffetargetReal2 tmp1, tmp2;
1648
1649   bad = ffetarget_multiply_real2 (&tmp1, l.real, r.real);
1650   if (bad != FFEBAD)
1651     return bad;
1652   bad = ffetarget_multiply_real2 (&tmp2, l.imaginary, r.imaginary);
1653   if (bad != FFEBAD)
1654     return bad;
1655   bad = ffetarget_subtract_real2 (&res->real, tmp1, tmp2);
1656   if (bad != FFEBAD)
1657     return bad;
1658   bad = ffetarget_multiply_real2 (&tmp1, l.imaginary, r.real);
1659   if (bad != FFEBAD)
1660     return bad;
1661   bad = ffetarget_multiply_real2 (&tmp2, l.real, r.imaginary);
1662   if (bad != FFEBAD)
1663     return bad;
1664   bad = ffetarget_add_real2 (&res->imaginary, tmp1, tmp2);
1665
1666   return bad;
1667 }
1668
1669 #endif
1670 /* ffetarget_power_complexdefault_integerdefault -- Power function
1671
1672    See prototype.  */
1673
1674 ffebad
1675 ffetarget_power_complexdefault_integerdefault (ffetargetComplexDefault *res,
1676                                                ffetargetComplexDefault l,
1677                                                ffetargetIntegerDefault r)
1678 {
1679   ffebad bad;
1680   ffetargetRealDefault tmp;
1681   ffetargetRealDefault tmp1;
1682   ffetargetRealDefault tmp2;
1683   ffetargetRealDefault two;
1684
1685   if (ffetarget_iszero_real1 (l.real)
1686       && ffetarget_iszero_real1 (l.imaginary))
1687     {
1688       ffetarget_real1_zero (&res->real);
1689       ffetarget_real1_zero (&res->imaginary);
1690       return FFEBAD;
1691     }
1692
1693   if (r == 0)
1694     {
1695       ffetarget_real1_one (&res->real);
1696       ffetarget_real1_zero (&res->imaginary);
1697       return FFEBAD;
1698     }
1699
1700   if (r < 0)
1701     {
1702       r = -r;
1703       bad = ffetarget_multiply_real1 (&tmp1, l.real, l.real);
1704       if (bad != FFEBAD)
1705         return bad;
1706       bad = ffetarget_multiply_real1 (&tmp2, l.imaginary, l.imaginary);
1707       if (bad != FFEBAD)
1708         return bad;
1709       bad = ffetarget_add_real1 (&tmp, tmp1, tmp2);
1710       if (bad != FFEBAD)
1711         return bad;
1712       bad = ffetarget_divide_real1 (&l.real, l.real, tmp);
1713       if (bad != FFEBAD)
1714         return bad;
1715       bad = ffetarget_divide_real1 (&l.imaginary, l.imaginary, tmp);
1716       if (bad != FFEBAD)
1717         return bad;
1718       bad = ffetarget_uminus_real1 (&l.imaginary, l.imaginary);
1719       if (bad != FFEBAD)
1720         return bad;
1721     }
1722
1723   ffetarget_real1_two (&two);
1724
1725   while ((r & 1) == 0)
1726     {
1727       bad = ffetarget_multiply_real1 (&tmp1, l.real, l.real);
1728       if (bad != FFEBAD)
1729         return bad;
1730       bad = ffetarget_multiply_real1 (&tmp2, l.imaginary, l.imaginary);
1731       if (bad != FFEBAD)
1732         return bad;
1733       bad = ffetarget_subtract_real1 (&tmp, tmp1, tmp2);
1734       if (bad != FFEBAD)
1735         return bad;
1736       bad = ffetarget_multiply_real1 (&l.imaginary, l.real, l.imaginary);
1737       if (bad != FFEBAD)
1738         return bad;
1739       bad = ffetarget_multiply_real1 (&l.imaginary, l.imaginary, two);
1740       if (bad != FFEBAD)
1741         return bad;
1742       l.real = tmp;
1743       r >>= 1;
1744     }
1745
1746   *res = l;
1747   r >>= 1;
1748
1749   while (r != 0)
1750     {
1751       bad = ffetarget_multiply_real1 (&tmp1, l.real, l.real);
1752       if (bad != FFEBAD)
1753         return bad;
1754       bad = ffetarget_multiply_real1 (&tmp2, l.imaginary, l.imaginary);
1755       if (bad != FFEBAD)
1756         return bad;
1757       bad = ffetarget_subtract_real1 (&tmp, tmp1, tmp2);
1758       if (bad != FFEBAD)
1759         return bad;
1760       bad = ffetarget_multiply_real1 (&l.imaginary, l.real, l.imaginary);
1761       if (bad != FFEBAD)
1762         return bad;
1763       bad = ffetarget_multiply_real1 (&l.imaginary, l.imaginary, two);
1764       if (bad != FFEBAD)
1765         return bad;
1766       l.real = tmp;
1767       if ((r & 1) == 1)
1768         {
1769           bad = ffetarget_multiply_real1 (&tmp1, res->real, l.real);
1770           if (bad != FFEBAD)
1771             return bad;
1772           bad = ffetarget_multiply_real1 (&tmp2, res->imaginary,
1773                                           l.imaginary);
1774           if (bad != FFEBAD)
1775             return bad;
1776           bad = ffetarget_subtract_real1 (&tmp, tmp1, tmp2);
1777           if (bad != FFEBAD)
1778             return bad;
1779           bad = ffetarget_multiply_real1 (&tmp1, res->imaginary, l.real);
1780           if (bad != FFEBAD)
1781             return bad;
1782           bad = ffetarget_multiply_real1 (&tmp2, res->real, l.imaginary);
1783           if (bad != FFEBAD)
1784             return bad;
1785           bad = ffetarget_add_real1 (&res->imaginary, tmp1, tmp2);
1786           if (bad != FFEBAD)
1787             return bad;
1788           res->real = tmp;
1789         }
1790       r >>= 1;
1791     }
1792
1793   return FFEBAD;
1794 }
1795
1796 /* ffetarget_power_complexdouble_integerdefault -- Power function
1797
1798    See prototype.  */
1799
1800 #if FFETARGET_okCOMPLEXDOUBLE
1801 ffebad
1802 ffetarget_power_complexdouble_integerdefault (ffetargetComplexDouble *res,
1803                         ffetargetComplexDouble l, ffetargetIntegerDefault r)
1804 {
1805   ffebad bad;
1806   ffetargetRealDouble tmp;
1807   ffetargetRealDouble tmp1;
1808   ffetargetRealDouble tmp2;
1809   ffetargetRealDouble two;
1810
1811   if (ffetarget_iszero_real2 (l.real)
1812       && ffetarget_iszero_real2 (l.imaginary))
1813     {
1814       ffetarget_real2_zero (&res->real);
1815       ffetarget_real2_zero (&res->imaginary);
1816       return FFEBAD;
1817     }
1818
1819   if (r == 0)
1820     {
1821       ffetarget_real2_one (&res->real);
1822       ffetarget_real2_zero (&res->imaginary);
1823       return FFEBAD;
1824     }
1825
1826   if (r < 0)
1827     {
1828       r = -r;
1829       bad = ffetarget_multiply_real2 (&tmp1, l.real, l.real);
1830       if (bad != FFEBAD)
1831         return bad;
1832       bad = ffetarget_multiply_real2 (&tmp2, l.imaginary, l.imaginary);
1833       if (bad != FFEBAD)
1834         return bad;
1835       bad = ffetarget_add_real2 (&tmp, tmp1, tmp2);
1836       if (bad != FFEBAD)
1837         return bad;
1838       bad = ffetarget_divide_real2 (&l.real, l.real, tmp);
1839       if (bad != FFEBAD)
1840         return bad;
1841       bad = ffetarget_divide_real2 (&l.imaginary, l.imaginary, tmp);
1842       if (bad != FFEBAD)
1843         return bad;
1844       bad = ffetarget_uminus_real2 (&l.imaginary, l.imaginary);
1845       if (bad != FFEBAD)
1846         return bad;
1847     }
1848
1849   ffetarget_real2_two (&two);
1850
1851   while ((r & 1) == 0)
1852     {
1853       bad = ffetarget_multiply_real2 (&tmp1, l.real, l.real);
1854       if (bad != FFEBAD)
1855         return bad;
1856       bad = ffetarget_multiply_real2 (&tmp2, l.imaginary, l.imaginary);
1857       if (bad != FFEBAD)
1858         return bad;
1859       bad = ffetarget_subtract_real2 (&tmp, tmp1, tmp2);
1860       if (bad != FFEBAD)
1861         return bad;
1862       bad = ffetarget_multiply_real2 (&l.imaginary, l.real, l.imaginary);
1863       if (bad != FFEBAD)
1864         return bad;
1865       bad = ffetarget_multiply_real2 (&l.imaginary, l.imaginary, two);
1866       if (bad != FFEBAD)
1867         return bad;
1868       l.real = tmp;
1869       r >>= 1;
1870     }
1871
1872   *res = l;
1873   r >>= 1;
1874
1875   while (r != 0)
1876     {
1877       bad = ffetarget_multiply_real2 (&tmp1, l.real, l.real);
1878       if (bad != FFEBAD)
1879         return bad;
1880       bad = ffetarget_multiply_real2 (&tmp2, l.imaginary, l.imaginary);
1881       if (bad != FFEBAD)
1882         return bad;
1883       bad = ffetarget_subtract_real2 (&tmp, tmp1, tmp2);
1884       if (bad != FFEBAD)
1885         return bad;
1886       bad = ffetarget_multiply_real2 (&l.imaginary, l.real, l.imaginary);
1887       if (bad != FFEBAD)
1888         return bad;
1889       bad = ffetarget_multiply_real2 (&l.imaginary, l.imaginary, two);
1890       if (bad != FFEBAD)
1891         return bad;
1892       l.real = tmp;
1893       if ((r & 1) == 1)
1894         {
1895           bad = ffetarget_multiply_real2 (&tmp1, res->real, l.real);
1896           if (bad != FFEBAD)
1897             return bad;
1898           bad = ffetarget_multiply_real2 (&tmp2, res->imaginary,
1899                                           l.imaginary);
1900           if (bad != FFEBAD)
1901             return bad;
1902           bad = ffetarget_subtract_real2 (&tmp, tmp1, tmp2);
1903           if (bad != FFEBAD)
1904             return bad;
1905           bad = ffetarget_multiply_real2 (&tmp1, res->imaginary, l.real);
1906           if (bad != FFEBAD)
1907             return bad;
1908           bad = ffetarget_multiply_real2 (&tmp2, res->real, l.imaginary);
1909           if (bad != FFEBAD)
1910             return bad;
1911           bad = ffetarget_add_real2 (&res->imaginary, tmp1, tmp2);
1912           if (bad != FFEBAD)
1913             return bad;
1914           res->real = tmp;
1915         }
1916       r >>= 1;
1917     }
1918
1919   return FFEBAD;
1920 }
1921
1922 #endif
1923 /* ffetarget_power_integerdefault_integerdefault -- Power function
1924
1925    See prototype.  */
1926
1927 ffebad
1928 ffetarget_power_integerdefault_integerdefault (ffetargetIntegerDefault *res,
1929                        ffetargetIntegerDefault l, ffetargetIntegerDefault r)
1930 {
1931   if (l == 0)
1932     {
1933       *res = 0;
1934       return FFEBAD;
1935     }
1936
1937   if (r == 0)
1938     {
1939       *res = 1;
1940       return FFEBAD;
1941     }
1942
1943   if (r < 0)
1944     {
1945       if (l == 1)
1946         *res = 1;
1947       else if (l == 0)
1948         *res = 1;
1949       else if (l == -1)
1950         *res = ((-r) & 1) == 0 ? 1 : -1;
1951       else
1952         *res = 0;
1953       return FFEBAD;
1954     }
1955
1956   while ((r & 1) == 0)
1957     {
1958       l *= l;
1959       r >>= 1;
1960     }
1961
1962   *res = l;
1963   r >>= 1;
1964
1965   while (r != 0)
1966     {
1967       l *= l;
1968       if ((r & 1) == 1)
1969         *res *= l;
1970       r >>= 1;
1971     }
1972
1973   return FFEBAD;
1974 }
1975
1976 /* ffetarget_power_realdefault_integerdefault -- Power function
1977
1978    See prototype.  */
1979
1980 ffebad
1981 ffetarget_power_realdefault_integerdefault (ffetargetRealDefault *res,
1982                           ffetargetRealDefault l, ffetargetIntegerDefault r)
1983 {
1984   ffebad bad;
1985
1986   if (ffetarget_iszero_real1 (l))
1987     {
1988       ffetarget_real1_zero (res);
1989       return FFEBAD;
1990     }
1991
1992   if (r == 0)
1993     {
1994       ffetarget_real1_one (res);
1995       return FFEBAD;
1996     }
1997
1998   if (r < 0)
1999     {
2000       ffetargetRealDefault one;
2001
2002       ffetarget_real1_one (&one);
2003       r = -r;
2004       bad = ffetarget_divide_real1 (&l, one, l);
2005       if (bad != FFEBAD)
2006         return bad;
2007     }
2008
2009   while ((r & 1) == 0)
2010     {
2011       bad = ffetarget_multiply_real1 (&l, l, l);
2012       if (bad != FFEBAD)
2013         return bad;
2014       r >>= 1;
2015     }
2016
2017   *res = l;
2018   r >>= 1;
2019
2020   while (r != 0)
2021     {
2022       bad = ffetarget_multiply_real1 (&l, l, l);
2023       if (bad != FFEBAD)
2024         return bad;
2025       if ((r & 1) == 1)
2026         {
2027           bad = ffetarget_multiply_real1 (res, *res, l);
2028           if (bad != FFEBAD)
2029             return bad;
2030         }
2031       r >>= 1;
2032     }
2033
2034   return FFEBAD;
2035 }
2036
2037 /* ffetarget_power_realdouble_integerdefault -- Power function
2038
2039    See prototype.  */
2040
2041 ffebad
2042 ffetarget_power_realdouble_integerdefault (ffetargetRealDouble *res,
2043                                            ffetargetRealDouble l,
2044                                            ffetargetIntegerDefault r)
2045 {
2046   ffebad bad;
2047
2048   if (ffetarget_iszero_real2 (l))
2049     {
2050       ffetarget_real2_zero (res);
2051       return FFEBAD;
2052     }
2053
2054   if (r == 0)
2055     {
2056       ffetarget_real2_one (res);
2057       return FFEBAD;
2058     }
2059
2060   if (r < 0)
2061     {
2062       ffetargetRealDouble one;
2063
2064       ffetarget_real2_one (&one);
2065       r = -r;
2066       bad = ffetarget_divide_real2 (&l, one, l);
2067       if (bad != FFEBAD)
2068         return bad;
2069     }
2070
2071   while ((r & 1) == 0)
2072     {
2073       bad = ffetarget_multiply_real2 (&l, l, l);
2074       if (bad != FFEBAD)
2075         return bad;
2076       r >>= 1;
2077     }
2078
2079   *res = l;
2080   r >>= 1;
2081
2082   while (r != 0)
2083     {
2084       bad = ffetarget_multiply_real2 (&l, l, l);
2085       if (bad != FFEBAD)
2086         return bad;
2087       if ((r & 1) == 1)
2088         {
2089           bad = ffetarget_multiply_real2 (res, *res, l);
2090           if (bad != FFEBAD)
2091             return bad;
2092         }
2093       r >>= 1;
2094     }
2095
2096   return FFEBAD;
2097 }
2098
2099 /* ffetarget_print_binary -- Output typeless binary integer
2100
2101    ffetargetTypeless val;
2102    ffetarget_typeless_binary(dmpout,val);  */
2103
2104 void
2105 ffetarget_print_binary (FILE *f, ffetargetTypeless value)
2106 {
2107   char *p;
2108   char digits[sizeof (value) * CHAR_BIT + 1];
2109
2110   if (f == NULL)
2111     f = dmpout;
2112
2113   p = &digits[ARRAY_SIZE (digits) - 1];
2114   *p = '\0';
2115   do
2116     {
2117       *--p = (value & 1) + '0';
2118       value >>= 1;
2119     } while (value == 0);
2120
2121   fputs (p, f);
2122 }
2123
2124 /* ffetarget_print_character1 -- Output character string
2125
2126    ffetargetCharacter1 val;
2127    ffetarget_print_character1(dmpout,val);  */
2128
2129 void
2130 ffetarget_print_character1 (FILE *f, ffetargetCharacter1 value)
2131 {
2132   unsigned char *p;
2133   ffetargetCharacterSize i;
2134
2135   fputc ('\'', dmpout);
2136   for (i = 0, p = value.text; i < value.length; ++i, ++p)
2137     ffetarget_print_char_ (f, *p);
2138   fputc ('\'', dmpout);
2139 }
2140
2141 /* ffetarget_print_hollerith -- Output hollerith string
2142
2143    ffetargetHollerith val;
2144    ffetarget_print_hollerith(dmpout,val);  */
2145
2146 void
2147 ffetarget_print_hollerith (FILE *f, ffetargetHollerith value)
2148 {
2149   unsigned char *p;
2150   ffetargetHollerithSize i;
2151
2152   fputc ('\'', dmpout);
2153   for (i = 0, p = value.text; i < value.length; ++i, ++p)
2154     ffetarget_print_char_ (f, *p);
2155   fputc ('\'', dmpout);
2156 }
2157
2158 /* ffetarget_print_octal -- Output typeless octal integer
2159
2160    ffetargetTypeless val;
2161    ffetarget_print_octal(dmpout,val);  */
2162
2163 void
2164 ffetarget_print_octal (FILE *f, ffetargetTypeless value)
2165 {
2166   char *p;
2167   char digits[sizeof (value) * CHAR_BIT / 3 + 1];
2168
2169   if (f == NULL)
2170     f = dmpout;
2171
2172   p = &digits[ARRAY_SIZE (digits) - 3];
2173   *p = '\0';
2174   do
2175     {
2176       *--p = (value & 3) + '0';
2177       value >>= 3;
2178     } while (value == 0);
2179
2180   fputs (p, f);
2181 }
2182
2183 /* ffetarget_print_hex -- Output typeless hex integer
2184
2185    ffetargetTypeless val;
2186    ffetarget_print_hex(dmpout,val);  */
2187
2188 void
2189 ffetarget_print_hex (FILE *f, ffetargetTypeless value)
2190 {
2191   char *p;
2192   char digits[sizeof (value) * CHAR_BIT / 4 + 1];
2193   static char hexdigits[16] = "0123456789ABCDEF";
2194
2195   if (f == NULL)
2196     f = dmpout;
2197
2198   p = &digits[ARRAY_SIZE (digits) - 3];
2199   *p = '\0';
2200   do
2201     {
2202       *--p = hexdigits[value & 4];
2203       value >>= 4;
2204     } while (value == 0);
2205
2206   fputs (p, f);
2207 }
2208
2209 /* ffetarget_real1 -- Convert token to a single-precision real number
2210
2211    See prototype.
2212
2213    Pass NULL for any token not provided by the user, but a valid Fortran
2214    real number must be provided somehow.  For example, it is ok for
2215    exponent_sign_token and exponent_digits_token to be NULL as long as
2216    exponent_token not only starts with "E" or "e" but also contains at least
2217    one digit following it.  Token use counts not affected overall.  */
2218
2219 #if FFETARGET_okREAL1
2220 bool
2221 ffetarget_real1 (ffetargetReal1 *value, ffelexToken integer,
2222                  ffelexToken decimal, ffelexToken fraction,
2223                  ffelexToken exponent, ffelexToken exponent_sign,
2224                  ffelexToken exponent_digits)
2225 {
2226   size_t sz = 1;                /* Allow room for '\0' byte at end. */
2227   char *ptr = &ffetarget_string_[0];
2228   char *p = ptr;
2229   char *q;
2230
2231 #define dotok(x) if (x != NULL) ++sz;
2232 #define dotoktxt(x) if (x != NULL) sz += ffelex_token_length(x)
2233
2234   dotoktxt (integer);
2235   dotok (decimal);
2236   dotoktxt (fraction);
2237   dotoktxt (exponent);
2238   dotok (exponent_sign);
2239   dotoktxt (exponent_digits);
2240
2241 #undef dotok
2242 #undef dotoktxt
2243
2244   if (sz > ARRAY_SIZE (ffetarget_string_))
2245     p = ptr = (char *) malloc_new_ks (malloc_pool_image (), "ffetarget_real1",
2246                                       sz);
2247
2248 #define dotoktxt(x) if (x != NULL)                                 \
2249                   {                                                \
2250                   for (q = ffelex_token_text(x); *q != '\0'; ++q)  \
2251                     *p++ = *q;                                     \
2252                   }
2253
2254   dotoktxt (integer);
2255
2256   if (decimal != NULL)
2257     *p++ = '.';
2258
2259   dotoktxt (fraction);
2260   dotoktxt (exponent);
2261
2262   if (exponent_sign != NULL)
2263     {
2264       if (ffelex_token_type (exponent_sign) == FFELEX_typePLUS)
2265         *p++ = '+';
2266       else
2267         {
2268           assert (ffelex_token_type (exponent_sign) == FFELEX_typeMINUS);
2269           *p++ = '-';
2270         }
2271     }
2272
2273   dotoktxt (exponent_digits);
2274
2275 #undef dotoktxt
2276
2277   *p = '\0';
2278
2279   ffetarget_make_real1 (value,
2280                         FFETARGET_ATOF_ (ptr,
2281                                          SFmode));
2282
2283   if (sz > ARRAY_SIZE (ffetarget_string_))
2284     malloc_kill_ks (malloc_pool_image (), ptr, sz);
2285
2286   return TRUE;
2287 }
2288
2289 #endif
2290 /* ffetarget_real2 -- Convert token to a single-precision real number
2291
2292    See prototype.
2293
2294    Pass NULL for any token not provided by the user, but a valid Fortran
2295    real number must be provided somehow.  For example, it is ok for
2296    exponent_sign_token and exponent_digits_token to be NULL as long as
2297    exponent_token not only starts with "E" or "e" but also contains at least
2298    one digit following it.  Token use counts not affected overall.  */
2299
2300 #if FFETARGET_okREAL2
2301 bool
2302 ffetarget_real2 (ffetargetReal2 *value, ffelexToken integer,
2303                  ffelexToken decimal, ffelexToken fraction,
2304                  ffelexToken exponent, ffelexToken exponent_sign,
2305                  ffelexToken exponent_digits)
2306 {
2307   size_t sz = 1;                /* Allow room for '\0' byte at end. */
2308   char *ptr = &ffetarget_string_[0];
2309   char *p = ptr;
2310   char *q;
2311
2312 #define dotok(x) if (x != NULL) ++sz;
2313 #define dotoktxt(x) if (x != NULL) sz += ffelex_token_length(x)
2314
2315   dotoktxt (integer);
2316   dotok (decimal);
2317   dotoktxt (fraction);
2318   dotoktxt (exponent);
2319   dotok (exponent_sign);
2320   dotoktxt (exponent_digits);
2321
2322 #undef dotok
2323 #undef dotoktxt
2324
2325   if (sz > ARRAY_SIZE (ffetarget_string_))
2326     p = ptr = (char *) malloc_new_ks (malloc_pool_image (), "ffetarget_real1", sz);
2327
2328 #define dotoktxt(x) if (x != NULL)                                 \
2329                   {                                                \
2330                   for (q = ffelex_token_text(x); *q != '\0'; ++q)  \
2331                     *p++ = *q;                                     \
2332                   }
2333 #define dotoktxtexp(x) if (x != NULL)                                  \
2334                   {                                                    \
2335                   *p++ = 'E';                                          \
2336                   for (q = ffelex_token_text(x) + 1; *q != '\0'; ++q)  \
2337                     *p++ = *q;                                         \
2338                   }
2339
2340   dotoktxt (integer);
2341
2342   if (decimal != NULL)
2343     *p++ = '.';
2344
2345   dotoktxt (fraction);
2346   dotoktxtexp (exponent);
2347
2348   if (exponent_sign != NULL)
2349     {
2350       if (ffelex_token_type (exponent_sign) == FFELEX_typePLUS)
2351         *p++ = '+';
2352       else
2353         {
2354           assert (ffelex_token_type (exponent_sign) == FFELEX_typeMINUS);
2355           *p++ = '-';
2356         }
2357     }
2358
2359   dotoktxt (exponent_digits);
2360
2361 #undef dotoktxt
2362
2363   *p = '\0';
2364
2365   ffetarget_make_real2 (value,
2366                         FFETARGET_ATOF_ (ptr,
2367                                          DFmode));
2368
2369   if (sz > ARRAY_SIZE (ffetarget_string_))
2370     malloc_kill_ks (malloc_pool_image (), ptr, sz);
2371
2372   return TRUE;
2373 }
2374
2375 #endif
2376 bool
2377 ffetarget_typeless_binary (ffetargetTypeless *xvalue, ffelexToken token)
2378 {
2379   char *p;
2380   char c;
2381   ffetargetTypeless value = 0;
2382   ffetargetTypeless new_value = 0;
2383   bool bad_digit = FALSE;
2384   bool overflow = FALSE;
2385
2386   p = ffelex_token_text (token);
2387
2388   for (c = *p; c != '\0'; c = *++p)
2389     {
2390       new_value <<= 1;
2391       if ((new_value >> 1) != value)
2392         overflow = TRUE;
2393       if (ISDIGIT (c))
2394         new_value += c - '0';
2395       else
2396         bad_digit = TRUE;
2397       value = new_value;
2398     }
2399
2400   if (bad_digit)
2401     {
2402       ffebad_start (FFEBAD_INVALID_TYPELESS_BINARY_DIGIT);
2403       ffebad_here (0, ffelex_token_where_line (token),
2404                    ffelex_token_where_column (token));
2405       ffebad_finish ();
2406     }
2407   else if (overflow)
2408     {
2409       ffebad_start (FFEBAD_TYPELESS_OVERFLOW);
2410       ffebad_here (0, ffelex_token_where_line (token),
2411                    ffelex_token_where_column (token));
2412       ffebad_finish ();
2413     }
2414
2415   *xvalue = value;
2416
2417   return !bad_digit && !overflow;
2418 }
2419
2420 bool
2421 ffetarget_typeless_octal (ffetargetTypeless *xvalue, ffelexToken token)
2422 {
2423   char *p;
2424   char c;
2425   ffetargetTypeless value = 0;
2426   ffetargetTypeless new_value = 0;
2427   bool bad_digit = FALSE;
2428   bool overflow = FALSE;
2429
2430   p = ffelex_token_text (token);
2431
2432   for (c = *p; c != '\0'; c = *++p)
2433     {
2434       new_value <<= 3;
2435       if ((new_value >> 3) != value)
2436         overflow = TRUE;
2437       if (ISDIGIT (c))
2438         new_value += c - '0';
2439       else
2440         bad_digit = TRUE;
2441       value = new_value;
2442     }
2443
2444   if (bad_digit)
2445     {
2446       ffebad_start (FFEBAD_INVALID_TYPELESS_OCTAL_DIGIT);
2447       ffebad_here (0, ffelex_token_where_line (token),
2448                    ffelex_token_where_column (token));
2449       ffebad_finish ();
2450     }
2451   else if (overflow)
2452     {
2453       ffebad_start (FFEBAD_TYPELESS_OVERFLOW);
2454       ffebad_here (0, ffelex_token_where_line (token),
2455                    ffelex_token_where_column (token));
2456       ffebad_finish ();
2457     }
2458
2459   *xvalue = value;
2460
2461   return !bad_digit && !overflow;
2462 }
2463
2464 bool
2465 ffetarget_typeless_hex (ffetargetTypeless *xvalue, ffelexToken token)
2466 {
2467   char *p;
2468   char c;
2469   ffetargetTypeless value = 0;
2470   ffetargetTypeless new_value = 0;
2471   bool bad_digit = FALSE;
2472   bool overflow = FALSE;
2473
2474   p = ffelex_token_text (token);
2475
2476   for (c = *p; c != '\0'; c = *++p)
2477     {
2478       new_value <<= 4;
2479       if ((new_value >> 4) != value)
2480         overflow = TRUE;
2481       if (hex_p (c))
2482         new_value += hex_value (c);
2483       else
2484         bad_digit = TRUE;
2485       value = new_value;
2486     }
2487
2488   if (bad_digit)
2489     {
2490       ffebad_start (FFEBAD_INVALID_TYPELESS_HEX_DIGIT);
2491       ffebad_here (0, ffelex_token_where_line (token),
2492                    ffelex_token_where_column (token));
2493       ffebad_finish ();
2494     }
2495   else if (overflow)
2496     {
2497       ffebad_start (FFEBAD_TYPELESS_OVERFLOW);
2498       ffebad_here (0, ffelex_token_where_line (token),
2499                    ffelex_token_where_column (token));
2500       ffebad_finish ();
2501     }
2502
2503   *xvalue = value;
2504
2505   return !bad_digit && !overflow;
2506 }
2507
2508 void
2509 ffetarget_verify_character1 (mallocPool pool, ffetargetCharacter1 val)
2510 {
2511   if (val.length != 0)
2512     malloc_verify_kp (pool, val.text, val.length);
2513 }
2514
2515 /* This is like memcpy.  It is needed because some systems' header files
2516    don't declare memcpy as a function but instead
2517    "#define memcpy(to,from,len) something".  */
2518
2519 void *
2520 ffetarget_memcpy_ (void *dst, void *src, size_t len)
2521 {
2522   return (void *) memcpy (dst, src, len);
2523 }
2524
2525 /* ffetarget_num_digits_ -- Determine number of non-space characters in token
2526
2527    ffetarget_num_digits_(token);
2528
2529    All non-spaces are assumed to be binary, octal, or hex digits.  */
2530
2531 int
2532 ffetarget_num_digits_ (ffelexToken token)
2533 {
2534   int i;
2535   char *c;
2536
2537   switch (ffelex_token_type (token))
2538     {
2539     case FFELEX_typeNAME:
2540     case FFELEX_typeNUMBER:
2541       return ffelex_token_length (token);
2542
2543     case FFELEX_typeCHARACTER:
2544       i = 0;
2545       for (c = ffelex_token_text (token); *c != '\0'; ++c)
2546         {
2547           if (*c != ' ')
2548             ++i;
2549         }
2550       return i;
2551
2552     default:
2553       assert ("weird token" == NULL);
2554       return 1;
2555     }
2556 }