diff options
Diffstat (limited to 'contrib/gcc/f/target.c')
| -rw-r--r-- | contrib/gcc/f/target.c | 2564 |
1 files changed, 0 insertions, 2564 deletions
diff --git a/contrib/gcc/f/target.c b/contrib/gcc/f/target.c deleted file mode 100644 index 5712bdd798ab..000000000000 --- a/contrib/gcc/f/target.c +++ /dev/null @@ -1,2564 +0,0 @@ -/* 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; - } -} |