gcc/f/target.c

   1 /* target.c -- Implementation File (module.c template V1.0)
   2    Copyright (C) 1995-1998 Free Software Foundation, Inc.
   3    Contributed by James Craig Burley (burley@gnu.org).
   4
   5 This file is part of GNU Fortran.
   6
   7 GNU Fortran is free software; you can redistribute it and/or modify
   8 it under the terms of the GNU General Public License as published by
   9 the Free Software Foundation; either version 2, or (at your option)
  10 any later version.
  11
  12 GNU Fortran is distributed in the hope that it will be useful,
  13 but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 GNU General Public License for more details.
  16
  17 You should have received a copy of the GNU General Public License
  18 along with GNU Fortran; see the file COPYING.  If not, write to
  19 the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
  20 02111-1307, USA.
  21
  22    Related Modules:
  23       None
  24
  25    Description:
  26       Implements conversion of lexer tokens to machine-dependent numerical
  27       form and accordingly issues diagnostic messages when necessary.
  28
  29       Also, this module, especially its .h file, provides nearly all of the
  30       information on the target machine's data type, kind type, and length
  31       type capabilities.  The idea is that by carefully going through
  32       target.h and changing things properly, one can accomplish much
  33       towards the porting of the FFE to a new machine.  There are limits
  34       to how much this can accomplish towards that end, however.  For one
  35       thing, the ffeexpr_collapse_convert function doesn't contain all the
  36       conversion cases necessary, because the text file would be
  37       enormous (even though most of the function would be cut during the
  38       cpp phase because of the absence of the types), so when adding to
  39       the number of supported kind types for a given type, one must look
  40       to see if ffeexpr_collapse_convert needs modification in this area,
  41       in addition to providing the appropriate macros and functions in
  42       ffetarget.  Note that if combinatorial explosion actually becomes a
  43       problem for a given machine, one might have to modify the way conversion
  44       expressions are built so that instead of just one conversion expr, a
  45       series of conversion exprs are built to make a path from one type to
  46       another that is not a "near neighbor".  For now, however, with a handful
  47       of each of the numeric types and only one character type, things appear
  48       manageable.
  49
  50       A nonobvious change to ffetarget would be if the target machine was
  51       not a 2's-complement machine.  Any item with the word "magical" (case-
  52       insensitive) in the FFE's source code (at least) indicates an assumption
  53       that a 2's-complement machine is the target, and thus that there exists
  54       a magnitude that can be represented as a negative number but not as
  55       a positive number.  It is possible that this situation can be dealt
  56       with by changing only ffetarget, for example, on a 1's-complement
  57       machine, perhaps #defineing ffetarget_constant_is_magical to simply
  58       FALSE along with making the appropriate changes in ffetarget's number
  59       parsing functions would be sufficient to effectively "comment out" code
  60       in places like ffeexpr that do certain magical checks.  But it is
  61       possible there are other 2's-complement dependencies lurking in the
  62       FFE (as possibly is true of any large program); if you find any, please
  63       report them so we can replace them with dependencies on ffetarget
  64       instead.
  65
  66    Modifications:
  67 */
  68
  69 /* Include files. */
  70
  71 #include "proj.h"
  72 #include "glimits.j"
  73 #include "target.h"
  74 #include "bad.h"
  75 #include "info.h"
  76 #include "lex.h"
  77 #include "malloc.h"
  78
  79 /* Externals defined here. */
  80
  81 char ffetarget_string_[40];     /* Temp for ascii-to-double (atof). */
  82 HOST_WIDE_INT ffetarget_long_val_;
  83 HOST_WIDE_INT ffetarget_long_junk_;
  84
  85 /* Simple definitions and enumerations. */
  86
  87
  88 /* Internal typedefs. */
  89
  90
  91 /* Private include files. */
  92
  93
  94 /* Internal structure definitions. */
  95
  96
  97 /* Static objects accessed by functions in this module. */
  98
  99
 100 /* Static functions (internal). */
 101
 102 static void ffetarget_print_char_ (FILE *f, unsigned char c);
 103
 104 /* Internal macros. */
 105
 106 #ifdef REAL_VALUE_ATOF
 107 #define FFETARGET_ATOF_(p,m) REAL_VALUE_ATOF ((p),(m))
 108 #else
 109 #define FFETARGET_ATOF_(p,m) atof ((p))
 110 #endif
 111 \f
 112
 113 /* ffetarget_print_char_ -- Print a single character (in apostrophe context)
 114
 115    See prototype.
 116
 117    Outputs char so it prints or is escaped C style.  */
 118
 119 static void
 120 ffetarget_print_char_ (FILE *f, unsigned char c)
 121 {
 122   switch (c)
 123     {
 124     case '\\':
 125       fputs ("\\\\", f);
 126       break;
 127
 128     case '\'':
 129       fputs ("\\\'", f);
 130       break;
 131
 132     default:
 133       if (ISPRINT (c))
 134         fputc (c, f);
 135       else
 136         fprintf (f, "\\%03o", (unsigned int) c);
 137       break;
 138     }
 139 }
 140
 141 /* ffetarget_aggregate_info -- Determine type for aggregate storage area
 142
 143    See prototype.
 144
 145    If aggregate type is distinct, just return it.  Else return a type
 146    representing a common denominator for the nondistinct type (for now,
 147    just return default character, since that'll work on almost all target
 148    machines).
 149
 150    The rules for abt/akt are (as implemented by ffestorag_update):
 151
 152    abt == FFEINFO_basictypeANY (akt == FFEINFO_kindtypeANY also, by
 153    definition): CHARACTER and non-CHARACTER types mixed.
 154
 155    abt == FFEINFO_basictypeNONE (akt == FFEINFO_kindtypeNONE also, by
 156    definition): More than one non-CHARACTER type mixed, but no CHARACTER
 157    types mixed in.
 158
 159    abt some other value, akt == FFEINFO_kindtypeNONE: abt indicates the
 160    only basic type mixed in, but more than one kind type is mixed in.
 161
 162    abt some other value, akt some other value: abt and akt indicate the
 163    only type represented in the aggregation.  */
 164
 165 void
 166 ffetarget_aggregate_info (ffeinfoBasictype *ebt, ffeinfoKindtype *ekt,
 167                           ffetargetAlign *units, ffeinfoBasictype abt,
 168                           ffeinfoKindtype akt)
 169 {
 170   ffetype type;
 171
 172   if ((abt == FFEINFO_basictypeNONE) || (abt == FFEINFO_basictypeANY)
 173       || (akt == FFEINFO_kindtypeNONE))
 174     {
 175       *ebt = FFEINFO_basictypeCHARACTER;
 176       *ekt = FFEINFO_kindtypeCHARACTERDEFAULT;
 177     }
 178   else
 179     {
 180       *ebt = abt;
 181       *ekt = akt;
 182     }
 183
 184   type = ffeinfo_type (*ebt, *ekt);
 185   assert (type != NULL);
 186
 187   *units = ffetype_size (type);
 188 }
 189
 190 /* ffetarget_align -- Align one storage area to superordinate, update super
 191
 192    See prototype.
 193
 194    updated_alignment/updated_modulo contain the already existing
 195    alignment requirements for the storage area at whose offset the
 196    object with alignment requirements alignment/modulo is to be placed.
 197    Find the smallest pad such that the requirements are maintained and
 198    return it, but only after updating the updated_alignment/_modulo
 199    requirements as necessary to indicate the placement of the new object.  */
 200
 201 ffetargetAlign
 202 ffetarget_align (ffetargetAlign *updated_alignment,
 203                  ffetargetAlign *updated_modulo, ffetargetOffset offset,
 204                  ffetargetAlign alignment, ffetargetAlign modulo)
 205 {
 206   ffetargetAlign pad;
 207   ffetargetAlign min_pad;       /* Minimum amount of padding needed. */
 208   ffetargetAlign min_m = 0;     /* Minimum-padding m. */
 209   ffetargetAlign ua;            /* Updated alignment. */
 210   ffetargetAlign um;            /* Updated modulo. */
 211   ffetargetAlign ucnt;          /* Multiplier applied to ua. */
 212   ffetargetAlign m;             /* Copy of modulo. */
 213   ffetargetAlign cnt;           /* Multiplier applied to alignment. */
 214   ffetargetAlign i;
 215   ffetargetAlign j;
 216
 217   assert (*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 (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 ((c >= 'A') && (c <= 'F'))
1448         c = c - 'A' + 10;
1449       else if ((c >= 'a') && (c <= 'f'))
1450         c = c - 'a' + 10;
1451       else if ((c >= '0') && (c <= '9'))
1452         c -= '0';
1453       else
1454         {
1455           bad_digit = TRUE;
1456           c = 0;
1457         }
1458
1459 #if 0                           /* Don't complain about signed overflow; just
1460                                    unsigned overflow. */
1461       if ((x == FFETARGET_integerALMOST_BIG_OVERFLOW_HEX)
1462           && (c == FFETARGET_integerFINISH_BIG_OVERFLOW_HEX)
1463           && (*(p + 1) == '\0'))
1464         {
1465           *val = FFETARGET_integerBIG_OVERFLOW_HEX;
1466           return TRUE;
1467         }
1468       else
1469 #endif
1470 #if FFETARGET_integerFINISH_BIG_OVERFLOW_HEX == 0
1471       if (x >= FFETARGET_integerALMOST_BIG_OVERFLOW_HEX)
1472 #else
1473       if (x == FFETARGET_integerALMOST_BIG_OVERFLOW_HEX)
1474         {
1475           if ((c > FFETARGET_integerFINISH_BIG_OVERFLOW_HEX)
1476               || (*(p + 1) != '\0'))
1477             {
1478               ffebad_start (FFEBAD_INTEGER_TOO_LARGE);
1479               ffebad_here (0, ffelex_token_where_line (integer),
1480                            ffelex_token_where_column (integer));
1481               ffebad_finish ();
1482               *val = 0;
1483               return FALSE;
1484             }
1485         }
1486       else if (x > FFETARGET_integerALMOST_BIG_OVERFLOW_HEX)
1487 #endif
1488         {
1489           ffebad_start (FFEBAD_INTEGER_TOO_LARGE);
1490           ffebad_here (0, ffelex_token_where_line (integer),
1491                        ffelex_token_where_column (integer));
1492           ffebad_finish ();
1493           *val = 0;
1494           return FALSE;
1495         }
1496       x = (x << 4) + c;
1497       c = *(++p);
1498     };
1499
1500   if (bad_digit)
1501     {
1502       ffebad_start (FFEBAD_INVALID_HEX_DIGIT);
1503       ffebad_here (0, ffelex_token_where_line (integer),
1504                    ffelex_token_where_column (integer));
1505       ffebad_finish ();
1506     }
1507
1508   *val = x;
1509   return !bad_digit;
1510 }
1511
1512 /* ffetarget_integeroctal -- Convert token to an octal integer
1513
1514    ffetarget_integeroctal x;
1515    if (ffetarget_integerdefault_8(&x,integer_token))
1516        // conversion ok.
1517
1518    Token use count not affected overall.  */
1519
1520 bool
1521 ffetarget_integeroctal (ffetargetIntegerDefault *val, ffelexToken integer)
1522 {
1523   ffetargetIntegerDefault x;
1524   char *p;
1525   char c;
1526   bool bad_digit;
1527
1528   assert ((ffelex_token_type (integer) == FFELEX_typeNAME)
1529           || (ffelex_token_type (integer) == FFELEX_typeNUMBER));
1530
1531   p = ffelex_token_text (integer);
1532   x = 0;
1533
1534   /* Skip past leading zeros. */
1535
1536   while (((c = *p) != '\0') && (c == '0'))
1537     ++p;
1538
1539   /* Interpret rest of number. */
1540
1541   bad_digit = FALSE;
1542   while (c != '\0')
1543     {
1544       if ((c >= '0') && (c <= '7'))
1545         c -= '0';
1546       else
1547         {
1548           bad_digit = TRUE;
1549           c = 0;
1550         }
1551
1552 #if 0                           /* Don't complain about signed overflow; just
1553                                    unsigned overflow. */
1554       if ((x == FFETARGET_integerALMOST_BIG_OVERFLOW_OCTAL)
1555           && (c == FFETARGET_integerFINISH_BIG_OVERFLOW_OCTAL)
1556           && (*(p + 1) == '\0'))
1557         {
1558           *val = FFETARGET_integerBIG_OVERFLOW_OCTAL;
1559           return TRUE;
1560         }
1561       else
1562 #endif
1563 #if FFETARGET_integerFINISH_BIG_OVERFLOW_OCTAL == 0
1564       if (x >= FFETARGET_integerALMOST_BIG_OVERFLOW_OCTAL)
1565 #else
1566       if (x == FFETARGET_integerALMOST_BIG_OVERFLOW_OCTAL)
1567         {
1568           if ((c > FFETARGET_integerFINISH_BIG_OVERFLOW_OCTAL)
1569               || (*(p + 1) != '\0'))
1570             {
1571               ffebad_start (FFEBAD_INTEGER_TOO_LARGE);
1572               ffebad_here (0, ffelex_token_where_line (integer),
1573                            ffelex_token_where_column (integer));
1574               ffebad_finish ();
1575               *val = 0;
1576               return FALSE;
1577             }
1578         }
1579       else if (x > FFETARGET_integerALMOST_BIG_OVERFLOW_OCTAL)
1580 #endif
1581         {
1582           ffebad_start (FFEBAD_INTEGER_TOO_LARGE);
1583           ffebad_here (0, ffelex_token_where_line (integer),
1584                        ffelex_token_where_column (integer));
1585           ffebad_finish ();
1586           *val = 0;
1587           return FALSE;
1588         }
1589       x = (x << 3) + c;
1590       c = *(++p);
1591     };
1592
1593   if (bad_digit)
1594     {
1595       ffebad_start (FFEBAD_INVALID_OCTAL_DIGIT);
1596       ffebad_here (0, ffelex_token_where_line (integer),
1597                    ffelex_token_where_column (integer));
1598       ffebad_finish ();
1599     }
1600
1601   *val = x;
1602   return !bad_digit;
1603 }
1604
1605 /* ffetarget_multiply_complex1 -- Multiply function
1606
1607    See prototype.  */
1608
1609 #if FFETARGET_okCOMPLEX1
1610 ffebad
1611 ffetarget_multiply_complex1 (ffetargetComplex1 *res, ffetargetComplex1 l,
1612                              ffetargetComplex1 r)
1613 {
1614   ffebad bad;
1615   ffetargetReal1 tmp1, tmp2;
1616
1617   bad = ffetarget_multiply_real1 (&tmp1, l.real, r.real);
1618   if (bad != FFEBAD)
1619     return bad;
1620   bad = ffetarget_multiply_real1 (&tmp2, l.imaginary, r.imaginary);
1621   if (bad != FFEBAD)
1622     return bad;
1623   bad = ffetarget_subtract_real1 (&res->real, tmp1, tmp2);
1624   if (bad != FFEBAD)
1625     return bad;
1626   bad = ffetarget_multiply_real1 (&tmp1, l.imaginary, r.real);
1627   if (bad != FFEBAD)
1628     return bad;
1629   bad = ffetarget_multiply_real1 (&tmp2, l.real, r.imaginary);
1630   if (bad != FFEBAD)
1631     return bad;
1632   bad = ffetarget_add_real1 (&res->imaginary, tmp1, tmp2);
1633
1634   return bad;
1635 }
1636
1637 #endif
1638 /* ffetarget_multiply_complex2 -- Multiply function
1639
1640    See prototype.  */
1641
1642 #if FFETARGET_okCOMPLEX2
1643 ffebad
1644 ffetarget_multiply_complex2 (ffetargetComplex2 *res, ffetargetComplex2 l,
1645                              ffetargetComplex2 r)
1646 {
1647   ffebad bad;
1648   ffetargetReal2 tmp1, tmp2;
1649
1650   bad = ffetarget_multiply_real2 (&tmp1, l.real, r.real);
1651   if (bad != FFEBAD)
1652     return bad;
1653   bad = ffetarget_multiply_real2 (&tmp2, l.imaginary, r.imaginary);
1654   if (bad != FFEBAD)
1655     return bad;
1656   bad = ffetarget_subtract_real2 (&res->real, tmp1, tmp2);
1657   if (bad != FFEBAD)
1658     return bad;
1659   bad = ffetarget_multiply_real2 (&tmp1, l.imaginary, r.real);
1660   if (bad != FFEBAD)
1661     return bad;
1662   bad = ffetarget_multiply_real2 (&tmp2, l.real, r.imaginary);
1663   if (bad != FFEBAD)
1664     return bad;
1665   bad = ffetarget_add_real2 (&res->imaginary, tmp1, tmp2);
1666
1667   return bad;
1668 }
1669
1670 #endif
1671 /* ffetarget_power_complexdefault_integerdefault -- Power function
1672
1673    See prototype.  */
1674
1675 ffebad
1676 ffetarget_power_complexdefault_integerdefault (ffetargetComplexDefault *res,
1677                                                ffetargetComplexDefault l,
1678                                                ffetargetIntegerDefault r)
1679 {
1680   ffebad bad;
1681   ffetargetRealDefault tmp;
1682   ffetargetRealDefault tmp1;
1683   ffetargetRealDefault tmp2;
1684   ffetargetRealDefault two;
1685
1686   if (ffetarget_iszero_real1 (l.real)
1687       && ffetarget_iszero_real1 (l.imaginary))
1688     {
1689       ffetarget_real1_zero (&res->real);
1690       ffetarget_real1_zero (&res->imaginary);
1691       return FFEBAD;
1692     }
1693
1694   if (r == 0)
1695     {
1696       ffetarget_real1_one (&res->real);
1697       ffetarget_real1_zero (&res->imaginary);
1698       return FFEBAD;
1699     }
1700
1701   if (r < 0)
1702     {
1703       r = -r;
1704       bad = ffetarget_multiply_real1 (&tmp1, l.real, l.real);
1705       if (bad != FFEBAD)
1706         return bad;
1707       bad = ffetarget_multiply_real1 (&tmp2, l.imaginary, l.imaginary);
1708       if (bad != FFEBAD)
1709         return bad;
1710       bad = ffetarget_add_real1 (&tmp, tmp1, tmp2);
1711       if (bad != FFEBAD)
1712         return bad;
1713       bad = ffetarget_divide_real1 (&l.real, l.real, tmp);
1714       if (bad != FFEBAD)
1715         return bad;
1716       bad = ffetarget_divide_real1 (&l.imaginary, l.imaginary, tmp);
1717       if (bad != FFEBAD)
1718         return bad;
1719       bad = ffetarget_uminus_real1 (&l.imaginary, l.imaginary);
1720       if (bad != FFEBAD)
1721         return bad;
1722     }
1723
1724   ffetarget_real1_two (&two);
1725
1726   while ((r & 1) == 0)
1727     {
1728       bad = ffetarget_multiply_real1 (&tmp1, l.real, l.real);
1729       if (bad != FFEBAD)
1730         return bad;
1731       bad = ffetarget_multiply_real1 (&tmp2, l.imaginary, l.imaginary);
1732       if (bad != FFEBAD)
1733         return bad;
1734       bad = ffetarget_subtract_real1 (&tmp, tmp1, tmp2);
1735       if (bad != FFEBAD)
1736         return bad;
1737       bad = ffetarget_multiply_real1 (&l.imaginary, l.real, l.imaginary);
1738       if (bad != FFEBAD)
1739         return bad;
1740       bad = ffetarget_multiply_real1 (&l.imaginary, l.imaginary, two);
1741       if (bad != FFEBAD)
1742         return bad;
1743       l.real = tmp;
1744       r >>= 1;
1745     }
1746
1747   *res = l;
1748   r >>= 1;
1749
1750   while (r != 0)
1751     {
1752       bad = ffetarget_multiply_real1 (&tmp1, l.real, l.real);
1753       if (bad != FFEBAD)
1754         return bad;
1755       bad = ffetarget_multiply_real1 (&tmp2, l.imaginary, l.imaginary);
1756       if (bad != FFEBAD)
1757         return bad;
1758       bad = ffetarget_subtract_real1 (&tmp, tmp1, tmp2);
1759       if (bad != FFEBAD)
1760         return bad;
1761       bad = ffetarget_multiply_real1 (&l.imaginary, l.real, l.imaginary);
1762       if (bad != FFEBAD)
1763         return bad;
1764       bad = ffetarget_multiply_real1 (&l.imaginary, l.imaginary, two);
1765       if (bad != FFEBAD)
1766         return bad;
1767       l.real = tmp;
1768       if ((r & 1) == 1)
1769         {
1770           bad = ffetarget_multiply_real1 (&tmp1, res->real, l.real);
1771           if (bad != FFEBAD)
1772             return bad;
1773           bad = ffetarget_multiply_real1 (&tmp2, res->imaginary,
1774                                           l.imaginary);
1775           if (bad != FFEBAD)
1776             return bad;
1777           bad = ffetarget_subtract_real1 (&tmp, tmp1, tmp2);
1778           if (bad != FFEBAD)
1779             return bad;
1780           bad = ffetarget_multiply_real1 (&tmp1, res->imaginary, l.real);
1781           if (bad != FFEBAD)
1782             return bad;
1783           bad = ffetarget_multiply_real1 (&tmp2, res->real, l.imaginary);
1784           if (bad != FFEBAD)
1785             return bad;
1786           bad = ffetarget_add_real1 (&res->imaginary, tmp1, tmp2);
1787           if (bad != FFEBAD)
1788             return bad;
1789           res->real = tmp;
1790         }
1791       r >>= 1;
1792     }
1793
1794   return FFEBAD;
1795 }
1796
1797 /* ffetarget_power_complexdouble_integerdefault -- Power function
1798
1799    See prototype.  */
1800
1801 #if FFETARGET_okCOMPLEXDOUBLE
1802 ffebad
1803 ffetarget_power_complexdouble_integerdefault (ffetargetComplexDouble *res,
1804                         ffetargetComplexDouble l, ffetargetIntegerDefault r)
1805 {
1806   ffebad bad;
1807   ffetargetRealDouble tmp;
1808   ffetargetRealDouble tmp1;
1809   ffetargetRealDouble tmp2;
1810   ffetargetRealDouble two;
1811
1812   if (ffetarget_iszero_real2 (l.real)
1813       && ffetarget_iszero_real2 (l.imaginary))
1814     {
1815       ffetarget_real2_zero (&res->real);
1816       ffetarget_real2_zero (&res->imaginary);
1817       return FFEBAD;
1818     }
1819
1820   if (r == 0)
1821     {
1822       ffetarget_real2_one (&res->real);
1823       ffetarget_real2_zero (&res->imaginary);
1824       return FFEBAD;
1825     }
1826
1827   if (r < 0)
1828     {
1829       r = -r;
1830       bad = ffetarget_multiply_real2 (&tmp1, l.real, l.real);
1831       if (bad != FFEBAD)
1832         return bad;
1833       bad = ffetarget_multiply_real2 (&tmp2, l.imaginary, l.imaginary);
1834       if (bad != FFEBAD)
1835         return bad;
1836       bad = ffetarget_add_real2 (&tmp, tmp1, tmp2);
1837       if (bad != FFEBAD)
1838         return bad;
1839       bad = ffetarget_divide_real2 (&l.real, l.real, tmp);
1840       if (bad != FFEBAD)
1841         return bad;
1842       bad = ffetarget_divide_real2 (&l.imaginary, l.imaginary, tmp);
1843       if (bad != FFEBAD)
1844         return bad;
1845       bad = ffetarget_uminus_real2 (&l.imaginary, l.imaginary);
1846       if (bad != FFEBAD)
1847         return bad;
1848     }
1849
1850   ffetarget_real2_two (&two);
1851
1852   while ((r & 1) == 0)
1853     {
1854       bad = ffetarget_multiply_real2 (&tmp1, l.real, l.real);
1855       if (bad != FFEBAD)
1856         return bad;
1857       bad = ffetarget_multiply_real2 (&tmp2, l.imaginary, l.imaginary);
1858       if (bad != FFEBAD)
1859         return bad;
1860       bad = ffetarget_subtract_real2 (&tmp, tmp1, tmp2);
1861       if (bad != FFEBAD)
1862         return bad;
1863       bad = ffetarget_multiply_real2 (&l.imaginary, l.real, l.imaginary);
1864       if (bad != FFEBAD)
1865         return bad;
1866       bad = ffetarget_multiply_real2 (&l.imaginary, l.imaginary, two);
1867       if (bad != FFEBAD)
1868         return bad;
1869       l.real = tmp;
1870       r >>= 1;
1871     }
1872
1873   *res = l;
1874   r >>= 1;
1875
1876   while (r != 0)
1877     {
1878       bad = ffetarget_multiply_real2 (&tmp1, l.real, l.real);
1879       if (bad != FFEBAD)
1880         return bad;
1881       bad = ffetarget_multiply_real2 (&tmp2, l.imaginary, l.imaginary);
1882       if (bad != FFEBAD)
1883         return bad;
1884       bad = ffetarget_subtract_real2 (&tmp, tmp1, tmp2);
1885       if (bad != FFEBAD)
1886         return bad;
1887       bad = ffetarget_multiply_real2 (&l.imaginary, l.real, l.imaginary);
1888       if (bad != FFEBAD)
1889         return bad;
1890       bad = ffetarget_multiply_real2 (&l.imaginary, l.imaginary, two);
1891       if (bad != FFEBAD)
1892         return bad;
1893       l.real = tmp;
1894       if ((r & 1) == 1)
1895         {
1896           bad = ffetarget_multiply_real2 (&tmp1, res->real, l.real);
1897           if (bad != FFEBAD)
1898             return bad;
1899           bad = ffetarget_multiply_real2 (&tmp2, res->imaginary,
1900                                           l.imaginary);
1901           if (bad != FFEBAD)
1902             return bad;
1903           bad = ffetarget_subtract_real2 (&tmp, tmp1, tmp2);
1904           if (bad != FFEBAD)
1905             return bad;
1906           bad = ffetarget_multiply_real2 (&tmp1, res->imaginary, l.real);
1907           if (bad != FFEBAD)
1908             return bad;
1909           bad = ffetarget_multiply_real2 (&tmp2, res->real, l.imaginary);
1910           if (bad != FFEBAD)
1911             return bad;
1912           bad = ffetarget_add_real2 (&res->imaginary, tmp1, tmp2);
1913           if (bad != FFEBAD)
1914             return bad;
1915           res->real = tmp;
1916         }
1917       r >>= 1;
1918     }
1919
1920   return FFEBAD;
1921 }
1922
1923 #endif
1924 /* ffetarget_power_integerdefault_integerdefault -- Power function
1925
1926    See prototype.  */
1927
1928 ffebad
1929 ffetarget_power_integerdefault_integerdefault (ffetargetIntegerDefault *res,
1930                        ffetargetIntegerDefault l, ffetargetIntegerDefault r)
1931 {
1932   if (l == 0)
1933     {
1934       *res = 0;
1935       return FFEBAD;
1936     }
1937
1938   if (r == 0)
1939     {
1940       *res = 1;
1941       return FFEBAD;
1942     }
1943
1944   if (r < 0)
1945     {
1946       if (l == 1)
1947         *res = 1;
1948       else if (l == 0)
1949         *res = 1;
1950       else if (l == -1)
1951         *res = ((-r) & 1) == 0 ? 1 : -1;
1952       else
1953         *res = 0;
1954       return FFEBAD;
1955     }
1956
1957   while ((r & 1) == 0)
1958     {
1959       l *= l;
1960       r >>= 1;
1961     }
1962
1963   *res = l;
1964   r >>= 1;
1965
1966   while (r != 0)
1967     {
1968       l *= l;
1969       if ((r & 1) == 1)
1970         *res *= l;
1971       r >>= 1;
1972     }
1973
1974   return FFEBAD;
1975 }
1976
1977 /* ffetarget_power_realdefault_integerdefault -- Power function
1978
1979    See prototype.  */
1980
1981 ffebad
1982 ffetarget_power_realdefault_integerdefault (ffetargetRealDefault *res,
1983                           ffetargetRealDefault l, ffetargetIntegerDefault r)
1984 {
1985   ffebad bad;
1986
1987   if (ffetarget_iszero_real1 (l))
1988     {
1989       ffetarget_real1_zero (res);
1990       return FFEBAD;
1991     }
1992
1993   if (r == 0)
1994     {
1995       ffetarget_real1_one (res);
1996       return FFEBAD;
1997     }
1998
1999   if (r < 0)
2000     {
2001       ffetargetRealDefault one;
2002
2003       ffetarget_real1_one (&one);
2004       r = -r;
2005       bad = ffetarget_divide_real1 (&l, one, l);
2006       if (bad != FFEBAD)
2007         return bad;
2008     }
2009
2010   while ((r & 1) == 0)
2011     {
2012       bad = ffetarget_multiply_real1 (&l, l, l);
2013       if (bad != FFEBAD)
2014         return bad;
2015       r >>= 1;
2016     }
2017
2018   *res = l;
2019   r >>= 1;
2020
2021   while (r != 0)
2022     {
2023       bad = ffetarget_multiply_real1 (&l, l, l);
2024       if (bad != FFEBAD)
2025         return bad;
2026       if ((r & 1) == 1)
2027         {
2028           bad = ffetarget_multiply_real1 (res, *res, l);
2029           if (bad != FFEBAD)
2030             return bad;
2031         }
2032       r >>= 1;
2033     }
2034
2035   return FFEBAD;
2036 }
2037
2038 /* ffetarget_power_realdouble_integerdefault -- Power function
2039
2040    See prototype.  */
2041
2042 ffebad
2043 ffetarget_power_realdouble_integerdefault (ffetargetRealDouble *res,
2044                                            ffetargetRealDouble l,
2045                                            ffetargetIntegerDefault r)
2046 {
2047   ffebad bad;
2048
2049   if (ffetarget_iszero_real2 (l))
2050     {
2051       ffetarget_real2_zero (res);
2052       return FFEBAD;
2053     }
2054
2055   if (r == 0)
2056     {
2057       ffetarget_real2_one (res);
2058       return FFEBAD;
2059     }
2060
2061   if (r < 0)
2062     {
2063       ffetargetRealDouble one;
2064
2065       ffetarget_real2_one (&one);
2066       r = -r;
2067       bad = ffetarget_divide_real2 (&l, one, l);
2068       if (bad != FFEBAD)
2069         return bad;
2070     }
2071
2072   while ((r & 1) == 0)
2073     {
2074       bad = ffetarget_multiply_real2 (&l, l, l);
2075       if (bad != FFEBAD)
2076         return bad;
2077       r >>= 1;
2078     }
2079
2080   *res = l;
2081   r >>= 1;
2082
2083   while (r != 0)
2084     {
2085       bad = ffetarget_multiply_real2 (&l, l, l);
2086       if (bad != FFEBAD)
2087         return bad;
2088       if ((r & 1) == 1)
2089         {
2090           bad = ffetarget_multiply_real2 (res, *res, l);
2091           if (bad != FFEBAD)
2092             return bad;
2093         }
2094       r >>= 1;
2095     }
2096
2097   return FFEBAD;
2098 }
2099
2100 /* ffetarget_print_binary -- Output typeless binary integer
2101
2102    ffetargetTypeless val;
2103    ffetarget_typeless_binary(dmpout,val);  */
2104
2105 void
2106 ffetarget_print_binary (FILE *f, ffetargetTypeless value)
2107 {
2108   char *p;
2109   char digits[sizeof (value) * CHAR_BIT + 1];
2110
2111   if (f == NULL)
2112     f = dmpout;
2113
2114   p = &digits[ARRAY_SIZE (digits) - 1];
2115   *p = '\0';
2116   do
2117     {
2118       *--p = (value & 1) + '0';
2119       value >>= 1;
2120     } while (value == 0);
2121
2122   fputs (p, f);
2123 }
2124
2125 /* ffetarget_print_character1 -- Output character string
2126
2127    ffetargetCharacter1 val;
2128    ffetarget_print_character1(dmpout,val);  */
2129
2130 void
2131 ffetarget_print_character1 (FILE *f, ffetargetCharacter1 value)
2132 {
2133   unsigned char *p;
2134   ffetargetCharacterSize i;
2135
2136   fputc ('\'', dmpout);
2137   for (i = 0, p = value.text; i < value.length; ++i, ++p)
2138     ffetarget_print_char_ (f, *p);
2139   fputc ('\'', dmpout);
2140 }
2141
2142 /* ffetarget_print_hollerith -- Output hollerith string
2143
2144    ffetargetHollerith val;
2145    ffetarget_print_hollerith(dmpout,val);  */
2146
2147 void
2148 ffetarget_print_hollerith (FILE *f, ffetargetHollerith value)
2149 {
2150   unsigned char *p;
2151   ffetargetHollerithSize i;
2152
2153   fputc ('\'', dmpout);
2154   for (i = 0, p = value.text; i < value.length; ++i, ++p)
2155     ffetarget_print_char_ (f, *p);
2156   fputc ('\'', dmpout);
2157 }
2158
2159 /* ffetarget_print_octal -- Output typeless octal integer
2160
2161    ffetargetTypeless val;
2162    ffetarget_print_octal(dmpout,val);  */
2163
2164 void
2165 ffetarget_print_octal (FILE *f, ffetargetTypeless value)
2166 {
2167   char *p;
2168   char digits[sizeof (value) * CHAR_BIT / 3 + 1];
2169
2170   if (f == NULL)
2171     f = dmpout;
2172
2173   p = &digits[ARRAY_SIZE (digits) - 3];
2174   *p = '\0';
2175   do
2176     {
2177       *--p = (value & 3) + '0';
2178       value >>= 3;
2179     } while (value == 0);
2180
2181   fputs (p, f);
2182 }
2183
2184 /* ffetarget_print_hex -- Output typeless hex integer
2185
2186    ffetargetTypeless val;
2187    ffetarget_print_hex(dmpout,val);  */
2188
2189 void
2190 ffetarget_print_hex (FILE *f, ffetargetTypeless value)
2191 {
2192   char *p;
2193   char digits[sizeof (value) * CHAR_BIT / 4 + 1];
2194   static char hexdigits[16] = "0123456789ABCDEF";
2195
2196   if (f == NULL)
2197     f = dmpout;
2198
2199   p = &digits[ARRAY_SIZE (digits) - 3];
2200   *p = '\0';
2201   do
2202     {
2203       *--p = hexdigits[value & 4];
2204       value >>= 4;
2205     } while (value == 0);
2206
2207   fputs (p, f);
2208 }
2209
2210 /* ffetarget_real1 -- Convert token to a single-precision real number
2211
2212    See prototype.
2213
2214    Pass NULL for any token not provided by the user, but a valid Fortran
2215    real number must be provided somehow.  For example, it is ok for
2216    exponent_sign_token and exponent_digits_token to be NULL as long as
2217    exponent_token not only starts with "E" or "e" but also contains at least
2218    one digit following it.  Token use counts not affected overall.  */
2219
2220 #if FFETARGET_okREAL1
2221 bool
2222 ffetarget_real1 (ffetargetReal1 *value, ffelexToken integer,
2223                  ffelexToken decimal, ffelexToken fraction,
2224                  ffelexToken exponent, ffelexToken exponent_sign,
2225                  ffelexToken exponent_digits)
2226 {
2227   size_t sz = 1;                /* Allow room for '\0' byte at end. */
2228   char *ptr = &ffetarget_string_[0];
2229   char *p = ptr;
2230   char *q;
2231
2232 #define dotok(x) if (x != NULL) ++sz;
2233 #define dotoktxt(x) if (x != NULL) sz += ffelex_token_length(x)
2234
2235   dotoktxt (integer);
2236   dotok (decimal);
2237   dotoktxt (fraction);
2238   dotoktxt (exponent);
2239   dotok (exponent_sign);
2240   dotoktxt (exponent_digits);
2241
2242 #undef dotok
2243 #undef dotoktxt
2244
2245   if (sz > ARRAY_SIZE (ffetarget_string_))
2246     p = ptr = (char *) malloc_new_ks (malloc_pool_image (), "ffetarget_real1",
2247                                       sz);
2248
2249 #define dotoktxt(x) if (x != NULL)                                 \
2250                   {                                                \
2251                   for (q = ffelex_token_text(x); *q != '\0'; ++q)  \
2252                     *p++ = *q;                                     \
2253                   }
2254
2255   dotoktxt (integer);
2256
2257   if (decimal != NULL)
2258     *p++ = '.';
2259
2260   dotoktxt (fraction);
2261   dotoktxt (exponent);
2262
2263   if (exponent_sign != NULL)
2264     {
2265       if (ffelex_token_type (exponent_sign) == FFELEX_typePLUS)
2266         *p++ = '+';
2267       else
2268         {
2269           assert (ffelex_token_type (exponent_sign) == FFELEX_typeMINUS);
2270           *p++ = '-';
2271         }
2272     }
2273
2274   dotoktxt (exponent_digits);
2275
2276 #undef dotoktxt
2277
2278   *p = '\0';
2279
2280   ffetarget_make_real1 (value,
2281                         FFETARGET_ATOF_ (ptr,
2282                                          SFmode));
2283
2284   if (sz > ARRAY_SIZE (ffetarget_string_))
2285     malloc_kill_ks (malloc_pool_image (), ptr, sz);
2286
2287   return TRUE;
2288 }
2289
2290 #endif
2291 /* ffetarget_real2 -- Convert token to a single-precision real number
2292
2293    See prototype.
2294
2295    Pass NULL for any token not provided by the user, but a valid Fortran
2296    real number must be provided somehow.  For example, it is ok for
2297    exponent_sign_token and exponent_digits_token to be NULL as long as
2298    exponent_token not only starts with "E" or "e" but also contains at least
2299    one digit following it.  Token use counts not affected overall.  */
2300
2301 #if FFETARGET_okREAL2
2302 bool
2303 ffetarget_real2 (ffetargetReal2 *value, ffelexToken integer,
2304                  ffelexToken decimal, ffelexToken fraction,
2305                  ffelexToken exponent, ffelexToken exponent_sign,
2306                  ffelexToken exponent_digits)
2307 {
2308   size_t sz = 1;                /* Allow room for '\0' byte at end. */
2309   char *ptr = &ffetarget_string_[0];
2310   char *p = ptr;
2311   char *q;
2312
2313 #define dotok(x) if (x != NULL) ++sz;
2314 #define dotoktxt(x) if (x != NULL) sz += ffelex_token_length(x)
2315
2316   dotoktxt (integer);
2317   dotok (decimal);
2318   dotoktxt (fraction);
2319   dotoktxt (exponent);
2320   dotok (exponent_sign);
2321   dotoktxt (exponent_digits);
2322
2323 #undef dotok
2324 #undef dotoktxt
2325
2326   if (sz > ARRAY_SIZE (ffetarget_string_))
2327     p = ptr = (char *) malloc_new_ks (malloc_pool_image (), "ffetarget_real1", sz);
2328
2329 #define dotoktxt(x) if (x != NULL)                                 \
2330                   {                                                \
2331                   for (q = ffelex_token_text(x); *q != '\0'; ++q)  \
2332                     *p++ = *q;                                     \
2333                   }
2334 #define dotoktxtexp(x) if (x != NULL)                                  \
2335                   {                                                    \
2336                   *p++ = 'E';                                          \
2337                   for (q = ffelex_token_text(x) + 1; *q != '\0'; ++q)  \
2338                     *p++ = *q;                                         \
2339                   }
2340
2341   dotoktxt (integer);
2342
2343   if (decimal != NULL)
2344     *p++ = '.';
2345
2346   dotoktxt (fraction);
2347   dotoktxtexp (exponent);
2348
2349   if (exponent_sign != NULL)
2350     {
2351       if (ffelex_token_type (exponent_sign) == FFELEX_typePLUS)
2352         *p++ = '+';
2353       else
2354         {
2355           assert (ffelex_token_type (exponent_sign) == FFELEX_typeMINUS);
2356           *p++ = '-';
2357         }
2358     }
2359
2360   dotoktxt (exponent_digits);
2361
2362 #undef dotoktxt
2363
2364   *p = '\0';
2365
2366   ffetarget_make_real2 (value,
2367                         FFETARGET_ATOF_ (ptr,
2368                                          DFmode));
2369
2370   if (sz > ARRAY_SIZE (ffetarget_string_))
2371     malloc_kill_ks (malloc_pool_image (), ptr, sz);
2372
2373   return TRUE;
2374 }
2375
2376 #endif
2377 bool
2378 ffetarget_typeless_binary (ffetargetTypeless *xvalue, ffelexToken token)
2379 {
2380   char *p;
2381   char c;
2382   ffetargetTypeless value = 0;
2383   ffetargetTypeless new_value = 0;
2384   bool bad_digit = FALSE;
2385   bool overflow = FALSE;
2386
2387   p = ffelex_token_text (token);
2388
2389   for (c = *p; c != '\0'; c = *++p)
2390     {
2391       new_value <<= 1;
2392       if ((new_value >> 1) != value)
2393         overflow = TRUE;
2394       if (ISDIGIT (c))
2395         new_value += c - '0';
2396       else
2397         bad_digit = TRUE;
2398       value = new_value;
2399     }
2400
2401   if (bad_digit)
2402     {
2403       ffebad_start (FFEBAD_INVALID_TYPELESS_BINARY_DIGIT);
2404       ffebad_here (0, ffelex_token_where_line (token),
2405                    ffelex_token_where_column (token));
2406       ffebad_finish ();
2407     }
2408   else if (overflow)
2409     {
2410       ffebad_start (FFEBAD_TYPELESS_OVERFLOW);
2411       ffebad_here (0, ffelex_token_where_line (token),
2412                    ffelex_token_where_column (token));
2413       ffebad_finish ();
2414     }
2415
2416   *xvalue = value;
2417
2418   return !bad_digit && !overflow;
2419 }
2420
2421 bool
2422 ffetarget_typeless_octal (ffetargetTypeless *xvalue, ffelexToken token)
2423 {
2424   char *p;
2425   char c;
2426   ffetargetTypeless value = 0;
2427   ffetargetTypeless new_value = 0;
2428   bool bad_digit = FALSE;
2429   bool overflow = FALSE;
2430
2431   p = ffelex_token_text (token);
2432
2433   for (c = *p; c != '\0'; c = *++p)
2434     {
2435       new_value <<= 3;
2436       if ((new_value >> 3) != value)
2437         overflow = TRUE;
2438       if (ISDIGIT (c))
2439         new_value += c - '0';
2440       else
2441         bad_digit = TRUE;
2442       value = new_value;
2443     }
2444
2445   if (bad_digit)
2446     {
2447       ffebad_start (FFEBAD_INVALID_TYPELESS_OCTAL_DIGIT);
2448       ffebad_here (0, ffelex_token_where_line (token),
2449                    ffelex_token_where_column (token));
2450       ffebad_finish ();
2451     }
2452   else if (overflow)
2453     {
2454       ffebad_start (FFEBAD_TYPELESS_OVERFLOW);
2455       ffebad_here (0, ffelex_token_where_line (token),
2456                    ffelex_token_where_column (token));
2457       ffebad_finish ();
2458     }
2459
2460   *xvalue = value;
2461
2462   return !bad_digit && !overflow;
2463 }
2464
2465 bool
2466 ffetarget_typeless_hex (ffetargetTypeless *xvalue, ffelexToken token)
2467 {
2468   char *p;
2469   char c;
2470   ffetargetTypeless value = 0;
2471   ffetargetTypeless new_value = 0;
2472   bool bad_digit = FALSE;
2473   bool overflow = FALSE;
2474
2475   p = ffelex_token_text (token);
2476
2477   for (c = *p; c != '\0'; c = *++p)
2478     {
2479       new_value <<= 4;
2480       if ((new_value >> 4) != value)
2481         overflow = TRUE;
2482       if (ISDIGIT (c))
2483         new_value += c - '0';
2484       else if ((c >= 'A') && (c <= 'F'))
2485         new_value += c - 'A' + 10;
2486       else if ((c >= 'a') && (c <= 'f'))
2487         new_value += c - 'a' + 10;
2488       else
2489         bad_digit = TRUE;
2490       value = new_value;
2491     }
2492
2493   if (bad_digit)
2494     {
2495       ffebad_start (FFEBAD_INVALID_TYPELESS_HEX_DIGIT);
2496       ffebad_here (0, ffelex_token_where_line (token),
2497                    ffelex_token_where_column (token));
2498       ffebad_finish ();
2499     }
2500   else if (overflow)
2501     {
2502       ffebad_start (FFEBAD_TYPELESS_OVERFLOW);
2503       ffebad_here (0, ffelex_token_where_line (token),
2504                    ffelex_token_where_column (token));
2505       ffebad_finish ();
2506     }
2507
2508   *xvalue = value;
2509
2510   return !bad_digit && !overflow;
2511 }
2512
2513 void
2514 ffetarget_verify_character1 (mallocPool pool, ffetargetCharacter1 val)
2515 {
2516   if (val.length != 0)
2517     malloc_verify_kp (pool, val.text, val.length);
2518 }
2519
2520 /* This is like memcpy.  It is needed because some systems' header files
2521    don't declare memcpy as a function but instead
2522    "#define memcpy(to,from,len) something".  */
2523
2524 void *
2525 ffetarget_memcpy_ (void *dst, void *src, size_t len)
2526 {
2527   return (void *) memcpy (dst, src, len);
2528 }
2529
2530 /* ffetarget_num_digits_ -- Determine number of non-space characters in token
2531
2532    ffetarget_num_digits_(token);
2533
2534    All non-spaces are assumed to be binary, octal, or hex digits.  */
2535
2536 int
2537 ffetarget_num_digits_ (ffelexToken token)
2538 {
2539   int i;
2540   char *c;
2541
2542   switch (ffelex_token_type (token))
2543     {
2544     case FFELEX_typeNAME:
2545     case FFELEX_typeNUMBER:
2546       return ffelex_token_length (token);
2547
2548     case FFELEX_typeCHARACTER:
2549       i = 0;
2550       for (c = ffelex_token_text (token); *c != '\0'; ++c)
2551         {
2552           if (*c != ' ')
2553             ++i;
2554         }
2555       return i;
2556
2557     default:
2558       assert ("weird token" == NULL);
2559       return 1;
2560     }
2561 }