gcc/f/target.c

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