gcc/f/target.c

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