home *** CD-ROM | disk | FTP | other *** search
/ Geek Gadgets 1 / ADE-1.bin / ade-dist / g77-0.5.15-src.tgz / tar.out / fsf / g77 / f / target.c < prev    next >
C/C++ Source or Header  |  1996-09-28  |  54KB  |  2,252 lines
  1. /* target.c -- Implementation File (module.c template V1.0)
  2.    Copyright (C) 1995 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, 675 Mass Ave, Cambridge, MA 02139, USA.
  20.  
  21.    Related Modules:
  22.       None
  23.  
  24.    Description:
  25.       Implements conversion of lexer tokens to machine-dependent numerical
  26.       form and accordingly issues diagnostic messages when necessary.
  27.  
  28.       Also, this module, especially its .h file, provides nearly all of the
  29.       information on the target machine's data type, kind type, and length
  30.       type capabilities.  The idea is that by carefully going through
  31.       target.h and changing things properly, one can accomplish much
  32.       towards the porting of the FFE to a new machine.    There are limits
  33.       to how much this can accomplish towards that end, however.  For one
  34.       thing, the ffeexpr_collapse_convert function doesn't contain all the
  35.       conversion cases necessary, because the text file would be
  36.       enormous (even though most of the function would be cut during the
  37.       cpp phase because of the absence of the types), so when adding to
  38.       the number of supported kind types for a given type, one must look
  39.       to see if ffeexpr_collapse_convert needs modification in this area,
  40.       in addition to providing the appropriate macros and functions in
  41.       ffetarget.  Note that if combinatorial explosion actually becomes a
  42.       problem for a given machine, one might have to modify the way conversion
  43.       expressions are built so that instead of just one conversion expr, a
  44.       series of conversion exprs are built to make a path from one type to
  45.       another that is not a "near neighbor".  For now, however, with a handful
  46.       of each of the numeric types and only one character type, things appear
  47.       manageable.
  48.  
  49.       A nonobvious change to ffetarget would be if the target machine was
  50.       not a 2's-complement machine.  Any item with the word "magical" (case-
  51.       insensitive) in the FFE's source code (at least) indicates an assumption
  52.       that a 2's-complement machine is the target, and thus that there exists
  53.       a magnitude that can be represented as a negative number but not as
  54.       a positive number.  It is possible that this situation can be dealt
  55.       with by changing only ffetarget, for example, on a 1's-complement
  56.       machine, perhaps #defineing ffetarget_constant_is_magical to simply
  57.       FALSE along with making the appropriate changes in ffetarget's number
  58.       parsing functions would be sufficient to effectively "comment out" code
  59.       in places like ffeexpr that do certain magical checks.  But it is
  60.       possible there are other 2's-complement dependencies lurking in the
  61.       FFE (as possibly is true of any large program); if you find any, please
  62.       report them so we can replace them with dependencies on ffetarget
  63.       instead.
  64.  
  65.    Modifications:
  66. */
  67.  
  68. /* Include files. */
  69.  
  70. #include "proj.h"
  71. #include <ctype.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.  
  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) && isascii (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.  
  222.   if (*updated_alignment == alignment)
  223.     {
  224.       if (modulo > *updated_modulo)
  225.     pad = alignment - (modulo - *updated_modulo);
  226.       else
  227.     pad = *updated_modulo - modulo;
  228.       pad = (offset + pad) % alignment;
  229.       if (pad != 0)
  230.     pad = alignment - pad;
  231.       return pad;
  232.     }
  233.  
  234.   /* Sigh, find LCM (Least Common Multiple) for the two alignment factors. */
  235.  
  236.   for (ua = *updated_alignment, ucnt = 1;
  237.        ua % alignment != 0;
  238.        ua += *updated_alignment)
  239.     ++ucnt;
  240.  
  241.   cnt = ua / alignment;
  242.  
  243.   min_pad = ~(ffetargetAlign) 0;/* Set to largest value. */
  244.  
  245.   /* Find all combinations of modulo values the two alignment requirements
  246.      have; pick the combination that results in the smallest padding
  247.      requirement.  Of course, if a zero-pad requirement is encountered, just
  248.      use that one. */
  249.  
  250.   for (um = *updated_modulo, i = 0; i < ucnt; um += *updated_alignment, ++i)
  251.     {
  252.       for (m = modulo, j = 0; j < cnt; m += alignment, ++j)
  253.     {
  254.       if (m > um)        /* This code is similar to the "easy case"
  255.                    code above. */
  256.         pad = ua - (m - um);
  257.       else
  258.         pad = um - m;
  259.       pad = (offset + pad) % ua;
  260.       if (pad != 0)
  261.         pad = ua - pad;
  262.       else
  263.         {            /* A zero pad means we've got something
  264.                    useful. */
  265.           *updated_alignment = ua;
  266.           *updated_modulo = um;
  267.           return 0;
  268.         }
  269.       if (pad < min_pad)
  270.         {            /* New minimum padding value. */
  271.           min_pad = pad;
  272.           min_m = um;
  273.         }
  274.     }
  275.     }
  276.  
  277.   *updated_alignment = ua;
  278.   *updated_modulo = min_m;
  279.   return min_pad;
  280. }
  281.  
  282. #if FFETARGET_okCHARACTER1
  283. bool
  284. ffetarget_character1 (ffetargetCharacter1 *val, ffelexToken character,
  285.               mallocPool pool)
  286. {
  287.   val->length = ffelex_token_length (character);
  288.   if (val->length == 0)
  289.     val->text = NULL;
  290.   else
  291.     {
  292.       val->text = malloc_new_kp (pool, "ffetargetCharacter1", val->length);
  293.       memcpy (val->text, ffelex_token_text (character), val->length);
  294.     }
  295.  
  296.   return TRUE;
  297. }
  298.  
  299. #endif
  300. /* Produce orderable comparison between two constants
  301.  
  302.    Compare lengths, if equal then use memcmp.  */
  303.  
  304. #if FFETARGET_okCHARACTER1
  305. int
  306. ffetarget_cmp_character1 (ffetargetCharacter1 l, ffetargetCharacter1 r)
  307. {
  308.   if (l.length < r.length)
  309.     return -1;
  310.   if (l.length > r.length)
  311.     return 1;
  312.   if (l.length == 0)
  313.     return 0;
  314.   return memcmp (l.text, r.text, l.length);
  315. }
  316.  
  317. #endif
  318. /* ffetarget_concatenate_character1 -- Perform CONCAT op on two constants
  319.  
  320.    Compare lengths, if equal then use memcmp.  */
  321.  
  322. #if FFETARGET_okCHARACTER1
  323. ffebad
  324. ffetarget_concatenate_character1 (ffetargetCharacter1 *res,
  325.           ffetargetCharacter1 l, ffetargetCharacter1 r, mallocPool pool,
  326.                   ffetargetCharacterSize *len)
  327. {
  328.   res->length = *len = l.length + r.length;
  329.   if (*len == 0)
  330.     res->text = NULL;
  331.   else
  332.     {
  333.       res->text = malloc_new_kp (pool, "ffetargetCharacter1(CONCAT)", *len);
  334.       if (l.length != 0)
  335.     memcpy (res->text, l.text, l.length);
  336.       if (r.length != 0)
  337.     memcpy (res->text + l.length, r.text, r.length);
  338.     }
  339.  
  340.   return FFEBAD;
  341. }
  342.  
  343. #endif
  344. /* ffetarget_eq_character1 -- Perform relational comparison on char constants
  345.  
  346.    Compare lengths, if equal then use memcmp.  */
  347.  
  348. #if FFETARGET_okCHARACTER1
  349. ffebad
  350. ffetarget_eq_character1 (bool *res, ffetargetCharacter1 l,
  351.              ffetargetCharacter1 r)
  352. {
  353.   assert (l.length == r.length);
  354.   *res = (memcmp (l.text, r.text, l.length) == 0);
  355.   return FFEBAD;
  356. }
  357.  
  358. #endif
  359. /* ffetarget_le_character1 -- Perform relational comparison on char constants
  360.  
  361.    Compare lengths, if equal then use memcmp.  */
  362.  
  363. #if FFETARGET_okCHARACTER1
  364. ffebad
  365. ffetarget_le_character1 (bool *res, ffetargetCharacter1 l,
  366.              ffetargetCharacter1 r)
  367. {
  368.   assert (l.length == r.length);
  369.   *res = (memcmp (l.text, r.text, l.length) <= 0);
  370.   return FFEBAD;
  371. }
  372.  
  373. #endif
  374. /* ffetarget_lt_character1 -- Perform relational comparison on char constants
  375.  
  376.    Compare lengths, if equal then use memcmp.  */
  377.  
  378. #if FFETARGET_okCHARACTER1
  379. ffebad
  380. ffetarget_lt_character1 (bool *res, ffetargetCharacter1 l,
  381.              ffetargetCharacter1 r)
  382. {
  383.   assert (l.length == r.length);
  384.   *res = (memcmp (l.text, r.text, l.length) < 0);
  385.   return FFEBAD;
  386. }
  387.  
  388. #endif
  389. /* ffetarget_ge_character1 -- Perform relational comparison on char constants
  390.  
  391.    Compare lengths, if equal then use memcmp.  */
  392.  
  393. #if FFETARGET_okCHARACTER1
  394. ffebad
  395. ffetarget_ge_character1 (bool *res, ffetargetCharacter1 l,
  396.              ffetargetCharacter1 r)
  397. {
  398.   assert (l.length == r.length);
  399.   *res = (memcmp (l.text, r.text, l.length) >= 0);
  400.   return FFEBAD;
  401. }
  402.  
  403. #endif
  404. /* ffetarget_gt_character1 -- Perform relational comparison on char constants
  405.  
  406.    Compare lengths, if equal then use memcmp.  */
  407.  
  408. #if FFETARGET_okCHARACTER1
  409. ffebad
  410. ffetarget_gt_character1 (bool *res, ffetargetCharacter1 l,
  411.              ffetargetCharacter1 r)
  412. {
  413.   assert (l.length == r.length);
  414.   *res = (memcmp (l.text, r.text, l.length) > 0);
  415.   return FFEBAD;
  416. }
  417.  
  418. #endif
  419. /* ffetarget_layout -- Do storage requirement analysis for entity
  420.  
  421.    Return the alignment/modulo requirements along with the size, given the
  422.    data type info and the number of elements an array (1 for a scalar).     */
  423.  
  424. void
  425. ffetarget_layout (char *error_text, ffetargetAlign *alignment,
  426.           ffetargetAlign *modulo, ffetargetOffset *size,
  427.           ffeinfoBasictype bt, ffeinfoKindtype kt,
  428.           ffetargetCharacterSize charsize,
  429.           ffetargetIntegerDefault num_elements)
  430. {
  431.   bool ok;            /* For character type. */
  432.   ffetargetOffset numele;    /* Converted from num_elements. */
  433.   ffetype type;
  434.  
  435.   type = ffeinfo_type (bt, kt);
  436.   assert (type != NULL);
  437.  
  438.   *alignment = ffetype_alignment (type);
  439.   *modulo = ffetype_modulo (type);
  440.   if (bt == FFEINFO_basictypeCHARACTER)
  441.     {
  442.       ok = ffetarget_offset_charsize (size, charsize, ffetype_size (type));
  443. #ifdef ffetarget_offset_overflow
  444.       if (!ok)
  445.     ffetarget_offset_overflow (error_text);
  446. #endif
  447.     }
  448.   else
  449.     *size = ffetype_size (type);
  450.  
  451.   if ((num_elements < 0)
  452.       || !ffetarget_offset (&numele, num_elements)
  453.       || !ffetarget_offset_multiply (size, *size, numele))
  454.     {
  455.       ffetarget_offset_overflow (error_text);
  456.       *alignment = 1;
  457.       *modulo = 0;
  458.       *size = 0;
  459.     }
  460. }
  461.  
  462. /* ffetarget_ne_character1 -- Perform relational comparison on char constants
  463.  
  464.    Compare lengths, if equal then use memcmp.  */
  465.  
  466. #if FFETARGET_okCHARACTER1
  467. ffebad
  468. ffetarget_ne_character1 (bool *res, ffetargetCharacter1 l,
  469.              ffetargetCharacter1 r)
  470. {
  471.   assert (l.length == r.length);
  472.   *res = (memcmp (l.text, r.text, l.length) != 0);
  473.   return FFEBAD;
  474. }
  475.  
  476. #endif
  477. /* ffetarget_substr_character1 -- Perform SUBSTR op on three constants
  478.  
  479.    Compare lengths, if equal then use memcmp.  */
  480.  
  481. #if FFETARGET_okCHARACTER1
  482. ffebad
  483. ffetarget_substr_character1 (ffetargetCharacter1 *res,
  484.                  ffetargetCharacter1 l,
  485.                  ffetargetCharacterSize first,
  486.                  ffetargetCharacterSize last, mallocPool pool,
  487.                  ffetargetCharacterSize *len)
  488. {
  489.   if (last < first)
  490.     {
  491.       res->length = *len = 0;
  492.       res->text = NULL;
  493.     }
  494.   else
  495.     {
  496.       res->length = *len = last - first + 1;
  497.       res->text = malloc_new_kp (pool, "ffetargetCharacter1(SUBSTR)", *len);
  498.       memcpy (res->text, l.text + first - 1, *len);
  499.     }
  500.  
  501.   return FFEBAD;
  502. }
  503.  
  504. #endif
  505. /* ffetarget_cmp_hollerith -- Produce orderable comparison between two
  506.    constants
  507.  
  508.    Compare lengths, if equal then use memcmp.  */
  509.  
  510. int
  511. ffetarget_cmp_hollerith (ffetargetHollerith l, ffetargetHollerith r)
  512. {
  513.   if (l.length < r.length)
  514.     return -1;
  515.   if (l.length > r.length)
  516.     return 1;
  517.   return memcmp (l.text, r.text, l.length);
  518. }
  519.  
  520. ffebad
  521. ffetarget_convert_any_character1_ (char *res, size_t size,
  522.                    ffetargetCharacter1 l)
  523. {
  524.   if (size <= l.length)
  525.     {
  526.       char *p;
  527.       ffetargetCharacterSize i;
  528.       
  529.       memcpy (res, l.text, size);
  530.       for (p = &l.text[0] + size, i = l.length - size;
  531.        i > 0;
  532.        ++p, --i)
  533.     if (*p != ' ')
  534.       return FFEBAD_TRUNCATING_CHARACTER;
  535.     }
  536.   else
  537.     {
  538.       memcpy (res, l.text, size);
  539.       memset (res + l.length, ' ', size - l.length);
  540.     }
  541.  
  542.   return FFEBAD;
  543. }
  544.  
  545. ffebad
  546. ffetarget_convert_any_hollerith_ (char *res, size_t size,
  547.                   ffetargetHollerith l)
  548. {
  549.   if (size <= 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_HOLLERITH;
  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_typeless_ (char *res, size_t size,
  572.                  ffetargetTypeless l)
  573. {
  574.   unsigned long long int l1;
  575.   unsigned long int l2;
  576.   unsigned int l3;
  577.   unsigned short int l4;
  578.   unsigned char l5;
  579.   int size_of;
  580.   char *p;
  581.  
  582.   if (size >= sizeof (l1))
  583.     {
  584.       l1 = l;
  585.       p = (char *) &l1;
  586.       size_of = sizeof (l1);
  587.     }
  588.   else if (size >= sizeof (l2))
  589.     {
  590.       l2 = l;
  591.       p = (char *) &l2;
  592.       size_of = sizeof (l2);
  593.       l1 = l2;
  594.     }
  595.   else if (size >= sizeof (l3))
  596.     {
  597.       l3 = l;
  598.       p = (char *) &l3;
  599.       size_of = sizeof (l3);
  600.       l1 = l3;
  601.     }
  602.   else if (size >= sizeof (l4))
  603.     {
  604.       l4 = l;
  605.       p = (char *) &l4;
  606.       size_of = sizeof (l4);
  607.       l1 = l4;
  608.     }
  609.   else if (size >= sizeof (l5))
  610.     {
  611.       l5 = l;
  612.       p = (char *) &l5;
  613.       size_of = sizeof (l5);
  614.       l1 = l5;
  615.     }
  616.   else
  617.     {
  618.       assert ("stumped by conversion from typeless!" == NULL);
  619.       abort ();
  620.     }
  621.  
  622.   if (size <= size_of)
  623.     {
  624.       int i = size_of - size;
  625.  
  626.       memcpy (res, p + i, size);
  627.       for (; i > 0; ++p, --i)
  628.     if (*p != '\0')
  629.       return FFEBAD_TRUNCATING_TYPELESS;
  630.     }
  631.   else
  632.     {
  633.       int i = size - size_of;
  634.  
  635.       memset (res, 0, i);
  636.       memcpy (res + i, p, size_of);
  637.     }
  638.  
  639.   if (l1 != l)
  640.     return FFEBAD_TRUNCATING_TYPELESS;
  641.   return FFEBAD;
  642. }
  643.  
  644. #if FFETARGET_okCHARACTER1
  645. ffebad
  646. ffetarget_convert_character1_character1 (ffetargetCharacter1 *res,
  647.                      ffetargetCharacterSize size,
  648.                      ffetargetCharacter1 l,
  649.                      mallocPool pool)
  650. {
  651.   res->length = size;
  652.   if (size == 0)
  653.     res->text = NULL;
  654.   else
  655.     {
  656.       res->text = malloc_new_kp (pool, "FFETARGET cvt char1", size);
  657.       if (size <= l.length)
  658.     memcpy (res->text, l.text, size);
  659.       else
  660.     {
  661.       memcpy (res->text, l.text, l.length);
  662.       memset (res->text + l.length, ' ', size - l.length);
  663.     }
  664.     }
  665.  
  666.   return FFEBAD;
  667. }
  668.  
  669. #endif
  670. #if FFETARGET_okCHARACTER1
  671. ffebad
  672. ffetarget_convert_character1_hollerith (ffetargetCharacter1 *res,
  673.                     ffetargetCharacterSize size,
  674.                     ffetargetHollerith l, 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.     {
  684.       char *p;
  685.       ffetargetCharacterSize i;
  686.  
  687.       memcpy (res->text, l.text, size);
  688.       for (p = &l.text[0] + size, i = l.length - size;
  689.            i > 0;
  690.            ++p, --i)
  691.         if (*p != ' ')
  692.           return FFEBAD_TRUNCATING_HOLLERITH;
  693.     }
  694.       else
  695.     {
  696.       memcpy (res->text, l.text, l.length);
  697.       memset (res->text + l.length, ' ', size - l.length);
  698.     }
  699.     }
  700.  
  701.   return FFEBAD;
  702. }
  703.  
  704. #endif
  705. /* ffetarget_convert_character1_integer1 -- Raw conversion.  */
  706.  
  707. #if FFETARGET_okCHARACTER1
  708. ffebad
  709. ffetarget_convert_character1_integer1 (ffetargetCharacter1 *res,
  710.                        ffetargetCharacterSize size,
  711.                        ffetargetInteger1 l, mallocPool pool)
  712. {
  713.   unsigned long long int l1;
  714.   unsigned long int l2;
  715.   unsigned int l3;
  716.   unsigned short int l4;
  717.   unsigned char l5;
  718.   int size_of;
  719.   char *p;
  720.  
  721.   if (size >= sizeof (l1))
  722.     {
  723.       l1 = l;
  724.       p = (char *) &l1;
  725.       size_of = sizeof (l1);
  726.     }
  727.   else if (size >= sizeof (l2))
  728.     {
  729.       l2 = l;
  730.       p = (char *) &l2;
  731.       size_of = sizeof (l2);
  732.       l1 = l2;
  733.     }
  734.   else if (size >= sizeof (l3))
  735.     {
  736.       l3 = l;
  737.       p = (char *) &l3;
  738.       size_of = sizeof (l3);
  739.       l1 = l3;
  740.     }
  741.   else if (size >= sizeof (l4))
  742.     {
  743.       l4 = l;
  744.       p = (char *) &l4;
  745.       size_of = sizeof (l4);
  746.       l1 = l4;
  747.     }
  748.   else if (size >= sizeof (l5))
  749.     {
  750.       l5 = l;
  751.       p = (char *) &l5;
  752.       size_of = sizeof (l5);
  753.       l1 = l5;
  754.     }
  755.   else
  756.     {
  757.       assert ("stumped by conversion from integer1!" == NULL);
  758.       abort ();
  759.     }
  760.  
  761.   res->length = size;
  762.   if (size == 0)
  763.     res->text = NULL;
  764.   else
  765.     {
  766.       res->text = malloc_new_kp (pool, "FFETARGET cvt char1", size);
  767.       if (size <= size_of)
  768.     {
  769.       int i = size_of - size;
  770.  
  771.       memcpy (res->text, p + i, size);
  772.       for (; i > 0; ++p, --i)
  773.         if (*p != 0)
  774.           return FFEBAD_TRUNCATING_NUMERIC;
  775.     }
  776.       else
  777.     {
  778.       int i = size - size_of;
  779.  
  780.       memset (res->text, 0, i);
  781.       memcpy (res->text + i, p, size_of);
  782.     }
  783.     }
  784.  
  785.   if (l1 != l)
  786.     return FFEBAD_TRUNCATING_NUMERIC;
  787.   return FFEBAD;
  788. }
  789.  
  790. #endif
  791. /* ffetarget_convert_character1_logical1 -- Raw conversion.  */
  792.  
  793. #if FFETARGET_okCHARACTER1
  794. ffebad
  795. ffetarget_convert_character1_logical1 (ffetargetCharacter1 *res,
  796.                        ffetargetCharacterSize size,
  797.                        ffetargetLogical1 l, mallocPool pool)
  798. {
  799.   unsigned long long int l1;
  800.   unsigned long int l2;
  801.   unsigned int l3;
  802.   unsigned short int l4;
  803.   unsigned char l5;
  804.   int size_of;
  805.   char *p;
  806.  
  807.   if (size >= sizeof (l1))
  808.     {
  809.       l1 = l;
  810.       p = (char *) &l1;
  811.       size_of = sizeof (l1);
  812.     }
  813.   else if (size >= sizeof (l2))
  814.     {
  815.       l2 = l;
  816.       p = (char *) &l2;
  817.       size_of = sizeof (l2);
  818.       l1 = l2;
  819.     }
  820.   else if (size >= sizeof (l3))
  821.     {
  822.       l3 = l;
  823.       p = (char *) &l3;
  824.       size_of = sizeof (l3);
  825.       l1 = l3;
  826.     }
  827.   else if (size >= sizeof (l4))
  828.     {
  829.       l4 = l;
  830.       p = (char *) &l4;
  831.       size_of = sizeof (l4);
  832.       l1 = l4;
  833.     }
  834.   else if (size >= sizeof (l5))
  835.     {
  836.       l5 = l;
  837.       p = (char *) &l5;
  838.       size_of = sizeof (l5);
  839.       l1 = l5;
  840.     }
  841.   else
  842.     {
  843.       assert ("stumped by conversion from logical1!" == NULL);
  844.       abort ();
  845.     }
  846.  
  847.   res->length = size;
  848.   if (size == 0)
  849.     res->text = NULL;
  850.   else
  851.     {
  852.       res->text = malloc_new_kp (pool, "FFETARGET cvt char1", size);
  853.       if (size <= size_of)
  854.     {
  855.       int i = size_of - size;
  856.  
  857.       memcpy (res->text, p + i, size);
  858.       for (; i > 0; ++p, --i)
  859.         if (*p != 0)
  860.           return FFEBAD_TRUNCATING_NUMERIC;
  861.     }
  862.       else
  863.     {
  864.       int i = size - size_of;
  865.  
  866.       memset (res->text, 0, i);
  867.       memcpy (res->text + i, p, size_of);
  868.     }
  869.     }
  870.  
  871.   if (l1 != l)
  872.     return FFEBAD_TRUNCATING_NUMERIC;
  873.   return FFEBAD;
  874. }
  875.  
  876. #endif
  877. /* ffetarget_convert_character1_typeless -- Raw conversion.  */
  878.  
  879. #if FFETARGET_okCHARACTER1
  880. ffebad
  881. ffetarget_convert_character1_typeless (ffetargetCharacter1 *res,
  882.                        ffetargetCharacterSize size,
  883.                        ffetargetTypeless l, mallocPool pool)
  884. {
  885.   unsigned long long int l1;
  886.   unsigned long int l2;
  887.   unsigned int l3;
  888.   unsigned short int l4;
  889.   unsigned char l5;
  890.   int size_of;
  891.   char *p;
  892.  
  893.   if (size >= sizeof (l1))
  894.     {
  895.       l1 = l;
  896.       p = (char *) &l1;
  897.       size_of = sizeof (l1);
  898.     }
  899.   else if (size >= sizeof (l2))
  900.     {
  901.       l2 = l;
  902.       p = (char *) &l2;
  903.       size_of = sizeof (l2);
  904.       l1 = l2;
  905.     }
  906.   else if (size >= sizeof (l3))
  907.     {
  908.       l3 = l;
  909.       p = (char *) &l3;
  910.       size_of = sizeof (l3);
  911.       l1 = l3;
  912.     }
  913.   else if (size >= sizeof (l4))
  914.     {
  915.       l4 = l;
  916.       p = (char *) &l4;
  917.       size_of = sizeof (l4);
  918.       l1 = l4;
  919.     }
  920.   else if (size >= sizeof (l5))
  921.     {
  922.       l5 = l;
  923.       p = (char *) &l5;
  924.       size_of = sizeof (l5);
  925.       l1 = l5;
  926.     }
  927.   else
  928.     {
  929.       assert ("stumped by conversion from typeless!" == NULL);
  930.       abort ();
  931.     }
  932.  
  933.   res->length = size;
  934.   if (size == 0)
  935.     res->text = NULL;
  936.   else
  937.     {
  938.       res->text = malloc_new_kp (pool, "FFETARGET cvt char1", size);
  939.       if (size <= size_of)
  940.     {
  941.       int i = size_of - size;
  942.  
  943.       memcpy (res->text, p + i, size);
  944.       for (; i > 0; ++p, --i)
  945.         if (*p != 0)
  946.           return FFEBAD_TRUNCATING_TYPELESS;
  947.     }
  948.       else
  949.     {
  950.       int i = size - size_of;
  951.  
  952.       memset (res->text, 0, i);
  953.       memcpy (res->text + i, p, size_of);
  954.     }
  955.     }
  956.  
  957.   if (l1 != l)
  958.     return FFEBAD_TRUNCATING_TYPELESS;
  959.   return FFEBAD;
  960. }
  961.  
  962. #endif
  963. /* ffetarget_divide_complex1 -- Divide function
  964.  
  965.    See prototype.  */
  966.  
  967. #if FFETARGET_okCOMPLEX1
  968. ffebad
  969. ffetarget_divide_complex1 (ffetargetComplex1 *res, ffetargetComplex1 l,
  970.                ffetargetComplex1 r)
  971. {
  972.   ffebad bad;
  973.   ffetargetReal1 tmp1, tmp2, tmp3, tmp4;
  974.  
  975.   bad = ffetarget_multiply_real1 (&tmp1, r.real, r.real);
  976.   if (bad != FFEBAD)
  977.     return bad;
  978.   bad = ffetarget_multiply_real1 (&tmp2, r.imaginary, r.imaginary);
  979.   if (bad != FFEBAD)
  980.     return bad;
  981.   bad = ffetarget_add_real1 (&tmp3, tmp1, tmp2);
  982.   if (bad != FFEBAD)
  983.     return bad;
  984.  
  985.   if (ffetarget_iszero_real1 (tmp3))
  986.     {
  987.       ffetarget_real1_zero (&(res)->real);
  988.       ffetarget_real1_zero (&(res)->imaginary);
  989.       return FFEBAD_DIV_BY_ZERO;
  990.     }
  991.  
  992.   bad = ffetarget_multiply_real1 (&tmp1, l.real, r.real);
  993.   if (bad != FFEBAD)
  994.     return bad;
  995.   bad = ffetarget_multiply_real1 (&tmp2, l.imaginary, r.imaginary);
  996.   if (bad != FFEBAD)
  997.     return bad;
  998.   bad = ffetarget_add_real1 (&tmp4, tmp1, tmp2);
  999.   if (bad != FFEBAD)
  1000.     return bad;
  1001.   bad = ffetarget_divide_real1 (&res->real, tmp4, tmp3);
  1002.   if (bad != FFEBAD)
  1003.     return bad;
  1004.  
  1005.   bad = ffetarget_multiply_real1 (&tmp1, r.real, l.imaginary);
  1006.   if (bad != FFEBAD)
  1007.     return bad;
  1008.   bad = ffetarget_multiply_real1 (&tmp2, l.real, r.imaginary);
  1009.   if (bad != FFEBAD)
  1010.     return bad;
  1011.   bad = ffetarget_subtract_real1 (&tmp4, tmp1, tmp2);
  1012.   if (bad != FFEBAD)
  1013.     return bad;
  1014.   bad = ffetarget_divide_real1 (&res->imaginary, tmp4, tmp3);
  1015.  
  1016.   return FFEBAD;
  1017. }
  1018.  
  1019. #endif
  1020. /* ffetarget_divide_complex2 -- Divide function
  1021.  
  1022.    See prototype.  */
  1023.  
  1024. #if FFETARGET_okCOMPLEX2
  1025. ffebad
  1026. ffetarget_divide_complex2 (ffetargetComplex2 *res, ffetargetComplex2 l,
  1027.                ffetargetComplex2 r)
  1028. {
  1029.   ffebad bad;
  1030.   ffetargetReal2 tmp1, tmp2, tmp3, tmp4;
  1031.  
  1032.   bad = ffetarget_multiply_real2 (&tmp1, r.real, r.real);
  1033.   if (bad != FFEBAD)
  1034.     return bad;
  1035.   bad = ffetarget_multiply_real2 (&tmp2, r.imaginary, r.imaginary);
  1036.   if (bad != FFEBAD)
  1037.     return bad;
  1038.   bad = ffetarget_add_real2 (&tmp3, tmp1, tmp2);
  1039.   if (bad != FFEBAD)
  1040.     return bad;
  1041.  
  1042.   if (ffetarget_iszero_real2 (tmp3))
  1043.     {
  1044.       ffetarget_real2_zero (&(res)->real);
  1045.       ffetarget_real2_zero (&(res)->imaginary);
  1046.       return FFEBAD_DIV_BY_ZERO;
  1047.     }
  1048.  
  1049.   bad = ffetarget_multiply_real2 (&tmp1, l.real, r.real);
  1050.   if (bad != FFEBAD)
  1051.     return bad;
  1052.   bad = ffetarget_multiply_real2 (&tmp2, l.imaginary, r.imaginary);
  1053.   if (bad != FFEBAD)
  1054.     return bad;
  1055.   bad = ffetarget_add_real2 (&tmp4, tmp1, tmp2);
  1056.   if (bad != FFEBAD)
  1057.     return bad;
  1058.   bad = ffetarget_divide_real2 (&res->real, tmp4, tmp3);
  1059.   if (bad != FFEBAD)
  1060.     return bad;
  1061.  
  1062.   bad = ffetarget_multiply_real2 (&tmp1, r.real, l.imaginary);
  1063.   if (bad != FFEBAD)
  1064.     return bad;
  1065.   bad = ffetarget_multiply_real2 (&tmp2, l.real, r.imaginary);
  1066.   if (bad != FFEBAD)
  1067.     return bad;
  1068.   bad = ffetarget_subtract_real2 (&tmp4, tmp1, tmp2);
  1069.   if (bad != FFEBAD)
  1070.     return bad;
  1071.   bad = ffetarget_divide_real2 (&res->imaginary, tmp4, tmp3);
  1072.  
  1073.   return FFEBAD;
  1074. }
  1075.  
  1076. #endif
  1077. /* ffetarget_hollerith -- Convert token to a hollerith constant
  1078.  
  1079.    See prototype.
  1080.  
  1081.    Token use count not affected overall.  */
  1082.  
  1083. bool
  1084. ffetarget_hollerith (ffetargetHollerith *val, ffelexToken integer,
  1085.              mallocPool pool)
  1086. {
  1087.   val->length = ffelex_token_length (integer);
  1088.   val->text = malloc_new_kp (pool, "ffetargetHollerith", val->length);
  1089.   memcpy (val->text, ffelex_token_text (integer), val->length);
  1090.  
  1091.   return TRUE;
  1092. }
  1093.  
  1094. /* ffetarget_integer_bad_magical -- Complain about a magical number
  1095.  
  1096.    Just calls ffebad with the arguments.  */
  1097.  
  1098. void
  1099. ffetarget_integer_bad_magical (ffelexToken t)
  1100. {
  1101.   ffebad_start (FFEBAD_BAD_MAGICAL);
  1102.   ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
  1103.   ffebad_finish ();
  1104. }
  1105.  
  1106. /* ffetarget_integer_bad_magical_binary -- Complain about a magical number
  1107.  
  1108.    Just calls ffebad with the arguments.  */
  1109.  
  1110. void
  1111. ffetarget_integer_bad_magical_binary (ffelexToken integer,
  1112.                       ffelexToken minus)
  1113. {
  1114.   ffebad_start (FFEBAD_BAD_MAGICAL_BINARY);
  1115.   ffebad_here (0, ffelex_token_where_line (integer),
  1116.            ffelex_token_where_column (integer));
  1117.   ffebad_here (1, ffelex_token_where_line (minus),
  1118.            ffelex_token_where_column (minus));
  1119.   ffebad_finish ();
  1120. }
  1121.  
  1122. /* ffetarget_integer_bad_magical_precedence -- Complain about a magical
  1123.                            number
  1124.  
  1125.    Just calls ffebad with the arguments.  */
  1126.  
  1127. void
  1128. ffetarget_integer_bad_magical_precedence (ffelexToken integer,
  1129.                       ffelexToken uminus,
  1130.                       ffelexToken higher_op)
  1131. {
  1132.   ffebad_start (FFEBAD_BAD_MAGICAL_PRECEDENCE);
  1133.   ffebad_here (0, ffelex_token_where_line (integer),
  1134.            ffelex_token_where_column (integer));
  1135.   ffebad_here (1, ffelex_token_where_line (uminus),
  1136.            ffelex_token_where_column (uminus));
  1137.   ffebad_here (2, ffelex_token_where_line (higher_op),
  1138.            ffelex_token_where_column (higher_op));
  1139.   ffebad_finish ();
  1140. }
  1141.  
  1142. /* ffetarget_integer_bad_magical_precedence_binary -- Complain...
  1143.  
  1144.    Just calls ffebad with the arguments.  */
  1145.  
  1146. void
  1147. ffetarget_integer_bad_magical_precedence_binary (ffelexToken integer,
  1148.                          ffelexToken minus,
  1149.                          ffelexToken higher_op)
  1150. {
  1151.   ffebad_start (FFEBAD_BAD_MAGICAL_PRECEDENCE_BINARY);
  1152.   ffebad_here (0, ffelex_token_where_line (integer),
  1153.            ffelex_token_where_column (integer));
  1154.   ffebad_here (1, ffelex_token_where_line (minus),
  1155.            ffelex_token_where_column (minus));
  1156.   ffebad_here (2, ffelex_token_where_line (higher_op),
  1157.            ffelex_token_where_column (higher_op));
  1158.   ffebad_finish ();
  1159. }
  1160.  
  1161. /* ffetarget_integer1 -- Convert token to an integer
  1162.  
  1163.    See prototype.
  1164.  
  1165.    Token use count not affected overall.  */
  1166.  
  1167. #if FFETARGET_okINTEGER1
  1168. bool
  1169. ffetarget_integer1 (ffetargetInteger1 *val, ffelexToken integer)
  1170. {
  1171.   ffetargetInteger1 x;
  1172.   char *p;
  1173.   char c;
  1174.  
  1175.   assert (ffelex_token_type (integer) == FFELEX_typeNUMBER);
  1176.  
  1177.   p = ffelex_token_text (integer);
  1178.   x = 0;
  1179.  
  1180.   /* Skip past leading zeros. */
  1181.  
  1182.   while (((c = *p) != '\0') && (c == '0'))
  1183.     ++p;
  1184.  
  1185.   /* Interpret rest of number. */
  1186.  
  1187.   while (c != '\0')
  1188.     {
  1189.       if ((x == FFETARGET_integerALMOST_BIG_MAGICAL)
  1190.       && (c == '0' + FFETARGET_integerFINISH_BIG_MAGICAL)
  1191.       && (*(p + 1) == '\0'))
  1192.     {
  1193.       *val = (ffetargetInteger1) FFETARGET_integerBIG_MAGICAL;
  1194.       return TRUE;
  1195.     }
  1196.       else if (x == FFETARGET_integerALMOST_BIG_MAGICAL)
  1197.     {
  1198.       if ((c > '0' + FFETARGET_integerFINISH_BIG_MAGICAL)
  1199.           || (*(p + 1) != '\0'))
  1200.         {
  1201.           ffebad_start (FFEBAD_INTEGER_TOO_LARGE);
  1202.           ffebad_here (0, ffelex_token_where_line (integer),
  1203.                ffelex_token_where_column (integer));
  1204.           ffebad_finish ();
  1205.           *val = 0;
  1206.           return FALSE;
  1207.         }
  1208.     }
  1209.       else if (x > FFETARGET_integerALMOST_BIG_MAGICAL)
  1210.     {
  1211.       ffebad_start (FFEBAD_INTEGER_TOO_LARGE);
  1212.       ffebad_here (0, ffelex_token_where_line (integer),
  1213.                ffelex_token_where_column (integer));
  1214.       ffebad_finish ();
  1215.       *val = 0;
  1216.       return FALSE;
  1217.     }
  1218.       x = x * 10 + c - '0';
  1219.       c = *(++p);
  1220.     };
  1221.  
  1222.   *val = x;
  1223.   return TRUE;
  1224. }
  1225.  
  1226. #endif
  1227. /* ffetarget_integeroctal -- Convert token to an octal integer
  1228.  
  1229.    ffetarget_integeroctal x;
  1230.    if (ffetarget_integerdefault_8(&x,integer_token))
  1231.        // conversion ok.
  1232.  
  1233.    Token use count not affected overall.  */
  1234.  
  1235. bool
  1236. ffetarget_integeroctal (ffetargetIntegerDefault *val, ffelexToken integer)
  1237. {
  1238.   ffetargetIntegerDefault x;
  1239.   char *p;
  1240.   char c;
  1241.   bool bad_digit;
  1242.  
  1243.   assert (ffelex_token_type (integer) == FFELEX_typeNUMBER);
  1244.  
  1245.   p = ffelex_token_text (integer);
  1246.   x = 0;
  1247.  
  1248.   /* Skip past leading zeros. */
  1249.  
  1250.   while (((c = *p) != '\0') && (c == '0'))
  1251.     ++p;
  1252.  
  1253.   /* Interpret rest of number. */
  1254.  
  1255.   bad_digit = FALSE;
  1256.   while (c != '\0')
  1257.     {
  1258. #if 0                /* Don't complain about signed overflow; just
  1259.                    unsigned overflow. */
  1260.       if ((x == FFETARGET_integerALMOST_BIG_OVERFLOW_OCTAL)
  1261.       && (c == '0' + FFETARGET_integerFINISH_BIG_OVERFLOW_OCTAL)
  1262.       && (*(p + 1) == '\0'))
  1263.     {
  1264.       *val = FFETARGET_integerBIG_OVERFLOW_OCTAL;
  1265.       return TRUE;
  1266.     }
  1267.       else
  1268. #endif
  1269. #if FFETARGET_integerFINISH_BIG_OVERFLOW_OCTAL == 0
  1270.       if (x >= FFETARGET_integerALMOST_BIG_OVERFLOW_OCTAL)
  1271. #else
  1272.       if (x == FFETARGET_integerALMOST_BIG_OVERFLOW_OCTAL)
  1273.     {
  1274.       if ((c > '0' + FFETARGET_integerFINISH_BIG_OVERFLOW_OCTAL)
  1275.           || (*(p + 1) != '\0'))
  1276.         {
  1277.           ffebad_start (FFEBAD_INTEGER_TOO_LARGE);
  1278.           ffebad_here (0, ffelex_token_where_line (integer),
  1279.                ffelex_token_where_column (integer));
  1280.           ffebad_finish ();
  1281.           *val = 0;
  1282.           return FALSE;
  1283.         }
  1284.     }
  1285.       else if (x > FFETARGET_integerALMOST_BIG_OVERFLOW_OCTAL)
  1286. #endif
  1287.     {
  1288.       ffebad_start (FFEBAD_INTEGER_TOO_LARGE);
  1289.       ffebad_here (0, ffelex_token_where_line (integer),
  1290.                ffelex_token_where_column (integer));
  1291.       ffebad_finish ();
  1292.       *val = 0;
  1293.       return FALSE;
  1294.     }
  1295.       x = (x << 3) + c - '0';
  1296.       if (c >= '8')
  1297.     bad_digit = TRUE;
  1298.       c = *(++p);
  1299.     };
  1300.  
  1301.   if (bad_digit)
  1302.     {
  1303.       ffebad_start (FFEBAD_INVALID_OCTAL_DIGIT);
  1304.       ffebad_here (0, ffelex_token_where_line (integer),
  1305.            ffelex_token_where_column (integer));
  1306.       ffebad_finish ();
  1307.     }
  1308.  
  1309.   *val = x;
  1310.   return !bad_digit;
  1311. }
  1312.  
  1313. /* ffetarget_multiply_complex1 -- Multiply function
  1314.  
  1315.    See prototype.  */
  1316.  
  1317. #if FFETARGET_okCOMPLEX1
  1318. ffebad
  1319. ffetarget_multiply_complex1 (ffetargetComplex1 *res, ffetargetComplex1 l,
  1320.                  ffetargetComplex1 r)
  1321. {
  1322.   ffebad bad;
  1323.   ffetargetReal1 tmp1, tmp2;
  1324.  
  1325.   bad = ffetarget_multiply_real1 (&tmp1, l.real, r.real);
  1326.   if (bad != FFEBAD)
  1327.     return bad;
  1328.   bad = ffetarget_multiply_real1 (&tmp2, l.imaginary, r.imaginary);
  1329.   if (bad != FFEBAD)
  1330.     return bad;
  1331.   bad = ffetarget_subtract_real1 (&res->real, tmp1, tmp2);
  1332.   if (bad != FFEBAD)
  1333.     return bad;
  1334.   bad = ffetarget_multiply_real1 (&tmp1, l.imaginary, r.real);
  1335.   if (bad != FFEBAD)
  1336.     return bad;
  1337.   bad = ffetarget_multiply_real1 (&tmp2, l.real, r.imaginary);
  1338.   if (bad != FFEBAD)
  1339.     return bad;
  1340.   bad = ffetarget_add_real1 (&res->imaginary, tmp1, tmp2);
  1341.  
  1342.   return bad;
  1343. }
  1344.  
  1345. #endif
  1346. /* ffetarget_multiply_complex2 -- Multiply function
  1347.  
  1348.    See prototype.  */
  1349.  
  1350. #if FFETARGET_okCOMPLEX2
  1351. ffebad
  1352. ffetarget_multiply_complex2 (ffetargetComplex2 *res, ffetargetComplex2 l,
  1353.                  ffetargetComplex2 r)
  1354. {
  1355.   ffebad bad;
  1356.   ffetargetReal2 tmp1, tmp2;
  1357.  
  1358.   bad = ffetarget_multiply_real2 (&tmp1, l.real, r.real);
  1359.   if (bad != FFEBAD)
  1360.     return bad;
  1361.   bad = ffetarget_multiply_real2 (&tmp2, l.imaginary, r.imaginary);
  1362.   if (bad != FFEBAD)
  1363.     return bad;
  1364.   bad = ffetarget_subtract_real2 (&res->real, tmp1, tmp2);
  1365.   if (bad != FFEBAD)
  1366.     return bad;
  1367.   bad = ffetarget_multiply_real2 (&tmp1, l.imaginary, r.real);
  1368.   if (bad != FFEBAD)
  1369.     return bad;
  1370.   bad = ffetarget_multiply_real2 (&tmp2, l.real, r.imaginary);
  1371.   if (bad != FFEBAD)
  1372.     return bad;
  1373.   bad = ffetarget_add_real2 (&res->imaginary, tmp1, tmp2);
  1374.  
  1375.   return bad;
  1376. }
  1377.  
  1378. #endif
  1379. /* ffetarget_power_complexdefault_integerdefault -- Power function
  1380.  
  1381.    See prototype.  */
  1382.  
  1383. ffebad
  1384. ffetarget_power_complexdefault_integerdefault (ffetargetComplexDefault *res,
  1385.                            ffetargetComplexDefault l,
  1386.                            ffetargetIntegerDefault r)
  1387. {
  1388.   ffebad bad;
  1389.   ffetargetRealDefault tmp;
  1390.   ffetargetRealDefault tmp1;
  1391.   ffetargetRealDefault tmp2;
  1392.   ffetargetRealDefault two;
  1393.  
  1394.   if (ffetarget_iszero_real1 (l.real)
  1395.       && ffetarget_iszero_real1 (l.imaginary))
  1396.     {
  1397.       ffetarget_real1_zero (&res->real);
  1398.       ffetarget_real1_zero (&res->imaginary);
  1399.       return FFEBAD_BAD_POWER;
  1400.     }
  1401.  
  1402.   if (r == 0)
  1403.     {
  1404.       ffetarget_real1_one (&res->real);
  1405.       ffetarget_real1_zero (&res->imaginary);
  1406.       return FFEBAD;
  1407.     }
  1408.  
  1409.   if (r < 0)
  1410.     {
  1411.       r = -r;
  1412.       bad = ffetarget_multiply_real1 (&tmp1, l.real, l.real);
  1413.       if (bad != FFEBAD)
  1414.     return bad;
  1415.       bad = ffetarget_multiply_real1 (&tmp2, l.imaginary, l.imaginary);
  1416.       if (bad != FFEBAD)
  1417.     return bad;
  1418.       bad = ffetarget_add_real1 (&tmp, tmp1, tmp2);
  1419.       if (bad != FFEBAD)
  1420.     return bad;
  1421.       bad = ffetarget_divide_real1 (&l.real, l.real, tmp);
  1422.       if (bad != FFEBAD)
  1423.     return bad;
  1424.       bad = ffetarget_divide_real1 (&l.imaginary, l.imaginary, tmp);
  1425.       if (bad != FFEBAD)
  1426.     return bad;
  1427.       bad = ffetarget_uminus_real1 (&l.imaginary, l.imaginary);
  1428.       if (bad != FFEBAD)
  1429.     return bad;
  1430.     }
  1431.  
  1432.   ffetarget_real1_two (&two);
  1433.  
  1434.   while ((r & 1) == 0)
  1435.     {
  1436.       bad = ffetarget_multiply_real1 (&tmp1, l.real, l.real);
  1437.       if (bad != FFEBAD)
  1438.     return bad;
  1439.       bad = ffetarget_multiply_real1 (&tmp2, l.imaginary, l.imaginary);
  1440.       if (bad != FFEBAD)
  1441.     return bad;
  1442.       bad = ffetarget_subtract_real1 (&tmp, tmp1, tmp2);
  1443.       if (bad != FFEBAD)
  1444.     return bad;
  1445.       bad = ffetarget_multiply_real1 (&l.imaginary, l.real, l.imaginary);
  1446.       if (bad != FFEBAD)
  1447.     return bad;
  1448.       bad = ffetarget_multiply_real1 (&l.imaginary, l.imaginary, two);
  1449.       if (bad != FFEBAD)
  1450.     return bad;
  1451.       l.real = tmp;
  1452.       r >>= 1;
  1453.     }
  1454.  
  1455.   *res = l;
  1456.   r >>= 1;
  1457.  
  1458.   while (r != 0)
  1459.     {
  1460.       bad = ffetarget_multiply_real1 (&tmp1, l.real, l.real);
  1461.       if (bad != FFEBAD)
  1462.     return bad;
  1463.       bad = ffetarget_multiply_real1 (&tmp2, l.imaginary, l.imaginary);
  1464.       if (bad != FFEBAD)
  1465.     return bad;
  1466.       bad = ffetarget_subtract_real1 (&tmp, tmp1, tmp2);
  1467.       if (bad != FFEBAD)
  1468.     return bad;
  1469.       bad = ffetarget_multiply_real1 (&l.imaginary, l.real, l.imaginary);
  1470.       if (bad != FFEBAD)
  1471.     return bad;
  1472.       bad = ffetarget_multiply_real1 (&l.imaginary, l.imaginary, two);
  1473.       if (bad != FFEBAD)
  1474.     return bad;
  1475.       l.real = tmp;
  1476.       if ((r & 1) == 1)
  1477.     {
  1478.       bad = ffetarget_multiply_real1 (&tmp1, res->real, l.real);
  1479.       if (bad != FFEBAD)
  1480.         return bad;
  1481.       bad = ffetarget_multiply_real1 (&tmp2, res->imaginary,
  1482.                       l.imaginary);
  1483.       if (bad != FFEBAD)
  1484.         return bad;
  1485.       bad = ffetarget_subtract_real1 (&tmp, tmp1, tmp2);
  1486.       if (bad != FFEBAD)
  1487.         return bad;
  1488.       bad = ffetarget_multiply_real1 (&tmp1, res->imaginary, l.real);
  1489.       if (bad != FFEBAD)
  1490.         return bad;
  1491.       bad = ffetarget_multiply_real1 (&tmp2, res->real, l.imaginary);
  1492.       if (bad != FFEBAD)
  1493.         return bad;
  1494.       bad = ffetarget_add_real1 (&res->imaginary, tmp1, tmp2);
  1495.       if (bad != FFEBAD)
  1496.         return bad;
  1497.       res->real = tmp;
  1498.     }
  1499.       r >>= 1;
  1500.     }
  1501.  
  1502.   return FFEBAD;
  1503. }
  1504.  
  1505. /* ffetarget_power_complexdouble_integerdefault -- Power function
  1506.  
  1507.    See prototype.  */
  1508.  
  1509. #if FFETARGET_okCOMPLEXDOUBLE
  1510. ffebad
  1511. ffetarget_power_complexdouble_integerdefault (ffetargetComplexDouble *res,
  1512.             ffetargetComplexDouble l, ffetargetIntegerDefault r)
  1513. {
  1514.   ffebad bad;
  1515.   ffetargetRealDouble tmp;
  1516.   ffetargetRealDouble tmp1;
  1517.   ffetargetRealDouble tmp2;
  1518.   ffetargetRealDouble two;
  1519.  
  1520.   if (ffetarget_iszero_real2 (l.real)
  1521.       && ffetarget_iszero_real2 (l.imaginary))
  1522.     {
  1523.       ffetarget_real2_zero (&res->real);
  1524.       ffetarget_real2_zero (&res->imaginary);
  1525.       return FFEBAD_BAD_POWER;
  1526.     }
  1527.  
  1528.   if (r == 0)
  1529.     {
  1530.       ffetarget_real2_one (&res->real);
  1531.       ffetarget_real2_zero (&res->imaginary);
  1532.       return FFEBAD;
  1533.     }
  1534.  
  1535.   if (r < 0)
  1536.     {
  1537.       r = -r;
  1538.       bad = ffetarget_multiply_real2 (&tmp1, l.real, l.real);
  1539.       if (bad != FFEBAD)
  1540.     return bad;
  1541.       bad = ffetarget_multiply_real2 (&tmp2, l.imaginary, l.imaginary);
  1542.       if (bad != FFEBAD)
  1543.     return bad;
  1544.       bad = ffetarget_add_real2 (&tmp, tmp1, tmp2);
  1545.       if (bad != FFEBAD)
  1546.     return bad;
  1547.       bad = ffetarget_divide_real2 (&l.real, l.real, tmp);
  1548.       if (bad != FFEBAD)
  1549.     return bad;
  1550.       bad = ffetarget_divide_real2 (&l.imaginary, l.imaginary, tmp);
  1551.       if (bad != FFEBAD)
  1552.     return bad;
  1553.       bad = ffetarget_uminus_real2 (&l.imaginary, l.imaginary);
  1554.       if (bad != FFEBAD)
  1555.     return bad;
  1556.     }
  1557.  
  1558.   ffetarget_real2_two (&two);
  1559.  
  1560.   while ((r & 1) == 0)
  1561.     {
  1562.       bad = ffetarget_multiply_real2 (&tmp1, l.real, l.real);
  1563.       if (bad != FFEBAD)
  1564.     return bad;
  1565.       bad = ffetarget_multiply_real2 (&tmp2, l.imaginary, l.imaginary);
  1566.       if (bad != FFEBAD)
  1567.     return bad;
  1568.       bad = ffetarget_subtract_real2 (&tmp, tmp1, tmp2);
  1569.       if (bad != FFEBAD)
  1570.     return bad;
  1571.       bad = ffetarget_multiply_real2 (&l.imaginary, l.real, l.imaginary);
  1572.       if (bad != FFEBAD)
  1573.     return bad;
  1574.       bad = ffetarget_multiply_real2 (&l.imaginary, l.imaginary, two);
  1575.       if (bad != FFEBAD)
  1576.     return bad;
  1577.       l.real = tmp;
  1578.       r >>= 1;
  1579.     }
  1580.  
  1581.   *res = l;
  1582.   r >>= 1;
  1583.  
  1584.   while (r != 0)
  1585.     {
  1586.       bad = ffetarget_multiply_real2 (&tmp1, l.real, l.real);
  1587.       if (bad != FFEBAD)
  1588.     return bad;
  1589.       bad = ffetarget_multiply_real2 (&tmp2, l.imaginary, l.imaginary);
  1590.       if (bad != FFEBAD)
  1591.     return bad;
  1592.       bad = ffetarget_subtract_real2 (&tmp, tmp1, tmp2);
  1593.       if (bad != FFEBAD)
  1594.     return bad;
  1595.       bad = ffetarget_multiply_real2 (&l.imaginary, l.real, l.imaginary);
  1596.       if (bad != FFEBAD)
  1597.     return bad;
  1598.       bad = ffetarget_multiply_real2 (&l.imaginary, l.imaginary, two);
  1599.       if (bad != FFEBAD)
  1600.     return bad;
  1601.       l.real = tmp;
  1602.       if ((r & 1) == 1)
  1603.     {
  1604.       bad = ffetarget_multiply_real2 (&tmp1, res->real, l.real);
  1605.       if (bad != FFEBAD)
  1606.         return bad;
  1607.       bad = ffetarget_multiply_real2 (&tmp2, res->imaginary,
  1608.                       l.imaginary);
  1609.       if (bad != FFEBAD)
  1610.         return bad;
  1611.       bad = ffetarget_subtract_real2 (&tmp, tmp1, tmp2);
  1612.       if (bad != FFEBAD)
  1613.         return bad;
  1614.       bad = ffetarget_multiply_real2 (&tmp1, res->imaginary, l.real);
  1615.       if (bad != FFEBAD)
  1616.         return bad;
  1617.       bad = ffetarget_multiply_real2 (&tmp2, res->real, l.imaginary);
  1618.       if (bad != FFEBAD)
  1619.         return bad;
  1620.       bad = ffetarget_add_real2 (&res->imaginary, tmp1, tmp2);
  1621.       if (bad != FFEBAD)
  1622.         return bad;
  1623.       res->real = tmp;
  1624.     }
  1625.       r >>= 1;
  1626.     }
  1627.  
  1628.   return FFEBAD;
  1629. }
  1630.  
  1631. #endif
  1632. /* ffetarget_power_integerdefault_integerdefault -- Power function
  1633.  
  1634.    See prototype.  */
  1635.  
  1636. ffebad
  1637. ffetarget_power_integerdefault_integerdefault (ffetargetIntegerDefault *res,
  1638.                ffetargetIntegerDefault l, ffetargetIntegerDefault r)
  1639. {
  1640.   if (l == 0)
  1641.     {
  1642.       *res = 0;
  1643.       return FFEBAD_BAD_POWER;
  1644.     }
  1645.  
  1646.   if (r == 0)
  1647.     {
  1648.       *res = 1;
  1649.       return FFEBAD;
  1650.     }
  1651.  
  1652.   if (r < 0)
  1653.     {
  1654.       *res = (l == 1) ? 1 : 0;
  1655.       return FFEBAD;
  1656.     }
  1657.  
  1658.   while ((r & 1) == 0)
  1659.     {
  1660.       l *= l;
  1661.       r >>= 1;
  1662.     }
  1663.  
  1664.   *res = l;
  1665.   r >>= 1;
  1666.  
  1667.   while (r != 0)
  1668.     {
  1669.       l *= l;
  1670.       if ((r & 1) == 1)
  1671.     *res *= l;
  1672.       r >>= 1;
  1673.     }
  1674.  
  1675.   return FFEBAD;
  1676. }
  1677.  
  1678. /* ffetarget_power_realdefault_integerdefault -- Power function
  1679.  
  1680.    See prototype.  */
  1681.  
  1682. ffebad
  1683. ffetarget_power_realdefault_integerdefault (ffetargetRealDefault *res,
  1684.               ffetargetRealDefault l, ffetargetIntegerDefault r)
  1685. {
  1686.   ffebad bad;
  1687.  
  1688.   if (ffetarget_iszero_real1 (l))
  1689.     {
  1690.       ffetarget_real1_zero (res);
  1691.       return FFEBAD_BAD_POWER;
  1692.     }
  1693.  
  1694.   if (r == 0)
  1695.     {
  1696.       ffetarget_real1_one (res);
  1697.       return FFEBAD;
  1698.     }
  1699.  
  1700.   if (r < 0)
  1701.     {
  1702.       ffetargetRealDefault one;
  1703.  
  1704.       ffetarget_real1_one (&one);
  1705.       r = -r;
  1706.       bad = ffetarget_divide_real1 (&l, one, l);
  1707.       if (bad != FFEBAD)
  1708.     return bad;
  1709.     }
  1710.  
  1711.   while ((r & 1) == 0)
  1712.     {
  1713.       bad = ffetarget_multiply_real1 (&l, l, l);
  1714.       if (bad != FFEBAD)
  1715.     return bad;
  1716.       r >>= 1;
  1717.     }
  1718.  
  1719.   *res = l;
  1720.   r >>= 1;
  1721.  
  1722.   while (r != 0)
  1723.     {
  1724.       bad = ffetarget_multiply_real1 (&l, l, l);
  1725.       if (bad != FFEBAD)
  1726.     return bad;
  1727.       if ((r & 1) == 1)
  1728.     {
  1729.       bad = ffetarget_multiply_real1 (res, *res, l);
  1730.       if (bad != FFEBAD)
  1731.         return bad;
  1732.     }
  1733.       r >>= 1;
  1734.     }
  1735.  
  1736.   return FFEBAD;
  1737. }
  1738.  
  1739. /* ffetarget_power_realdouble_integerdefault -- Power function
  1740.  
  1741.    See prototype.  */
  1742.  
  1743. ffebad
  1744. ffetarget_power_realdouble_integerdefault (ffetargetRealDouble *res,
  1745.                        ffetargetRealDouble l,
  1746.                        ffetargetIntegerDefault r)
  1747. {
  1748.   ffebad bad;
  1749.  
  1750.   if (ffetarget_iszero_real2 (l))
  1751.     {
  1752.       ffetarget_real2_zero (res);
  1753.       return FFEBAD_BAD_POWER;
  1754.     }
  1755.  
  1756.   if (r == 0)
  1757.     {
  1758.       ffetarget_real2_one (res);
  1759.       return FFEBAD;
  1760.     }
  1761.  
  1762.   if (r < 0)
  1763.     {
  1764.       ffetargetRealDouble one;
  1765.  
  1766.       ffetarget_real2_one (&one);
  1767.       r = -r;
  1768.       bad = ffetarget_divide_real2 (&l, one, l);
  1769.       if (bad != FFEBAD)
  1770.     return bad;
  1771.     }
  1772.  
  1773.   while ((r & 1) == 0)
  1774.     {
  1775.       bad = ffetarget_multiply_real2 (&l, l, l);
  1776.       if (bad != FFEBAD)
  1777.     return bad;
  1778.       r >>= 1;
  1779.     }
  1780.  
  1781.   *res = l;
  1782.   r >>= 1;
  1783.  
  1784.   while (r != 0)
  1785.     {
  1786.       bad = ffetarget_multiply_real2 (&l, l, l);
  1787.       if (bad != FFEBAD)
  1788.     return bad;
  1789.       if ((r & 1) == 1)
  1790.     {
  1791.       bad = ffetarget_multiply_real2 (res, *res, l);
  1792.       if (bad != FFEBAD)
  1793.         return bad;
  1794.     }
  1795.       r >>= 1;
  1796.     }
  1797.  
  1798.   return FFEBAD;
  1799. }
  1800.  
  1801. /* ffetarget_print_binary -- Output typeless binary integer
  1802.  
  1803.    ffetargetTypeless val;
  1804.    ffetarget_typeless_binary(stdout,val);  */
  1805.  
  1806. void
  1807. ffetarget_print_binary (FILE *f, ffetargetTypeless value)
  1808. {
  1809.   char *p;
  1810.   char digits[sizeof (value) * CHAR_BIT + 1];
  1811.  
  1812.   if (f == NULL)
  1813.     f = stdout;
  1814.  
  1815.   p = &digits[ARRAY_SIZE (digits) - 1];
  1816.   *p = '\0';
  1817.   do
  1818.     {
  1819.       *--p = (value & 1) + '0';
  1820.       value >>= 1;
  1821.     } while (value == 0);
  1822.  
  1823.   fputs (p, f);
  1824. }
  1825.  
  1826. /* ffetarget_print_character1 -- Output character string
  1827.  
  1828.    ffetargetCharacter1 val;
  1829.    ffetarget_print_character1(stdout,val);  */
  1830.  
  1831. void
  1832. ffetarget_print_character1 (FILE *f, ffetargetCharacter1 value)
  1833. {
  1834.   unsigned char *p;
  1835.   ffetargetCharacterSize i;
  1836.  
  1837.   fputc ('\'', stdout);
  1838.   for (i = 0, p = value.text; i < value.length; ++i, ++p)
  1839.     ffetarget_print_char_ (f, *p);
  1840.   fputc ('\'', stdout);
  1841. }
  1842.  
  1843. /* ffetarget_print_hollerith -- Output hollerith string
  1844.  
  1845.    ffetargetHollerith val;
  1846.    ffetarget_print_hollerith(stdout,val);  */
  1847.  
  1848. void
  1849. ffetarget_print_hollerith (FILE *f, ffetargetHollerith value)
  1850. {
  1851.   unsigned char *p;
  1852.   ffetargetHollerithSize i;
  1853.  
  1854.   fputc ('\'', stdout);
  1855.   for (i = 0, p = value.text; i < value.length; ++i, ++p)
  1856.     ffetarget_print_char_ (f, *p);
  1857.   fputc ('\'', stdout);
  1858. }
  1859.  
  1860. /* ffetarget_print_octal -- Output typeless octal integer
  1861.  
  1862.    ffetargetTypeless val;
  1863.    ffetarget_print_octal(stdout,val);  */
  1864.  
  1865. void
  1866. ffetarget_print_octal (FILE *f, ffetargetTypeless value)
  1867. {
  1868.   char *p;
  1869.   char digits[sizeof (value) * CHAR_BIT / 3 + 1];
  1870.  
  1871.   if (f == NULL)
  1872.     f = stdout;
  1873.  
  1874.   p = &digits[ARRAY_SIZE (digits) - 3];
  1875.   *p = '\0';
  1876.   do
  1877.     {
  1878.       *--p = (value & 3) + '0';
  1879.       value >>= 3;
  1880.     } while (value == 0);
  1881.  
  1882.   fputs (p, f);
  1883. }
  1884.  
  1885. /* ffetarget_print_hex -- Output typeless hex integer
  1886.  
  1887.    ffetargetTypeless val;
  1888.    ffetarget_print_hex(stdout,val);  */
  1889.  
  1890. void
  1891. ffetarget_print_hex (FILE *f, ffetargetTypeless value)
  1892. {
  1893.   char *p;
  1894.   char digits[sizeof (value) * CHAR_BIT / 4 + 1];
  1895.   static char hexdigits[16] = "0123456789ABCDEF";
  1896.  
  1897.   if (f == NULL)
  1898.     f = stdout;
  1899.  
  1900.   p = &digits[ARRAY_SIZE (digits) - 3];
  1901.   *p = '\0';
  1902.   do
  1903.     {
  1904.       *--p = hexdigits[value & 4];
  1905.       value >>= 4;
  1906.     } while (value == 0);
  1907.  
  1908.   fputs (p, f);
  1909. }
  1910.  
  1911. /* ffetarget_real1 -- Convert token to a single-precision real number
  1912.  
  1913.    See prototype.
  1914.  
  1915.    Pass NULL for any token not provided by the user, but a valid Fortran
  1916.    real number must be provided somehow.  For example, it is ok for
  1917.    exponent_sign_token and exponent_digits_token to be NULL as long as
  1918.    exponent_token not only starts with "E" or "e" but also contains at least
  1919.    one digit following it.  Token use counts not affected overall.  */
  1920.  
  1921. #if FFETARGET_okREAL1
  1922. bool
  1923. ffetarget_real1 (ffetargetReal1 *value, ffelexToken integer,
  1924.          ffelexToken decimal, ffelexToken fraction,
  1925.          ffelexToken exponent, ffelexToken exponent_sign,
  1926.          ffelexToken exponent_digits)
  1927. {
  1928.   size_t sz = 1;        /* Allow room for '\0' byte at end. */
  1929.   char *ptr = &ffetarget_string_[0];
  1930.   char *p = ptr;
  1931.   char *q;
  1932.  
  1933. #define dotok(x) if (x != NULL) ++sz;
  1934. #define dotoktxt(x) if (x != NULL) sz += ffelex_token_length(x)
  1935.  
  1936.   dotoktxt (integer);
  1937.   dotok (decimal);
  1938.   dotoktxt (fraction);
  1939.   dotoktxt (exponent);
  1940.   dotok (exponent_sign);
  1941.   dotoktxt (exponent_digits);
  1942.  
  1943. #undef dotok
  1944. #undef dotoktxt
  1945.  
  1946.   if (sz > ARRAY_SIZE (ffetarget_string_))
  1947.     p = ptr = (char *) malloc_new_ks (malloc_pool_image (), "ffetarget_real1",
  1948.                       sz);
  1949.  
  1950. #define dotoktxt(x) if (x != NULL)                   \
  1951.           {                           \
  1952.           for (q = ffelex_token_text(x); *q != '\0'; ++q)  \
  1953.             *p++ = *q;                       \
  1954.           }
  1955.  
  1956.   dotoktxt (integer);
  1957.  
  1958.   if (decimal != NULL)
  1959.     *p++ = '.';
  1960.  
  1961.   dotoktxt (fraction);
  1962.   dotoktxt (exponent);
  1963.  
  1964.   if (exponent_sign != NULL)
  1965.     if (ffelex_token_type (exponent_sign) == FFELEX_typePLUS)
  1966.       *p++ = '+';
  1967.     else
  1968.       {
  1969.     assert (ffelex_token_type (exponent_sign) == FFELEX_typeMINUS);
  1970.     *p++ = '-';
  1971.       }
  1972.  
  1973.   dotoktxt (exponent_digits);
  1974.  
  1975. #undef dotoktxt
  1976.  
  1977.   *p = '\0';
  1978.  
  1979.   ffetarget_make_real1 (value,
  1980.             FFETARGET_ATOF_ (ptr,
  1981.                      SFmode));
  1982.  
  1983.   if (sz > ARRAY_SIZE (ffetarget_string_))
  1984.     malloc_kill_ks (malloc_pool_image (), ptr, sz);
  1985.  
  1986.   return TRUE;
  1987. }
  1988.  
  1989. #endif
  1990. /* ffetarget_real2 -- Convert token to a single-precision real number
  1991.  
  1992.    See prototype.
  1993.  
  1994.    Pass NULL for any token not provided by the user, but a valid Fortran
  1995.    real number must be provided somehow.  For example, it is ok for
  1996.    exponent_sign_token and exponent_digits_token to be NULL as long as
  1997.    exponent_token not only starts with "E" or "e" but also contains at least
  1998.    one digit following it.  Token use counts not affected overall.  */
  1999.  
  2000. #if FFETARGET_okREAL2
  2001. bool
  2002. ffetarget_real2 (ffetargetReal2 *value, ffelexToken integer,
  2003.          ffelexToken decimal, ffelexToken fraction,
  2004.          ffelexToken exponent, ffelexToken exponent_sign,
  2005.          ffelexToken exponent_digits)
  2006. {
  2007.   size_t sz = 1;        /* Allow room for '\0' byte at end. */
  2008.   char *ptr = &ffetarget_string_[0];
  2009.   char *p = ptr;
  2010.   char *q;
  2011.  
  2012. #define dotok(x) if (x != NULL) ++sz;
  2013. #define dotoktxt(x) if (x != NULL) sz += ffelex_token_length(x)
  2014.  
  2015.   dotoktxt (integer);
  2016.   dotok (decimal);
  2017.   dotoktxt (fraction);
  2018.   dotoktxt (exponent);
  2019.   dotok (exponent_sign);
  2020.   dotoktxt (exponent_digits);
  2021.  
  2022. #undef dotok
  2023. #undef dotoktxt
  2024.  
  2025.   if (sz > ARRAY_SIZE (ffetarget_string_))
  2026.     p = ptr = (char *) malloc_new_ks (malloc_pool_image (), "ffetarget_real1", sz);
  2027.  
  2028. #define dotoktxt(x) if (x != NULL)                   \
  2029.           {                           \
  2030.           for (q = ffelex_token_text(x); *q != '\0'; ++q)  \
  2031.             *p++ = *q;                       \
  2032.           }
  2033. #define dotoktxtexp(x) if (x != NULL)                       \
  2034.           {                               \
  2035.           *p++ = 'E';                           \
  2036.           for (q = ffelex_token_text(x) + 1; *q != '\0'; ++q)  \
  2037.             *p++ = *q;                           \
  2038.           }
  2039.  
  2040.   dotoktxt (integer);
  2041.  
  2042.   if (decimal != NULL)
  2043.     *p++ = '.';
  2044.  
  2045.   dotoktxt (fraction);
  2046.   dotoktxtexp (exponent);
  2047.  
  2048.   if (exponent_sign != NULL)
  2049.     if (ffelex_token_type (exponent_sign) == FFELEX_typePLUS)
  2050.       *p++ = '+';
  2051.     else
  2052.       {
  2053.     assert (ffelex_token_type (exponent_sign) == FFELEX_typeMINUS);
  2054.     *p++ = '-';
  2055.       }
  2056.  
  2057.   dotoktxt (exponent_digits);
  2058.  
  2059. #undef dotoktxt
  2060.  
  2061.   *p = '\0';
  2062.  
  2063.   ffetarget_make_real2 (value,
  2064.             FFETARGET_ATOF_ (ptr,
  2065.                      DFmode));
  2066.  
  2067.   if (sz > ARRAY_SIZE (ffetarget_string_))
  2068.     malloc_kill_ks (malloc_pool_image (), ptr, sz);
  2069.  
  2070.   return TRUE;
  2071. }
  2072.  
  2073. #endif
  2074. bool
  2075. ffetarget_typeless_binary (ffetargetTypeless *xvalue, ffelexToken token)
  2076. {
  2077.   char *p;
  2078.   char c;
  2079.   ffetargetTypeless value = 0;
  2080.   ffetargetTypeless new_value = 0;
  2081.   bool bad_digit = FALSE;
  2082.   bool overflow = FALSE;
  2083.  
  2084.   p = ffelex_token_text (token);
  2085.  
  2086.   for (c = *p; c != '\0'; c = *++p)
  2087.     {
  2088.       new_value <<= 1;
  2089.       if ((new_value >> 1) != value)
  2090.     overflow = TRUE;
  2091.       if (isdigit (c))
  2092.     new_value += c - '0';
  2093.       else
  2094.     bad_digit = TRUE;
  2095.       value = new_value;
  2096.     }
  2097.  
  2098.   if (bad_digit)
  2099.     {
  2100.       ffebad_start (FFEBAD_INVALID_TYPELESS_BINARY_DIGIT);
  2101.       ffebad_here (0, ffelex_token_where_line (token),
  2102.            ffelex_token_where_column (token));
  2103.       ffebad_finish ();
  2104.     }
  2105.   else if (overflow)
  2106.     {
  2107.       ffebad_start (FFEBAD_TYPELESS_OVERFLOW);
  2108.       ffebad_here (0, ffelex_token_where_line (token),
  2109.            ffelex_token_where_column (token));
  2110.       ffebad_finish ();
  2111.     }
  2112.  
  2113.   *xvalue = value;
  2114.  
  2115.   return !bad_digit && !overflow;
  2116. }
  2117.  
  2118. bool
  2119. ffetarget_typeless_octal (ffetargetTypeless *xvalue, ffelexToken token)
  2120. {
  2121.   char *p;
  2122.   char c;
  2123.   ffetargetTypeless value = 0;
  2124.   ffetargetTypeless new_value = 0;
  2125.   bool bad_digit = FALSE;
  2126.   bool overflow = FALSE;
  2127.  
  2128.   p = ffelex_token_text (token);
  2129.  
  2130.   for (c = *p; c != '\0'; c = *++p)
  2131.     {
  2132.       new_value <<= 3;
  2133.       if ((new_value >> 3) != value)
  2134.     overflow = TRUE;
  2135.       if (isdigit (c))
  2136.     new_value += c - '0';
  2137.       else
  2138.     bad_digit = TRUE;
  2139.       value = new_value;
  2140.     }
  2141.  
  2142.   if (bad_digit)
  2143.     {
  2144.       ffebad_start (FFEBAD_INVALID_TYPELESS_OCTAL_DIGIT);
  2145.       ffebad_here (0, ffelex_token_where_line (token),
  2146.            ffelex_token_where_column (token));
  2147.       ffebad_finish ();
  2148.     }
  2149.   else if (overflow)
  2150.     {
  2151.       ffebad_start (FFEBAD_TYPELESS_OVERFLOW);
  2152.       ffebad_here (0, ffelex_token_where_line (token),
  2153.            ffelex_token_where_column (token));
  2154.       ffebad_finish ();
  2155.     }
  2156.  
  2157.   *xvalue = value;
  2158.  
  2159.   return !bad_digit && !overflow;
  2160. }
  2161.  
  2162. bool
  2163. ffetarget_typeless_hex (ffetargetTypeless *xvalue, ffelexToken token)
  2164. {
  2165.   char *p;
  2166.   char c;
  2167.   ffetargetTypeless value = 0;
  2168.   ffetargetTypeless new_value = 0;
  2169.   bool bad_digit = FALSE;
  2170.   bool overflow = FALSE;
  2171.  
  2172.   p = ffelex_token_text (token);
  2173.  
  2174.   for (c = *p; c != '\0'; c = *++p)
  2175.     {
  2176.       new_value <<= 4;
  2177.       if ((new_value >> 4) != value)
  2178.     overflow = TRUE;
  2179.       if (isdigit (c))
  2180.     new_value += c - '0';
  2181.       else if ((c >= 'A') && (c <= 'F'))
  2182.     new_value += c - 'A' + 10;
  2183.       else if ((c >= 'a') && (c <= 'f'))
  2184.     new_value += c - 'a' + 10;
  2185.       else
  2186.     bad_digit = TRUE;
  2187.       value = new_value;
  2188.     }
  2189.  
  2190.   if (bad_digit)
  2191.     {
  2192.       ffebad_start (FFEBAD_INVALID_TYPELESS_HEX_DIGIT);
  2193.       ffebad_here (0, ffelex_token_where_line (token),
  2194.            ffelex_token_where_column (token));
  2195.       ffebad_finish ();
  2196.     }
  2197.   else if (overflow)
  2198.     {
  2199.       ffebad_start (FFEBAD_TYPELESS_OVERFLOW);
  2200.       ffebad_here (0, ffelex_token_where_line (token),
  2201.            ffelex_token_where_column (token));
  2202.       ffebad_finish ();
  2203.     }
  2204.  
  2205.   *xvalue = value;
  2206.  
  2207.   return !bad_digit && !overflow;
  2208. }
  2209.  
  2210. /* This is like memcpy.     It is needed because some systems' header files
  2211.    don't declare memcpy as a function but instead
  2212.    "#define memcpy(to,from,len) something".  */
  2213.  
  2214. void *
  2215. ffetarget_memcpy_ (void *dst, void *src, size_t len)
  2216. {
  2217.   return (void *) memcpy (dst, src, len);
  2218. }
  2219.  
  2220. /* ffetarget_num_digits_ -- Determine number of non-space characters in token
  2221.  
  2222.    ffetarget_num_digits_(token);
  2223.  
  2224.    All non-spaces are assumed to be binary, octal, or hex digits.  */
  2225.  
  2226. int
  2227. ffetarget_num_digits_ (ffelexToken token)
  2228. {
  2229.   int i;
  2230.   char *c;
  2231.  
  2232.   switch (ffelex_token_type (token))
  2233.     {
  2234.     case FFELEX_typeNAME:
  2235.     case FFELEX_typeNUMBER:
  2236.       return ffelex_token_length (token);
  2237.  
  2238.     case FFELEX_typeCHARACTER:
  2239.       i = 0;
  2240.       for (c = ffelex_token_text (token); *c != '\0'; ++c)
  2241.     {
  2242.       if (*c != ' ')
  2243.         ++i;
  2244.     }
  2245.       return i;
  2246.  
  2247.     default:
  2248.       assert ("weird token" == NULL);
  2249.       return 1;
  2250.     }
  2251. }
  2252.