| /* target.c -- Implementation File (module.c template V1.0) |
| Copyright (C) 1995-1998 Free Software Foundation, Inc. |
| Contributed by James Craig Burley (burley@gnu.org). |
| |
| 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 (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; |
| } |
| } |