diff options
Diffstat (limited to 'gcc/f/target.c')
| -rw-r--r-- | gcc/f/target.c | 2487 |
1 files changed, 2487 insertions, 0 deletions
diff --git a/gcc/f/target.c b/gcc/f/target.c new file mode 100644 index 00000000000..828e7adcf75 --- /dev/null +++ b/gcc/f/target.c @@ -0,0 +1,2487 @@ +/* target.c -- Implementation File (module.c template V1.0) + Copyright (C) 1995-1997 Free Software Foundation, Inc. + Contributed by James Craig Burley (burley@gnu.ai.mit.edu). + +This file is part of GNU Fortran. + +GNU Fortran is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Fortran; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA +02111-1307, USA. + + Related Modules: + None + + Description: + Implements conversion of lexer tokens to machine-dependent numerical + form and accordingly issues diagnostic messages when necessary. + + Also, this module, especially its .h file, provides nearly all of the + information on the target machine's data type, kind type, and length + type capabilities. The idea is that by carefully going through + target.h and changing things properly, one can accomplish much + towards the porting of the FFE to a new machine. There are limits + to how much this can accomplish towards that end, however. For one + thing, the ffeexpr_collapse_convert function doesn't contain all the + conversion cases necessary, because the text file would be + enormous (even though most of the function would be cut during the + cpp phase because of the absence of the types), so when adding to + the number of supported kind types for a given type, one must look + to see if ffeexpr_collapse_convert needs modification in this area, + in addition to providing the appropriate macros and functions in + ffetarget. Note that if combinatorial explosion actually becomes a + problem for a given machine, one might have to modify the way conversion + expressions are built so that instead of just one conversion expr, a + series of conversion exprs are built to make a path from one type to + another that is not a "near neighbor". For now, however, with a handful + of each of the numeric types and only one character type, things appear + manageable. + + A nonobvious change to ffetarget would be if the target machine was + not a 2's-complement machine. Any item with the word "magical" (case- + insensitive) in the FFE's source code (at least) indicates an assumption + that a 2's-complement machine is the target, and thus that there exists + a magnitude that can be represented as a negative number but not as + a positive number. It is possible that this situation can be dealt + with by changing only ffetarget, for example, on a 1's-complement + machine, perhaps #defineing ffetarget_constant_is_magical to simply + FALSE along with making the appropriate changes in ffetarget's number + parsing functions would be sufficient to effectively "comment out" code + in places like ffeexpr that do certain magical checks. But it is + possible there are other 2's-complement dependencies lurking in the + FFE (as possibly is true of any large program); if you find any, please + report them so we can replace them with dependencies on ffetarget + instead. + + Modifications: +*/ + +/* Include files. */ + +#include "proj.h" +#include <ctype.h> +#include "glimits.j" +#include "target.h" +#include "bad.h" +#include "info.h" +#include "lex.h" +#include "malloc.h" + +/* Externals defined here. */ + +char ffetarget_string_[40]; /* Temp for ascii-to-double (atof). */ +HOST_WIDE_INT ffetarget_long_val_; +HOST_WIDE_INT ffetarget_long_junk_; + +/* Simple definitions and enumerations. */ + + +/* Internal typedefs. */ + + +/* Private include files. */ + + +/* Internal structure definitions. */ + + +/* Static objects accessed by functions in this module. */ + + +/* Static functions (internal). */ + +static void ffetarget_print_char_ (FILE *f, unsigned char c); + +/* Internal macros. */ + +#ifdef REAL_VALUE_ATOF +#define FFETARGET_ATOF_(p,m) REAL_VALUE_ATOF ((p),(m)) +#else +#define FFETARGET_ATOF_(p,m) atof ((p)) +#endif + + +/* ffetarget_print_char_ -- Print a single character (in apostrophe context) + + See prototype. + + Outputs char so it prints or is escaped C style. */ + +static void +ffetarget_print_char_ (FILE *f, unsigned char c) +{ + switch (c) + { + case '\\': + fputs ("\\\\", f); + break; + + case '\'': + fputs ("\\\'", f); + break; + + default: + if (isprint (c) && isascii (c)) + fputc (c, f); + else + fprintf (f, "\\%03o", (unsigned int) c); + break; + } +} + +/* ffetarget_aggregate_info -- Determine type for aggregate storage area + + See prototype. + + If aggregate type is distinct, just return it. Else return a type + representing a common denominator for the nondistinct type (for now, + just return default character, since that'll work on almost all target + machines). + + The rules for abt/akt are (as implemented by ffestorag_update): + + abt == FFEINFO_basictypeANY (akt == FFEINFO_kindtypeANY also, by + definition): CHARACTER and non-CHARACTER types mixed. + + abt == FFEINFO_basictypeNONE (akt == FFEINFO_kindtypeNONE also, by + definition): More than one non-CHARACTER type mixed, but no CHARACTER + types mixed in. + + abt some other value, akt == FFEINFO_kindtypeNONE: abt indicates the + only basic type mixed in, but more than one kind type is mixed in. + + abt some other value, akt some other value: abt and akt indicate the + only type represented in the aggregation. */ + +void +ffetarget_aggregate_info (ffeinfoBasictype *ebt, ffeinfoKindtype *ekt, + ffetargetAlign *units, ffeinfoBasictype abt, + ffeinfoKindtype akt) +{ + ffetype type; + + if ((abt == FFEINFO_basictypeNONE) || (abt == FFEINFO_basictypeANY) + || (akt == FFEINFO_kindtypeNONE)) + { + *ebt = FFEINFO_basictypeCHARACTER; + *ekt = FFEINFO_kindtypeCHARACTERDEFAULT; + } + else + { + *ebt = abt; + *ekt = akt; + } + + type = ffeinfo_type (*ebt, *ekt); + assert (type != NULL); + + *units = ffetype_size (type); +} + +/* ffetarget_align -- Align one storage area to superordinate, update super + + See prototype. + + updated_alignment/updated_modulo contain the already existing + alignment requirements for the storage area at whose offset the + object with alignment requirements alignment/modulo is to be placed. + Find the smallest pad such that the requirements are maintained and + return it, but only after updating the updated_alignment/_modulo + requirements as necessary to indicate the placement of the new object. */ + +ffetargetAlign +ffetarget_align (ffetargetAlign *updated_alignment, + ffetargetAlign *updated_modulo, ffetargetOffset offset, + ffetargetAlign alignment, ffetargetAlign modulo) +{ + ffetargetAlign pad; + ffetargetAlign min_pad; /* Minimum amount of padding needed. */ + ffetargetAlign min_m = 0; /* Minimum-padding m. */ + ffetargetAlign ua; /* Updated alignment. */ + ffetargetAlign um; /* Updated modulo. */ + ffetargetAlign ucnt; /* Multiplier applied to ua. */ + ffetargetAlign m; /* Copy of modulo. */ + ffetargetAlign cnt; /* Multiplier applied to alignment. */ + ffetargetAlign i; + ffetargetAlign j; + + assert (*updated_modulo < *updated_alignment); + assert (modulo < alignment); + + /* The easy case: similar alignment requirements. */ + + if (*updated_alignment == alignment) + { + if (modulo > *updated_modulo) + pad = alignment - (modulo - *updated_modulo); + else + pad = *updated_modulo - modulo; + pad = (offset + pad) % alignment; + if (pad != 0) + pad = alignment - pad; + return pad; + } + + /* Sigh, find LCM (Least Common Multiple) for the two alignment factors. */ + + for (ua = *updated_alignment, ucnt = 1; + ua % alignment != 0; + ua += *updated_alignment) + ++ucnt; + + cnt = ua / alignment; + + min_pad = ~(ffetargetAlign) 0;/* Set to largest value. */ + + /* Find all combinations of modulo values the two alignment requirements + have; pick the combination that results in the smallest padding + requirement. Of course, if a zero-pad requirement is encountered, just + use that one. */ + + for (um = *updated_modulo, i = 0; i < ucnt; um += *updated_alignment, ++i) + { + for (m = modulo, j = 0; j < cnt; m += alignment, ++j) + { + if (m > um) /* This code is similar to the "easy case" + code above. */ + pad = ua - (m - um); + else + pad = um - m; + pad = (offset + pad) % ua; + if (pad != 0) + pad = ua - pad; + else + { /* A zero pad means we've got something + useful. */ + *updated_alignment = ua; + *updated_modulo = um; + return 0; + } + if (pad < min_pad) + { /* New minimum padding value. */ + min_pad = pad; + min_m = um; + } + } + } + + *updated_alignment = ua; + *updated_modulo = min_m; + return min_pad; +} + +#if FFETARGET_okCHARACTER1 +bool +ffetarget_character1 (ffetargetCharacter1 *val, ffelexToken character, + mallocPool pool) +{ + val->length = ffelex_token_length (character); + if (val->length == 0) + val->text = NULL; + else + { + val->text = malloc_new_kp (pool, "ffetargetCharacter1", val->length); + memcpy (val->text, ffelex_token_text (character), val->length); + } + + return TRUE; +} + +#endif +/* Produce orderable comparison between two constants + + Compare lengths, if equal then use memcmp. */ + +#if FFETARGET_okCHARACTER1 +int +ffetarget_cmp_character1 (ffetargetCharacter1 l, ffetargetCharacter1 r) +{ + if (l.length < r.length) + return -1; + if (l.length > r.length) + return 1; + if (l.length == 0) + return 0; + return memcmp (l.text, r.text, l.length); +} + +#endif +/* ffetarget_concatenate_character1 -- Perform CONCAT op on two constants + + Compare lengths, if equal then use memcmp. */ + +#if FFETARGET_okCHARACTER1 +ffebad +ffetarget_concatenate_character1 (ffetargetCharacter1 *res, + ffetargetCharacter1 l, ffetargetCharacter1 r, mallocPool pool, + ffetargetCharacterSize *len) +{ + res->length = *len = l.length + r.length; + if (*len == 0) + res->text = NULL; + else + { + res->text = malloc_new_kp (pool, "ffetargetCharacter1(CONCAT)", *len); + if (l.length != 0) + memcpy (res->text, l.text, l.length); + if (r.length != 0) + memcpy (res->text + l.length, r.text, r.length); + } + + return FFEBAD; +} + +#endif +/* ffetarget_eq_character1 -- Perform relational comparison on char constants + + Compare lengths, if equal then use memcmp. */ + +#if FFETARGET_okCHARACTER1 +ffebad +ffetarget_eq_character1 (bool *res, ffetargetCharacter1 l, + ffetargetCharacter1 r) +{ + assert (l.length == r.length); + *res = (memcmp (l.text, r.text, l.length) == 0); + return FFEBAD; +} + +#endif +/* ffetarget_le_character1 -- Perform relational comparison on char constants + + Compare lengths, if equal then use memcmp. */ + +#if FFETARGET_okCHARACTER1 +ffebad +ffetarget_le_character1 (bool *res, ffetargetCharacter1 l, + ffetargetCharacter1 r) +{ + assert (l.length == r.length); + *res = (memcmp (l.text, r.text, l.length) <= 0); + return FFEBAD; +} + +#endif +/* ffetarget_lt_character1 -- Perform relational comparison on char constants + + Compare lengths, if equal then use memcmp. */ + +#if FFETARGET_okCHARACTER1 +ffebad +ffetarget_lt_character1 (bool *res, ffetargetCharacter1 l, + ffetargetCharacter1 r) +{ + assert (l.length == r.length); + *res = (memcmp (l.text, r.text, l.length) < 0); + return FFEBAD; +} + +#endif +/* ffetarget_ge_character1 -- Perform relational comparison on char constants + + Compare lengths, if equal then use memcmp. */ + +#if FFETARGET_okCHARACTER1 +ffebad +ffetarget_ge_character1 (bool *res, ffetargetCharacter1 l, + ffetargetCharacter1 r) +{ + assert (l.length == r.length); + *res = (memcmp (l.text, r.text, l.length) >= 0); + return FFEBAD; +} + +#endif +/* ffetarget_gt_character1 -- Perform relational comparison on char constants + + Compare lengths, if equal then use memcmp. */ + +#if FFETARGET_okCHARACTER1 +ffebad +ffetarget_gt_character1 (bool *res, ffetargetCharacter1 l, + ffetargetCharacter1 r) +{ + assert (l.length == r.length); + *res = (memcmp (l.text, r.text, l.length) > 0); + return FFEBAD; +} +#endif + +#if FFETARGET_okCHARACTER1 +bool +ffetarget_iszero_character1 (ffetargetCharacter1 constant) +{ + ffetargetCharacterSize i; + + for (i = 0; i < constant.length; ++i) + if (constant.text[i] != 0) + return FALSE; + return TRUE; +} +#endif + +bool +ffetarget_iszero_hollerith (ffetargetHollerith constant) +{ + ffetargetHollerithSize i; + + for (i = 0; i < constant.length; ++i) + if (constant.text[i] != 0) + return FALSE; + return TRUE; +} + +/* ffetarget_layout -- Do storage requirement analysis for entity + + Return the alignment/modulo requirements along with the size, given the + data type info and the number of elements an array (1 for a scalar). */ + +void +ffetarget_layout (char *error_text UNUSED, ffetargetAlign *alignment, + ffetargetAlign *modulo, ffetargetOffset *size, + ffeinfoBasictype bt, ffeinfoKindtype kt, + ffetargetCharacterSize charsize, + ffetargetIntegerDefault num_elements) +{ + bool ok; /* For character type. */ + ffetargetOffset numele; /* Converted from num_elements. */ + ffetype type; + + type = ffeinfo_type (bt, kt); + assert (type != NULL); + + *alignment = ffetype_alignment (type); + *modulo = ffetype_modulo (type); + if (bt == FFEINFO_basictypeCHARACTER) + { + ok = ffetarget_offset_charsize (size, charsize, ffetype_size (type)); +#ifdef ffetarget_offset_overflow + if (!ok) + ffetarget_offset_overflow (error_text); +#endif + } + else + *size = ffetype_size (type); + + if ((num_elements < 0) + || !ffetarget_offset (&numele, num_elements) + || !ffetarget_offset_multiply (size, *size, numele)) + { + ffetarget_offset_overflow (error_text); + *alignment = 1; + *modulo = 0; + *size = 0; + } +} + +/* ffetarget_ne_character1 -- Perform relational comparison on char constants + + Compare lengths, if equal then use memcmp. */ + +#if FFETARGET_okCHARACTER1 +ffebad +ffetarget_ne_character1 (bool *res, ffetargetCharacter1 l, + ffetargetCharacter1 r) +{ + assert (l.length == r.length); + *res = (memcmp (l.text, r.text, l.length) != 0); + return FFEBAD; +} + +#endif +/* ffetarget_substr_character1 -- Perform SUBSTR op on three constants + + Compare lengths, if equal then use memcmp. */ + +#if FFETARGET_okCHARACTER1 +ffebad +ffetarget_substr_character1 (ffetargetCharacter1 *res, + ffetargetCharacter1 l, + ffetargetCharacterSize first, + ffetargetCharacterSize last, mallocPool pool, + ffetargetCharacterSize *len) +{ + if (last < first) + { + res->length = *len = 0; + res->text = NULL; + } + else + { + res->length = *len = last - first + 1; + res->text = malloc_new_kp (pool, "ffetargetCharacter1(SUBSTR)", *len); + memcpy (res->text, l.text + first - 1, *len); + } + + return FFEBAD; +} + +#endif +/* ffetarget_cmp_hollerith -- Produce orderable comparison between two + constants + + Compare lengths, if equal then use memcmp. */ + +int +ffetarget_cmp_hollerith (ffetargetHollerith l, ffetargetHollerith r) +{ + if (l.length < r.length) + return -1; + if (l.length > r.length) + return 1; + return memcmp (l.text, r.text, l.length); +} + +ffebad +ffetarget_convert_any_character1_ (char *res, size_t size, + ffetargetCharacter1 l) +{ + if (size <= (size_t) l.length) + { + char *p; + ffetargetCharacterSize i; + + memcpy (res, l.text, size); + for (p = &l.text[0] + size, i = l.length - size; + i > 0; + ++p, --i) + if (*p != ' ') + return FFEBAD_TRUNCATING_CHARACTER; + } + else + { + memcpy (res, l.text, size); + memset (res + l.length, ' ', size - l.length); + } + + return FFEBAD; +} + +ffebad +ffetarget_convert_any_hollerith_ (char *res, size_t size, + ffetargetHollerith l) +{ + if (size <= (size_t) l.length) + { + char *p; + ffetargetCharacterSize i; + + memcpy (res, l.text, size); + for (p = &l.text[0] + size, i = l.length - size; + i > 0; + ++p, --i) + if (*p != ' ') + return FFEBAD_TRUNCATING_HOLLERITH; + } + else + { + memcpy (res, l.text, size); + memset (res + l.length, ' ', size - l.length); + } + + return FFEBAD; +} + +ffebad +ffetarget_convert_any_typeless_ (char *res, size_t size, + ffetargetTypeless l) +{ + unsigned long long int l1; + unsigned long int l2; + unsigned int l3; + unsigned short int l4; + unsigned char l5; + size_t size_of; + char *p; + + if (size >= sizeof (l1)) + { + l1 = l; + p = (char *) &l1; + size_of = sizeof (l1); + } + else if (size >= sizeof (l2)) + { + l2 = l; + p = (char *) &l2; + size_of = sizeof (l2); + l1 = l2; + } + else if (size >= sizeof (l3)) + { + l3 = l; + p = (char *) &l3; + size_of = sizeof (l3); + l1 = l3; + } + else if (size >= sizeof (l4)) + { + l4 = l; + p = (char *) &l4; + size_of = sizeof (l4); + l1 = l4; + } + else if (size >= sizeof (l5)) + { + l5 = l; + p = (char *) &l5; + size_of = sizeof (l5); + l1 = l5; + } + else + { + assert ("stumped by conversion from typeless!" == NULL); + abort (); + } + + if (size <= size_of) + { + int i = size_of - size; + + memcpy (res, p + i, size); + for (; i > 0; ++p, --i) + if (*p != '\0') + return FFEBAD_TRUNCATING_TYPELESS; + } + else + { + int i = size - size_of; + + memset (res, 0, i); + memcpy (res + i, p, size_of); + } + + if (l1 != l) + return FFEBAD_TRUNCATING_TYPELESS; + return FFEBAD; +} + +#if FFETARGET_okCHARACTER1 +ffebad +ffetarget_convert_character1_character1 (ffetargetCharacter1 *res, + ffetargetCharacterSize size, + ffetargetCharacter1 l, + mallocPool pool) +{ + res->length = size; + if (size == 0) + res->text = NULL; + else + { + res->text = malloc_new_kp (pool, "FFETARGET cvt char1", size); + if (size <= l.length) + memcpy (res->text, l.text, size); + else + { + memcpy (res->text, l.text, l.length); + memset (res->text + l.length, ' ', size - l.length); + } + } + + return FFEBAD; +} + +#endif +#if FFETARGET_okCHARACTER1 +ffebad +ffetarget_convert_character1_hollerith (ffetargetCharacter1 *res, + ffetargetCharacterSize size, + ffetargetHollerith l, mallocPool pool) +{ + res->length = size; + if (size == 0) + res->text = NULL; + else + { + res->text = malloc_new_kp (pool, "FFETARGET cvt char1", size); + if (size <= l.length) + { + char *p; + ffetargetCharacterSize i; + + memcpy (res->text, l.text, size); + for (p = &l.text[0] + size, i = l.length - size; + i > 0; + ++p, --i) + if (*p != ' ') + return FFEBAD_TRUNCATING_HOLLERITH; + } + else + { + memcpy (res->text, l.text, l.length); + memset (res->text + l.length, ' ', size - l.length); + } + } + + return FFEBAD; +} + +#endif +/* ffetarget_convert_character1_integer1 -- Raw conversion. */ + +#if FFETARGET_okCHARACTER1 +ffebad +ffetarget_convert_character1_integer4 (ffetargetCharacter1 *res, + ffetargetCharacterSize size, + ffetargetInteger4 l, mallocPool pool) +{ + long long int l1; + long int l2; + int l3; + short int l4; + char l5; + size_t size_of; + char *p; + + if (((size_t) size) >= sizeof (l1)) + { + l1 = l; + p = (char *) &l1; + size_of = sizeof (l1); + } + else if (((size_t) size) >= sizeof (l2)) + { + l2 = l; + p = (char *) &l2; + size_of = sizeof (l2); + l1 = l2; + } + else if (((size_t) size) >= sizeof (l3)) + { + l3 = l; + p = (char *) &l3; + size_of = sizeof (l3); + l1 = l3; + } + else if (((size_t) size) >= sizeof (l4)) + { + l4 = l; + p = (char *) &l4; + size_of = sizeof (l4); + l1 = l4; + } + else if (((size_t) size) >= sizeof (l5)) + { + l5 = l; + p = (char *) &l5; + size_of = sizeof (l5); + l1 = l5; + } + else + { + assert ("stumped by conversion from integer1!" == NULL); + abort (); + } + + res->length = size; + if (size == 0) + res->text = NULL; + else + { + res->text = malloc_new_kp (pool, "FFETARGET cvt char1", size); + if (((size_t) size) <= size_of) + { + int i = size_of - size; + + memcpy (res->text, p + i, size); + for (; i > 0; ++p, --i) + if (*p != 0) + return FFEBAD_TRUNCATING_NUMERIC; + } + else + { + int i = size - size_of; + + memset (res->text, 0, i); + memcpy (res->text + i, p, size_of); + } + } + + if (l1 != l) + return FFEBAD_TRUNCATING_NUMERIC; + return FFEBAD; +} + +#endif +/* ffetarget_convert_character1_logical1 -- Raw conversion. */ + +#if FFETARGET_okCHARACTER1 +ffebad +ffetarget_convert_character1_logical4 (ffetargetCharacter1 *res, + ffetargetCharacterSize size, + ffetargetLogical4 l, mallocPool pool) +{ + long long int l1; + long int l2; + int l3; + short int l4; + char l5; + size_t size_of; + char *p; + + if (((size_t) size) >= sizeof (l1)) + { + l1 = l; + p = (char *) &l1; + size_of = sizeof (l1); + } + else if (((size_t) size) >= sizeof (l2)) + { + l2 = l; + p = (char *) &l2; + size_of = sizeof (l2); + l1 = l2; + } + else if (((size_t) size) >= sizeof (l3)) + { + l3 = l; + p = (char *) &l3; + size_of = sizeof (l3); + l1 = l3; + } + else if (((size_t) size) >= sizeof (l4)) + { + l4 = l; + p = (char *) &l4; + size_of = sizeof (l4); + l1 = l4; + } + else if (((size_t) size) >= sizeof (l5)) + { + l5 = l; + p = (char *) &l5; + size_of = sizeof (l5); + l1 = l5; + } + else + { + assert ("stumped by conversion from logical1!" == NULL); + abort (); + } + + res->length = size; + if (size == 0) + res->text = NULL; + else + { + res->text = malloc_new_kp (pool, "FFETARGET cvt char1", size); + if (((size_t) size) <= size_of) + { + int i = size_of - size; + + memcpy (res->text, p + i, size); + for (; i > 0; ++p, --i) + if (*p != 0) + return FFEBAD_TRUNCATING_NUMERIC; + } + else + { + int i = size - size_of; + + memset (res->text, 0, i); + memcpy (res->text + i, p, size_of); + } + } + + if (l1 != l) + return FFEBAD_TRUNCATING_NUMERIC; + return FFEBAD; +} + +#endif +/* ffetarget_convert_character1_typeless -- Raw conversion. */ + +#if FFETARGET_okCHARACTER1 +ffebad +ffetarget_convert_character1_typeless (ffetargetCharacter1 *res, + ffetargetCharacterSize size, + ffetargetTypeless l, mallocPool pool) +{ + unsigned long long int l1; + unsigned long int l2; + unsigned int l3; + unsigned short int l4; + unsigned char l5; + size_t size_of; + char *p; + + if (((size_t) size) >= sizeof (l1)) + { + l1 = l; + p = (char *) &l1; + size_of = sizeof (l1); + } + else if (((size_t) size) >= sizeof (l2)) + { + l2 = l; + p = (char *) &l2; + size_of = sizeof (l2); + l1 = l2; + } + else if (((size_t) size) >= sizeof (l3)) + { + l3 = l; + p = (char *) &l3; + size_of = sizeof (l3); + l1 = l3; + } + else if (((size_t) size) >= sizeof (l4)) + { + l4 = l; + p = (char *) &l4; + size_of = sizeof (l4); + l1 = l4; + } + else if (((size_t) size) >= sizeof (l5)) + { + l5 = l; + p = (char *) &l5; + size_of = sizeof (l5); + l1 = l5; + } + else + { + assert ("stumped by conversion from typeless!" == NULL); + abort (); + } + + res->length = size; + if (size == 0) + res->text = NULL; + else + { + res->text = malloc_new_kp (pool, "FFETARGET cvt char1", size); + if (((size_t) size) <= size_of) + { + int i = size_of - size; + + memcpy (res->text, p + i, size); + for (; i > 0; ++p, --i) + if (*p != 0) + return FFEBAD_TRUNCATING_TYPELESS; + } + else + { + int i = size - size_of; + + memset (res->text, 0, i); + memcpy (res->text + i, p, size_of); + } + } + + if (l1 != l) + return FFEBAD_TRUNCATING_TYPELESS; + return FFEBAD; +} + +#endif +/* ffetarget_divide_complex1 -- Divide function + + See prototype. */ + +#if FFETARGET_okCOMPLEX1 +ffebad +ffetarget_divide_complex1 (ffetargetComplex1 *res, ffetargetComplex1 l, + ffetargetComplex1 r) +{ + ffebad bad; + ffetargetReal1 tmp1, tmp2, tmp3, tmp4; + + bad = ffetarget_multiply_real1 (&tmp1, r.real, r.real); + if (bad != FFEBAD) + return bad; + bad = ffetarget_multiply_real1 (&tmp2, r.imaginary, r.imaginary); + if (bad != FFEBAD) + return bad; + bad = ffetarget_add_real1 (&tmp3, tmp1, tmp2); + if (bad != FFEBAD) + return bad; + + if (ffetarget_iszero_real1 (tmp3)) + { + ffetarget_real1_zero (&(res)->real); + ffetarget_real1_zero (&(res)->imaginary); + return FFEBAD_DIV_BY_ZERO; + } + + bad = ffetarget_multiply_real1 (&tmp1, l.real, r.real); + if (bad != FFEBAD) + return bad; + bad = ffetarget_multiply_real1 (&tmp2, l.imaginary, r.imaginary); + if (bad != FFEBAD) + return bad; + bad = ffetarget_add_real1 (&tmp4, tmp1, tmp2); + if (bad != FFEBAD) + return bad; + bad = ffetarget_divide_real1 (&res->real, tmp4, tmp3); + if (bad != FFEBAD) + return bad; + + bad = ffetarget_multiply_real1 (&tmp1, r.real, l.imaginary); + if (bad != FFEBAD) + return bad; + bad = ffetarget_multiply_real1 (&tmp2, l.real, r.imaginary); + if (bad != FFEBAD) + return bad; + bad = ffetarget_subtract_real1 (&tmp4, tmp1, tmp2); + if (bad != FFEBAD) + return bad; + bad = ffetarget_divide_real1 (&res->imaginary, tmp4, tmp3); + + return FFEBAD; +} + +#endif +/* ffetarget_divide_complex2 -- Divide function + + See prototype. */ + +#if FFETARGET_okCOMPLEX2 +ffebad +ffetarget_divide_complex2 (ffetargetComplex2 *res, ffetargetComplex2 l, + ffetargetComplex2 r) +{ + ffebad bad; + ffetargetReal2 tmp1, tmp2, tmp3, tmp4; + + bad = ffetarget_multiply_real2 (&tmp1, r.real, r.real); + if (bad != FFEBAD) + return bad; + bad = ffetarget_multiply_real2 (&tmp2, r.imaginary, r.imaginary); + if (bad != FFEBAD) + return bad; + bad = ffetarget_add_real2 (&tmp3, tmp1, tmp2); + if (bad != FFEBAD) + return bad; + + if (ffetarget_iszero_real2 (tmp3)) + { + ffetarget_real2_zero (&(res)->real); + ffetarget_real2_zero (&(res)->imaginary); + return FFEBAD_DIV_BY_ZERO; + } + + bad = ffetarget_multiply_real2 (&tmp1, l.real, r.real); + if (bad != FFEBAD) + return bad; + bad = ffetarget_multiply_real2 (&tmp2, l.imaginary, r.imaginary); + if (bad != FFEBAD) + return bad; + bad = ffetarget_add_real2 (&tmp4, tmp1, tmp2); + if (bad != FFEBAD) + return bad; + bad = ffetarget_divide_real2 (&res->real, tmp4, tmp3); + if (bad != FFEBAD) + return bad; + + bad = ffetarget_multiply_real2 (&tmp1, r.real, l.imaginary); + if (bad != FFEBAD) + return bad; + bad = ffetarget_multiply_real2 (&tmp2, l.real, r.imaginary); + if (bad != FFEBAD) + return bad; + bad = ffetarget_subtract_real2 (&tmp4, tmp1, tmp2); + if (bad != FFEBAD) + return bad; + bad = ffetarget_divide_real2 (&res->imaginary, tmp4, tmp3); + + return FFEBAD; +} + +#endif +/* ffetarget_hollerith -- Convert token to a hollerith constant + + See prototype. + + Token use count not affected overall. */ + +bool +ffetarget_hollerith (ffetargetHollerith *val, ffelexToken integer, + mallocPool pool) +{ + val->length = ffelex_token_length (integer); + val->text = malloc_new_kp (pool, "ffetargetHollerith", val->length); + memcpy (val->text, ffelex_token_text (integer), val->length); + + return TRUE; +} + +/* ffetarget_integer_bad_magical -- Complain about a magical number + + Just calls ffebad with the arguments. */ + +void +ffetarget_integer_bad_magical (ffelexToken t) +{ + ffebad_start (FFEBAD_BAD_MAGICAL); + ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_finish (); +} + +/* ffetarget_integer_bad_magical_binary -- Complain about a magical number + + Just calls ffebad with the arguments. */ + +void +ffetarget_integer_bad_magical_binary (ffelexToken integer, + ffelexToken minus) +{ + ffebad_start (FFEBAD_BAD_MAGICAL_BINARY); + ffebad_here (0, ffelex_token_where_line (integer), + ffelex_token_where_column (integer)); + ffebad_here (1, ffelex_token_where_line (minus), + ffelex_token_where_column (minus)); + ffebad_finish (); +} + +/* ffetarget_integer_bad_magical_precedence -- Complain about a magical + number + + Just calls ffebad with the arguments. */ + +void +ffetarget_integer_bad_magical_precedence (ffelexToken integer, + ffelexToken uminus, + ffelexToken higher_op) +{ + ffebad_start (FFEBAD_BAD_MAGICAL_PRECEDENCE); + ffebad_here (0, ffelex_token_where_line (integer), + ffelex_token_where_column (integer)); + ffebad_here (1, ffelex_token_where_line (uminus), + ffelex_token_where_column (uminus)); + ffebad_here (2, ffelex_token_where_line (higher_op), + ffelex_token_where_column (higher_op)); + ffebad_finish (); +} + +/* ffetarget_integer_bad_magical_precedence_binary -- Complain... + + Just calls ffebad with the arguments. */ + +void +ffetarget_integer_bad_magical_precedence_binary (ffelexToken integer, + ffelexToken minus, + ffelexToken higher_op) +{ + ffebad_start (FFEBAD_BAD_MAGICAL_PRECEDENCE_BINARY); + ffebad_here (0, ffelex_token_where_line (integer), + ffelex_token_where_column (integer)); + ffebad_here (1, ffelex_token_where_line (minus), + ffelex_token_where_column (minus)); + ffebad_here (2, ffelex_token_where_line (higher_op), + ffelex_token_where_column (higher_op)); + ffebad_finish (); +} + +/* ffetarget_integer1 -- Convert token to an integer + + See prototype. + + Token use count not affected overall. */ + +#if FFETARGET_okINTEGER1 +bool +ffetarget_integer1 (ffetargetInteger1 *val, ffelexToken integer) +{ + ffetargetInteger1 x; + char *p; + char c; + + assert (ffelex_token_type (integer) == FFELEX_typeNUMBER); + + p = ffelex_token_text (integer); + x = 0; + + /* Skip past leading zeros. */ + + while (((c = *p) != '\0') && (c == '0')) + ++p; + + /* Interpret rest of number. */ + + while (c != '\0') + { + if ((x == FFETARGET_integerALMOST_BIG_MAGICAL) + && (c == '0' + FFETARGET_integerFINISH_BIG_MAGICAL) + && (*(p + 1) == '\0')) + { + *val = (ffetargetInteger1) FFETARGET_integerBIG_MAGICAL; + return TRUE; + } + else if (x == FFETARGET_integerALMOST_BIG_MAGICAL) + { + if ((c > '0' + FFETARGET_integerFINISH_BIG_MAGICAL) + || (*(p + 1) != '\0')) + { + ffebad_start (FFEBAD_INTEGER_TOO_LARGE); + ffebad_here (0, ffelex_token_where_line (integer), + ffelex_token_where_column (integer)); + ffebad_finish (); + *val = 0; + return FALSE; + } + } + else if (x > FFETARGET_integerALMOST_BIG_MAGICAL) + { + ffebad_start (FFEBAD_INTEGER_TOO_LARGE); + ffebad_here (0, ffelex_token_where_line (integer), + ffelex_token_where_column (integer)); + ffebad_finish (); + *val = 0; + return FALSE; + } + x = x * 10 + c - '0'; + c = *(++p); + }; + + *val = x; + return TRUE; +} + +#endif +/* ffetarget_integerbinary -- Convert token to a binary integer + + ffetarget_integerbinary x; + if (ffetarget_integerdefault_8(&x,integer_token)) + // conversion ok. + + Token use count not affected overall. */ + +bool +ffetarget_integerbinary (ffetargetIntegerDefault *val, ffelexToken integer) +{ + ffetargetIntegerDefault x; + char *p; + char c; + bool bad_digit; + + assert ((ffelex_token_type (integer) == FFELEX_typeNAME) + || (ffelex_token_type (integer) == FFELEX_typeNUMBER)); + + p = ffelex_token_text (integer); + x = 0; + + /* Skip past leading zeros. */ + + while (((c = *p) != '\0') && (c == '0')) + ++p; + + /* Interpret rest of number. */ + + bad_digit = FALSE; + while (c != '\0') + { + if ((c >= '0') && (c <= '1')) + c -= '0'; + else + { + bad_digit = TRUE; + c = 0; + } + +#if 0 /* Don't complain about signed overflow; just + unsigned overflow. */ + if ((x == FFETARGET_integerALMOST_BIG_OVERFLOW_BINARY) + && (c == FFETARGET_integerFINISH_BIG_OVERFLOW_BINARY) + && (*(p + 1) == '\0')) + { + *val = FFETARGET_integerBIG_OVERFLOW_BINARY; + return TRUE; + } + else +#endif +#if FFETARGET_integerFINISH_BIG_OVERFLOW_BINARY == 0 + if ((x & FFETARGET_integerALMOST_BIG_OVERFLOW_BINARY) != 0) +#else + if (x == FFETARGET_integerALMOST_BIG_OVERFLOW_BINARY) + { + if ((c > FFETARGET_integerFINISH_BIG_OVERFLOW_BINARY) + || (*(p + 1) != '\0')) + { + ffebad_start (FFEBAD_INTEGER_TOO_LARGE); + ffebad_here (0, ffelex_token_where_line (integer), + ffelex_token_where_column (integer)); + ffebad_finish (); + *val = 0; + return FALSE; + } + } + else if (x > FFETARGET_integerALMOST_BIG_OVERFLOW_BINARY) +#endif + { + ffebad_start (FFEBAD_INTEGER_TOO_LARGE); + ffebad_here (0, ffelex_token_where_line (integer), + ffelex_token_where_column (integer)); + ffebad_finish (); + *val = 0; + return FALSE; + } + x = (x << 1) + c; + c = *(++p); + }; + + if (bad_digit) + { + ffebad_start (FFEBAD_INVALID_BINARY_DIGIT); + ffebad_here (0, ffelex_token_where_line (integer), + ffelex_token_where_column (integer)); + ffebad_finish (); + } + + *val = x; + return !bad_digit; +} + +/* ffetarget_integerhex -- Convert token to a hex integer + + ffetarget_integerhex x; + if (ffetarget_integerdefault_8(&x,integer_token)) + // conversion ok. + + Token use count not affected overall. */ + +bool +ffetarget_integerhex (ffetargetIntegerDefault *val, ffelexToken integer) +{ + ffetargetIntegerDefault x; + char *p; + char c; + bool bad_digit; + + assert ((ffelex_token_type (integer) == FFELEX_typeNAME) + || (ffelex_token_type (integer) == FFELEX_typeNUMBER)); + + p = ffelex_token_text (integer); + x = 0; + + /* Skip past leading zeros. */ + + while (((c = *p) != '\0') && (c == '0')) + ++p; + + /* Interpret rest of number. */ + + bad_digit = FALSE; + while (c != '\0') + { + if ((c >= 'A') && (c <= 'F')) + c = c - 'A' + 10; + else if ((c >= 'a') && (c <= 'f')) + c = c - 'a' + 10; + else if ((c >= '0') && (c <= '9')) + c -= '0'; + else + { + bad_digit = TRUE; + c = 0; + } + +#if 0 /* Don't complain about signed overflow; just + unsigned overflow. */ + if ((x == FFETARGET_integerALMOST_BIG_OVERFLOW_HEX) + && (c == FFETARGET_integerFINISH_BIG_OVERFLOW_HEX) + && (*(p + 1) == '\0')) + { + *val = FFETARGET_integerBIG_OVERFLOW_HEX; + return TRUE; + } + else +#endif +#if FFETARGET_integerFINISH_BIG_OVERFLOW_HEX == 0 + if (x >= FFETARGET_integerALMOST_BIG_OVERFLOW_HEX) +#else + if (x == FFETARGET_integerALMOST_BIG_OVERFLOW_HEX) + { + if ((c > FFETARGET_integerFINISH_BIG_OVERFLOW_HEX) + || (*(p + 1) != '\0')) + { + ffebad_start (FFEBAD_INTEGER_TOO_LARGE); + ffebad_here (0, ffelex_token_where_line (integer), + ffelex_token_where_column (integer)); + ffebad_finish (); + *val = 0; + return FALSE; + } + } + else if (x > FFETARGET_integerALMOST_BIG_OVERFLOW_HEX) +#endif + { + ffebad_start (FFEBAD_INTEGER_TOO_LARGE); + ffebad_here (0, ffelex_token_where_line (integer), + ffelex_token_where_column (integer)); + ffebad_finish (); + *val = 0; + return FALSE; + } + x = (x << 4) + c; + c = *(++p); + }; + + if (bad_digit) + { + ffebad_start (FFEBAD_INVALID_HEX_DIGIT); + ffebad_here (0, ffelex_token_where_line (integer), + ffelex_token_where_column (integer)); + ffebad_finish (); + } + + *val = x; + return !bad_digit; +} + +/* ffetarget_integeroctal -- Convert token to an octal integer + + ffetarget_integeroctal x; + if (ffetarget_integerdefault_8(&x,integer_token)) + // conversion ok. + + Token use count not affected overall. */ + +bool +ffetarget_integeroctal (ffetargetIntegerDefault *val, ffelexToken integer) +{ + ffetargetIntegerDefault x; + char *p; + char c; + bool bad_digit; + + assert ((ffelex_token_type (integer) == FFELEX_typeNAME) + || (ffelex_token_type (integer) == FFELEX_typeNUMBER)); + + p = ffelex_token_text (integer); + x = 0; + + /* Skip past leading zeros. */ + + while (((c = *p) != '\0') && (c == '0')) + ++p; + + /* Interpret rest of number. */ + + bad_digit = FALSE; + while (c != '\0') + { + if ((c >= '0') && (c <= '7')) + c -= '0'; + else + { + bad_digit = TRUE; + c = 0; + } + +#if 0 /* Don't complain about signed overflow; just + unsigned overflow. */ + if ((x == FFETARGET_integerALMOST_BIG_OVERFLOW_OCTAL) + && (c == FFETARGET_integerFINISH_BIG_OVERFLOW_OCTAL) + && (*(p + 1) == '\0')) + { + *val = FFETARGET_integerBIG_OVERFLOW_OCTAL; + return TRUE; + } + else +#endif +#if FFETARGET_integerFINISH_BIG_OVERFLOW_OCTAL == 0 + if (x >= FFETARGET_integerALMOST_BIG_OVERFLOW_OCTAL) +#else + if (x == FFETARGET_integerALMOST_BIG_OVERFLOW_OCTAL) + { + if ((c > FFETARGET_integerFINISH_BIG_OVERFLOW_OCTAL) + || (*(p + 1) != '\0')) + { + ffebad_start (FFEBAD_INTEGER_TOO_LARGE); + ffebad_here (0, ffelex_token_where_line (integer), + ffelex_token_where_column (integer)); + ffebad_finish (); + *val = 0; + return FALSE; + } + } + else if (x > FFETARGET_integerALMOST_BIG_OVERFLOW_OCTAL) +#endif + { + ffebad_start (FFEBAD_INTEGER_TOO_LARGE); + ffebad_here (0, ffelex_token_where_line (integer), + ffelex_token_where_column (integer)); + ffebad_finish (); + *val = 0; + return FALSE; + } + x = (x << 3) + c; + c = *(++p); + }; + + if (bad_digit) + { + ffebad_start (FFEBAD_INVALID_OCTAL_DIGIT); + ffebad_here (0, ffelex_token_where_line (integer), + ffelex_token_where_column (integer)); + ffebad_finish (); + } + + *val = x; + return !bad_digit; +} + +/* ffetarget_multiply_complex1 -- Multiply function + + See prototype. */ + +#if FFETARGET_okCOMPLEX1 +ffebad +ffetarget_multiply_complex1 (ffetargetComplex1 *res, ffetargetComplex1 l, + ffetargetComplex1 r) +{ + ffebad bad; + ffetargetReal1 tmp1, tmp2; + + bad = ffetarget_multiply_real1 (&tmp1, l.real, r.real); + if (bad != FFEBAD) + return bad; + bad = ffetarget_multiply_real1 (&tmp2, l.imaginary, r.imaginary); + if (bad != FFEBAD) + return bad; + bad = ffetarget_subtract_real1 (&res->real, tmp1, tmp2); + if (bad != FFEBAD) + return bad; + bad = ffetarget_multiply_real1 (&tmp1, l.imaginary, r.real); + if (bad != FFEBAD) + return bad; + bad = ffetarget_multiply_real1 (&tmp2, l.real, r.imaginary); + if (bad != FFEBAD) + return bad; + bad = ffetarget_add_real1 (&res->imaginary, tmp1, tmp2); + + return bad; +} + +#endif +/* ffetarget_multiply_complex2 -- Multiply function + + See prototype. */ + +#if FFETARGET_okCOMPLEX2 +ffebad +ffetarget_multiply_complex2 (ffetargetComplex2 *res, ffetargetComplex2 l, + ffetargetComplex2 r) +{ + ffebad bad; + ffetargetReal2 tmp1, tmp2; + + bad = ffetarget_multiply_real2 (&tmp1, l.real, r.real); + if (bad != FFEBAD) + return bad; + bad = ffetarget_multiply_real2 (&tmp2, l.imaginary, r.imaginary); + if (bad != FFEBAD) + return bad; + bad = ffetarget_subtract_real2 (&res->real, tmp1, tmp2); + if (bad != FFEBAD) + return bad; + bad = ffetarget_multiply_real2 (&tmp1, l.imaginary, r.real); + if (bad != FFEBAD) + return bad; + bad = ffetarget_multiply_real2 (&tmp2, l.real, r.imaginary); + if (bad != FFEBAD) + return bad; + bad = ffetarget_add_real2 (&res->imaginary, tmp1, tmp2); + + return bad; +} + +#endif +/* ffetarget_power_complexdefault_integerdefault -- Power function + + See prototype. */ + +ffebad +ffetarget_power_complexdefault_integerdefault (ffetargetComplexDefault *res, + ffetargetComplexDefault l, + ffetargetIntegerDefault r) +{ + ffebad bad; + ffetargetRealDefault tmp; + ffetargetRealDefault tmp1; + ffetargetRealDefault tmp2; + ffetargetRealDefault two; + + if (ffetarget_iszero_real1 (l.real) + && ffetarget_iszero_real1 (l.imaginary)) + { + ffetarget_real1_zero (&res->real); + ffetarget_real1_zero (&res->imaginary); + return FFEBAD; + } + + if (r == 0) + { + ffetarget_real1_one (&res->real); + ffetarget_real1_zero (&res->imaginary); + return FFEBAD; + } + + if (r < 0) + { + r = -r; + bad = ffetarget_multiply_real1 (&tmp1, l.real, l.real); + if (bad != FFEBAD) + return bad; + bad = ffetarget_multiply_real1 (&tmp2, l.imaginary, l.imaginary); + if (bad != FFEBAD) + return bad; + bad = ffetarget_add_real1 (&tmp, tmp1, tmp2); + if (bad != FFEBAD) + return bad; + bad = ffetarget_divide_real1 (&l.real, l.real, tmp); + if (bad != FFEBAD) + return bad; + bad = ffetarget_divide_real1 (&l.imaginary, l.imaginary, tmp); + if (bad != FFEBAD) + return bad; + bad = ffetarget_uminus_real1 (&l.imaginary, l.imaginary); + if (bad != FFEBAD) + return bad; + } + + ffetarget_real1_two (&two); + + while ((r & 1) == 0) + { + bad = ffetarget_multiply_real1 (&tmp1, l.real, l.real); + if (bad != FFEBAD) + return bad; + bad = ffetarget_multiply_real1 (&tmp2, l.imaginary, l.imaginary); + if (bad != FFEBAD) + return bad; + bad = ffetarget_subtract_real1 (&tmp, tmp1, tmp2); + if (bad != FFEBAD) + return bad; + bad = ffetarget_multiply_real1 (&l.imaginary, l.real, l.imaginary); + if (bad != FFEBAD) + return bad; + bad = ffetarget_multiply_real1 (&l.imaginary, l.imaginary, two); + if (bad != FFEBAD) + return bad; + l.real = tmp; + r >>= 1; + } + + *res = l; + r >>= 1; + + while (r != 0) + { + bad = ffetarget_multiply_real1 (&tmp1, l.real, l.real); + if (bad != FFEBAD) + return bad; + bad = ffetarget_multiply_real1 (&tmp2, l.imaginary, l.imaginary); + if (bad != FFEBAD) + return bad; + bad = ffetarget_subtract_real1 (&tmp, tmp1, tmp2); + if (bad != FFEBAD) + return bad; + bad = ffetarget_multiply_real1 (&l.imaginary, l.real, l.imaginary); + if (bad != FFEBAD) + return bad; + bad = ffetarget_multiply_real1 (&l.imaginary, l.imaginary, two); + if (bad != FFEBAD) + return bad; + l.real = tmp; + if ((r & 1) == 1) + { + bad = ffetarget_multiply_real1 (&tmp1, res->real, l.real); + if (bad != FFEBAD) + return bad; + bad = ffetarget_multiply_real1 (&tmp2, res->imaginary, + l.imaginary); + if (bad != FFEBAD) + return bad; + bad = ffetarget_subtract_real1 (&tmp, tmp1, tmp2); + if (bad != FFEBAD) + return bad; + bad = ffetarget_multiply_real1 (&tmp1, res->imaginary, l.real); + if (bad != FFEBAD) + return bad; + bad = ffetarget_multiply_real1 (&tmp2, res->real, l.imaginary); + if (bad != FFEBAD) + return bad; + bad = ffetarget_add_real1 (&res->imaginary, tmp1, tmp2); + if (bad != FFEBAD) + return bad; + res->real = tmp; + } + r >>= 1; + } + + return FFEBAD; +} + +/* ffetarget_power_complexdouble_integerdefault -- Power function + + See prototype. */ + +#if FFETARGET_okCOMPLEXDOUBLE +ffebad +ffetarget_power_complexdouble_integerdefault (ffetargetComplexDouble *res, + ffetargetComplexDouble l, ffetargetIntegerDefault r) +{ + ffebad bad; + ffetargetRealDouble tmp; + ffetargetRealDouble tmp1; + ffetargetRealDouble tmp2; + ffetargetRealDouble two; + + if (ffetarget_iszero_real2 (l.real) + && ffetarget_iszero_real2 (l.imaginary)) + { + ffetarget_real2_zero (&res->real); + ffetarget_real2_zero (&res->imaginary); + return FFEBAD; + } + + if (r == 0) + { + ffetarget_real2_one (&res->real); + ffetarget_real2_zero (&res->imaginary); + return FFEBAD; + } + + if (r < 0) + { + r = -r; + bad = ffetarget_multiply_real2 (&tmp1, l.real, l.real); + if (bad != FFEBAD) + return bad; + bad = ffetarget_multiply_real2 (&tmp2, l.imaginary, l.imaginary); + if (bad != FFEBAD) + return bad; + bad = ffetarget_add_real2 (&tmp, tmp1, tmp2); + if (bad != FFEBAD) + return bad; + bad = ffetarget_divide_real2 (&l.real, l.real, tmp); + if (bad != FFEBAD) + return bad; + bad = ffetarget_divide_real2 (&l.imaginary, l.imaginary, tmp); + if (bad != FFEBAD) + return bad; + bad = ffetarget_uminus_real2 (&l.imaginary, l.imaginary); + if (bad != FFEBAD) + return bad; + } + + ffetarget_real2_two (&two); + + while ((r & 1) == 0) + { + bad = ffetarget_multiply_real2 (&tmp1, l.real, l.real); + if (bad != FFEBAD) + return bad; + bad = ffetarget_multiply_real2 (&tmp2, l.imaginary, l.imaginary); + if (bad != FFEBAD) + return bad; + bad = ffetarget_subtract_real2 (&tmp, tmp1, tmp2); + if (bad != FFEBAD) + return bad; + bad = ffetarget_multiply_real2 (&l.imaginary, l.real, l.imaginary); + if (bad != FFEBAD) + return bad; + bad = ffetarget_multiply_real2 (&l.imaginary, l.imaginary, two); + if (bad != FFEBAD) + return bad; + l.real = tmp; + r >>= 1; + } + + *res = l; + r >>= 1; + + while (r != 0) + { + bad = ffetarget_multiply_real2 (&tmp1, l.real, l.real); + if (bad != FFEBAD) + return bad; + bad = ffetarget_multiply_real2 (&tmp2, l.imaginary, l.imaginary); + if (bad != FFEBAD) + return bad; + bad = ffetarget_subtract_real2 (&tmp, tmp1, tmp2); + if (bad != FFEBAD) + return bad; + bad = ffetarget_multiply_real2 (&l.imaginary, l.real, l.imaginary); + if (bad != FFEBAD) + return bad; + bad = ffetarget_multiply_real2 (&l.imaginary, l.imaginary, two); + if (bad != FFEBAD) + return bad; + l.real = tmp; + if ((r & 1) == 1) + { + bad = ffetarget_multiply_real2 (&tmp1, res->real, l.real); + if (bad != FFEBAD) + return bad; + bad = ffetarget_multiply_real2 (&tmp2, res->imaginary, + l.imaginary); + if (bad != FFEBAD) + return bad; + bad = ffetarget_subtract_real2 (&tmp, tmp1, tmp2); + if (bad != FFEBAD) + return bad; + bad = ffetarget_multiply_real2 (&tmp1, res->imaginary, l.real); + if (bad != FFEBAD) + return bad; + bad = ffetarget_multiply_real2 (&tmp2, res->real, l.imaginary); + if (bad != FFEBAD) + return bad; + bad = ffetarget_add_real2 (&res->imaginary, tmp1, tmp2); + if (bad != FFEBAD) + return bad; + res->real = tmp; + } + r >>= 1; + } + + return FFEBAD; +} + +#endif +/* ffetarget_power_integerdefault_integerdefault -- Power function + + See prototype. */ + +ffebad +ffetarget_power_integerdefault_integerdefault (ffetargetIntegerDefault *res, + ffetargetIntegerDefault l, ffetargetIntegerDefault r) +{ + if (l == 0) + { + *res = 0; + return FFEBAD; + } + + if (r == 0) + { + *res = 1; + return FFEBAD; + } + + if (r < 0) + { + if (l == 1) + *res = 1; + else if (l == 0) + *res = 1; + else if (l == -1) + *res = ((-r) & 1) == 0 ? 1 : -1; + else + *res = 0; + return FFEBAD; + } + + while ((r & 1) == 0) + { + l *= l; + r >>= 1; + } + + *res = l; + r >>= 1; + + while (r != 0) + { + l *= l; + if ((r & 1) == 1) + *res *= l; + r >>= 1; + } + + return FFEBAD; +} + +/* ffetarget_power_realdefault_integerdefault -- Power function + + See prototype. */ + +ffebad +ffetarget_power_realdefault_integerdefault (ffetargetRealDefault *res, + ffetargetRealDefault l, ffetargetIntegerDefault r) +{ + ffebad bad; + + if (ffetarget_iszero_real1 (l)) + { + ffetarget_real1_zero (res); + return FFEBAD; + } + + if (r == 0) + { + ffetarget_real1_one (res); + return FFEBAD; + } + + if (r < 0) + { + ffetargetRealDefault one; + + ffetarget_real1_one (&one); + r = -r; + bad = ffetarget_divide_real1 (&l, one, l); + if (bad != FFEBAD) + return bad; + } + + while ((r & 1) == 0) + { + bad = ffetarget_multiply_real1 (&l, l, l); + if (bad != FFEBAD) + return bad; + r >>= 1; + } + + *res = l; + r >>= 1; + + while (r != 0) + { + bad = ffetarget_multiply_real1 (&l, l, l); + if (bad != FFEBAD) + return bad; + if ((r & 1) == 1) + { + bad = ffetarget_multiply_real1 (res, *res, l); + if (bad != FFEBAD) + return bad; + } + r >>= 1; + } + + return FFEBAD; +} + +/* ffetarget_power_realdouble_integerdefault -- Power function + + See prototype. */ + +ffebad +ffetarget_power_realdouble_integerdefault (ffetargetRealDouble *res, + ffetargetRealDouble l, + ffetargetIntegerDefault r) +{ + ffebad bad; + + if (ffetarget_iszero_real2 (l)) + { + ffetarget_real2_zero (res); + return FFEBAD; + } + + if (r == 0) + { + ffetarget_real2_one (res); + return FFEBAD; + } + + if (r < 0) + { + ffetargetRealDouble one; + + ffetarget_real2_one (&one); + r = -r; + bad = ffetarget_divide_real2 (&l, one, l); + if (bad != FFEBAD) + return bad; + } + + while ((r & 1) == 0) + { + bad = ffetarget_multiply_real2 (&l, l, l); + if (bad != FFEBAD) + return bad; + r >>= 1; + } + + *res = l; + r >>= 1; + + while (r != 0) + { + bad = ffetarget_multiply_real2 (&l, l, l); + if (bad != FFEBAD) + return bad; + if ((r & 1) == 1) + { + bad = ffetarget_multiply_real2 (res, *res, l); + if (bad != FFEBAD) + return bad; + } + r >>= 1; + } + + return FFEBAD; +} + +/* ffetarget_print_binary -- Output typeless binary integer + + ffetargetTypeless val; + ffetarget_typeless_binary(dmpout,val); */ + +void +ffetarget_print_binary (FILE *f, ffetargetTypeless value) +{ + char *p; + char digits[sizeof (value) * CHAR_BIT + 1]; + + if (f == NULL) + f = dmpout; + + p = &digits[ARRAY_SIZE (digits) - 1]; + *p = '\0'; + do + { + *--p = (value & 1) + '0'; + value >>= 1; + } while (value == 0); + + fputs (p, f); +} + +/* ffetarget_print_character1 -- Output character string + + ffetargetCharacter1 val; + ffetarget_print_character1(dmpout,val); */ + +void +ffetarget_print_character1 (FILE *f, ffetargetCharacter1 value) +{ + unsigned char *p; + ffetargetCharacterSize i; + + fputc ('\'', dmpout); + for (i = 0, p = value.text; i < value.length; ++i, ++p) + ffetarget_print_char_ (f, *p); + fputc ('\'', dmpout); +} + +/* ffetarget_print_hollerith -- Output hollerith string + + ffetargetHollerith val; + ffetarget_print_hollerith(dmpout,val); */ + +void +ffetarget_print_hollerith (FILE *f, ffetargetHollerith value) +{ + unsigned char *p; + ffetargetHollerithSize i; + + fputc ('\'', dmpout); + for (i = 0, p = value.text; i < value.length; ++i, ++p) + ffetarget_print_char_ (f, *p); + fputc ('\'', dmpout); +} + +/* ffetarget_print_octal -- Output typeless octal integer + + ffetargetTypeless val; + ffetarget_print_octal(dmpout,val); */ + +void +ffetarget_print_octal (FILE *f, ffetargetTypeless value) +{ + char *p; + char digits[sizeof (value) * CHAR_BIT / 3 + 1]; + + if (f == NULL) + f = dmpout; + + p = &digits[ARRAY_SIZE (digits) - 3]; + *p = '\0'; + do + { + *--p = (value & 3) + '0'; + value >>= 3; + } while (value == 0); + + fputs (p, f); +} + +/* ffetarget_print_hex -- Output typeless hex integer + + ffetargetTypeless val; + ffetarget_print_hex(dmpout,val); */ + +void +ffetarget_print_hex (FILE *f, ffetargetTypeless value) +{ + char *p; + char digits[sizeof (value) * CHAR_BIT / 4 + 1]; + static char hexdigits[16] = "0123456789ABCDEF"; + + if (f == NULL) + f = dmpout; + + p = &digits[ARRAY_SIZE (digits) - 3]; + *p = '\0'; + do + { + *--p = hexdigits[value & 4]; + value >>= 4; + } while (value == 0); + + fputs (p, f); +} + +/* ffetarget_real1 -- Convert token to a single-precision real number + + See prototype. + + Pass NULL for any token not provided by the user, but a valid Fortran + real number must be provided somehow. For example, it is ok for + exponent_sign_token and exponent_digits_token to be NULL as long as + exponent_token not only starts with "E" or "e" but also contains at least + one digit following it. Token use counts not affected overall. */ + +#if FFETARGET_okREAL1 +bool +ffetarget_real1 (ffetargetReal1 *value, ffelexToken integer, + ffelexToken decimal, ffelexToken fraction, + ffelexToken exponent, ffelexToken exponent_sign, + ffelexToken exponent_digits) +{ + size_t sz = 1; /* Allow room for '\0' byte at end. */ + char *ptr = &ffetarget_string_[0]; + char *p = ptr; + char *q; + +#define dotok(x) if (x != NULL) ++sz; +#define dotoktxt(x) if (x != NULL) sz += ffelex_token_length(x) + + dotoktxt (integer); + dotok (decimal); + dotoktxt (fraction); + dotoktxt (exponent); + dotok (exponent_sign); + dotoktxt (exponent_digits); + +#undef dotok +#undef dotoktxt + + if (sz > ARRAY_SIZE (ffetarget_string_)) + p = ptr = (char *) malloc_new_ks (malloc_pool_image (), "ffetarget_real1", + sz); + +#define dotoktxt(x) if (x != NULL) \ + { \ + for (q = ffelex_token_text(x); *q != '\0'; ++q) \ + *p++ = *q; \ + } + + dotoktxt (integer); + + if (decimal != NULL) + *p++ = '.'; + + dotoktxt (fraction); + dotoktxt (exponent); + + if (exponent_sign != NULL) + if (ffelex_token_type (exponent_sign) == FFELEX_typePLUS) + *p++ = '+'; + else + { + assert (ffelex_token_type (exponent_sign) == FFELEX_typeMINUS); + *p++ = '-'; + } + + dotoktxt (exponent_digits); + +#undef dotoktxt + + *p = '\0'; + + ffetarget_make_real1 (value, + FFETARGET_ATOF_ (ptr, + SFmode)); + + if (sz > ARRAY_SIZE (ffetarget_string_)) + malloc_kill_ks (malloc_pool_image (), ptr, sz); + + return TRUE; +} + +#endif +/* ffetarget_real2 -- Convert token to a single-precision real number + + See prototype. + + Pass NULL for any token not provided by the user, but a valid Fortran + real number must be provided somehow. For example, it is ok for + exponent_sign_token and exponent_digits_token to be NULL as long as + exponent_token not only starts with "E" or "e" but also contains at least + one digit following it. Token use counts not affected overall. */ + +#if FFETARGET_okREAL2 +bool +ffetarget_real2 (ffetargetReal2 *value, ffelexToken integer, + ffelexToken decimal, ffelexToken fraction, + ffelexToken exponent, ffelexToken exponent_sign, + ffelexToken exponent_digits) +{ + size_t sz = 1; /* Allow room for '\0' byte at end. */ + char *ptr = &ffetarget_string_[0]; + char *p = ptr; + char *q; + +#define dotok(x) if (x != NULL) ++sz; +#define dotoktxt(x) if (x != NULL) sz += ffelex_token_length(x) + + dotoktxt (integer); + dotok (decimal); + dotoktxt (fraction); + dotoktxt (exponent); + dotok (exponent_sign); + dotoktxt (exponent_digits); + +#undef dotok +#undef dotoktxt + + if (sz > ARRAY_SIZE (ffetarget_string_)) + p = ptr = (char *) malloc_new_ks (malloc_pool_image (), "ffetarget_real1", sz); + +#define dotoktxt(x) if (x != NULL) \ + { \ + for (q = ffelex_token_text(x); *q != '\0'; ++q) \ + *p++ = *q; \ + } +#define dotoktxtexp(x) if (x != NULL) \ + { \ + *p++ = 'E'; \ + for (q = ffelex_token_text(x) + 1; *q != '\0'; ++q) \ + *p++ = *q; \ + } + + dotoktxt (integer); + + if (decimal != NULL) + *p++ = '.'; + + dotoktxt (fraction); + dotoktxtexp (exponent); + + if (exponent_sign != NULL) + if (ffelex_token_type (exponent_sign) == FFELEX_typePLUS) + *p++ = '+'; + else + { + assert (ffelex_token_type (exponent_sign) == FFELEX_typeMINUS); + *p++ = '-'; + } + + dotoktxt (exponent_digits); + +#undef dotoktxt + + *p = '\0'; + + ffetarget_make_real2 (value, + FFETARGET_ATOF_ (ptr, + DFmode)); + + if (sz > ARRAY_SIZE (ffetarget_string_)) + malloc_kill_ks (malloc_pool_image (), ptr, sz); + + return TRUE; +} + +#endif +bool +ffetarget_typeless_binary (ffetargetTypeless *xvalue, ffelexToken token) +{ + char *p; + char c; + ffetargetTypeless value = 0; + ffetargetTypeless new_value = 0; + bool bad_digit = FALSE; + bool overflow = FALSE; + + p = ffelex_token_text (token); + + for (c = *p; c != '\0'; c = *++p) + { + new_value <<= 1; + if ((new_value >> 1) != value) + overflow = TRUE; + if (isdigit (c)) + new_value += c - '0'; + else + bad_digit = TRUE; + value = new_value; + } + + if (bad_digit) + { + ffebad_start (FFEBAD_INVALID_TYPELESS_BINARY_DIGIT); + ffebad_here (0, ffelex_token_where_line (token), + ffelex_token_where_column (token)); + ffebad_finish (); + } + else if (overflow) + { + ffebad_start (FFEBAD_TYPELESS_OVERFLOW); + ffebad_here (0, ffelex_token_where_line (token), + ffelex_token_where_column (token)); + ffebad_finish (); + } + + *xvalue = value; + + return !bad_digit && !overflow; +} + +bool +ffetarget_typeless_octal (ffetargetTypeless *xvalue, ffelexToken token) +{ + char *p; + char c; + ffetargetTypeless value = 0; + ffetargetTypeless new_value = 0; + bool bad_digit = FALSE; + bool overflow = FALSE; + + p = ffelex_token_text (token); + + for (c = *p; c != '\0'; c = *++p) + { + new_value <<= 3; + if ((new_value >> 3) != value) + overflow = TRUE; + if (isdigit (c)) + new_value += c - '0'; + else + bad_digit = TRUE; + value = new_value; + } + + if (bad_digit) + { + ffebad_start (FFEBAD_INVALID_TYPELESS_OCTAL_DIGIT); + ffebad_here (0, ffelex_token_where_line (token), + ffelex_token_where_column (token)); + ffebad_finish (); + } + else if (overflow) + { + ffebad_start (FFEBAD_TYPELESS_OVERFLOW); + ffebad_here (0, ffelex_token_where_line (token), + ffelex_token_where_column (token)); + ffebad_finish (); + } + + *xvalue = value; + + return !bad_digit && !overflow; +} + +bool +ffetarget_typeless_hex (ffetargetTypeless *xvalue, ffelexToken token) +{ + char *p; + char c; + ffetargetTypeless value = 0; + ffetargetTypeless new_value = 0; + bool bad_digit = FALSE; + bool overflow = FALSE; + + p = ffelex_token_text (token); + + for (c = *p; c != '\0'; c = *++p) + { + new_value <<= 4; + if ((new_value >> 4) != value) + overflow = TRUE; + if (isdigit (c)) + new_value += c - '0'; + else if ((c >= 'A') && (c <= 'F')) + new_value += c - 'A' + 10; + else if ((c >= 'a') && (c <= 'f')) + new_value += c - 'a' + 10; + else + bad_digit = TRUE; + value = new_value; + } + + if (bad_digit) + { + ffebad_start (FFEBAD_INVALID_TYPELESS_HEX_DIGIT); + ffebad_here (0, ffelex_token_where_line (token), + ffelex_token_where_column (token)); + ffebad_finish (); + } + else if (overflow) + { + ffebad_start (FFEBAD_TYPELESS_OVERFLOW); + ffebad_here (0, ffelex_token_where_line (token), + ffelex_token_where_column (token)); + ffebad_finish (); + } + + *xvalue = value; + + return !bad_digit && !overflow; +} + +void +ffetarget_verify_character1 (mallocPool pool, ffetargetCharacter1 val) +{ + if (val.length != 0) + malloc_verify_kp (pool, val.text, val.length); +} + +/* This is like memcpy. It is needed because some systems' header files + don't declare memcpy as a function but instead + "#define memcpy(to,from,len) something". */ + +void * +ffetarget_memcpy_ (void *dst, void *src, size_t len) +{ + return (void *) memcpy (dst, src, len); +} + +/* ffetarget_num_digits_ -- Determine number of non-space characters in token + + ffetarget_num_digits_(token); + + All non-spaces are assumed to be binary, octal, or hex digits. */ + +int +ffetarget_num_digits_ (ffelexToken token) +{ + int i; + char *c; + + switch (ffelex_token_type (token)) + { + case FFELEX_typeNAME: + case FFELEX_typeNUMBER: + return ffelex_token_length (token); + + case FFELEX_typeCHARACTER: + i = 0; + for (c = ffelex_token_text (token); *c != '\0'; ++c) + { + if (*c != ' ') + ++i; + } + return i; + + default: + assert ("weird token" == NULL); + return 1; + } +} |