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