/* target.c -- Implementation File (module.c template V1.0) Copyright (C) 1995-1998 Free Software Foundation, Inc. Contributed by James Craig Burley. 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 "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)) 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 (alignment > 0); assert (*updated_alignment > 0); 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; if (offset < 0) /* De-negatize offset, since % wouldn't do the expected thing. */ offset = alignment - ((- offset) % alignment); 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; if (offset < 0) /* De-negatize offset, since % wouldn't do the expected thing. */ offset = ua - ((- offset) % ua); /* Set to largest value. */ min_pad = ~(ffetargetAlign) 0; /* 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) { /* This code is similar to the "easy case" code above. */ if (m > um) pad = ua - (m - um); else pad = um - m; pad = (offset + pad) % ua; if (pad == 0) { /* A zero pad means we've got something useful. */ *updated_alignment = ua; *updated_modulo = um; return 0; } pad = ua - pad; if (pad < min_pad) { /* New minimum padding value. */ min_pad = pad; min_m = um; } } } *updated_alignment = ua; *updated_modulo = min_m; return min_pad; } /* Always append a null byte to the end, in case this is wanted in a special case such as passing a string as a FORMAT or %REF. Done to save a bit of hassle, nothing more, but it's a kludge anyway, because it isn't a "feature" that is self-documenting. Use the string "FFETARGET-NULL-KLUDGE" to flag anyplace you use this feature in the code. */ #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 + 1); memcpy (val->text, ffelex_token_text (character), val->length); val->text[val->length] = '\0'; } 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 Always append a null byte to the end, in case this is wanted in a special case such as passing a string as a FORMAT or %REF. Done to save a bit of hassle, nothing more, but it's a kludge anyway, because it isn't a "feature" that is self-documenting. Use the string "FFETARGET-NULL-KLUDGE" to flag anyplace you use this feature in the code. */ #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 + 1); if (l.length != 0) memcpy (res->text, l.text, l.length); if (r.length != 0) memcpy (res->text + l.length, r.text, r.length); res->text[*len] = '\0'; } 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 (const 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 Always append a null byte to the end, in case this is wanted in a special case such as passing a string as a FORMAT or %REF. Done to save a bit of hassle, nothing more, but it's a kludge anyway, because it isn't a "feature" that is self-documenting. Use the string "FFETARGET-NULL-KLUDGE" to flag anyplace you use this feature in the code. */ #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 + 1); memcpy (res->text, l.text + first - 1, *len); res->text[*len] = '\0'; } 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; } /* Always append a null byte to the end, in case this is wanted in a special case such as passing a string as a FORMAT or %REF. Done to save a bit of hassle, nothing more, but it's a kludge anyway, because it isn't a "feature" that is self-documenting. Use the string "FFETARGET-NULL-KLUDGE" to flag anyplace you use this feature in the code. */ #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 + 1); 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); } res->text[size] = '\0'; } return FFEBAD; } #endif /* Always append a null byte to the end, in case this is wanted in a special case such as passing a string as a FORMAT or %REF. Done to save a bit of hassle, nothing more, but it's a kludge anyway, because it isn't a "feature" that is self-documenting. Use the string "FFETARGET-NULL-KLUDGE" to flag anyplace you use this feature in the code. */ #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 + 1); res->text[size] = '\0'; 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_integer4 -- Raw conversion. Always append a null byte to the end, in case this is wanted in a special case such as passing a string as a FORMAT or %REF. Done to save a bit of hassle, nothing more, but it's a kludge anyway, because it isn't a "feature" that is self-documenting. Use the string "FFETARGET-NULL-KLUDGE" to flag anyplace you use this feature in the code. */ #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 + 1); res->text[size] = '\0'; 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_logical4 -- Raw conversion. Always append a null byte to the end, in case this is wanted in a special case such as passing a string as a FORMAT or %REF. Done to save a bit of hassle, nothing more, but it's a kludge anyway, because it isn't a "feature" that is self-documenting. Use the string "FFETARGET-NULL-KLUDGE" to flag anyplace you use this feature in the code. */ #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 + 1); res->text[size] = '\0'; 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. Always append a null byte to the end, in case this is wanted in a special case such as passing a string as a FORMAT or %REF. Done to save a bit of hassle, nothing more, but it's a kludge anyway, because it isn't a "feature" that is self-documenting. Use the string "FFETARGET-NULL-KLUDGE" to flag anyplace you use this feature in the code. */ #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 + 1); res->text[size] = '\0'; 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 Always append a null byte to the end, in case this is wanted in a special case such as passing a string as a FORMAT or %REF. Done to save a bit of hassle, nothing more, but it's a kludge anyway, because it isn't a "feature" that is self-documenting. Use the string "FFETARGET-NULL-KLUDGE" to flag anyplace you use this feature in the code. */ bool ffetarget_hollerith (ffetargetHollerith *val, ffelexToken integer, mallocPool pool) { val->length = ffelex_token_length (integer); val->text = malloc_new_kp (pool, "ffetargetHollerith", val->length + 1); memcpy (val->text, ffelex_token_text (integer), val->length); val->text[val->length] = '\0'; 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; } }