contrib/gcc/f/target.c

   1 /* target.c -- Implementation File (module.c template V1.0)
   2    Copyright (C) 1995-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.j"
  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 ((c >= 'A') && (c <= 'F'))
1451         c = c - 'A' + 10;
1452       else if ((c >= 'a') && (c <= 'f'))
1453         c = c - 'a' + 10;
1454       else if ((c >= '0') && (c <= '9'))
1455         c -= '0';
1456       else
1457         {
1458           bad_digit = TRUE;
1459           c = 0;
1460         }
1461
1462 #if 0                           /* Don't complain about signed overflow; just
1463                                    unsigned overflow. */
1464       if ((x == FFETARGET_integerALMOST_BIG_OVERFLOW_HEX)
1465           && (c == FFETARGET_integerFINISH_BIG_OVERFLOW_HEX)
1466           && (*(p + 1) == '\0'))
1467         {
1468           *val = FFETARGET_integerBIG_OVERFLOW_HEX;
1469           return TRUE;
1470         }
1471       else
1472 #endif
1473 #if FFETARGET_integerFINISH_BIG_OVERFLOW_HEX == 0
1474       if (x >= FFETARGET_integerALMOST_BIG_OVERFLOW_HEX)
1475 #else
1476       if (x == FFETARGET_integerALMOST_BIG_OVERFLOW_HEX)
1477         {
1478           if ((c > FFETARGET_integerFINISH_BIG_OVERFLOW_HEX)
1479               || (*(p + 1) != '\0'))
1480             {
1481               ffebad_start (FFEBAD_INTEGER_TOO_LARGE);
1482               ffebad_here (0, ffelex_token_where_line (integer),
1483                            ffelex_token_where_column (integer));
1484               ffebad_finish ();
1485               *val = 0;
1486               return FALSE;
1487             }
1488         }
1489       else if (x > FFETARGET_integerALMOST_BIG_OVERFLOW_HEX)
1490 #endif
1491         {
1492           ffebad_start (FFEBAD_INTEGER_TOO_LARGE);
1493           ffebad_here (0, ffelex_token_where_line (integer),
1494                        ffelex_token_where_column (integer));
1495           ffebad_finish ();
1496           *val = 0;
1497           return FALSE;
1498         }
1499       x = (x << 4) + c;
1500       c = *(++p);
1501     };
1502
1503   if (bad_digit)
1504     {
1505       ffebad_start (FFEBAD_INVALID_HEX_DIGIT);
1506       ffebad_here (0, ffelex_token_where_line (integer),
1507                    ffelex_token_where_column (integer));
1508       ffebad_finish ();
1509     }
1510
1511   *val = x;
1512   return !bad_digit;
1513 }
1514
1515 /* ffetarget_integeroctal -- Convert token to an octal integer
1516
1517    ffetarget_integeroctal x;
1518    if (ffetarget_integerdefault_8(&x,integer_token))
1519        // conversion ok.
1520
1521    Token use count not affected overall.  */
1522
1523 bool
1524 ffetarget_integeroctal (ffetargetIntegerDefault *val, ffelexToken integer)
1525 {
1526   ffetargetIntegerDefault x;
1527   char *p;
1528   char c;
1529   bool bad_digit;
1530
1531   assert ((ffelex_token_type (integer) == FFELEX_typeNAME)
1532           || (ffelex_token_type (integer) == FFELEX_typeNUMBER));
1533
1534   p = ffelex_token_text (integer);
1535   x = 0;
1536
1537   /* Skip past leading zeros. */
1538
1539   while (((c = *p) != '\0') && (c == '0'))
1540     ++p;
1541
1542   /* Interpret rest of number. */
1543
1544   bad_digit = FALSE;
1545   while (c != '\0')
1546     {
1547       if ((c >= '0') && (c <= '7'))
1548         c -= '0';
1549       else
1550         {
1551           bad_digit = TRUE;
1552           c = 0;
1553         }
1554
1555 #if 0                           /* Don't complain about signed overflow; just
1556                                    unsigned overflow. */
1557       if ((x == FFETARGET_integerALMOST_BIG_OVERFLOW_OCTAL)
1558           && (c == FFETARGET_integerFINISH_BIG_OVERFLOW_OCTAL)
1559           && (*(p + 1) == '\0'))
1560         {
1561           *val = FFETARGET_integerBIG_OVERFLOW_OCTAL;
1562           return TRUE;
1563         }
1564       else
1565 #endif
1566 #if FFETARGET_integerFINISH_BIG_OVERFLOW_OCTAL == 0
1567       if (x >= FFETARGET_integerALMOST_BIG_OVERFLOW_OCTAL)
1568 #else
1569       if (x == FFETARGET_integerALMOST_BIG_OVERFLOW_OCTAL)
1570         {
1571           if ((c > FFETARGET_integerFINISH_BIG_OVERFLOW_OCTAL)
1572               || (*(p + 1) != '\0'))
1573             {
1574               ffebad_start (FFEBAD_INTEGER_TOO_LARGE);
1575               ffebad_here (0, ffelex_token_where_line (integer),
1576                            ffelex_token_where_column (integer));
1577               ffebad_finish ();
1578               *val = 0;
1579               return FALSE;
1580             }
1581         }
1582       else if (x > FFETARGET_integerALMOST_BIG_OVERFLOW_OCTAL)
1583 #endif
1584         {
1585           ffebad_start (FFEBAD_INTEGER_TOO_LARGE);
1586           ffebad_here (0, ffelex_token_where_line (integer),
1587                        ffelex_token_where_column (integer));
1588           ffebad_finish ();
1589           *val = 0;
1590           return FALSE;
1591         }
1592       x = (x << 3) + c;
1593       c = *(++p);
1594     };
1595
1596   if (bad_digit)
1597     {
1598       ffebad_start (FFEBAD_INVALID_OCTAL_DIGIT);
1599       ffebad_here (0, ffelex_token_where_line (integer),
1600                    ffelex_token_where_column (integer));
1601       ffebad_finish ();
1602     }
1603
1604   *val = x;
1605   return !bad_digit;
1606 }
1607
1608 /* ffetarget_multiply_complex1 -- Multiply function
1609
1610    See prototype.  */
1611
1612 #if FFETARGET_okCOMPLEX1
1613 ffebad
1614 ffetarget_multiply_complex1 (ffetargetComplex1 *res, ffetargetComplex1 l,
1615                              ffetargetComplex1 r)
1616 {
1617   ffebad bad;
1618   ffetargetReal1 tmp1, tmp2;
1619
1620   bad = ffetarget_multiply_real1 (&tmp1, l.real, r.real);
1621   if (bad != FFEBAD)
1622     return bad;
1623   bad = ffetarget_multiply_real1 (&tmp2, l.imaginary, r.imaginary);
1624   if (bad != FFEBAD)
1625     return bad;
1626   bad = ffetarget_subtract_real1 (&res->real, tmp1, tmp2);
1627   if (bad != FFEBAD)
1628     return bad;
1629   bad = ffetarget_multiply_real1 (&tmp1, l.imaginary, r.real);
1630   if (bad != FFEBAD)
1631     return bad;
1632   bad = ffetarget_multiply_real1 (&tmp2, l.real, r.imaginary);
1633   if (bad != FFEBAD)
1634     return bad;
1635   bad = ffetarget_add_real1 (&res->imaginary, tmp1, tmp2);
1636
1637   return bad;
1638 }
1639
1640 #endif
1641 /* ffetarget_multiply_complex2 -- Multiply function
1642
1643    See prototype.  */
1644
1645 #if FFETARGET_okCOMPLEX2
1646 ffebad
1647 ffetarget_multiply_complex2 (ffetargetComplex2 *res, ffetargetComplex2 l,
1648                              ffetargetComplex2 r)
1649 {
1650   ffebad bad;
1651   ffetargetReal2 tmp1, tmp2;
1652
1653   bad = ffetarget_multiply_real2 (&tmp1, l.real, r.real);
1654   if (bad != FFEBAD)
1655     return bad;
1656   bad = ffetarget_multiply_real2 (&tmp2, l.imaginary, r.imaginary);
1657   if (bad != FFEBAD)
1658     return bad;
1659   bad = ffetarget_subtract_real2 (&res->real, tmp1, tmp2);
1660   if (bad != FFEBAD)
1661     return bad;
1662   bad = ffetarget_multiply_real2 (&tmp1, l.imaginary, r.real);
1663   if (bad != FFEBAD)
1664     return bad;
1665   bad = ffetarget_multiply_real2 (&tmp2, l.real, r.imaginary);
1666   if (bad != FFEBAD)
1667     return bad;
1668   bad = ffetarget_add_real2 (&res->imaginary, tmp1, tmp2);
1669
1670   return bad;
1671 }
1672
1673 #endif
1674 /* ffetarget_power_complexdefault_integerdefault -- Power function
1675
1676    See prototype.  */
1677
1678 ffebad
1679 ffetarget_power_complexdefault_integerdefault (ffetargetComplexDefault *res,
1680                                                ffetargetComplexDefault l,
1681                                                ffetargetIntegerDefault r)
1682 {
1683   ffebad bad;
1684   ffetargetRealDefault tmp;
1685   ffetargetRealDefault tmp1;
1686   ffetargetRealDefault tmp2;
1687   ffetargetRealDefault two;
1688
1689   if (ffetarget_iszero_real1 (l.real)
1690       && ffetarget_iszero_real1 (l.imaginary))
1691     {
1692       ffetarget_real1_zero (&res->real);
1693       ffetarget_real1_zero (&res->imaginary);
1694       return FFEBAD;
1695     }
1696
1697   if (r == 0)
1698     {
1699       ffetarget_real1_one (&res->real);
1700       ffetarget_real1_zero (&res->imaginary);
1701       return FFEBAD;
1702     }
1703
1704   if (r < 0)
1705     {
1706       r = -r;
1707       bad = ffetarget_multiply_real1 (&tmp1, l.real, l.real);
1708       if (bad != FFEBAD)
1709         return bad;
1710       bad = ffetarget_multiply_real1 (&tmp2, l.imaginary, l.imaginary);
1711       if (bad != FFEBAD)
1712         return bad;
1713       bad = ffetarget_add_real1 (&tmp, tmp1, tmp2);
1714       if (bad != FFEBAD)
1715         return bad;
1716       bad = ffetarget_divide_real1 (&l.real, l.real, tmp);
1717       if (bad != FFEBAD)
1718         return bad;
1719       bad = ffetarget_divide_real1 (&l.imaginary, l.imaginary, tmp);
1720       if (bad != FFEBAD)
1721         return bad;
1722       bad = ffetarget_uminus_real1 (&l.imaginary, l.imaginary);
1723       if (bad != FFEBAD)
1724         return bad;
1725     }
1726
1727   ffetarget_real1_two (&two);
1728
1729   while ((r & 1) == 0)
1730     {
1731       bad = ffetarget_multiply_real1 (&tmp1, l.real, l.real);
1732       if (bad != FFEBAD)
1733         return bad;
1734       bad = ffetarget_multiply_real1 (&tmp2, l.imaginary, l.imaginary);
1735       if (bad != FFEBAD)
1736         return bad;
1737       bad = ffetarget_subtract_real1 (&tmp, tmp1, tmp2);
1738       if (bad != FFEBAD)
1739         return bad;
1740       bad = ffetarget_multiply_real1 (&l.imaginary, l.real, l.imaginary);
1741       if (bad != FFEBAD)
1742         return bad;
1743       bad = ffetarget_multiply_real1 (&l.imaginary, l.imaginary, two);
1744       if (bad != FFEBAD)
1745         return bad;
1746       l.real = tmp;
1747       r >>= 1;
1748     }
1749
1750   *res = l;
1751   r >>= 1;
1752
1753   while (r != 0)
1754     {
1755       bad = ffetarget_multiply_real1 (&tmp1, l.real, l.real);
1756       if (bad != FFEBAD)
1757         return bad;
1758       bad = ffetarget_multiply_real1 (&tmp2, l.imaginary, l.imaginary);
1759       if (bad != FFEBAD)
1760         return bad;
1761       bad = ffetarget_subtract_real1 (&tmp, tmp1, tmp2);
1762       if (bad != FFEBAD)
1763         return bad;
1764       bad = ffetarget_multiply_real1 (&l.imaginary, l.real, l.imaginary);
1765       if (bad != FFEBAD)
1766         return bad;
1767       bad = ffetarget_multiply_real1 (&l.imaginary, l.imaginary, two);
1768       if (bad != FFEBAD)
1769         return bad;
1770       l.real = tmp;
1771       if ((r & 1) == 1)
1772         {
1773           bad = ffetarget_multiply_real1 (&tmp1, res->real, l.real);
1774           if (bad != FFEBAD)
1775             return bad;
1776           bad = ffetarget_multiply_real1 (&tmp2, res->imaginary,
1777                                           l.imaginary);
1778           if (bad != FFEBAD)
1779             return bad;
1780           bad = ffetarget_subtract_real1 (&tmp, tmp1, tmp2);
1781           if (bad != FFEBAD)
1782             return bad;
1783           bad = ffetarget_multiply_real1 (&tmp1, res->imaginary, l.real);
1784           if (bad != FFEBAD)
1785             return bad;
1786           bad = ffetarget_multiply_real1 (&tmp2, res->real, l.imaginary);
1787           if (bad != FFEBAD)
1788             return bad;
1789           bad = ffetarget_add_real1 (&res->imaginary, tmp1, tmp2);
1790           if (bad != FFEBAD)
1791             return bad;
1792           res->real = tmp;
1793         }
1794       r >>= 1;
1795     }
1796
1797   return FFEBAD;
1798 }
1799
1800 /* ffetarget_power_complexdouble_integerdefault -- Power function
1801
1802    See prototype.  */
1803
1804 #if FFETARGET_okCOMPLEXDOUBLE
1805 ffebad
1806 ffetarget_power_complexdouble_integerdefault (ffetargetComplexDouble *res,
1807                         ffetargetComplexDouble l, ffetargetIntegerDefault r)
1808 {
1809   ffebad bad;
1810   ffetargetRealDouble tmp;
1811   ffetargetRealDouble tmp1;
1812   ffetargetRealDouble tmp2;
1813   ffetargetRealDouble two;
1814
1815   if (ffetarget_iszero_real2 (l.real)
1816       && ffetarget_iszero_real2 (l.imaginary))
1817     {
1818       ffetarget_real2_zero (&res->real);
1819       ffetarget_real2_zero (&res->imaginary);
1820       return FFEBAD;
1821     }
1822
1823   if (r == 0)
1824     {
1825       ffetarget_real2_one (&res->real);
1826       ffetarget_real2_zero (&res->imaginary);
1827       return FFEBAD;
1828     }
1829
1830   if (r < 0)
1831     {
1832       r = -r;
1833       bad = ffetarget_multiply_real2 (&tmp1, l.real, l.real);
1834       if (bad != FFEBAD)
1835         return bad;
1836       bad = ffetarget_multiply_real2 (&tmp2, l.imaginary, l.imaginary);
1837       if (bad != FFEBAD)
1838         return bad;
1839       bad = ffetarget_add_real2 (&tmp, tmp1, tmp2);
1840       if (bad != FFEBAD)
1841         return bad;
1842       bad = ffetarget_divide_real2 (&l.real, l.real, tmp);
1843       if (bad != FFEBAD)
1844         return bad;
1845       bad = ffetarget_divide_real2 (&l.imaginary, l.imaginary, tmp);
1846       if (bad != FFEBAD)
1847         return bad;
1848       bad = ffetarget_uminus_real2 (&l.imaginary, l.imaginary);
1849       if (bad != FFEBAD)
1850         return bad;
1851     }
1852
1853   ffetarget_real2_two (&two);
1854
1855   while ((r & 1) == 0)
1856     {
1857       bad = ffetarget_multiply_real2 (&tmp1, l.real, l.real);
1858       if (bad != FFEBAD)
1859         return bad;
1860       bad = ffetarget_multiply_real2 (&tmp2, l.imaginary, l.imaginary);
1861       if (bad != FFEBAD)
1862         return bad;
1863       bad = ffetarget_subtract_real2 (&tmp, tmp1, tmp2);
1864       if (bad != FFEBAD)
1865         return bad;
1866       bad = ffetarget_multiply_real2 (&l.imaginary, l.real, l.imaginary);
1867       if (bad != FFEBAD)
1868         return bad;
1869       bad = ffetarget_multiply_real2 (&l.imaginary, l.imaginary, two);
1870       if (bad != FFEBAD)
1871         return bad;
1872       l.real = tmp;
1873       r >>= 1;
1874     }
1875
1876   *res = l;
1877   r >>= 1;
1878
1879   while (r != 0)
1880     {
1881       bad = ffetarget_multiply_real2 (&tmp1, l.real, l.real);
1882       if (bad != FFEBAD)
1883         return bad;
1884       bad = ffetarget_multiply_real2 (&tmp2, l.imaginary, l.imaginary);
1885       if (bad != FFEBAD)
1886         return bad;
1887       bad = ffetarget_subtract_real2 (&tmp, tmp1, tmp2);
1888       if (bad != FFEBAD)
1889         return bad;
1890       bad = ffetarget_multiply_real2 (&l.imaginary, l.real, l.imaginary);
1891       if (bad != FFEBAD)
1892         return bad;
1893       bad = ffetarget_multiply_real2 (&l.imaginary, l.imaginary, two);
1894       if (bad != FFEBAD)
1895         return bad;
1896       l.real = tmp;
1897       if ((r & 1) == 1)
1898         {
1899           bad = ffetarget_multiply_real2 (&tmp1, res->real, l.real);
1900           if (bad != FFEBAD)
1901             return bad;
1902           bad = ffetarget_multiply_real2 (&tmp2, res->imaginary,
1903                                           l.imaginary);
1904           if (bad != FFEBAD)
1905             return bad;
1906           bad = ffetarget_subtract_real2 (&tmp, tmp1, tmp2);
1907           if (bad != FFEBAD)
1908             return bad;
1909           bad = ffetarget_multiply_real2 (&tmp1, res->imaginary, l.real);
1910           if (bad != FFEBAD)
1911             return bad;
1912           bad = ffetarget_multiply_real2 (&tmp2, res->real, l.imaginary);
1913           if (bad != FFEBAD)
1914             return bad;
1915           bad = ffetarget_add_real2 (&res->imaginary, tmp1, tmp2);
1916           if (bad != FFEBAD)
1917             return bad;
1918           res->real = tmp;
1919         }
1920       r >>= 1;
1921     }
1922
1923   return FFEBAD;
1924 }
1925
1926 #endif
1927 /* ffetarget_power_integerdefault_integerdefault -- Power function
1928
1929    See prototype.  */
1930
1931 ffebad
1932 ffetarget_power_integerdefault_integerdefault (ffetargetIntegerDefault *res,
1933                        ffetargetIntegerDefault l, ffetargetIntegerDefault r)
1934 {
1935   if (l == 0)
1936     {
1937       *res = 0;
1938       return FFEBAD;
1939     }
1940
1941   if (r == 0)
1942     {
1943       *res = 1;
1944       return FFEBAD;
1945     }
1946
1947   if (r < 0)
1948     {
1949       if (l == 1)
1950         *res = 1;
1951       else if (l == 0)
1952         *res = 1;
1953       else if (l == -1)
1954         *res = ((-r) & 1) == 0 ? 1 : -1;
1955       else
1956         *res = 0;
1957       return FFEBAD;
1958     }
1959
1960   while ((r & 1) == 0)
1961     {
1962       l *= l;
1963       r >>= 1;
1964     }
1965
1966   *res = l;
1967   r >>= 1;
1968
1969   while (r != 0)
1970     {
1971       l *= l;
1972       if ((r & 1) == 1)
1973         *res *= l;
1974       r >>= 1;
1975     }
1976
1977   return FFEBAD;
1978 }
1979
1980 /* ffetarget_power_realdefault_integerdefault -- Power function
1981
1982    See prototype.  */
1983
1984 ffebad
1985 ffetarget_power_realdefault_integerdefault (ffetargetRealDefault *res,
1986                           ffetargetRealDefault l, ffetargetIntegerDefault r)
1987 {
1988   ffebad bad;
1989
1990   if (ffetarget_iszero_real1 (l))
1991     {
1992       ffetarget_real1_zero (res);
1993       return FFEBAD;
1994     }
1995
1996   if (r == 0)
1997     {
1998       ffetarget_real1_one (res);
1999       return FFEBAD;
2000     }
2001
2002   if (r < 0)
2003     {
2004       ffetargetRealDefault one;
2005
2006       ffetarget_real1_one (&one);
2007       r = -r;
2008       bad = ffetarget_divide_real1 (&l, one, l);
2009       if (bad != FFEBAD)
2010         return bad;
2011     }
2012
2013   while ((r & 1) == 0)
2014     {
2015       bad = ffetarget_multiply_real1 (&l, l, l);
2016       if (bad != FFEBAD)
2017         return bad;
2018       r >>= 1;
2019     }
2020
2021   *res = l;
2022   r >>= 1;
2023
2024   while (r != 0)
2025     {
2026       bad = ffetarget_multiply_real1 (&l, l, l);
2027       if (bad != FFEBAD)
2028         return bad;
2029       if ((r & 1) == 1)
2030         {
2031           bad = ffetarget_multiply_real1 (res, *res, l);
2032           if (bad != FFEBAD)
2033             return bad;
2034         }
2035       r >>= 1;
2036     }
2037
2038   return FFEBAD;
2039 }
2040
2041 /* ffetarget_power_realdouble_integerdefault -- Power function
2042
2043    See prototype.  */
2044
2045 ffebad
2046 ffetarget_power_realdouble_integerdefault (ffetargetRealDouble *res,
2047                                            ffetargetRealDouble l,
2048                                            ffetargetIntegerDefault r)
2049 {
2050   ffebad bad;
2051
2052   if (ffetarget_iszero_real2 (l))
2053     {
2054       ffetarget_real2_zero (res);
2055       return FFEBAD;
2056     }
2057
2058   if (r == 0)
2059     {
2060       ffetarget_real2_one (res);
2061       return FFEBAD;
2062     }
2063
2064   if (r < 0)
2065     {
2066       ffetargetRealDouble one;
2067
2068       ffetarget_real2_one (&one);
2069       r = -r;
2070       bad = ffetarget_divide_real2 (&l, one, l);
2071       if (bad != FFEBAD)
2072         return bad;
2073     }
2074
2075   while ((r & 1) == 0)
2076     {
2077       bad = ffetarget_multiply_real2 (&l, l, l);
2078       if (bad != FFEBAD)
2079         return bad;
2080       r >>= 1;
2081     }
2082
2083   *res = l;
2084   r >>= 1;
2085
2086   while (r != 0)
2087     {
2088       bad = ffetarget_multiply_real2 (&l, l, l);
2089       if (bad != FFEBAD)
2090         return bad;
2091       if ((r & 1) == 1)
2092         {
2093           bad = ffetarget_multiply_real2 (res, *res, l);
2094           if (bad != FFEBAD)
2095             return bad;
2096         }
2097       r >>= 1;
2098     }
2099
2100   return FFEBAD;
2101 }
2102
2103 /* ffetarget_print_binary -- Output typeless binary integer
2104
2105    ffetargetTypeless val;
2106    ffetarget_typeless_binary(dmpout,val);  */
2107
2108 void
2109 ffetarget_print_binary (FILE *f, ffetargetTypeless value)
2110 {
2111   char *p;
2112   char digits[sizeof (value) * CHAR_BIT + 1];
2113
2114   if (f == NULL)
2115     f = dmpout;
2116
2117   p = &digits[ARRAY_SIZE (digits) - 1];
2118   *p = '\0';
2119   do
2120     {
2121       *--p = (value & 1) + '0';
2122       value >>= 1;
2123     } while (value == 0);
2124
2125   fputs (p, f);
2126 }
2127
2128 /* ffetarget_print_character1 -- Output character string
2129
2130    ffetargetCharacter1 val;
2131    ffetarget_print_character1(dmpout,val);  */
2132
2133 void
2134 ffetarget_print_character1 (FILE *f, ffetargetCharacter1 value)
2135 {
2136   unsigned char *p;
2137   ffetargetCharacterSize i;
2138
2139   fputc ('\'', dmpout);
2140   for (i = 0, p = value.text; i < value.length; ++i, ++p)
2141     ffetarget_print_char_ (f, *p);
2142   fputc ('\'', dmpout);
2143 }
2144
2145 /* ffetarget_print_hollerith -- Output hollerith string
2146
2147    ffetargetHollerith val;
2148    ffetarget_print_hollerith(dmpout,val);  */
2149
2150 void
2151 ffetarget_print_hollerith (FILE *f, ffetargetHollerith value)
2152 {
2153   unsigned char *p;
2154   ffetargetHollerithSize i;
2155
2156   fputc ('\'', dmpout);
2157   for (i = 0, p = value.text; i < value.length; ++i, ++p)
2158     ffetarget_print_char_ (f, *p);
2159   fputc ('\'', dmpout);
2160 }
2161
2162 /* ffetarget_print_octal -- Output typeless octal integer
2163
2164    ffetargetTypeless val;
2165    ffetarget_print_octal(dmpout,val);  */
2166
2167 void
2168 ffetarget_print_octal (FILE *f, ffetargetTypeless value)
2169 {
2170   char *p;
2171   char digits[sizeof (value) * CHAR_BIT / 3 + 1];
2172
2173   if (f == NULL)
2174     f = dmpout;
2175
2176   p = &digits[ARRAY_SIZE (digits) - 3];
2177   *p = '\0';
2178   do
2179     {
2180       *--p = (value & 3) + '0';
2181       value >>= 3;
2182     } while (value == 0);
2183
2184   fputs (p, f);
2185 }
2186
2187 /* ffetarget_print_hex -- Output typeless hex integer
2188
2189    ffetargetTypeless val;
2190    ffetarget_print_hex(dmpout,val);  */
2191
2192 void
2193 ffetarget_print_hex (FILE *f, ffetargetTypeless value)
2194 {
2195   char *p;
2196   char digits[sizeof (value) * CHAR_BIT / 4 + 1];
2197   static char hexdigits[16] = "0123456789ABCDEF";
2198
2199   if (f == NULL)
2200     f = dmpout;
2201
2202   p = &digits[ARRAY_SIZE (digits) - 3];
2203   *p = '\0';
2204   do
2205     {
2206       *--p = hexdigits[value & 4];
2207       value >>= 4;
2208     } while (value == 0);
2209
2210   fputs (p, f);
2211 }
2212
2213 /* ffetarget_real1 -- Convert token to a single-precision real number
2214
2215    See prototype.
2216
2217    Pass NULL for any token not provided by the user, but a valid Fortran
2218    real number must be provided somehow.  For example, it is ok for
2219    exponent_sign_token and exponent_digits_token to be NULL as long as
2220    exponent_token not only starts with "E" or "e" but also contains at least
2221    one digit following it.  Token use counts not affected overall.  */
2222
2223 #if FFETARGET_okREAL1
2224 bool
2225 ffetarget_real1 (ffetargetReal1 *value, ffelexToken integer,
2226                  ffelexToken decimal, ffelexToken fraction,
2227                  ffelexToken exponent, ffelexToken exponent_sign,
2228                  ffelexToken exponent_digits)
2229 {
2230   size_t sz = 1;                /* Allow room for '\0' byte at end. */
2231   char *ptr = &ffetarget_string_[0];
2232   char *p = ptr;
2233   char *q;
2234
2235 #define dotok(x) if (x != NULL) ++sz;
2236 #define dotoktxt(x) if (x != NULL) sz += ffelex_token_length(x)
2237
2238   dotoktxt (integer);
2239   dotok (decimal);
2240   dotoktxt (fraction);
2241   dotoktxt (exponent);
2242   dotok (exponent_sign);
2243   dotoktxt (exponent_digits);
2244
2245 #undef dotok
2246 #undef dotoktxt
2247
2248   if (sz > ARRAY_SIZE (ffetarget_string_))
2249     p = ptr = (char *) malloc_new_ks (malloc_pool_image (), "ffetarget_real1",
2250                                       sz);
2251
2252 #define dotoktxt(x) if (x != NULL)                                 \
2253                   {                                                \
2254                   for (q = ffelex_token_text(x); *q != '\0'; ++q)  \
2255                     *p++ = *q;                                     \
2256                   }
2257
2258   dotoktxt (integer);
2259
2260   if (decimal != NULL)
2261     *p++ = '.';
2262
2263   dotoktxt (fraction);
2264   dotoktxt (exponent);
2265
2266   if (exponent_sign != NULL)
2267     {
2268       if (ffelex_token_type (exponent_sign) == FFELEX_typePLUS)
2269         *p++ = '+';
2270       else
2271         {
2272           assert (ffelex_token_type (exponent_sign) == FFELEX_typeMINUS);
2273           *p++ = '-';
2274         }
2275     }
2276
2277   dotoktxt (exponent_digits);
2278
2279 #undef dotoktxt
2280
2281   *p = '\0';
2282
2283   ffetarget_make_real1 (value,
2284                         FFETARGET_ATOF_ (ptr,
2285                                          SFmode));
2286
2287   if (sz > ARRAY_SIZE (ffetarget_string_))
2288     malloc_kill_ks (malloc_pool_image (), ptr, sz);
2289
2290   return TRUE;
2291 }
2292
2293 #endif
2294 /* ffetarget_real2 -- Convert token to a single-precision real number
2295
2296    See prototype.
2297
2298    Pass NULL for any token not provided by the user, but a valid Fortran
2299    real number must be provided somehow.  For example, it is ok for
2300    exponent_sign_token and exponent_digits_token to be NULL as long as
2301    exponent_token not only starts with "E" or "e" but also contains at least
2302    one digit following it.  Token use counts not affected overall.  */
2303
2304 #if FFETARGET_okREAL2
2305 bool
2306 ffetarget_real2 (ffetargetReal2 *value, ffelexToken integer,
2307                  ffelexToken decimal, ffelexToken fraction,
2308                  ffelexToken exponent, ffelexToken exponent_sign,
2309                  ffelexToken exponent_digits)
2310 {
2311   size_t sz = 1;                /* Allow room for '\0' byte at end. */
2312   char *ptr = &ffetarget_string_[0];
2313   char *p = ptr;
2314   char *q;
2315
2316 #define dotok(x) if (x != NULL) ++sz;
2317 #define dotoktxt(x) if (x != NULL) sz += ffelex_token_length(x)
2318
2319   dotoktxt (integer);
2320   dotok (decimal);
2321   dotoktxt (fraction);
2322   dotoktxt (exponent);
2323   dotok (exponent_sign);
2324   dotoktxt (exponent_digits);
2325
2326 #undef dotok
2327 #undef dotoktxt
2328
2329   if (sz > ARRAY_SIZE (ffetarget_string_))
2330     p = ptr = (char *) malloc_new_ks (malloc_pool_image (), "ffetarget_real1", sz);
2331
2332 #define dotoktxt(x) if (x != NULL)                                 \
2333                   {                                                \
2334                   for (q = ffelex_token_text(x); *q != '\0'; ++q)  \
2335                     *p++ = *q;                                     \
2336                   }
2337 #define dotoktxtexp(x) if (x != NULL)                                  \
2338                   {                                                    \
2339                   *p++ = 'E';                                          \
2340                   for (q = ffelex_token_text(x) + 1; *q != '\0'; ++q)  \
2341                     *p++ = *q;                                         \
2342                   }
2343
2344   dotoktxt (integer);
2345
2346   if (decimal != NULL)
2347     *p++ = '.';
2348
2349   dotoktxt (fraction);
2350   dotoktxtexp (exponent);
2351
2352   if (exponent_sign != NULL)
2353     {
2354       if (ffelex_token_type (exponent_sign) == FFELEX_typePLUS)
2355         *p++ = '+';
2356       else
2357         {
2358           assert (ffelex_token_type (exponent_sign) == FFELEX_typeMINUS);
2359           *p++ = '-';
2360         }
2361     }
2362
2363   dotoktxt (exponent_digits);
2364
2365 #undef dotoktxt
2366
2367   *p = '\0';
2368
2369   ffetarget_make_real2 (value,
2370                         FFETARGET_ATOF_ (ptr,
2371                                          DFmode));
2372
2373   if (sz > ARRAY_SIZE (ffetarget_string_))
2374     malloc_kill_ks (malloc_pool_image (), ptr, sz);
2375
2376   return TRUE;
2377 }
2378
2379 #endif
2380 bool
2381 ffetarget_typeless_binary (ffetargetTypeless *xvalue, ffelexToken token)
2382 {
2383   char *p;
2384   char c;
2385   ffetargetTypeless value = 0;
2386   ffetargetTypeless new_value = 0;
2387   bool bad_digit = FALSE;
2388   bool overflow = FALSE;
2389
2390   p = ffelex_token_text (token);
2391
2392   for (c = *p; c != '\0'; c = *++p)
2393     {
2394       new_value <<= 1;
2395       if ((new_value >> 1) != value)
2396         overflow = TRUE;
2397       if (ISDIGIT (c))
2398         new_value += c - '0';
2399       else
2400         bad_digit = TRUE;
2401       value = new_value;
2402     }
2403
2404   if (bad_digit)
2405     {
2406       ffebad_start (FFEBAD_INVALID_TYPELESS_BINARY_DIGIT);
2407       ffebad_here (0, ffelex_token_where_line (token),
2408                    ffelex_token_where_column (token));
2409       ffebad_finish ();
2410     }
2411   else if (overflow)
2412     {
2413       ffebad_start (FFEBAD_TYPELESS_OVERFLOW);
2414       ffebad_here (0, ffelex_token_where_line (token),
2415                    ffelex_token_where_column (token));
2416       ffebad_finish ();
2417     }
2418
2419   *xvalue = value;
2420
2421   return !bad_digit && !overflow;
2422 }
2423
2424 bool
2425 ffetarget_typeless_octal (ffetargetTypeless *xvalue, ffelexToken token)
2426 {
2427   char *p;
2428   char c;
2429   ffetargetTypeless value = 0;
2430   ffetargetTypeless new_value = 0;
2431   bool bad_digit = FALSE;
2432   bool overflow = FALSE;
2433
2434   p = ffelex_token_text (token);
2435
2436   for (c = *p; c != '\0'; c = *++p)
2437     {
2438       new_value <<= 3;
2439       if ((new_value >> 3) != value)
2440         overflow = TRUE;
2441       if (ISDIGIT (c))
2442         new_value += c - '0';
2443       else
2444         bad_digit = TRUE;
2445       value = new_value;
2446     }
2447
2448   if (bad_digit)
2449     {
2450       ffebad_start (FFEBAD_INVALID_TYPELESS_OCTAL_DIGIT);
2451       ffebad_here (0, ffelex_token_where_line (token),
2452                    ffelex_token_where_column (token));
2453       ffebad_finish ();
2454     }
2455   else if (overflow)
2456     {
2457       ffebad_start (FFEBAD_TYPELESS_OVERFLOW);
2458       ffebad_here (0, ffelex_token_where_line (token),
2459                    ffelex_token_where_column (token));
2460       ffebad_finish ();
2461     }
2462
2463   *xvalue = value;
2464
2465   return !bad_digit && !overflow;
2466 }
2467
2468 bool
2469 ffetarget_typeless_hex (ffetargetTypeless *xvalue, ffelexToken token)
2470 {
2471   char *p;
2472   char c;
2473   ffetargetTypeless value = 0;
2474   ffetargetTypeless new_value = 0;
2475   bool bad_digit = FALSE;
2476   bool overflow = FALSE;
2477
2478   p = ffelex_token_text (token);
2479
2480   for (c = *p; c != '\0'; c = *++p)
2481     {
2482       new_value <<= 4;
2483       if ((new_value >> 4) != value)
2484         overflow = TRUE;
2485       if (ISDIGIT (c))
2486         new_value += c - '0';
2487       else if ((c >= 'A') && (c <= 'F'))
2488         new_value += c - 'A' + 10;
2489       else if ((c >= 'a') && (c <= 'f'))
2490         new_value += c - 'a' + 10;
2491       else
2492         bad_digit = TRUE;
2493       value = new_value;
2494     }
2495
2496   if (bad_digit)
2497     {
2498       ffebad_start (FFEBAD_INVALID_TYPELESS_HEX_DIGIT);
2499       ffebad_here (0, ffelex_token_where_line (token),
2500                    ffelex_token_where_column (token));
2501       ffebad_finish ();
2502     }
2503   else if (overflow)
2504     {
2505       ffebad_start (FFEBAD_TYPELESS_OVERFLOW);
2506       ffebad_here (0, ffelex_token_where_line (token),
2507                    ffelex_token_where_column (token));
2508       ffebad_finish ();
2509     }
2510
2511   *xvalue = value;
2512
2513   return !bad_digit && !overflow;
2514 }
2515
2516 void
2517 ffetarget_verify_character1 (mallocPool pool, ffetargetCharacter1 val)
2518 {
2519   if (val.length != 0)
2520     malloc_verify_kp (pool, val.text, val.length);
2521 }
2522
2523 /* This is like memcpy.  It is needed because some systems' header files
2524    don't declare memcpy as a function but instead
2525    "#define memcpy(to,from,len) something".  */
2526
2527 void *
2528 ffetarget_memcpy_ (void *dst, void *src, size_t len)
2529 {
2530   return (void *) memcpy (dst, src, len);
2531 }
2532
2533 /* ffetarget_num_digits_ -- Determine number of non-space characters in token
2534
2535    ffetarget_num_digits_(token);
2536
2537    All non-spaces are assumed to be binary, octal, or hex digits.  */
2538
2539 int
2540 ffetarget_num_digits_ (ffelexToken token)
2541 {
2542   int i;
2543   char *c;
2544
2545   switch (ffelex_token_type (token))
2546     {
2547     case FFELEX_typeNAME:
2548     case FFELEX_typeNUMBER:
2549       return ffelex_token_length (token);
2550
2551     case FFELEX_typeCHARACTER:
2552       i = 0;
2553       for (c = ffelex_token_text (token); *c != '\0'; ++c)
2554         {
2555           if (*c != ' ')
2556             ++i;
2557         }
2558       return i;
2559
2560     default:
2561       assert ("weird token" == NULL);
2562       return 1;
2563     }
2564 }