-
Notifications
You must be signed in to change notification settings - Fork 51
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
Merge pull request #370 from olebole/fix-f2c
Fix problems with using f2c.e/f77.sh on plain Fortran files
- Loading branch information
Showing
30 changed files
with
4,106 additions
and
1,004 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -1,6 +1,5 @@ | ||
| #include <stdio.h> | ||
| #include <string.h> | ||
| #include <stdlib.h> | ||
| #include "arith.h" | ||
|
|
||
| #define TYSHORT 2 | ||
|
|
@@ -58,15 +57,6 @@ static unsigned Long rnan = RNAN, | |
|
|
||
| double _0 = 0.; | ||
|
|
||
| void unsupported_error() | ||
| { | ||
| fprintf(stderr,"Runtime Error: Your Architecture is not supported by the" | ||
| " -trapuv option of f2c\n"); | ||
| exit(-1); | ||
| } | ||
|
|
||
|
|
||
|
|
||
| void | ||
| #ifdef KR_headers | ||
| _uninit_f2c(x, type, len) void *x; int type; long len; | ||
|
|
@@ -188,8 +178,7 @@ ieee0(Void) | |
| } | ||
| #endif /* MSpc */ | ||
|
|
||
| /* What follows is for SGI IRIX only */ | ||
| #if defined(__mips) && defined(__sgi) /* must link with -lfpe */ | ||
| #ifdef __mips /* must link with -lfpe */ | ||
| #define IEEE0_done | ||
| /* code from Eric Grosse */ | ||
| #include <stdlib.h> | ||
|
|
@@ -240,155 +229,80 @@ ieee0(Void) | |
| _EN_UNDERFL|_EN_OVERFL|_EN_DIVZERO|_EN_INVALID, | ||
| ieeeuserhand,_ABORT_ON_ERROR,ieeeuserhand2); | ||
| } | ||
| #endif /* IRIX mips */ | ||
|
|
||
| /* | ||
| * The following is the preferred method but depends upon a GLIBC extension only | ||
| * to be found in GLIBC 2.2 or later. It is a GNU extension, not included in the | ||
| * C99 extensions which allow the FP status register to be examined in a platform | ||
| * independent way. It should be used if at all possible -- AFRB | ||
| */ | ||
|
|
||
|
|
||
| #if (defined(__GLIBC__)&& ( __GLIBC__>=2) && (__GLIBC_MINOR__>=2) ) | ||
| #define _GNU_SOURCE 1 | ||
| #define IEEE0_done | ||
| #include <fenv.h> | ||
| static void | ||
| ieee0(Void) | ||
|
|
||
| { | ||
| /* Clear all exception flags */ | ||
| if (fedisableexcept(FE_ALL_EXCEPT)==-1) | ||
| unsupported_error(); | ||
| if (feenableexcept(FE_DIVBYZERO|FE_INVALID|FE_OVERFLOW)==-1) | ||
| unsupported_error(); | ||
| } | ||
|
|
||
| #endif /* Glibc control */ | ||
| #endif /* mips */ | ||
|
|
||
| /* Many linux cases will be treated through GLIBC. Note that modern | ||
| * linux runs on many non-i86 plaforms and as a result the following code | ||
| * must be processor dependent rather than simply OS specific */ | ||
|
|
||
| #if (defined(__linux__)&&(!defined(IEEE0_done))) | ||
| #ifdef __linux__ | ||
| #define IEEE0_done | ||
| #include <fpu_control.h> | ||
|
|
||
| #include "fpu_control.h" | ||
|
|
||
| #ifdef __alpha__ | ||
| #ifndef USE_setfpucw | ||
| #define __setfpucw(x) __fpu_control = (x) | ||
| #endif | ||
| #endif | ||
|
|
||
| /* Not all versions of libc define _FPU_SETCW; | ||
| * * some only provide the __setfpucw() function. | ||
| * */ | ||
| #ifndef _FPU_SETCW | ||
| #define _FPU_SETCW(cw) __setfpucw(cw) | ||
| #endif | ||
|
|
||
| /* The exact set of flags we want to set in the FPU control word | ||
| * depends on the architecture. | ||
| * Note also that whether an exception is enabled or disabled when | ||
| * the _FPU_MASK_nn bit is set is architecture dependent! | ||
| * Enabled-when-set: M68k, ARM, MIPS, PowerPC | ||
| * Disabled-when-set: x86, Alpha | ||
| * The state we are after is: | ||
| * exceptions on division by zero, overflow and invalid operation. | ||
| */ | ||
|
|
||
|
|
||
| #ifdef __alpha__ | ||
| #ifndef USE_setfpucw | ||
| #define __setfpucw(x) __fpu_control = (x) | ||
| #endif | ||
| #endif | ||
|
|
||
|
|
||
| #ifndef _FPU_SETCW | ||
| #undef Can_use__setfpucw | ||
| #define Can_use__setfpucw | ||
| #endif | ||
|
|
||
| #undef RQD_FPU_MASK | ||
| #undef RQD_FPU_CLEAR_MASK | ||
|
|
||
| static void | ||
| ieee0(Void) | ||
| { | ||
| #if (defined(__mc68000__) || defined(__mc68020__) || defined(mc68020) || defined (__mc68k__)) | ||
| /* Reported 20010705 by Alan Bain <[email protected]> */ | ||
| /* Note that IEEE 754 IOP (illegal operation) */ | ||
| /* = Signaling NAN (SNAN) + operation error (OPERR). */ | ||
| #define RQD_FPU_STATE (_FPU_IEEE + _FPU_DOUBLE + _FPU_MASK_OPERR + \ | ||
| _FPU_MASK_DZ + _FPU_MASK_SNAN+_FPU_MASK_OVFL) | ||
| #define RQD_FPU_MASK (_FPU_MASK_OPERR+_FPU_MASK_DZ+_FPU_MASK_SNAN+_FPU_MASK_OVFL) | ||
| #ifdef Can_use__setfpucw | ||
| __setfpucw(_FPU_IEEE + _FPU_DOUBLE + _FPU_MASK_OPERR + _FPU_MASK_DZ + _FPU_MASK_SNAN+_FPU_MASK_OVFL); | ||
| #else | ||
| __fpu_control = _FPU_IEEE + _FPU_DOUBLE + _FPU_MASK_OPERR + _FPU_MASK_DZ + _FPU_MASK_SNAN+_FPU_MASK_OVFL; | ||
| _FPU_SETCW(__fpu_control); | ||
| #endif | ||
|
|
||
| #elif (defined(__powerpc__)||defined(_ARCH_PPC)||defined(_ARCH_PWR)) /* !__mc68k__ */ | ||
| /* The following is NOT a mistake -- the author of the fpu_control.h | ||
| * for the PPC has erroneously defined IEEE mode to turn on exceptions | ||
| * other than Inexact! Start from default then and turn on only the ones | ||
| * which we want*/ | ||
|
|
||
| /* I have changed _FPU_MASK_UM here to _FPU_MASK_ZM, because that is | ||
| * in line with all the other architectures specified here. -- AFRB | ||
| */ | ||
| #define RQD_FPU_STATE (_FPU_DEFAULT +_FPU_MASK_OM+_FPU_MASK_IM+_FPU_MASK_ZM) | ||
| #define RQD_FPU_MASK (_FPU_MASK_OM+_FPU_MASK_IM+_FPU_MASK_ZM) | ||
|
|
||
| #elif (defined(__arm__)) | ||
| /* On ARM too, IEEE implies all exceptions enabled. | ||
| * -- Peter Maydell <[email protected]> | ||
| * Unfortunately some version of ARMlinux don't include any | ||
| * flags in the fpu_control.h file | ||
| */ | ||
| #define RQD_FPU_STATE (_FPU_DEFAULT +_FPU_MASK_OM+_FPU_MASK_IM+_FPU_MASK_ZM) | ||
| #define RQD_FPU_MASK (_FPU_MASK_OM+_FPU_MASK_IM+_FPU_MASK_ZM) | ||
|
|
||
| #elif (defined(__mips__)) | ||
| /* And same again for MIPS; _FPU_IEEE => exceptions seems a common meme. | ||
| * * MIPS uses different MASK constant names, no idea why -- PMM | ||
| * */ | ||
| #define RQD_FPU_STATE (_FPU_DEFAULT +_FPU_MASK_O+_FPU_MASK_V+_FPU_MASK_Z) | ||
| #define RQD_FPU_MASK (_FPU_MASK_O+_FPU_MASK_V+_FPU_MASK_Z) | ||
|
|
||
| #elif (defined(__sparc__)) | ||
| #define RQD_FPU_STATE (_FPU_DEFAULT +_FPU_DOUBLE+_FPU_MASK_OM+_FPU_MASK_IM+_FPU_MASK_ZM) | ||
| #define RQD_FPU_MASK (_FPU_MASK_OM+_FPU_MASK_IM+_FPU_MASK_ZM) | ||
|
|
||
| #elif (defined(__i386__) || defined(__alpha__)) | ||
| /* This case is for Intel, and also Alpha, because the Alpha header | ||
| * purposely emulates x86 flags and meanings for compatibility with | ||
| * stupid programs. | ||
| * We used to try this case for anything defining _FPU_IEEE, but I think | ||
| * that that's a bad idea because it isn't really likely to work. | ||
| * Instead for unknown architectures we just won't allow -trapuv to work. | ||
| * Trying this case was just getting us | ||
| * (a) compile errors on archs which didn't know all these constants | ||
| * (b) silent wrong behaviour on archs (like SPARC) which do know all | ||
| * constants but have different semantics for them | ||
| */ | ||
| #define RQD_FPU_STATE (_FPU_IEEE - _FPU_EXTENDED + _FPU_DOUBLE - _FPU_MASK_IM - _FPU_MASK_ZM - _FPU_MASK_OM) | ||
| #define RQD_FPU_CLEAR_MASK (_FPU_MASK_IM + _FPU_MASK_ZM + _FPU_MASK_OM) | ||
| #endif | ||
| /* Reported 20011109 by Alan Bain <[email protected]> */ | ||
|
|
||
| static void ieee0(Void) | ||
| { | ||
| #ifdef RQD_FPU_STATE | ||
|
|
||
| #ifndef UNINIT_F2C_PRECISION_53 /* 20051004 */ | ||
| __fpu_control = RQD_FPU_STATE; | ||
| _FPU_SETCW(__fpu_control); | ||
| #else | ||
| #ifdef Can_use__setfpucw | ||
|
|
||
| /* The following is NOT a mistake -- the author of the fpu_control.h | ||
| for the PPC has erroneously defined IEEE mode to turn on exceptions | ||
| other than Inexact! Start from default then and turn on only the ones | ||
| which we want*/ | ||
|
|
||
| __setfpucw(_FPU_DEFAULT + _FPU_MASK_IM+_FPU_MASK_OM+_FPU_MASK_UM); | ||
|
|
||
| #else /* PPC && !Can_use__setfpucw */ | ||
|
|
||
| __fpu_control = _FPU_DEFAULT +_FPU_MASK_OM+_FPU_MASK_IM+_FPU_MASK_UM; | ||
| _FPU_SETCW(__fpu_control); | ||
|
|
||
| #endif /*Can_use__setfpucw*/ | ||
|
|
||
| #else /* !(mc68000||powerpc) */ | ||
|
|
||
| #ifdef _FPU_IEEE | ||
| #ifndef _FPU_EXTENDED /* e.g., ARM processor under Linux */ | ||
| #define _FPU_EXTENDED 0 | ||
| #endif | ||
| #ifndef _FPU_DOUBLE | ||
| #define _FPU_DOUBLE 0 | ||
| #endif | ||
| #ifdef Can_use__setfpucw /* pre-1997 (?) Linux */ | ||
| __setfpucw(_FPU_IEEE - _FPU_MASK_IM - _FPU_MASK_ZM - _FPU_MASK_OM); | ||
| #else | ||
| #ifdef UNINIT_F2C_PRECISION_53 /* 20051004 */ | ||
| /* unmask invalid, etc., and change rounding precision to double */ | ||
| __fpu_control = _FPU_IEEE - _FPU_EXTENDED + _FPU_DOUBLE - _FPU_MASK_IM - _FPU_MASK_ZM - _FPU_MASK_OM; | ||
| _FPU_SETCW(__fpu_control); | ||
| #else | ||
| /* unmask invalid, etc., and keep current rounding precision */ | ||
| fpu_control_t cw; | ||
| _FPU_GETCW(cw); | ||
| #ifdef RQD_FPU_CLEAR_MASK | ||
| cw &= ~ RQD_FPU_CLEAR_MASK; | ||
| #else | ||
| cw |= RQD_FPU_MASK; | ||
| #endif | ||
| cw &= ~(_FPU_MASK_IM | _FPU_MASK_ZM | _FPU_MASK_OM); | ||
| _FPU_SETCW(cw); | ||
| #endif | ||
| #endif | ||
|
|
||
| #else /* !_FPU_IEEE */ | ||
|
|
||
|
|
@@ -400,11 +314,11 @@ static void ieee0(Void) | |
| fflush(stderr); | ||
|
|
||
| #endif /* _FPU_IEEE */ | ||
| #endif /* __mc68k__ */ | ||
| } | ||
| #endif /* __linux__ */ | ||
|
|
||
| /* Specific to OSF/1 */ | ||
| #if (defined(__alpha)&&defined(__osf__)) | ||
| #ifdef __alpha | ||
| #ifndef IEEE0_done | ||
| #define IEEE0_done | ||
| #include <machine/fpu.h> | ||
|
|
@@ -414,7 +328,7 @@ ieee0(Void) | |
| ieee_set_fp_control(IEEE_TRAP_ENABLE_INV); | ||
| } | ||
| #endif /*IEEE0_done*/ | ||
| #endif /*__alpha OSF/1*/ | ||
| #endif /*__alpha*/ | ||
|
|
||
| #ifdef __hpux | ||
| #define IEEE0_done | ||
|
|
||
Oops, something went wrong.