diff options
Diffstat (limited to 'gcc-4.4.0/libgfortran/intrinsics')
64 files changed, 13055 insertions, 0 deletions
diff --git a/gcc-4.4.0/libgfortran/intrinsics/abort.c b/gcc-4.4.0/libgfortran/intrinsics/abort.c new file mode 100644 index 000000000..ada406143 --- /dev/null +++ b/gcc-4.4.0/libgfortran/intrinsics/abort.c @@ -0,0 +1,35 @@ +/* Implementation of the ABORT intrinsic. + Copyright (C) 2003, 2004, 2005, 2006, 2007, 2009 Free Software Foundation, Inc. + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran 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 3 of the License, or (at your option) any later version. + +Libgfortran 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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. */ + +#include "libgfortran.h" +#include <stdlib.h> + +void PREFIX(abort) (void); +export_proto_np(PREFIX(abort)); + +void PREFIX(abort) (void) +{ + close_units (); + abort (); +} diff --git a/gcc-4.4.0/libgfortran/intrinsics/access.c b/gcc-4.4.0/libgfortran/intrinsics/access.c new file mode 100644 index 000000000..9d44531e2 --- /dev/null +++ b/gcc-4.4.0/libgfortran/intrinsics/access.c @@ -0,0 +1,90 @@ +/* Implementation of the ACCESS intrinsic. + Copyright (C) 2006, 2007, 2009 Free Software Foundation, Inc. + Contributed by François-Xavier Coudert <coudert@clipper.ens.fr> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran 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 3 of the License, or (at your option) any later version. + +Libgfortran 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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. */ + +#include "libgfortran.h" + +#include <errno.h> +#include <string.h> + +#ifdef HAVE_UNISTD_H +#include <unistd.h> +#endif + +/* INTEGER FUNCTION ACCESS(NAME, MODE) + CHARACTER(len=*), INTENT(IN) :: NAME, MODE */ + +#ifdef HAVE_ACCESS +extern int access_func (char *, char *, gfc_charlen_type, gfc_charlen_type); +export_proto(access_func); + +int +access_func (char *name, char *mode, gfc_charlen_type name_len, + gfc_charlen_type mode_len) +{ + char * file; + gfc_charlen_type i; + int m; + + /* Parse the MODE string. */ + m = F_OK; + for (i = 0; i < mode_len && mode[i]; i++) + switch (mode[i]) + { + case ' ': + break; + + case 'r': + case 'R': + m |= R_OK; + break; + + case 'w': + case 'W': + m |= W_OK; + break; + + case 'x': + case 'X': + m |= X_OK; + break; + + default: + return -1; + break; + } + + /* Trim trailing spaces from NAME argument. */ + while (name_len > 0 && name[name_len - 1] == ' ') + name_len--; + + /* Make a null terminated copy of the string. */ + file = gfc_alloca (name_len + 1); + memcpy (file, name, name_len); + file[name_len] = '\0'; + + /* And make the call to access(). */ + return (access (file, m) == 0 ? 0 : errno); +} +#endif diff --git a/gcc-4.4.0/libgfortran/intrinsics/args.c b/gcc-4.4.0/libgfortran/intrinsics/args.c new file mode 100644 index 000000000..7187beccb --- /dev/null +++ b/gcc-4.4.0/libgfortran/intrinsics/args.c @@ -0,0 +1,271 @@ +/* Implementation of the GETARG and IARGC g77, and + corresponding F2003, intrinsics. + Copyright (C) 2004, 2005, 2007, 2009 Free Software Foundation, Inc. + Contributed by Bud Davis and Janne Blomqvist. + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran 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 3 of the License, or (at your option) any later version. + +Libgfortran 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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. */ + +#include "libgfortran.h" +#include <string.h> + + +/* Get a commandline argument. */ + +extern void getarg_i4 (GFC_INTEGER_4 *, char *, gfc_charlen_type); +iexport_proto(getarg_i4); + +void +getarg_i4 (GFC_INTEGER_4 *pos, char *val, gfc_charlen_type val_len) +{ + int argc; + int arglen; + char **argv; + + get_args (&argc, &argv); + + if (val_len < 1 || !val ) + return; /* something is wrong , leave immediately */ + + memset (val, ' ', val_len); + + if ((*pos) + 1 <= argc && *pos >=0 ) + { + arglen = strlen (argv[*pos]); + if (arglen > val_len) + arglen = val_len; + memcpy (val, argv[*pos], arglen); + } +} +iexport(getarg_i4); + + +/* INTEGER*8 wrapper of getarg. */ + +extern void getarg_i8 (GFC_INTEGER_8 *, char *, gfc_charlen_type); +export_proto (getarg_i8); + +void +getarg_i8 (GFC_INTEGER_8 *pos, char *val, gfc_charlen_type val_len) +{ + GFC_INTEGER_4 pos4 = (GFC_INTEGER_4) *pos; + getarg_i4 (&pos4, val, val_len); +} + + +/* Return the number of commandline arguments. The g77 info page + states that iargc does not include the specification of the + program name itself. */ + +extern GFC_INTEGER_4 iargc (void); +export_proto(iargc); + +GFC_INTEGER_4 +iargc (void) +{ + int argc; + char **argv; + + get_args (&argc, &argv); + + return (argc - 1); +} + + +/* F2003 intrinsic functions and subroutines related to command line + arguments. + + - function command_argument_count() is converted to iargc by the compiler. + + - subroutine get_command([command, length, status]). + + - subroutine get_command_argument(number, [value, length, status]). +*/ + +/* These two status codes are specified in the standard. */ +#define GFC_GC_SUCCESS 0 +#define GFC_GC_VALUE_TOO_SHORT -1 + +/* Processor-specific status failure code. */ +#define GFC_GC_FAILURE 42 + + +extern void get_command_argument_i4 (GFC_INTEGER_4 *, char *, GFC_INTEGER_4 *, + GFC_INTEGER_4 *, gfc_charlen_type); +iexport_proto(get_command_argument_i4); + +/* Get a single commandline argument. */ + +void +get_command_argument_i4 (GFC_INTEGER_4 *number, char *value, + GFC_INTEGER_4 *length, GFC_INTEGER_4 *status, + gfc_charlen_type value_len) +{ + int argc, arglen = 0, stat_flag = GFC_GC_SUCCESS; + char **argv; + + if (number == NULL ) + /* Should never happen. */ + runtime_error ("Missing argument to get_command_argument"); + + if (value == NULL && length == NULL && status == NULL) + return; /* No need to do anything. */ + + get_args (&argc, &argv); + + if (*number < 0 || *number >= argc) + stat_flag = GFC_GC_FAILURE; + else + arglen = strlen(argv[*number]); + + if (value != NULL) + { + if (value_len < 1) + stat_flag = GFC_GC_FAILURE; + else + memset (value, ' ', value_len); + } + + if (value != NULL && stat_flag != GFC_GC_FAILURE) + { + if (arglen > value_len) + { + arglen = value_len; + stat_flag = GFC_GC_VALUE_TOO_SHORT; + } + memcpy (value, argv[*number], arglen); + } + + if (length != NULL) + *length = arglen; + + if (status != NULL) + *status = stat_flag; +} +iexport(get_command_argument_i4); + + +/* INTEGER*8 wrapper for get_command_argument. */ + +extern void get_command_argument_i8 (GFC_INTEGER_8 *, char *, GFC_INTEGER_8 *, + GFC_INTEGER_8 *, gfc_charlen_type); +export_proto(get_command_argument_i8); + +void +get_command_argument_i8 (GFC_INTEGER_8 *number, char *value, + GFC_INTEGER_8 *length, GFC_INTEGER_8 *status, + gfc_charlen_type value_len) +{ + GFC_INTEGER_4 number4; + GFC_INTEGER_4 length4; + GFC_INTEGER_4 status4; + + number4 = (GFC_INTEGER_4) *number; + get_command_argument_i4 (&number4, value, &length4, &status4, value_len); + if (length) + *length = length4; + if (status) + *status = status4; +} + + +/* Return the whole commandline. */ + +extern void get_command_i4 (char *, GFC_INTEGER_4 *, GFC_INTEGER_4 *, + gfc_charlen_type); +iexport_proto(get_command_i4); + +void +get_command_i4 (char *command, GFC_INTEGER_4 *length, GFC_INTEGER_4 *status, + gfc_charlen_type command_len) +{ + int i, argc, arglen, thisarg; + int stat_flag = GFC_GC_SUCCESS; + int tot_len = 0; + char **argv; + + if (command == NULL && length == NULL && status == NULL) + return; /* No need to do anything. */ + + get_args (&argc, &argv); + + if (command != NULL) + { + /* Initialize the string to blanks. */ + if (command_len < 1) + stat_flag = GFC_GC_FAILURE; + else + memset (command, ' ', command_len); + } + + for (i = 0; i < argc ; i++) + { + arglen = strlen(argv[i]); + + if (command != NULL && stat_flag == GFC_GC_SUCCESS) + { + thisarg = arglen; + if (tot_len + thisarg > command_len) + { + thisarg = command_len - tot_len; /* Truncate. */ + stat_flag = GFC_GC_VALUE_TOO_SHORT; + } + /* Also a space before the next arg. */ + else if (i != argc - 1 && tot_len + arglen == command_len) + stat_flag = GFC_GC_VALUE_TOO_SHORT; + + memcpy (&command[tot_len], argv[i], thisarg); + } + + /* Add the legth of the argument. */ + tot_len += arglen; + if (i != argc - 1) + tot_len++; + } + + if (length != NULL) + *length = tot_len; + + if (status != NULL) + *status = stat_flag; +} +iexport(get_command_i4); + + +/* INTEGER*8 wrapper for get_command. */ + +extern void get_command_i8 (char *, GFC_INTEGER_8 *, GFC_INTEGER_8 *, + gfc_charlen_type); +export_proto(get_command_i8); + +void +get_command_i8 (char *command, GFC_INTEGER_8 *length, GFC_INTEGER_8 *status, + gfc_charlen_type command_len) +{ + GFC_INTEGER_4 length4; + GFC_INTEGER_4 status4; + + get_command_i4 (command, &length4, &status4, command_len); + if (length) + *length = length4; + if (status) + *status = status4; +} diff --git a/gcc-4.4.0/libgfortran/intrinsics/associated.c b/gcc-4.4.0/libgfortran/intrinsics/associated.c new file mode 100644 index 000000000..87b449edb --- /dev/null +++ b/gcc-4.4.0/libgfortran/intrinsics/associated.c @@ -0,0 +1,58 @@ +/* Implementation of the ASSOCIATED intrinsic + Copyright 2003, 2009 Free Software Foundation, Inc. + Contributed by kejia Zhao (CCRG) <kejia_zh@yahoo.com.cn> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran 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 3 of the License, or (at your option) any later version. + +Libgfortran 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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. */ + +#include "libgfortran.h" + +extern int associated (const gfc_array_void *, const gfc_array_void *); +export_proto(associated); + +int +associated (const gfc_array_void *pointer, const gfc_array_void *target) +{ + int n, rank; + + if (GFC_DESCRIPTOR_DATA (pointer) == NULL) + return 0; + if (GFC_DESCRIPTOR_DATA (pointer) != GFC_DESCRIPTOR_DATA (target)) + return 0; + if (GFC_DESCRIPTOR_DTYPE (pointer) != GFC_DESCRIPTOR_DTYPE (target)) + return 0; + + rank = GFC_DESCRIPTOR_RANK (pointer); + for (n = 0; n < rank; n++) + { + long diff; + diff = pointer->dim[n].ubound - pointer->dim[n].lbound; + + if (diff != (target->dim[n].ubound - target->dim[n].lbound)) + return 0; + if (pointer->dim[n].stride != target->dim[n].stride && diff != 0) + return 0; + if (pointer->dim[n].ubound < pointer->dim[n].lbound) + return 0; + } + + return 1; +} diff --git a/gcc-4.4.0/libgfortran/intrinsics/c99_functions.c b/gcc-4.4.0/libgfortran/intrinsics/c99_functions.c new file mode 100644 index 000000000..9b3170234 --- /dev/null +++ b/gcc-4.4.0/libgfortran/intrinsics/c99_functions.c @@ -0,0 +1,1745 @@ +/* Implementation of various C99 functions + Copyright (C) 2004, 2009 Free Software Foundation, Inc. + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran 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 3 of the License, or (at your option) any later version. + +Libgfortran 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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. */ + +#include "config.h" + +#define C99_PROTOS_H WE_DONT_WANT_PROTOS_NOW +#include "libgfortran.h" + +/* IRIX's <math.h> declares a non-C99 compliant implementation of cabs, + which takes two floating point arguments instead of a single complex. + If <complex.h> is missing this prevents building of c99_functions.c. + To work around this we redirect cabs{,f,l} calls to __gfc_cabs{,f,l}. */ + +#if defined(__sgi__) && !defined(HAVE_COMPLEX_H) +#undef HAVE_CABS +#undef HAVE_CABSF +#undef HAVE_CABSL +#define cabs __gfc_cabs +#define cabsf __gfc_cabsf +#define cabsl __gfc_cabsl +#endif + +/* Tru64's <math.h> declares a non-C99 compliant implementation of cabs, + which takes two floating point arguments instead of a single complex. + To work around this we redirect cabs{,f,l} calls to __gfc_cabs{,f,l}. */ + +#ifdef __osf__ +#undef HAVE_CABS +#undef HAVE_CABSF +#undef HAVE_CABSL +#define cabs __gfc_cabs +#define cabsf __gfc_cabsf +#define cabsl __gfc_cabsl +#endif + +/* Prototypes to silence -Wstrict-prototypes -Wmissing-prototypes. */ + +float cabsf(float complex); +double cabs(double complex); +long double cabsl(long double complex); + +float cargf(float complex); +double carg(double complex); +long double cargl(long double complex); + +float complex clog10f(float complex); +double complex clog10(double complex); +long double complex clog10l(long double complex); + + +/* Wrappers for systems without the various C99 single precision Bessel + functions. */ + +#if defined(HAVE_J0) && ! defined(HAVE_J0F) +#define HAVE_J0F 1 +extern float j0f (float); + +float +j0f (float x) +{ + return (float) j0 ((double) x); +} +#endif + +#if defined(HAVE_J1) && !defined(HAVE_J1F) +#define HAVE_J1F 1 +extern float j1f (float); + +float j1f (float x) +{ + return (float) j1 ((double) x); +} +#endif + +#if defined(HAVE_JN) && !defined(HAVE_JNF) +#define HAVE_JNF 1 +extern float jnf (int, float); + +float +jnf (int n, float x) +{ + return (float) jn (n, (double) x); +} +#endif + +#if defined(HAVE_Y0) && !defined(HAVE_Y0F) +#define HAVE_Y0F 1 +extern float y0f (float); + +float +y0f (float x) +{ + return (float) y0 ((double) x); +} +#endif + +#if defined(HAVE_Y1) && !defined(HAVE_Y1F) +#define HAVE_Y1F 1 +extern float y1f (float); + +float +y1f (float x) +{ + return (float) y1 ((double) x); +} +#endif + +#if defined(HAVE_YN) && !defined(HAVE_YNF) +#define HAVE_YNF 1 +extern float ynf (int, float); + +float +ynf (int n, float x) +{ + return (float) yn (n, (double) x); +} +#endif + + +/* Wrappers for systems without the C99 erff() and erfcf() functions. */ + +#if defined(HAVE_ERF) && !defined(HAVE_ERFF) +#define HAVE_ERFF 1 +extern float erff (float); + +float +erff (float x) +{ + return (float) erf ((double) x); +} +#endif + +#if defined(HAVE_ERFC) && !defined(HAVE_ERFCF) +#define HAVE_ERFCF 1 +extern float erfcf (float); + +float +erfcf (float x) +{ + return (float) erfc ((double) x); +} +#endif + + +#ifndef HAVE_ACOSF +#define HAVE_ACOSF 1 +float +acosf(float x) +{ + return (float) acos(x); +} +#endif + +#if HAVE_ACOSH && !HAVE_ACOSHF +float +acoshf (float x) +{ + return (float) acosh ((double) x); +} +#endif + +#ifndef HAVE_ASINF +#define HAVE_ASINF 1 +float +asinf(float x) +{ + return (float) asin(x); +} +#endif + +#if HAVE_ASINH && !HAVE_ASINHF +float +asinhf (float x) +{ + return (float) asinh ((double) x); +} +#endif + +#ifndef HAVE_ATAN2F +#define HAVE_ATAN2F 1 +float +atan2f(float y, float x) +{ + return (float) atan2(y, x); +} +#endif + +#ifndef HAVE_ATANF +#define HAVE_ATANF 1 +float +atanf(float x) +{ + return (float) atan(x); +} +#endif + +#if HAVE_ATANH && !HAVE_ATANHF +float +atanhf (float x) +{ + return (float) atanh ((double) x); +} +#endif + +#ifndef HAVE_CEILF +#define HAVE_CEILF 1 +float +ceilf(float x) +{ + return (float) ceil(x); +} +#endif + +#ifndef HAVE_COPYSIGNF +#define HAVE_COPYSIGNF 1 +float +copysignf(float x, float y) +{ + return (float) copysign(x, y); +} +#endif + +#ifndef HAVE_COSF +#define HAVE_COSF 1 +float +cosf(float x) +{ + return (float) cos(x); +} +#endif + +#ifndef HAVE_COSHF +#define HAVE_COSHF 1 +float +coshf(float x) +{ + return (float) cosh(x); +} +#endif + +#ifndef HAVE_EXPF +#define HAVE_EXPF 1 +float +expf(float x) +{ + return (float) exp(x); +} +#endif + +#ifndef HAVE_FABSF +#define HAVE_FABSF 1 +float +fabsf(float x) +{ + return (float) fabs(x); +} +#endif + +#ifndef HAVE_FLOORF +#define HAVE_FLOORF 1 +float +floorf(float x) +{ + return (float) floor(x); +} +#endif + +#ifndef HAVE_FMODF +#define HAVE_FMODF 1 +float +fmodf (float x, float y) +{ + return (float) fmod (x, y); +} +#endif + +#ifndef HAVE_FREXPF +#define HAVE_FREXPF 1 +float +frexpf(float x, int *exp) +{ + return (float) frexp(x, exp); +} +#endif + +#ifndef HAVE_HYPOTF +#define HAVE_HYPOTF 1 +float +hypotf(float x, float y) +{ + return (float) hypot(x, y); +} +#endif + +#ifndef HAVE_LOGF +#define HAVE_LOGF 1 +float +logf(float x) +{ + return (float) log(x); +} +#endif + +#ifndef HAVE_LOG10F +#define HAVE_LOG10F 1 +float +log10f(float x) +{ + return (float) log10(x); +} +#endif + +#ifndef HAVE_SCALBN +#define HAVE_SCALBN 1 +double +scalbn(double x, int y) +{ +#if (FLT_RADIX == 2) && defined(HAVE_LDEXP) + return ldexp (x, y); +#else + return x * pow(FLT_RADIX, y); +#endif +} +#endif + +#ifndef HAVE_SCALBNF +#define HAVE_SCALBNF 1 +float +scalbnf(float x, int y) +{ + return (float) scalbn(x, y); +} +#endif + +#ifndef HAVE_SINF +#define HAVE_SINF 1 +float +sinf(float x) +{ + return (float) sin(x); +} +#endif + +#ifndef HAVE_SINHF +#define HAVE_SINHF 1 +float +sinhf(float x) +{ + return (float) sinh(x); +} +#endif + +#ifndef HAVE_SQRTF +#define HAVE_SQRTF 1 +float +sqrtf(float x) +{ + return (float) sqrt(x); +} +#endif + +#ifndef HAVE_TANF +#define HAVE_TANF 1 +float +tanf(float x) +{ + return (float) tan(x); +} +#endif + +#ifndef HAVE_TANHF +#define HAVE_TANHF 1 +float +tanhf(float x) +{ + return (float) tanh(x); +} +#endif + +#ifndef HAVE_TRUNC +#define HAVE_TRUNC 1 +double +trunc(double x) +{ + if (!isfinite (x)) + return x; + + if (x < 0.0) + return - floor (-x); + else + return floor (x); +} +#endif + +#ifndef HAVE_TRUNCF +#define HAVE_TRUNCF 1 +float +truncf(float x) +{ + return (float) trunc (x); +} +#endif + +#ifndef HAVE_NEXTAFTERF +#define HAVE_NEXTAFTERF 1 +/* This is a portable implementation of nextafterf that is intended to be + independent of the floating point format or its in memory representation. + This implementation works correctly with denormalized values. */ +float +nextafterf(float x, float y) +{ + /* This variable is marked volatile to avoid excess precision problems + on some platforms, including IA-32. */ + volatile float delta; + float absx, denorm_min; + + if (isnan(x) || isnan(y)) + return x + y; + if (x == y) + return x; + if (!isfinite (x)) + return x > 0 ? __FLT_MAX__ : - __FLT_MAX__; + + /* absx = fabsf (x); */ + absx = (x < 0.0) ? -x : x; + + /* __FLT_DENORM_MIN__ is non-zero iff the target supports denormals. */ + if (__FLT_DENORM_MIN__ == 0.0f) + denorm_min = __FLT_MIN__; + else + denorm_min = __FLT_DENORM_MIN__; + + if (absx < __FLT_MIN__) + delta = denorm_min; + else + { + float frac; + int exp; + + /* Discard the fraction from x. */ + frac = frexpf (absx, &exp); + delta = scalbnf (0.5f, exp); + + /* Scale x by the epsilon of the representation. By rights we should + have been able to combine this with scalbnf, but some targets don't + get that correct with denormals. */ + delta *= __FLT_EPSILON__; + + /* If we're going to be reducing the absolute value of X, and doing so + would reduce the exponent of X, then the delta to be applied is + one exponent smaller. */ + if (frac == 0.5f && (y < x) == (x > 0)) + delta *= 0.5f; + + /* If that underflows to zero, then we're back to the minimum. */ + if (delta == 0.0f) + delta = denorm_min; + } + + if (y < x) + delta = -delta; + + return x + delta; +} +#endif + + +#if !defined(HAVE_POWF) || defined(HAVE_BROKEN_POWF) +#ifndef HAVE_POWF +#define HAVE_POWF 1 +#endif +float +powf(float x, float y) +{ + return (float) pow(x, y); +} +#endif + +/* Note that if fpclassify is not defined, then NaN is not handled */ + +/* Algorithm by Steven G. Kargl. */ + +#if !defined(HAVE_ROUNDL) +#define HAVE_ROUNDL 1 +#if defined(HAVE_CEILL) +/* Round to nearest integral value. If the argument is halfway between two + integral values then round away from zero. */ + +long double +roundl(long double x) +{ + long double t; + if (!isfinite (x)) + return (x); + + if (x >= 0.0) + { + t = ceill(x); + if (t - x > 0.5) + t -= 1.0; + return (t); + } + else + { + t = ceill(-x); + if (t + x > 0.5) + t -= 1.0; + return (-t); + } +} +#else + +/* Poor version of roundl for system that don't have ceill. */ +long double +roundl(long double x) +{ + if (x > DBL_MAX || x < -DBL_MAX) + { +#ifdef HAVE_NEXTAFTERL + static long double prechalf = nexafterl (0.5L, LDBL_MAX); +#else + static long double prechalf = 0.5L; +#endif + return (GFC_INTEGER_LARGEST) (x + (x > 0 ? prechalf : -prechalf)); + } + else + /* Use round(). */ + return round((double) x); +} + +#endif +#endif + +#ifndef HAVE_ROUND +#define HAVE_ROUND 1 +/* Round to nearest integral value. If the argument is halfway between two + integral values then round away from zero. */ + +double +round(double x) +{ + double t; + if (!isfinite (x)) + return (x); + + if (x >= 0.0) + { + t = ceil(x); + if (t - x > 0.5) + t -= 1.0; + return (t); + } + else + { + t = ceil(-x); + if (t + x > 0.5) + t -= 1.0; + return (-t); + } +} +#endif + +#ifndef HAVE_ROUNDF +#define HAVE_ROUNDF 1 +/* Round to nearest integral value. If the argument is halfway between two + integral values then round away from zero. */ + +float +roundf(float x) +{ + float t; + if (!isfinite (x)) + return (x); + + if (x >= 0.0) + { + t = ceilf(x); + if (t - x > 0.5) + t -= 1.0; + return (t); + } + else + { + t = ceilf(-x); + if (t + x > 0.5) + t -= 1.0; + return (-t); + } +} +#endif + + +/* lround{f,,l} and llround{f,,l} functions. */ + +#if !defined(HAVE_LROUNDF) && defined(HAVE_ROUNDF) +#define HAVE_LROUNDF 1 +long int +lroundf (float x) +{ + return (long int) roundf (x); +} +#endif + +#if !defined(HAVE_LROUND) && defined(HAVE_ROUND) +#define HAVE_LROUND 1 +long int +lround (double x) +{ + return (long int) round (x); +} +#endif + +#if !defined(HAVE_LROUNDL) && defined(HAVE_ROUNDL) +#define HAVE_LROUNDL 1 +long int +lroundl (long double x) +{ + return (long long int) roundl (x); +} +#endif + +#if !defined(HAVE_LLROUNDF) && defined(HAVE_ROUNDF) +#define HAVE_LLROUNDF 1 +long long int +llroundf (float x) +{ + return (long long int) roundf (x); +} +#endif + +#if !defined(HAVE_LLROUND) && defined(HAVE_ROUND) +#define HAVE_LLROUND 1 +long long int +llround (double x) +{ + return (long long int) round (x); +} +#endif + +#if !defined(HAVE_LLROUNDL) && defined(HAVE_ROUNDL) +#define HAVE_LLROUNDL 1 +long long int +llroundl (long double x) +{ + return (long long int) roundl (x); +} +#endif + + +#ifndef HAVE_LOG10L +#define HAVE_LOG10L 1 +/* log10 function for long double variables. The version provided here + reduces the argument until it fits into a double, then use log10. */ +long double +log10l(long double x) +{ +#if LDBL_MAX_EXP > DBL_MAX_EXP + if (x > DBL_MAX) + { + double val; + int p2_result = 0; + if (x > 0x1p16383L) { p2_result += 16383; x /= 0x1p16383L; } + if (x > 0x1p8191L) { p2_result += 8191; x /= 0x1p8191L; } + if (x > 0x1p4095L) { p2_result += 4095; x /= 0x1p4095L; } + if (x > 0x1p2047L) { p2_result += 2047; x /= 0x1p2047L; } + if (x > 0x1p1023L) { p2_result += 1023; x /= 0x1p1023L; } + val = log10 ((double) x); + return (val + p2_result * .30102999566398119521373889472449302L); + } +#endif +#if LDBL_MIN_EXP < DBL_MIN_EXP + if (x < DBL_MIN) + { + double val; + int p2_result = 0; + if (x < 0x1p-16380L) { p2_result += 16380; x /= 0x1p-16380L; } + if (x < 0x1p-8189L) { p2_result += 8189; x /= 0x1p-8189L; } + if (x < 0x1p-4093L) { p2_result += 4093; x /= 0x1p-4093L; } + if (x < 0x1p-2045L) { p2_result += 2045; x /= 0x1p-2045L; } + if (x < 0x1p-1021L) { p2_result += 1021; x /= 0x1p-1021L; } + val = fabs(log10 ((double) x)); + return (- val - p2_result * .30102999566398119521373889472449302L); + } +#endif + return log10 (x); +} +#endif + + +#ifndef HAVE_FLOORL +#define HAVE_FLOORL 1 +long double +floorl (long double x) +{ + /* Zero, possibly signed. */ + if (x == 0) + return x; + + /* Large magnitude. */ + if (x > DBL_MAX || x < (-DBL_MAX)) + return x; + + /* Small positive values. */ + if (x >= 0 && x < DBL_MIN) + return 0; + + /* Small negative values. */ + if (x < 0 && x > (-DBL_MIN)) + return -1; + + return floor (x); +} +#endif + + +#ifndef HAVE_FMODL +#define HAVE_FMODL 1 +long double +fmodl (long double x, long double y) +{ + if (y == 0.0L) + return 0.0L; + + /* Need to check that the result has the same sign as x and magnitude + less than the magnitude of y. */ + return x - floorl (x / y) * y; +} +#endif + + +#if !defined(HAVE_CABSF) +#define HAVE_CABSF 1 +float +cabsf (float complex z) +{ + return hypotf (REALPART (z), IMAGPART (z)); +} +#endif + +#if !defined(HAVE_CABS) +#define HAVE_CABS 1 +double +cabs (double complex z) +{ + return hypot (REALPART (z), IMAGPART (z)); +} +#endif + +#if !defined(HAVE_CABSL) && defined(HAVE_HYPOTL) +#define HAVE_CABSL 1 +long double +cabsl (long double complex z) +{ + return hypotl (REALPART (z), IMAGPART (z)); +} +#endif + + +#if !defined(HAVE_CARGF) +#define HAVE_CARGF 1 +float +cargf (float complex z) +{ + return atan2f (IMAGPART (z), REALPART (z)); +} +#endif + +#if !defined(HAVE_CARG) +#define HAVE_CARG 1 +double +carg (double complex z) +{ + return atan2 (IMAGPART (z), REALPART (z)); +} +#endif + +#if !defined(HAVE_CARGL) && defined(HAVE_ATAN2L) +#define HAVE_CARGL 1 +long double +cargl (long double complex z) +{ + return atan2l (IMAGPART (z), REALPART (z)); +} +#endif + + +/* exp(z) = exp(a)*(cos(b) + i sin(b)) */ +#if !defined(HAVE_CEXPF) +#define HAVE_CEXPF 1 +float complex +cexpf (float complex z) +{ + float a, b; + float complex v; + + a = REALPART (z); + b = IMAGPART (z); + COMPLEX_ASSIGN (v, cosf (b), sinf (b)); + return expf (a) * v; +} +#endif + +#if !defined(HAVE_CEXP) +#define HAVE_CEXP 1 +double complex +cexp (double complex z) +{ + double a, b; + double complex v; + + a = REALPART (z); + b = IMAGPART (z); + COMPLEX_ASSIGN (v, cos (b), sin (b)); + return exp (a) * v; +} +#endif + +#if !defined(HAVE_CEXPL) && defined(HAVE_COSL) && defined(HAVE_SINL) && defined(EXPL) +#define HAVE_CEXPL 1 +long double complex +cexpl (long double complex z) +{ + long double a, b; + long double complex v; + + a = REALPART (z); + b = IMAGPART (z); + COMPLEX_ASSIGN (v, cosl (b), sinl (b)); + return expl (a) * v; +} +#endif + + +/* log(z) = log (cabs(z)) + i*carg(z) */ +#if !defined(HAVE_CLOGF) +#define HAVE_CLOGF 1 +float complex +clogf (float complex z) +{ + float complex v; + + COMPLEX_ASSIGN (v, logf (cabsf (z)), cargf (z)); + return v; +} +#endif + +#if !defined(HAVE_CLOG) +#define HAVE_CLOG 1 +double complex +clog (double complex z) +{ + double complex v; + + COMPLEX_ASSIGN (v, log (cabs (z)), carg (z)); + return v; +} +#endif + +#if !defined(HAVE_CLOGL) && defined(HAVE_LOGL) && defined(HAVE_CABSL) && defined(HAVE_CARGL) +#define HAVE_CLOGL 1 +long double complex +clogl (long double complex z) +{ + long double complex v; + + COMPLEX_ASSIGN (v, logl (cabsl (z)), cargl (z)); + return v; +} +#endif + + +/* log10(z) = log10 (cabs(z)) + i*carg(z) */ +#if !defined(HAVE_CLOG10F) +#define HAVE_CLOG10F 1 +float complex +clog10f (float complex z) +{ + float complex v; + + COMPLEX_ASSIGN (v, log10f (cabsf (z)), cargf (z)); + return v; +} +#endif + +#if !defined(HAVE_CLOG10) +#define HAVE_CLOG10 1 +double complex +clog10 (double complex z) +{ + double complex v; + + COMPLEX_ASSIGN (v, log10 (cabs (z)), carg (z)); + return v; +} +#endif + +#if !defined(HAVE_CLOG10L) && defined(HAVE_LOG10L) && defined(HAVE_CABSL) && defined(HAVE_CARGL) +#define HAVE_CLOG10L 1 +long double complex +clog10l (long double complex z) +{ + long double complex v; + + COMPLEX_ASSIGN (v, log10l (cabsl (z)), cargl (z)); + return v; +} +#endif + + +/* pow(base, power) = cexp (power * clog (base)) */ +#if !defined(HAVE_CPOWF) +#define HAVE_CPOWF 1 +float complex +cpowf (float complex base, float complex power) +{ + return cexpf (power * clogf (base)); +} +#endif + +#if !defined(HAVE_CPOW) +#define HAVE_CPOW 1 +double complex +cpow (double complex base, double complex power) +{ + return cexp (power * clog (base)); +} +#endif + +#if !defined(HAVE_CPOWL) && defined(HAVE_CEXPL) && defined(HAVE_CLOGL) +#define HAVE_CPOWL 1 +long double complex +cpowl (long double complex base, long double complex power) +{ + return cexpl (power * clogl (base)); +} +#endif + + +/* sqrt(z). Algorithm pulled from glibc. */ +#if !defined(HAVE_CSQRTF) +#define HAVE_CSQRTF 1 +float complex +csqrtf (float complex z) +{ + float re, im; + float complex v; + + re = REALPART (z); + im = IMAGPART (z); + if (im == 0) + { + if (re < 0) + { + COMPLEX_ASSIGN (v, 0, copysignf (sqrtf (-re), im)); + } + else + { + COMPLEX_ASSIGN (v, fabsf (sqrtf (re)), copysignf (0, im)); + } + } + else if (re == 0) + { + float r; + + r = sqrtf (0.5 * fabsf (im)); + + COMPLEX_ASSIGN (v, r, copysignf (r, im)); + } + else + { + float d, r, s; + + d = hypotf (re, im); + /* Use the identity 2 Re res Im res = Im x + to avoid cancellation error in d +/- Re x. */ + if (re > 0) + { + r = sqrtf (0.5 * d + 0.5 * re); + s = (0.5 * im) / r; + } + else + { + s = sqrtf (0.5 * d - 0.5 * re); + r = fabsf ((0.5 * im) / s); + } + + COMPLEX_ASSIGN (v, r, copysignf (s, im)); + } + return v; +} +#endif + +#if !defined(HAVE_CSQRT) +#define HAVE_CSQRT 1 +double complex +csqrt (double complex z) +{ + double re, im; + double complex v; + + re = REALPART (z); + im = IMAGPART (z); + if (im == 0) + { + if (re < 0) + { + COMPLEX_ASSIGN (v, 0, copysign (sqrt (-re), im)); + } + else + { + COMPLEX_ASSIGN (v, fabs (sqrt (re)), copysign (0, im)); + } + } + else if (re == 0) + { + double r; + + r = sqrt (0.5 * fabs (im)); + + COMPLEX_ASSIGN (v, r, copysign (r, im)); + } + else + { + double d, r, s; + + d = hypot (re, im); + /* Use the identity 2 Re res Im res = Im x + to avoid cancellation error in d +/- Re x. */ + if (re > 0) + { + r = sqrt (0.5 * d + 0.5 * re); + s = (0.5 * im) / r; + } + else + { + s = sqrt (0.5 * d - 0.5 * re); + r = fabs ((0.5 * im) / s); + } + + COMPLEX_ASSIGN (v, r, copysign (s, im)); + } + return v; +} +#endif + +#if !defined(HAVE_CSQRTL) && defined(HAVE_COPYSIGNL) && defined(HAVE_SQRTL) && defined(HAVE_FABSL) && defined(HAVE_HYPOTL) +#define HAVE_CSQRTL 1 +long double complex +csqrtl (long double complex z) +{ + long double re, im; + long double complex v; + + re = REALPART (z); + im = IMAGPART (z); + if (im == 0) + { + if (re < 0) + { + COMPLEX_ASSIGN (v, 0, copysignl (sqrtl (-re), im)); + } + else + { + COMPLEX_ASSIGN (v, fabsl (sqrtl (re)), copysignl (0, im)); + } + } + else if (re == 0) + { + long double r; + + r = sqrtl (0.5 * fabsl (im)); + + COMPLEX_ASSIGN (v, copysignl (r, im), r); + } + else + { + long double d, r, s; + + d = hypotl (re, im); + /* Use the identity 2 Re res Im res = Im x + to avoid cancellation error in d +/- Re x. */ + if (re > 0) + { + r = sqrtl (0.5 * d + 0.5 * re); + s = (0.5 * im) / r; + } + else + { + s = sqrtl (0.5 * d - 0.5 * re); + r = fabsl ((0.5 * im) / s); + } + + COMPLEX_ASSIGN (v, r, copysignl (s, im)); + } + return v; +} +#endif + + +/* sinh(a + i b) = sinh(a) cos(b) + i cosh(a) sin(b) */ +#if !defined(HAVE_CSINHF) +#define HAVE_CSINHF 1 +float complex +csinhf (float complex a) +{ + float r, i; + float complex v; + + r = REALPART (a); + i = IMAGPART (a); + COMPLEX_ASSIGN (v, sinhf (r) * cosf (i), coshf (r) * sinf (i)); + return v; +} +#endif + +#if !defined(HAVE_CSINH) +#define HAVE_CSINH 1 +double complex +csinh (double complex a) +{ + double r, i; + double complex v; + + r = REALPART (a); + i = IMAGPART (a); + COMPLEX_ASSIGN (v, sinh (r) * cos (i), cosh (r) * sin (i)); + return v; +} +#endif + +#if !defined(HAVE_CSINHL) && defined(HAVE_COSL) && defined(HAVE_COSHL) && defined(HAVE_SINL) && defined(HAVE_SINHL) +#define HAVE_CSINHL 1 +long double complex +csinhl (long double complex a) +{ + long double r, i; + long double complex v; + + r = REALPART (a); + i = IMAGPART (a); + COMPLEX_ASSIGN (v, sinhl (r) * cosl (i), coshl (r) * sinl (i)); + return v; +} +#endif + + +/* cosh(a + i b) = cosh(a) cos(b) - i sinh(a) sin(b) */ +#if !defined(HAVE_CCOSHF) +#define HAVE_CCOSHF 1 +float complex +ccoshf (float complex a) +{ + float r, i; + float complex v; + + r = REALPART (a); + i = IMAGPART (a); + COMPLEX_ASSIGN (v, coshf (r) * cosf (i), - (sinhf (r) * sinf (i))); + return v; +} +#endif + +#if !defined(HAVE_CCOSH) +#define HAVE_CCOSH 1 +double complex +ccosh (double complex a) +{ + double r, i; + double complex v; + + r = REALPART (a); + i = IMAGPART (a); + COMPLEX_ASSIGN (v, cosh (r) * cos (i), - (sinh (r) * sin (i))); + return v; +} +#endif + +#if !defined(HAVE_CCOSHL) && defined(HAVE_COSL) && defined(HAVE_COSHL) && defined(HAVE_SINL) && defined(HAVE_SINHL) +#define HAVE_CCOSHL 1 +long double complex +ccoshl (long double complex a) +{ + long double r, i; + long double complex v; + + r = REALPART (a); + i = IMAGPART (a); + COMPLEX_ASSIGN (v, coshl (r) * cosl (i), - (sinhl (r) * sinl (i))); + return v; +} +#endif + + +/* tanh(a + i b) = (tanh(a) + i tan(b)) / (1 - i tanh(a) tan(b)) */ +#if !defined(HAVE_CTANHF) +#define HAVE_CTANHF 1 +float complex +ctanhf (float complex a) +{ + float rt, it; + float complex n, d; + + rt = tanhf (REALPART (a)); + it = tanf (IMAGPART (a)); + COMPLEX_ASSIGN (n, rt, it); + COMPLEX_ASSIGN (d, 1, - (rt * it)); + + return n / d; +} +#endif + +#if !defined(HAVE_CTANH) +#define HAVE_CTANH 1 +double complex +ctanh (double complex a) +{ + double rt, it; + double complex n, d; + + rt = tanh (REALPART (a)); + it = tan (IMAGPART (a)); + COMPLEX_ASSIGN (n, rt, it); + COMPLEX_ASSIGN (d, 1, - (rt * it)); + + return n / d; +} +#endif + +#if !defined(HAVE_CTANHL) && defined(HAVE_TANL) && defined(HAVE_TANHL) +#define HAVE_CTANHL 1 +long double complex +ctanhl (long double complex a) +{ + long double rt, it; + long double complex n, d; + + rt = tanhl (REALPART (a)); + it = tanl (IMAGPART (a)); + COMPLEX_ASSIGN (n, rt, it); + COMPLEX_ASSIGN (d, 1, - (rt * it)); + + return n / d; +} +#endif + + +/* sin(a + i b) = sin(a) cosh(b) + i cos(a) sinh(b) */ +#if !defined(HAVE_CSINF) +#define HAVE_CSINF 1 +float complex +csinf (float complex a) +{ + float r, i; + float complex v; + + r = REALPART (a); + i = IMAGPART (a); + COMPLEX_ASSIGN (v, sinf (r) * coshf (i), cosf (r) * sinhf (i)); + return v; +} +#endif + +#if !defined(HAVE_CSIN) +#define HAVE_CSIN 1 +double complex +csin (double complex a) +{ + double r, i; + double complex v; + + r = REALPART (a); + i = IMAGPART (a); + COMPLEX_ASSIGN (v, sin (r) * cosh (i), cos (r) * sinh (i)); + return v; +} +#endif + +#if !defined(HAVE_CSINL) && defined(HAVE_COSL) && defined(HAVE_COSHL) && defined(HAVE_SINL) && defined(HAVE_SINHL) +#define HAVE_CSINL 1 +long double complex +csinl (long double complex a) +{ + long double r, i; + long double complex v; + + r = REALPART (a); + i = IMAGPART (a); + COMPLEX_ASSIGN (v, sinl (r) * coshl (i), cosl (r) * sinhl (i)); + return v; +} +#endif + + +/* cos(a + i b) = cos(a) cosh(b) - i sin(a) sinh(b) */ +#if !defined(HAVE_CCOSF) +#define HAVE_CCOSF 1 +float complex +ccosf (float complex a) +{ + float r, i; + float complex v; + + r = REALPART (a); + i = IMAGPART (a); + COMPLEX_ASSIGN (v, cosf (r) * coshf (i), - (sinf (r) * sinhf (i))); + return v; +} +#endif + +#if !defined(HAVE_CCOS) +#define HAVE_CCOS 1 +double complex +ccos (double complex a) +{ + double r, i; + double complex v; + + r = REALPART (a); + i = IMAGPART (a); + COMPLEX_ASSIGN (v, cos (r) * cosh (i), - (sin (r) * sinh (i))); + return v; +} +#endif + +#if !defined(HAVE_CCOSL) && defined(HAVE_COSL) && defined(HAVE_COSHL) && defined(HAVE_SINL) && defined(HAVE_SINHL) +#define HAVE_CCOSL 1 +long double complex +ccosl (long double complex a) +{ + long double r, i; + long double complex v; + + r = REALPART (a); + i = IMAGPART (a); + COMPLEX_ASSIGN (v, cosl (r) * coshl (i), - (sinl (r) * sinhl (i))); + return v; +} +#endif + + +/* tan(a + i b) = (tan(a) + i tanh(b)) / (1 - i tan(a) tanh(b)) */ +#if !defined(HAVE_CTANF) +#define HAVE_CTANF 1 +float complex +ctanf (float complex a) +{ + float rt, it; + float complex n, d; + + rt = tanf (REALPART (a)); + it = tanhf (IMAGPART (a)); + COMPLEX_ASSIGN (n, rt, it); + COMPLEX_ASSIGN (d, 1, - (rt * it)); + + return n / d; +} +#endif + +#if !defined(HAVE_CTAN) +#define HAVE_CTAN 1 +double complex +ctan (double complex a) +{ + double rt, it; + double complex n, d; + + rt = tan (REALPART (a)); + it = tanh (IMAGPART (a)); + COMPLEX_ASSIGN (n, rt, it); + COMPLEX_ASSIGN (d, 1, - (rt * it)); + + return n / d; +} +#endif + +#if !defined(HAVE_CTANL) && defined(HAVE_TANL) && defined(HAVE_TANHL) +#define HAVE_CTANL 1 +long double complex +ctanl (long double complex a) +{ + long double rt, it; + long double complex n, d; + + rt = tanl (REALPART (a)); + it = tanhl (IMAGPART (a)); + COMPLEX_ASSIGN (n, rt, it); + COMPLEX_ASSIGN (d, 1, - (rt * it)); + + return n / d; +} +#endif + + +#if !defined(HAVE_TGAMMA) +#define HAVE_TGAMMA 1 + +extern double tgamma (double); + +/* Fallback tgamma() function. Uses the algorithm from + http://www.netlib.org/specfun/gamma and references therein. */ + +#undef SQRTPI +#define SQRTPI 0.9189385332046727417803297 + +#undef PI +#define PI 3.1415926535897932384626434 + +double +tgamma (double x) +{ + int i, n, parity; + double fact, res, sum, xden, xnum, y, y1, ysq, z; + + static double p[8] = { + -1.71618513886549492533811e0, 2.47656508055759199108314e1, + -3.79804256470945635097577e2, 6.29331155312818442661052e2, + 8.66966202790413211295064e2, -3.14512729688483675254357e4, + -3.61444134186911729807069e4, 6.64561438202405440627855e4 }; + + static double q[8] = { + -3.08402300119738975254353e1, 3.15350626979604161529144e2, + -1.01515636749021914166146e3, -3.10777167157231109440444e3, + 2.25381184209801510330112e4, 4.75584627752788110767815e3, + -1.34659959864969306392456e5, -1.15132259675553483497211e5 }; + + static double c[7] = { -1.910444077728e-03, + 8.4171387781295e-04, -5.952379913043012e-04, + 7.93650793500350248e-04, -2.777777777777681622553e-03, + 8.333333333333333331554247e-02, 5.7083835261e-03 }; + + static const double xminin = 2.23e-308; + static const double xbig = 171.624; + static const double xnan = __builtin_nan ("0x0"), xinf = __builtin_inf (); + static double eps = 0; + + if (eps == 0) + eps = nextafter(1., 2.) - 1.; + + parity = 0; + fact = 1; + n = 0; + y = x; + + if (__builtin_isnan (x)) + return x; + + if (y <= 0) + { + y = -x; + y1 = trunc(y); + res = y - y1; + + if (res != 0) + { + if (y1 != trunc(y1*0.5l)*2) + parity = 1; + fact = -PI / sin(PI*res); + y = y + 1; + } + else + return x == 0 ? copysign (xinf, x) : xnan; + } + + if (y < eps) + { + if (y >= xminin) + res = 1 / y; + else + return xinf; + } + else if (y < 13) + { + y1 = y; + if (y < 1) + { + z = y; + y = y + 1; + } + else + { + n = (int)y - 1; + y = y - n; + z = y - 1; + } + + xnum = 0; + xden = 1; + for (i = 0; i < 8; i++) + { + xnum = (xnum + p[i]) * z; + xden = xden * z + q[i]; + } + + res = xnum / xden + 1; + + if (y1 < y) + res = res / y1; + else if (y1 > y) + for (i = 1; i <= n; i++) + { + res = res * y; + y = y + 1; + } + } + else + { + if (y < xbig) + { + ysq = y * y; + sum = c[6]; + for (i = 0; i < 6; i++) + sum = sum / ysq + c[i]; + + sum = sum/y - y + SQRTPI; + sum = sum + (y - 0.5) * log(y); + res = exp(sum); + } + else + return x < 0 ? xnan : xinf; + } + + if (parity) + res = -res; + if (fact != 1) + res = fact / res; + + return res; +} +#endif + + + +#if !defined(HAVE_LGAMMA) +#define HAVE_LGAMMA 1 + +extern double lgamma (double); + +/* Fallback lgamma() function. Uses the algorithm from + http://www.netlib.org/specfun/algama and references therein, + except for negative arguments (where netlib would return +Inf) + where we use the following identity: + lgamma(y) = log(pi/(|y*sin(pi*y)|)) - lgamma(-y) + */ + +double +lgamma (double y) +{ + +#undef SQRTPI +#define SQRTPI 0.9189385332046727417803297 + +#undef PI +#define PI 3.1415926535897932384626434 + +#define PNT68 0.6796875 +#define D1 -0.5772156649015328605195174 +#define D2 0.4227843350984671393993777 +#define D4 1.791759469228055000094023 + + static double p1[8] = { + 4.945235359296727046734888e0, 2.018112620856775083915565e2, + 2.290838373831346393026739e3, 1.131967205903380828685045e4, + 2.855724635671635335736389e4, 3.848496228443793359990269e4, + 2.637748787624195437963534e4, 7.225813979700288197698961e3 }; + static double q1[8] = { + 6.748212550303777196073036e1, 1.113332393857199323513008e3, + 7.738757056935398733233834e3, 2.763987074403340708898585e4, + 5.499310206226157329794414e4, 6.161122180066002127833352e4, + 3.635127591501940507276287e4, 8.785536302431013170870835e3 }; + static double p2[8] = { + 4.974607845568932035012064e0, 5.424138599891070494101986e2, + 1.550693864978364947665077e4, 1.847932904445632425417223e5, + 1.088204769468828767498470e6, 3.338152967987029735917223e6, + 5.106661678927352456275255e6, 3.074109054850539556250927e6 }; + static double q2[8] = { + 1.830328399370592604055942e2, 7.765049321445005871323047e3, + 1.331903827966074194402448e5, 1.136705821321969608938755e6, + 5.267964117437946917577538e6, 1.346701454311101692290052e7, + 1.782736530353274213975932e7, 9.533095591844353613395747e6 }; + static double p4[8] = { + 1.474502166059939948905062e4, 2.426813369486704502836312e6, + 1.214755574045093227939592e8, 2.663432449630976949898078e9, + 2.940378956634553899906876e10, 1.702665737765398868392998e11, + 4.926125793377430887588120e11, 5.606251856223951465078242e11 }; + static double q4[8] = { + 2.690530175870899333379843e3, 6.393885654300092398984238e5, + 4.135599930241388052042842e7, 1.120872109616147941376570e9, + 1.488613728678813811542398e10, 1.016803586272438228077304e11, + 3.417476345507377132798597e11, 4.463158187419713286462081e11 }; + static double c[7] = { + -1.910444077728e-03, 8.4171387781295e-04, + -5.952379913043012e-04, 7.93650793500350248e-04, + -2.777777777777681622553e-03, 8.333333333333333331554247e-02, + 5.7083835261e-03 }; + + static double xbig = 2.55e305, xinf = __builtin_inf (), eps = 0, + frtbig = 2.25e76; + + int i; + double corr, res, xden, xm1, xm2, xm4, xnum, ysq; + + if (eps == 0) + eps = __builtin_nextafter(1., 2.) - 1.; + + if ((y > 0) && (y <= xbig)) + { + if (y <= eps) + res = -log(y); + else if (y <= 1.5) + { + if (y < PNT68) + { + corr = -log(y); + xm1 = y; + } + else + { + corr = 0; + xm1 = (y - 0.5) - 0.5; + } + + if ((y <= 0.5) || (y >= PNT68)) + { + xden = 1; + xnum = 0; + for (i = 0; i < 8; i++) + { + xnum = xnum*xm1 + p1[i]; + xden = xden*xm1 + q1[i]; + } + res = corr + (xm1 * (D1 + xm1*(xnum/xden))); + } + else + { + xm2 = (y - 0.5) - 0.5; + xden = 1; + xnum = 0; + for (i = 0; i < 8; i++) + { + xnum = xnum*xm2 + p2[i]; + xden = xden*xm2 + q2[i]; + } + res = corr + xm2 * (D2 + xm2*(xnum/xden)); + } + } + else if (y <= 4) + { + xm2 = y - 2; + xden = 1; + xnum = 0; + for (i = 0; i < 8; i++) + { + xnum = xnum*xm2 + p2[i]; + xden = xden*xm2 + q2[i]; + } + res = xm2 * (D2 + xm2*(xnum/xden)); + } + else if (y <= 12) + { + xm4 = y - 4; + xden = -1; + xnum = 0; + for (i = 0; i < 8; i++) + { + xnum = xnum*xm4 + p4[i]; + xden = xden*xm4 + q4[i]; + } + res = D4 + xm4*(xnum/xden); + } + else + { + res = 0; + if (y <= frtbig) + { + res = c[6]; + ysq = y * y; + for (i = 0; i < 6; i++) + res = res / ysq + c[i]; + } + res = res/y; + corr = log(y); + res = res + SQRTPI - 0.5*corr; + res = res + y*(corr-1); + } + } + else if (y < 0 && __builtin_floor (y) != y) + { + /* lgamma(y) = log(pi/(|y*sin(pi*y)|)) - lgamma(-y) + For abs(y) very close to zero, we use a series expansion to + the first order in y to avoid overflow. */ + if (y > -1.e-100) + res = -2 * log (fabs (y)) - lgamma (-y); + else + res = log (PI / fabs (y * sin (PI * y))) - lgamma (-y); + } + else + res = xinf; + + return res; +} +#endif + + +#if defined(HAVE_TGAMMA) && !defined(HAVE_TGAMMAF) +#define HAVE_TGAMMAF 1 +extern float tgammaf (float); + +float +tgammaf (float x) +{ + return (float) tgamma ((double) x); +} +#endif + +#if defined(HAVE_LGAMMA) && !defined(HAVE_LGAMMAF) +#define HAVE_LGAMMAF 1 +extern float lgammaf (float); + +float +lgammaf (float x) +{ + return (float) lgamma ((double) x); +} +#endif diff --git a/gcc-4.4.0/libgfortran/intrinsics/chdir.c b/gcc-4.4.0/libgfortran/intrinsics/chdir.c new file mode 100644 index 000000000..62f46931b --- /dev/null +++ b/gcc-4.4.0/libgfortran/intrinsics/chdir.c @@ -0,0 +1,111 @@ +/* Implementation of the CHDIR intrinsic. + Copyright (C) 2005, 2007, 2009 Free Software Foundation, Inc. + Contributed by François-Xavier Coudert <coudert@clipper.ens.fr> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran 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 3 of the License, or (at your option) any later version. + +Libgfortran 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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. */ + +#include "libgfortran.h" + +#include <errno.h> +#include <string.h> + +#ifdef HAVE_UNISTD_H +#include <unistd.h> +#endif + +/* SUBROUTINE CHDIR(DIR, STATUS) + CHARACTER(len=*), INTENT(IN) :: DIR + INTEGER, INTENT(OUT), OPTIONAL :: STATUS */ + +#ifdef HAVE_CHDIR +extern void chdir_i4_sub (char *, GFC_INTEGER_4 *, gfc_charlen_type); +iexport_proto(chdir_i4_sub); + +void +chdir_i4_sub (char *dir, GFC_INTEGER_4 *status, gfc_charlen_type dir_len) +{ + int val; + char *str; + + /* Trim trailing spaces from paths. */ + while (dir_len > 0 && dir[dir_len - 1] == ' ') + dir_len--; + + /* Make a null terminated copy of the strings. */ + str = gfc_alloca (dir_len + 1); + memcpy (str, dir, dir_len); + str[dir_len] = '\0'; + + val = chdir (str); + + if (status != NULL) + *status = (val == 0) ? 0 : errno; +} +iexport(chdir_i4_sub); + +extern void chdir_i8_sub (char *, GFC_INTEGER_8 *, gfc_charlen_type); +iexport_proto(chdir_i8_sub); + +void +chdir_i8_sub (char *dir, GFC_INTEGER_8 *status, gfc_charlen_type dir_len) +{ + int val; + char *str; + + /* Trim trailing spaces from paths. */ + while (dir_len > 0 && dir[dir_len - 1] == ' ') + dir_len--; + + /* Make a null terminated copy of the strings. */ + str = gfc_alloca (dir_len + 1); + memcpy (str, dir, dir_len); + str[dir_len] = '\0'; + + val = chdir (str); + + if (status != NULL) + *status = (val == 0) ? 0 : errno; +} +iexport(chdir_i8_sub); + +extern GFC_INTEGER_4 chdir_i4 (char *, gfc_charlen_type); +export_proto(chdir_i4); + +GFC_INTEGER_4 +chdir_i4 (char *dir, gfc_charlen_type dir_len) +{ + GFC_INTEGER_4 val; + chdir_i4_sub (dir, &val, dir_len); + return val; +} + +extern GFC_INTEGER_8 chdir_i8 (char *, gfc_charlen_type); +export_proto(chdir_i8); + +GFC_INTEGER_8 +chdir_i8 (char *dir, gfc_charlen_type dir_len) +{ + GFC_INTEGER_8 val; + chdir_i8_sub (dir, &val, dir_len); + return val; +} +#endif diff --git a/gcc-4.4.0/libgfortran/intrinsics/chmod.c b/gcc-4.4.0/libgfortran/intrinsics/chmod.c new file mode 100644 index 000000000..cf768ff00 --- /dev/null +++ b/gcc-4.4.0/libgfortran/intrinsics/chmod.c @@ -0,0 +1,120 @@ +/* Implementation of the CHMOD intrinsic. + Copyright (C) 2006, 2007, 2009 Free Software Foundation, Inc. + Contributed by François-Xavier Coudert <coudert@clipper.ens.fr> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran 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 3 of the License, or (at your option) any later version. + +Libgfortran 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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. */ + +#include "libgfortran.h" + +#include <errno.h> +#include <string.h> + +#ifdef HAVE_UNISTD_H +#include <unistd.h> +#endif +#ifdef HAVE_SYS_WAIT_H +#include <sys/wait.h> +#endif + +/* INTEGER FUNCTION ACCESS(NAME, MODE) + CHARACTER(len=*), INTENT(IN) :: NAME, MODE */ + +#if defined(HAVE_FORK) && defined(HAVE_EXECL) && defined(HAVE_WAIT) + +extern int chmod_func (char *, char *, gfc_charlen_type, gfc_charlen_type); +export_proto(chmod_func); + +int +chmod_func (char *name, char *mode, gfc_charlen_type name_len, + gfc_charlen_type mode_len) +{ + char * file, * m; + pid_t pid; + int status; + + /* Trim trailing spaces. */ + while (name_len > 0 && name[name_len - 1] == ' ') + name_len--; + while (mode_len > 0 && mode[mode_len - 1] == ' ') + mode_len--; + + /* Make a null terminated copy of the strings. */ + file = gfc_alloca (name_len + 1); + memcpy (file, name, name_len); + file[name_len] = '\0'; + + m = gfc_alloca (mode_len + 1); + memcpy (m, mode, mode_len); + m[mode_len]= '\0'; + + /* Execute /bin/chmod. */ + if ((pid = fork()) < 0) + return errno; + if (pid == 0) + { + /* Child process. */ + execl ("/bin/chmod", "chmod", m, file, (char *) NULL); + return errno; + } + else + wait (&status); + + if (WIFEXITED(status)) + return WEXITSTATUS(status); + else + return -1; +} + + + +extern void chmod_i4_sub (char *, char *, GFC_INTEGER_4 *, + gfc_charlen_type, gfc_charlen_type); +export_proto(chmod_i4_sub); + +void +chmod_i4_sub (char *name, char *mode, GFC_INTEGER_4 * status, + gfc_charlen_type name_len, gfc_charlen_type mode_len) +{ + int val; + + val = chmod_func (name, mode, name_len, mode_len); + if (status) + *status = val; +} + + +extern void chmod_i8_sub (char *, char *, GFC_INTEGER_8 *, + gfc_charlen_type, gfc_charlen_type); +export_proto(chmod_i8_sub); + +void +chmod_i8_sub (char *name, char *mode, GFC_INTEGER_8 * status, + gfc_charlen_type name_len, gfc_charlen_type mode_len) +{ + int val; + + val = chmod_func (name, mode, name_len, mode_len); + if (status) + *status = val; +} + +#endif diff --git a/gcc-4.4.0/libgfortran/intrinsics/clock.c b/gcc-4.4.0/libgfortran/intrinsics/clock.c new file mode 100644 index 000000000..b1d61d886 --- /dev/null +++ b/gcc-4.4.0/libgfortran/intrinsics/clock.c @@ -0,0 +1,72 @@ +/* Implementation of the MCLOCK and MCLOCK8 g77 intrinsics. + Copyright (C) 2006, 2007, 2009 Free Software Foundation, Inc. + Contributed by François-Xavier Coudert <coudert@clipper.ens.fr> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran 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 3 of the License, or (at your option) any later version. + +Libgfortran 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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. */ + +#include "libgfortran.h" + +#ifdef TIME_WITH_SYS_TIME +# include <sys/time.h> +# include <time.h> +#else +# if HAVE_SYS_TIME_H +# include <sys/time.h> +# else +# ifdef HAVE_TIME_H +# include <time.h> +# endif +# endif +#endif + + +/* INTEGER(KIND=4) FUNCTION MCLOCK() */ + +extern GFC_INTEGER_4 mclock (void); +export_proto(mclock); + +GFC_INTEGER_4 +mclock (void) +{ +#ifdef HAVE_CLOCK + return (GFC_INTEGER_4) clock (); +#else + return (GFC_INTEGER_4) -1; +#endif +} + + +/* INTEGER(KIND=8) FUNCTION MCLOCK8() */ + +extern GFC_INTEGER_8 mclock8 (void); +export_proto(mclock8); + +GFC_INTEGER_8 +mclock8 (void) +{ +#ifdef HAVE_CLOCK + return (GFC_INTEGER_8) clock (); +#else + return (GFC_INTEGER_8) -1; +#endif +} + diff --git a/gcc-4.4.0/libgfortran/intrinsics/cpu_time.c b/gcc-4.4.0/libgfortran/intrinsics/cpu_time.c new file mode 100644 index 000000000..0ac502340 --- /dev/null +++ b/gcc-4.4.0/libgfortran/intrinsics/cpu_time.c @@ -0,0 +1,137 @@ +/* Implementation of the CPU_TIME intrinsic. + Copyright (C) 2003, 2007, 2009 Free Software Foundation, Inc. + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran 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 3 of the License, or (at your option) any later version. + +Libgfortran 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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. */ + +#include "libgfortran.h" +#include "time_1.h" + +/* The most accurate way to get the CPU time is getrusage (). + If we have times(), that's good enough, too. */ +#if !defined (HAVE_GETRUSAGE) || !defined (HAVE_SYS_RESOURCE_H) +/* For times(), we _must_ know the number of clock ticks per second. */ +# if defined (HAVE_TIMES) && (defined (HZ) || defined (_SC_CLK_TCK) || defined (CLK_TCK)) +# ifdef HAVE_SYS_PARAM_H +# include <sys/param.h> +# endif +# if defined (HAVE_SYS_TIMES_H) +# include <sys/times.h> +# endif +# ifndef HZ +# if defined _SC_CLK_TCK +# define HZ sysconf(_SC_CLK_TCK) +# else +# define HZ CLK_TCK +# endif +# endif +# endif /* HAVE_TIMES etc. */ +#endif /* !HAVE_GETRUSAGE || !HAVE_SYS_RESOURCE_H */ + +static inline void __cpu_time_1 (long *, long *) ATTRIBUTE_ALWAYS_INLINE; + +static inline void +__cpu_time_1 (long *sec, long *usec) +{ +#if defined(__MINGW32__) || defined (HAVE_GETRUSAGE) && defined (HAVE_SYS_RESOURCE_H) + long user_sec, user_usec, system_sec, system_usec; + __time_1 (&user_sec, &user_usec, &system_sec, &system_usec); + *sec = user_sec + system_sec; + *usec = user_usec + system_usec; +#else /* ! HAVE_GETRUSAGE || ! HAVE_SYS_RESOURCE_H */ +#ifdef HAVE_TIMES + struct tms buf; + times (&buf); + *sec = 0; + *usec = (buf.tms_utime + buf.tms_stime) * (1000000 / HZ); +#else /* ! HAVE_TIMES */ + /* We have nothing to go on. Return -1. */ + *sec = -1; + *usec = 0; +#endif /* HAVE_TIMES */ +#endif /* __MINGW32__ || HAVE_GETRUSAGE */ +} + + +extern void cpu_time_4 (GFC_REAL_4 *); +iexport_proto(cpu_time_4); + +void cpu_time_4 (GFC_REAL_4 *time) +{ + long sec, usec; + __cpu_time_1 (&sec, &usec); + *time = sec + usec * (GFC_REAL_4)1.e-6; +} +iexport(cpu_time_4); + +extern void cpu_time_8 (GFC_REAL_8 *); +export_proto(cpu_time_8); + +void cpu_time_8 (GFC_REAL_8 *time) +{ + long sec, usec; + __cpu_time_1 (&sec, &usec); + *time = sec + usec * (GFC_REAL_8)1.e-6; +} + +#ifdef HAVE_GFC_REAL_10 +extern void cpu_time_10 (GFC_REAL_10 *); +export_proto(cpu_time_10); + +void cpu_time_10 (GFC_REAL_10 *time) +{ + long sec, usec; + __cpu_time_1 (&sec, &usec); + *time = sec + usec * (GFC_REAL_10)1.e-6; +} +#endif + +#ifdef HAVE_GFC_REAL_16 +extern void cpu_time_16 (GFC_REAL_16 *); +export_proto(cpu_time_16); + +void cpu_time_16 (GFC_REAL_16 *time) +{ + long sec, usec; + __cpu_time_1 (&sec, &usec); + *time = sec + usec * (GFC_REAL_16)1.e-6; +} +#endif + +extern void second_sub (GFC_REAL_4 *); +export_proto(second_sub); + +void +second_sub (GFC_REAL_4 *s) +{ + cpu_time_4 (s); +} + +extern GFC_REAL_4 second (void); +export_proto(second); + +GFC_REAL_4 +second (void) +{ + GFC_REAL_4 s; + cpu_time_4 (&s); + return s; +} diff --git a/gcc-4.4.0/libgfortran/intrinsics/cshift0.c b/gcc-4.4.0/libgfortran/intrinsics/cshift0.c new file mode 100644 index 000000000..ce49832f3 --- /dev/null +++ b/gcc-4.4.0/libgfortran/intrinsics/cshift0.c @@ -0,0 +1,432 @@ +/* Generic implementation of the CSHIFT intrinsic + Copyright 2003, 2005, 2006, 2007, 2009 Free Software Foundation, Inc. + Contributed by Feng Wang <wf_cs@yahoo.com> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran 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 3 of the License, or (at your option) any later version. + +Libgfortran 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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. */ + +#include "libgfortran.h" +#include <stdlib.h> +#include <assert.h> +#include <string.h> + +static void +cshift0 (gfc_array_char * ret, const gfc_array_char * array, + ssize_t shift, int which, index_type size) +{ + /* r.* indicates the return array. */ + index_type rstride[GFC_MAX_DIMENSIONS]; + index_type rstride0; + index_type roffset; + char *rptr; + + /* s.* indicates the source array. */ + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type sstride0; + index_type soffset; + const char *sptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dim; + index_type len; + index_type n; + index_type arraysize; + + index_type type_size; + + if (which < 1 || which > GFC_DESCRIPTOR_RANK (array)) + runtime_error ("Argument 'DIM' is out of range in call to 'CSHIFT'"); + + arraysize = size0 ((array_t *) array); + + if (ret->data == NULL) + { + int i; + + ret->offset = 0; + ret->dtype = array->dtype; + for (i = 0; i < GFC_DESCRIPTOR_RANK (array); i++) + { + ret->dim[i].lbound = 0; + ret->dim[i].ubound = array->dim[i].ubound - array->dim[i].lbound; + + if (i == 0) + ret->dim[i].stride = 1; + else + ret->dim[i].stride = (ret->dim[i-1].ubound + 1) + * ret->dim[i-1].stride; + } + + if (arraysize > 0) + ret->data = internal_malloc_size (size * arraysize); + else + { + ret->data = internal_malloc_size (1); + return; + } + } + + if (arraysize == 0) + return; + type_size = GFC_DTYPE_TYPE_SIZE (array); + + switch(type_size) + { + case GFC_DTYPE_LOGICAL_1: + case GFC_DTYPE_INTEGER_1: + case GFC_DTYPE_DERIVED_1: + cshift0_i1 ((gfc_array_i1 *)ret, (gfc_array_i1 *) array, shift, which); + return; + + case GFC_DTYPE_LOGICAL_2: + case GFC_DTYPE_INTEGER_2: + cshift0_i2 ((gfc_array_i2 *)ret, (gfc_array_i2 *) array, shift, which); + return; + + case GFC_DTYPE_LOGICAL_4: + case GFC_DTYPE_INTEGER_4: + cshift0_i4 ((gfc_array_i4 *)ret, (gfc_array_i4 *) array, shift, which); + return; + + case GFC_DTYPE_LOGICAL_8: + case GFC_DTYPE_INTEGER_8: + cshift0_i8 ((gfc_array_i8 *)ret, (gfc_array_i8 *) array, shift, which); + return; + +#ifdef HAVE_GFC_INTEGER_16 + case GFC_DTYPE_LOGICAL_16: + case GFC_DTYPE_INTEGER_16: + cshift0_i16 ((gfc_array_i16 *)ret, (gfc_array_i16 *) array, shift, + which); + return; +#endif + + case GFC_DTYPE_REAL_4: + cshift0_r4 ((gfc_array_r4 *)ret, (gfc_array_r4 *) array, shift, which); + return; + + case GFC_DTYPE_REAL_8: + cshift0_r8 ((gfc_array_r8 *)ret, (gfc_array_r8 *) array, shift, which); + return; + +#ifdef HAVE_GFC_REAL_10 + case GFC_DTYPE_REAL_10: + cshift0_r10 ((gfc_array_r10 *)ret, (gfc_array_r10 *) array, shift, + which); + return; +#endif + +#ifdef HAVE_GFC_REAL_16 + case GFC_DTYPE_REAL_16: + cshift0_r16 ((gfc_array_r16 *)ret, (gfc_array_r16 *) array, shift, + which); + return; +#endif + + case GFC_DTYPE_COMPLEX_4: + cshift0_c4 ((gfc_array_c4 *)ret, (gfc_array_c4 *) array, shift, which); + return; + + case GFC_DTYPE_COMPLEX_8: + cshift0_c8 ((gfc_array_c8 *)ret, (gfc_array_c8 *) array, shift, which); + return; + +#ifdef HAVE_GFC_COMPLEX_10 + case GFC_DTYPE_COMPLEX_10: + cshift0_c10 ((gfc_array_c10 *)ret, (gfc_array_c10 *) array, shift, + which); + return; +#endif + +#ifdef HAVE_GFC_COMPLEX_16 + case GFC_DTYPE_COMPLEX_16: + cshift0_c16 ((gfc_array_c16 *)ret, (gfc_array_c16 *) array, shift, + which); + return; +#endif + + default: + break; + } + + switch (size) + { + /* Let's check the actual alignment of the data pointers. If they + are suitably aligned, we can safely call the unpack functions. */ + + case sizeof (GFC_INTEGER_1): + cshift0_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) array, shift, + which); + break; + + case sizeof (GFC_INTEGER_2): + if (GFC_UNALIGNED_2(ret->data) || GFC_UNALIGNED_2(array->data)) + break; + else + { + cshift0_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) array, shift, + which); + return; + } + + case sizeof (GFC_INTEGER_4): + if (GFC_UNALIGNED_4(ret->data) || GFC_UNALIGNED_4(array->data)) + break; + else + { + cshift0_i4 ((gfc_array_i4 *)ret, (gfc_array_i4 *) array, shift, + which); + return; + } + + case sizeof (GFC_INTEGER_8): + if (GFC_UNALIGNED_8(ret->data) || GFC_UNALIGNED_8(array->data)) + { + /* Let's try to use the complex routines. First, a sanity + check that the sizes match; this should be optimized to + a no-op. */ + if (sizeof(GFC_INTEGER_8) != sizeof(GFC_COMPLEX_4)) + break; + + if (GFC_UNALIGNED_C4(ret->data) || GFC_UNALIGNED_C4(array->data)) + break; + + cshift0_c4 ((gfc_array_c4 *) ret, (gfc_array_c4 *) array, shift, + which); + return; + } + else + { + cshift0_i8 ((gfc_array_i8 *)ret, (gfc_array_i8 *) array, shift, + which); + return; + } + +#ifdef HAVE_GFC_INTEGER_16 + case sizeof (GFC_INTEGER_16): + if (GFC_UNALIGNED_16(ret->data) || GFC_UNALIGNED_16(array->data)) + { + /* Let's try to use the complex routines. First, a sanity + check that the sizes match; this should be optimized to + a no-op. */ + if (sizeof(GFC_INTEGER_16) != sizeof(GFC_COMPLEX_8)) + break; + + if (GFC_UNALIGNED_C8(ret->data) || GFC_UNALIGNED_C8(array->data)) + break; + + cshift0_c8 ((gfc_array_c8 *) ret, (gfc_array_c8 *) array, shift, + which); + return; + } + else + { + cshift0_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) array, + shift, which); + return; + } +#else + case sizeof (GFC_COMPLEX_8): + + if (GFC_UNALIGNED_C8(ret->data) || GFC_UNALIGNED_C8(array->data)) + break; + else + { + cshift0_c8 ((gfc_array_c8 *) ret, (gfc_array_c8 *) array, shift, + which); + return; + } +#endif + + default: + break; + } + + + which = which - 1; + sstride[0] = 0; + rstride[0] = 0; + + extent[0] = 1; + count[0] = 0; + n = 0; + /* Initialized for avoiding compiler warnings. */ + roffset = size; + soffset = size; + len = 0; + + for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++) + { + if (dim == which) + { + roffset = ret->dim[dim].stride * size; + if (roffset == 0) + roffset = size; + soffset = array->dim[dim].stride * size; + if (soffset == 0) + soffset = size; + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + } + else + { + count[n] = 0; + extent[n] = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + rstride[n] = ret->dim[dim].stride * size; + sstride[n] = array->dim[dim].stride * size; + n++; + } + } + if (sstride[0] == 0) + sstride[0] = size; + if (rstride[0] == 0) + rstride[0] = size; + + dim = GFC_DESCRIPTOR_RANK (array); + rstride0 = rstride[0]; + sstride0 = sstride[0]; + rptr = ret->data; + sptr = array->data; + + shift = len == 0 ? 0 : shift % (ssize_t)len; + if (shift < 0) + shift += len; + + while (rptr) + { + /* Do the shift for this dimension. */ + + /* If elements are contiguous, perform the operation + in two block moves. */ + if (soffset == size && roffset == size) + { + size_t len1 = shift * size; + size_t len2 = (len - shift) * size; + memcpy (rptr, sptr + len1, len2); + memcpy (rptr + len2, sptr, len1); + } + else + { + /* Otherwise, we'll have to perform the copy one element at + a time. */ + char *dest = rptr; + const char *src = &sptr[shift * soffset]; + + for (n = 0; n < len - shift; n++) + { + memcpy (dest, src, size); + dest += roffset; + src += soffset; + } + for (src = sptr, n = 0; n < shift; n++) + { + memcpy (dest, src, size); + dest += roffset; + src += soffset; + } + } + + /* Advance to the next section. */ + rptr += rstride0; + sptr += sstride0; + count[0]++; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + rptr -= rstride[n] * extent[n]; + sptr -= sstride[n] * extent[n]; + n++; + if (n >= dim - 1) + { + /* Break out of the loop. */ + rptr = NULL; + break; + } + else + { + count[n]++; + rptr += rstride[n]; + sptr += sstride[n]; + } + } + } +} + +#define DEFINE_CSHIFT(N) \ + extern void cshift0_##N (gfc_array_char *, const gfc_array_char *, \ + const GFC_INTEGER_##N *, const GFC_INTEGER_##N *); \ + export_proto(cshift0_##N); \ + \ + void \ + cshift0_##N (gfc_array_char *ret, const gfc_array_char *array, \ + const GFC_INTEGER_##N *pshift, const GFC_INTEGER_##N *pdim) \ + { \ + cshift0 (ret, array, *pshift, pdim ? *pdim : 1, \ + GFC_DESCRIPTOR_SIZE (array)); \ + } \ + \ + extern void cshift0_##N##_char (gfc_array_char *, GFC_INTEGER_4, \ + const gfc_array_char *, \ + const GFC_INTEGER_##N *, \ + const GFC_INTEGER_##N *, GFC_INTEGER_4); \ + export_proto(cshift0_##N##_char); \ + \ + void \ + cshift0_##N##_char (gfc_array_char *ret, \ + GFC_INTEGER_4 ret_length __attribute__((unused)), \ + const gfc_array_char *array, \ + const GFC_INTEGER_##N *pshift, \ + const GFC_INTEGER_##N *pdim, \ + GFC_INTEGER_4 array_length) \ + { \ + cshift0 (ret, array, *pshift, pdim ? *pdim : 1, array_length); \ + } \ + \ + extern void cshift0_##N##_char4 (gfc_array_char *, GFC_INTEGER_4, \ + const gfc_array_char *, \ + const GFC_INTEGER_##N *, \ + const GFC_INTEGER_##N *, GFC_INTEGER_4); \ + export_proto(cshift0_##N##_char4); \ + \ + void \ + cshift0_##N##_char4 (gfc_array_char *ret, \ + GFC_INTEGER_4 ret_length __attribute__((unused)), \ + const gfc_array_char *array, \ + const GFC_INTEGER_##N *pshift, \ + const GFC_INTEGER_##N *pdim, \ + GFC_INTEGER_4 array_length) \ + { \ + cshift0 (ret, array, *pshift, pdim ? *pdim : 1, \ + array_length * sizeof (gfc_char4_t)); \ + } + +DEFINE_CSHIFT (1); +DEFINE_CSHIFT (2); +DEFINE_CSHIFT (4); +DEFINE_CSHIFT (8); +#ifdef HAVE_GFC_INTEGER_16 +DEFINE_CSHIFT (16); +#endif diff --git a/gcc-4.4.0/libgfortran/intrinsics/ctime.c b/gcc-4.4.0/libgfortran/intrinsics/ctime.c new file mode 100644 index 000000000..98bf29d7d --- /dev/null +++ b/gcc-4.4.0/libgfortran/intrinsics/ctime.c @@ -0,0 +1,154 @@ +/* Implementation of the CTIME and FDATE g77 intrinsics. + Copyright (C) 2005, 2007, 2009 Free Software Foundation, Inc. + Contributed by François-Xavier Coudert <coudert@clipper.ens.fr> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran 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 3 of the License, or (at your option) any later version. + +Libgfortran 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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. */ + +#include "libgfortran.h" + +#ifdef TIME_WITH_SYS_TIME +# include <sys/time.h> +# include <time.h> +#else +# if HAVE_SYS_TIME_H +# include <sys/time.h> +# else +# ifdef HAVE_TIME_H +# include <time.h> +# endif +# endif +#endif + +#include <string.h> + + +extern void fdate (char **, gfc_charlen_type *); +export_proto(fdate); + +void +fdate (char ** date, gfc_charlen_type * date_len) +{ +#if defined(HAVE_TIME) && defined(HAVE_CTIME) + int i; + time_t now = time(NULL); + *date = ctime (&now); + if (*date != NULL) + { + *date = strdup (*date); + *date_len = strlen (*date); + + i = 0; + while ((*date)[i]) + { + if ((*date)[i] == '\n') + (*date)[i] = ' '; + i++; + } + return; + } +#endif + + *date = NULL; + *date_len = 0; +} + + +extern void fdate_sub (char *, gfc_charlen_type); +export_proto(fdate_sub); + +void +fdate_sub (char * date, gfc_charlen_type date_len) +{ +#if defined(HAVE_TIME) && defined(HAVE_CTIME) + int i; + char *d; + time_t now = time(NULL); +#endif + + memset (date, ' ', date_len); +#if defined(HAVE_TIME) && defined(HAVE_CTIME) + d = ctime (&now); + if (d != NULL) + { + i = 0; + while (*d && *d != '\n' && i < date_len) + date[i++] = *(d++); + } +#endif +} + + + +extern void PREFIX(ctime) (char **, gfc_charlen_type *, GFC_INTEGER_8); +export_proto_np(PREFIX(ctime)); + +void +PREFIX(ctime) (char ** date, gfc_charlen_type * date_len, GFC_INTEGER_8 t) +{ +#if defined(HAVE_CTIME) + time_t now = t; + int i; + *date = ctime (&now); + if (*date != NULL) + { + *date = strdup (*date); + *date_len = strlen (*date); + + i = 0; + while ((*date)[i]) + { + if ((*date)[i] == '\n') + (*date)[i] = ' '; + i++; + } + return; + } +#endif + + *date = NULL; + *date_len = 0; +} + + +extern void ctime_sub (GFC_INTEGER_8 *, char *, gfc_charlen_type); +export_proto(ctime_sub); + +void +ctime_sub (GFC_INTEGER_8 * t, char * date, gfc_charlen_type date_len) +{ +#if defined(HAVE_CTIME) + int i; + char *d; + time_t now = *t; +#endif + + memset (date, ' ', date_len); +#if defined(HAVE_CTIME) + d = ctime (&now); + if (d != NULL) + { + i = 0; + while (*d && *d != '\n' && i < date_len) + date[i++] = *(d++); + } +#endif +} diff --git a/gcc-4.4.0/libgfortran/intrinsics/date_and_time.c b/gcc-4.4.0/libgfortran/intrinsics/date_and_time.c new file mode 100644 index 000000000..2aac5ecd0 --- /dev/null +++ b/gcc-4.4.0/libgfortran/intrinsics/date_and_time.c @@ -0,0 +1,692 @@ +/* Implementation of the DATE_AND_TIME intrinsic. + Copyright (C) 2003, 2004, 2005, 2006, 2007, 2009 + Free Software Foundation, Inc. + Contributed by Steven Bosscher. + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran 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 3 of the License, or (at your option) any later version. + +Libgfortran 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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. */ + +#include "libgfortran.h" +#include <string.h> +#include <assert.h> +#include <stdlib.h> + +#undef HAVE_NO_DATE_TIME +#if TIME_WITH_SYS_TIME +# include <sys/time.h> +# include <time.h> +#else +# if HAVE_SYS_TIME_H +# include <sys/time.h> +# else +# ifdef HAVE_TIME_H +# include <time.h> +# else +# define HAVE_NO_DATE_TIME +# endif /* HAVE_TIME_H */ +# endif /* HAVE_SYS_TIME_H */ +#endif /* TIME_WITH_SYS_TIME */ + +#ifndef abs +#define abs(x) ((x)>=0 ? (x) : -(x)) +#endif + +/* DATE_AND_TIME ([DATE, TIME, ZONE, VALUES]) + + Description: Returns data on the real-time clock and date in a form + compatible with the representations defined in ISO 8601:1988. + + Class: Non-elemental subroutine. + + Arguments: + + DATE (optional) shall be scalar and of type default character, and + shall be of length at least 8 in order to contain the complete + value. It is an INTENT(OUT) argument. Its leftmost 8 characters + are assigned a value of the form CCYYMMDD, where CC is the century, + YY the year within the century, MM the month within the year, and + DD the day within the month. If there is no date available, they + are assigned blanks. + + TIME (optional) shall be scalar and of type default character, and + shall be of length at least 10 in order to contain the complete + value. It is an INTENT(OUT) argument. Its leftmost 10 characters + are assigned a value of the form hhmmss.sss, where hh is the hour + of the day, mm is the minutes of the hour, and ss.sss is the + seconds and milliseconds of the minute. If there is no clock + available, they are assigned blanks. + + ZONE (optional) shall be scalar and of type default character, and + shall be of length at least 5 in order to contain the complete + value. It is an INTENT(OUT) argument. Its leftmost 5 characters + are assigned a value of the form [+-]hhmm, where hh and mm are the + time difference with respect to Coordinated Universal Time (UTC) in + hours and parts of an hour expressed in minutes, respectively. If + there is no clock available, they are assigned blanks. + + VALUES (optional) shall be of type default integer and of rank + one. It is an INTENT(OUT) argument. Its size shall be at least + 8. The values returned in VALUES are as follows: + + VALUES(1) the year (for example, 2003), or -HUGE(0) if there is + no date available; + + VALUES(2) the month of the year, or -HUGE(0) if there + is no date available; + + VALUES(3) the day of the month, or -HUGE(0) if there is no date + available; + + VALUES(4) the time difference with respect to Coordinated + Universal Time (UTC) in minutes, or -HUGE(0) if this information + is not available; + + VALUES(5) the hour of the day, in the range of 0 to 23, or + -HUGE(0) if there is no clock; + + VALUES(6) the minutes of the hour, in the range 0 to 59, or + -HUGE(0) if there is no clock; + + VALUES(7) the seconds of the minute, in the range 0 to 60, or + -HUGE(0) if there is no clock; + + VALUES(8) the milliseconds of the second, in the range 0 to + 999, or -HUGE(0) if there is no clock. + + NULL pointer represent missing OPTIONAL arguments. All arguments + have INTENT(OUT). Because of the -i8 option, we must implement + VALUES for INTEGER(kind=4) and INTEGER(kind=8). + + Based on libU77's date_time_.c. + + TODO : + - Check year boundaries. +*/ +#define DATE_LEN 8 +#define TIME_LEN 10 +#define ZONE_LEN 5 +#define VALUES_SIZE 8 + +extern void date_and_time (char *, char *, char *, gfc_array_i4 *, + GFC_INTEGER_4, GFC_INTEGER_4, GFC_INTEGER_4); +export_proto(date_and_time); + +void +date_and_time (char *__date, char *__time, char *__zone, + gfc_array_i4 *__values, GFC_INTEGER_4 __date_len, + GFC_INTEGER_4 __time_len, GFC_INTEGER_4 __zone_len) +{ + int i; + char date[DATE_LEN + 1]; + char timec[TIME_LEN + 1]; + char zone[ZONE_LEN + 1]; + GFC_INTEGER_4 values[VALUES_SIZE]; + +#ifndef HAVE_NO_DATE_TIME + time_t lt; + struct tm local_time; + struct tm UTC_time; + +#if HAVE_GETTIMEOFDAY + { + struct timeval tp; + + if (!gettimeofday (&tp, NULL)) + { + lt = tp.tv_sec; + values[7] = tp.tv_usec / 1000; + } + else + { + lt = time (NULL); + values[7] = 0; + } + } +#else + lt = time (NULL); + values[7] = 0; +#endif /* HAVE_GETTIMEOFDAY */ + + if (lt != (time_t) -1) + { + local_time = *localtime (<); + UTC_time = *gmtime (<); + + /* All arguments can be derived from VALUES. */ + values[0] = 1900 + local_time.tm_year; + values[1] = 1 + local_time.tm_mon; + values[2] = local_time.tm_mday; + values[3] = (local_time.tm_min - UTC_time.tm_min + + 60 * (local_time.tm_hour - UTC_time.tm_hour + + 24 * (local_time.tm_yday - UTC_time.tm_yday))); + values[4] = local_time.tm_hour; + values[5] = local_time.tm_min; + values[6] = local_time.tm_sec; + +#if HAVE_SNPRINTF + if (__date) + snprintf (date, DATE_LEN + 1, "%04d%02d%02d", + values[0], values[1], values[2]); + if (__time) + snprintf (timec, TIME_LEN + 1, "%02d%02d%02d.%03d", + values[4], values[5], values[6], values[7]); + + if (__zone) + snprintf (zone, ZONE_LEN + 1, "%+03d%02d", + values[3] / 60, abs (values[3] % 60)); +#else + if (__date) + sprintf (date, "%04d%02d%02d", values[0], values[1], values[2]); + + if (__time) + sprintf (timec, "%02d%02d%02d.%03d", + values[4], values[5], values[6], values[7]); + + if (__zone) + sprintf (zone, "%+03d%02d", + values[3] / 60, abs (values[3] % 60)); +#endif + } + else + { + memset (date, ' ', DATE_LEN); + date[DATE_LEN] = '\0'; + + memset (timec, ' ', TIME_LEN); + timec[TIME_LEN] = '\0'; + + memset (zone, ' ', ZONE_LEN); + zone[ZONE_LEN] = '\0'; + + for (i = 0; i < VALUES_SIZE; i++) + values[i] = - GFC_INTEGER_4_HUGE; + } +#else /* if defined HAVE_NO_DATE_TIME */ + /* We really have *nothing* to return, so return blanks and HUGE(0). */ + + memset (date, ' ', DATE_LEN); + date[DATE_LEN] = '\0'; + + memset (timec, ' ', TIME_LEN); + timec[TIME_LEN] = '\0'; + + memset (zone, ' ', ZONE_LEN); + zone[ZONE_LEN] = '\0'; + + for (i = 0; i < VALUES_SIZE; i++) + values[i] = - GFC_INTEGER_4_HUGE; +#endif /* HAVE_NO_DATE_TIME */ + + /* Copy the values into the arguments. */ + if (__values) + { + size_t len, delta, elt_size; + + elt_size = GFC_DESCRIPTOR_SIZE (__values); + len = __values->dim[0].ubound + 1 - __values->dim[0].lbound; + delta = __values->dim[0].stride; + if (delta == 0) + delta = 1; + + assert (len >= VALUES_SIZE); + /* Cope with different type kinds. */ + if (elt_size == 4) + { + GFC_INTEGER_4 *vptr4 = __values->data; + + for (i = 0; i < VALUES_SIZE; i++, vptr4 += delta) + *vptr4 = values[i]; + } + else if (elt_size == 8) + { + GFC_INTEGER_8 *vptr8 = (GFC_INTEGER_8 *)__values->data; + + for (i = 0; i < VALUES_SIZE; i++, vptr8 += delta) + { + if (values[i] == - GFC_INTEGER_4_HUGE) + *vptr8 = - GFC_INTEGER_8_HUGE; + else + *vptr8 = values[i]; + } + } + else + abort (); + } + + if (__zone) + { + assert (__zone_len >= ZONE_LEN); + fstrcpy (__zone, ZONE_LEN, zone, ZONE_LEN); + } + + if (__time) + { + assert (__time_len >= TIME_LEN); + fstrcpy (__time, TIME_LEN, timec, TIME_LEN); + } + + if (__date) + { + assert (__date_len >= DATE_LEN); + fstrcpy (__date, DATE_LEN, date, DATE_LEN); + } +} + + +/* SECNDS (X) - Non-standard + + Description: Returns the system time of day, or elapsed time, as a GFC_REAL_4 + in seconds. + + Class: Non-elemental subroutine. + + Arguments: + + X must be REAL(4) and the result is of the same type. The accuracy is system + dependent. + + Usage: + + T = SECNDS (X) + + yields the time in elapsed seconds since X. If X is 0.0, T is the time in + seconds since midnight. Note that a time that spans midnight but is less than + 24hours will be calculated correctly. */ + +extern GFC_REAL_4 secnds (GFC_REAL_4 *); +export_proto(secnds); + +GFC_REAL_4 +secnds (GFC_REAL_4 *x) +{ + GFC_INTEGER_4 values[VALUES_SIZE]; + GFC_REAL_4 temp1, temp2; + + /* Make the INTEGER*4 array for passing to date_and_time. */ + gfc_array_i4 *avalues = internal_malloc_size (sizeof (gfc_array_i4)); + avalues->data = &values[0]; + GFC_DESCRIPTOR_DTYPE (avalues) = ((GFC_DTYPE_REAL << GFC_DTYPE_TYPE_SHIFT) + & GFC_DTYPE_TYPE_MASK) + + (4 << GFC_DTYPE_SIZE_SHIFT); + + avalues->dim[0].ubound = 7; + avalues->dim[0].lbound = 0; + avalues->dim[0].stride = 1; + + date_and_time (NULL, NULL, NULL, avalues, 0, 0, 0); + + free_mem (avalues); + + temp1 = 3600.0 * (GFC_REAL_4)values[4] + + 60.0 * (GFC_REAL_4)values[5] + + (GFC_REAL_4)values[6] + + 0.001 * (GFC_REAL_4)values[7]; + temp2 = fmod (*x, 86400.0); + temp2 = (temp1 - temp2 >= 0.0) ? temp2 : (temp2 - 86400.0); + return temp1 - temp2; +} + + + +/* ITIME(X) - Non-standard + + Description: Returns the current local time hour, minutes, and seconds + in elements 1, 2, and 3 of X, respectively. */ + +static void +itime0 (int x[3]) +{ +#ifndef HAVE_NO_DATE_TIME + time_t lt; + struct tm local_time; + + lt = time (NULL); + + if (lt != (time_t) -1) + { + local_time = *localtime (<); + + x[0] = local_time.tm_hour; + x[1] = local_time.tm_min; + x[2] = local_time.tm_sec; + } +#else + x[0] = x[1] = x[2] = -1; +#endif +} + +extern void itime_i4 (gfc_array_i4 *); +export_proto(itime_i4); + +void +itime_i4 (gfc_array_i4 *__values) +{ + int x[3], i; + size_t len, delta; + GFC_INTEGER_4 *vptr; + + /* Call helper function. */ + itime0(x); + + /* Copy the value into the array. */ + len = __values->dim[0].ubound + 1 - __values->dim[0].lbound; + assert (len >= 3); + delta = __values->dim[0].stride; + if (delta == 0) + delta = 1; + + vptr = __values->data; + for (i = 0; i < 3; i++, vptr += delta) + *vptr = x[i]; +} + + +extern void itime_i8 (gfc_array_i8 *); +export_proto(itime_i8); + +void +itime_i8 (gfc_array_i8 *__values) +{ + int x[3], i; + size_t len, delta; + GFC_INTEGER_8 *vptr; + + /* Call helper function. */ + itime0(x); + + /* Copy the value into the array. */ + len = __values->dim[0].ubound + 1 - __values->dim[0].lbound; + assert (len >= 3); + delta = __values->dim[0].stride; + if (delta == 0) + delta = 1; + + vptr = __values->data; + for (i = 0; i < 3; i++, vptr += delta) + *vptr = x[i]; +} + + + +/* IDATE(X) - Non-standard + + Description: Fills TArray with the numerical values at the current + local time. The day (in the range 1-31), month (in the range 1-12), + and year appear in elements 1, 2, and 3 of X, respectively. + The year has four significant digits. */ + +static void +idate0 (int x[3]) +{ +#ifndef HAVE_NO_DATE_TIME + time_t lt; + struct tm local_time; + + lt = time (NULL); + + if (lt != (time_t) -1) + { + local_time = *localtime (<); + + x[0] = local_time.tm_mday; + x[1] = 1 + local_time.tm_mon; + x[2] = 1900 + local_time.tm_year; + } +#else + x[0] = x[1] = x[2] = -1; +#endif +} + +extern void idate_i4 (gfc_array_i4 *); +export_proto(idate_i4); + +void +idate_i4 (gfc_array_i4 *__values) +{ + int x[3], i; + size_t len, delta; + GFC_INTEGER_4 *vptr; + + /* Call helper function. */ + idate0(x); + + /* Copy the value into the array. */ + len = __values->dim[0].ubound + 1 - __values->dim[0].lbound; + assert (len >= 3); + delta = __values->dim[0].stride; + if (delta == 0) + delta = 1; + + vptr = __values->data; + for (i = 0; i < 3; i++, vptr += delta) + *vptr = x[i]; +} + + +extern void idate_i8 (gfc_array_i8 *); +export_proto(idate_i8); + +void +idate_i8 (gfc_array_i8 *__values) +{ + int x[3], i; + size_t len, delta; + GFC_INTEGER_8 *vptr; + + /* Call helper function. */ + idate0(x); + + /* Copy the value into the array. */ + len = __values->dim[0].ubound + 1 - __values->dim[0].lbound; + assert (len >= 3); + delta = __values->dim[0].stride; + if (delta == 0) + delta = 1; + + vptr = __values->data; + for (i = 0; i < 3; i++, vptr += delta) + *vptr = x[i]; +} + + + +/* GMTIME(STIME, TARRAY) - Non-standard + + Description: Given a system time value STime, fills TArray with values + extracted from it appropriate to the GMT time zone using gmtime(3). + + The array elements are as follows: + + 1. Seconds after the minute, range 0-59 or 0-61 to allow for leap seconds + 2. Minutes after the hour, range 0-59 + 3. Hours past midnight, range 0-23 + 4. Day of month, range 0-31 + 5. Number of months since January, range 0-11 + 6. Years since 1900 + 7. Number of days since Sunday, range 0-6 + 8. Days since January 1 + 9. Daylight savings indicator: positive if daylight savings is in effect, + zero if not, and negative if the information isn't available. */ + +static void +gmtime_0 (const time_t * t, int x[9]) +{ + struct tm lt; + + lt = *gmtime (t); + x[0] = lt.tm_sec; + x[1] = lt.tm_min; + x[2] = lt.tm_hour; + x[3] = lt.tm_mday; + x[4] = lt.tm_mon; + x[5] = lt.tm_year; + x[6] = lt.tm_wday; + x[7] = lt.tm_yday; + x[8] = lt.tm_isdst; +} + +extern void gmtime_i4 (GFC_INTEGER_4 *, gfc_array_i4 *); +export_proto(gmtime_i4); + +void +gmtime_i4 (GFC_INTEGER_4 * t, gfc_array_i4 * tarray) +{ + int x[9], i; + size_t len, delta; + GFC_INTEGER_4 *vptr; + time_t tt; + + /* Call helper function. */ + tt = (time_t) *t; + gmtime_0(&tt, x); + + /* Copy the values into the array. */ + len = tarray->dim[0].ubound + 1 - tarray->dim[0].lbound; + assert (len >= 9); + delta = tarray->dim[0].stride; + if (delta == 0) + delta = 1; + + vptr = tarray->data; + for (i = 0; i < 9; i++, vptr += delta) + *vptr = x[i]; +} + +extern void gmtime_i8 (GFC_INTEGER_8 *, gfc_array_i8 *); +export_proto(gmtime_i8); + +void +gmtime_i8 (GFC_INTEGER_8 * t, gfc_array_i8 * tarray) +{ + int x[9], i; + size_t len, delta; + GFC_INTEGER_8 *vptr; + time_t tt; + + /* Call helper function. */ + tt = (time_t) *t; + gmtime_0(&tt, x); + + /* Copy the values into the array. */ + len = tarray->dim[0].ubound + 1 - tarray->dim[0].lbound; + assert (len >= 9); + delta = tarray->dim[0].stride; + if (delta == 0) + delta = 1; + + vptr = tarray->data; + for (i = 0; i < 9; i++, vptr += delta) + *vptr = x[i]; +} + + + + +/* LTIME(STIME, TARRAY) - Non-standard + + Description: Given a system time value STime, fills TArray with values + extracted from it appropriate to the local time zone using localtime(3). + + The array elements are as follows: + + 1. Seconds after the minute, range 0-59 or 0-61 to allow for leap seconds + 2. Minutes after the hour, range 0-59 + 3. Hours past midnight, range 0-23 + 4. Day of month, range 0-31 + 5. Number of months since January, range 0-11 + 6. Years since 1900 + 7. Number of days since Sunday, range 0-6 + 8. Days since January 1 + 9. Daylight savings indicator: positive if daylight savings is in effect, + zero if not, and negative if the information isn't available. */ + +static void +ltime_0 (const time_t * t, int x[9]) +{ + struct tm lt; + + lt = *localtime (t); + x[0] = lt.tm_sec; + x[1] = lt.tm_min; + x[2] = lt.tm_hour; + x[3] = lt.tm_mday; + x[4] = lt.tm_mon; + x[5] = lt.tm_year; + x[6] = lt.tm_wday; + x[7] = lt.tm_yday; + x[8] = lt.tm_isdst; +} + +extern void ltime_i4 (GFC_INTEGER_4 *, gfc_array_i4 *); +export_proto(ltime_i4); + +void +ltime_i4 (GFC_INTEGER_4 * t, gfc_array_i4 * tarray) +{ + int x[9], i; + size_t len, delta; + GFC_INTEGER_4 *vptr; + time_t tt; + + /* Call helper function. */ + tt = (time_t) *t; + ltime_0(&tt, x); + + /* Copy the values into the array. */ + len = tarray->dim[0].ubound + 1 - tarray->dim[0].lbound; + assert (len >= 9); + delta = tarray->dim[0].stride; + if (delta == 0) + delta = 1; + + vptr = tarray->data; + for (i = 0; i < 9; i++, vptr += delta) + *vptr = x[i]; +} + +extern void ltime_i8 (GFC_INTEGER_8 *, gfc_array_i8 *); +export_proto(ltime_i8); + +void +ltime_i8 (GFC_INTEGER_8 * t, gfc_array_i8 * tarray) +{ + int x[9], i; + size_t len, delta; + GFC_INTEGER_8 *vptr; + time_t tt; + + /* Call helper function. */ + tt = (time_t) * t; + ltime_0(&tt, x); + + /* Copy the values into the array. */ + len = tarray->dim[0].ubound + 1 - tarray->dim[0].lbound; + assert (len >= 9); + delta = tarray->dim[0].stride; + if (delta == 0) + delta = 1; + + vptr = tarray->data; + for (i = 0; i < 9; i++, vptr += delta) + *vptr = x[i]; +} + + diff --git a/gcc-4.4.0/libgfortran/intrinsics/dprod_r8.f90 b/gcc-4.4.0/libgfortran/intrinsics/dprod_r8.f90 new file mode 100644 index 000000000..7eb0ede01 --- /dev/null +++ b/gcc-4.4.0/libgfortran/intrinsics/dprod_r8.f90 @@ -0,0 +1,32 @@ +! Copyright 2003, 2009 Free Software Foundation, Inc. +! Contributed by Paul Brook <paul@nowt.org> +! +!This file is part of the GNU Fortran 95 runtime library (libgfortran). +! +!Libgfortran 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 3 of the License, or (at your option) any later version. +! +!Libgfortran 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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!<http://www.gnu.org/licenses/>. + + +elemental function _gfortran_specific__dprod_r8 (p1, p2) + implicit none + real (kind=4), intent (in) :: p1, p2 + real (kind=8) :: _gfortran_specific__dprod_r8 + + _gfortran_specific__dprod_r8 = dprod (p1, p2) +end function diff --git a/gcc-4.4.0/libgfortran/intrinsics/dtime.c b/gcc-4.4.0/libgfortran/intrinsics/dtime.c new file mode 100644 index 000000000..40028a689 --- /dev/null +++ b/gcc-4.4.0/libgfortran/intrinsics/dtime.c @@ -0,0 +1,81 @@ +/* Implementation of the dtime intrinsic. + Copyright (C) 2004, 2005, 2006, 2007, 2009 Free Software Foundation, Inc. + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran 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 3 of the License, or (at your option) any later version. + +Libgfortran 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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. */ + +#include "libgfortran.h" +#include "time_1.h" +#include <gthr.h> + +#ifdef __GTHREAD_MUTEX_INIT +static __gthread_mutex_t dtime_update_lock = __GTHREAD_MUTEX_INIT; +#else +static __gthread_mutex_t dtime_update_lock; +#endif + +extern void dtime_sub (gfc_array_r4 *t, GFC_REAL_4 *result); +iexport_proto(dtime_sub); + +void +dtime_sub (gfc_array_r4 *t, GFC_REAL_4 *result) +{ + static GFC_REAL_4 tu = 0.0, ts = 0.0, tt = 0.0; + GFC_REAL_4 *tp; + long user_sec, user_usec, system_sec, system_usec; + + if (((t->dim[0].ubound + 1 - t->dim[0].lbound)) < 2) + runtime_error ("Insufficient number of elements in TARRAY."); + + __gthread_mutex_lock (&dtime_update_lock); + if (__time_1 (&user_sec, &user_usec, &system_sec, &system_usec) == 0) + { + tu = (GFC_REAL_4)(user_sec + 1.e-6 * user_usec) - tu; + ts = (GFC_REAL_4)(system_sec + 1.e-6 * system_usec) - ts; + tt = tu + ts; + } + else + { + tu = (GFC_REAL_4)-1.0; + ts = (GFC_REAL_4)-1.0; + tt = (GFC_REAL_4)-1.0; + } + + tp = t->data; + + *tp = tu; + tp += t->dim[0].stride; + *tp = ts; + *result = tt; + __gthread_mutex_unlock (&dtime_update_lock); +} +iexport(dtime_sub); + +extern GFC_REAL_4 dtime (gfc_array_r4 *t); +export_proto(dtime); + +GFC_REAL_4 +dtime (gfc_array_r4 *t) +{ + GFC_REAL_4 val; + dtime_sub (t, &val); + return val; +} diff --git a/gcc-4.4.0/libgfortran/intrinsics/env.c b/gcc-4.4.0/libgfortran/intrinsics/env.c new file mode 100644 index 000000000..883603848 --- /dev/null +++ b/gcc-4.4.0/libgfortran/intrinsics/env.c @@ -0,0 +1,195 @@ +/* Implementation of the GETENV g77, and + GET_ENVIRONMENT_VARIABLE F2003, intrinsics. + Copyright (C) 2004, 2007, 2009 Free Software Foundation, Inc. + Contributed by Janne Blomqvist. + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran 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 3 of the License, or (at your option) any later version. + +Libgfortran 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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. */ + +#include "libgfortran.h" +#include <stdlib.h> +#include <string.h> + + +/* GETENV (NAME, VALUE), g77 intrinsic for retrieving the value of + an environment variable. The name of the variable is specified in + NAME, and the result is stored into VALUE. */ + +void PREFIX(getenv) (char *, char *, gfc_charlen_type, gfc_charlen_type); +export_proto_np(PREFIX(getenv)); + +void +PREFIX(getenv) (char * name, char * value, gfc_charlen_type name_len, + gfc_charlen_type value_len) +{ + char *name_nt; + char *res = NULL; + int res_len; + + if (name == NULL || value == NULL) + runtime_error ("Both arguments to getenv are mandatory."); + + if (value_len < 1 || name_len < 1) + runtime_error ("Zero length string(s) passed to getenv."); + else + memset (value, ' ', value_len); /* Blank the string. */ + + /* Trim trailing spaces from name. */ + while (name_len > 0 && name[name_len - 1] == ' ') + name_len--; + + /* Make a null terminated copy of the string. */ + name_nt = gfc_alloca (name_len + 1); + memcpy (name_nt, name, name_len); + name_nt[name_len] = '\0'; + + res = getenv(name_nt); + + /* If res is NULL, it means that the environment variable didn't + exist, so just return. */ + if (res == NULL) + return; + + res_len = strlen(res); + if (value_len < res_len) + memcpy (value, res, value_len); + else + memcpy (value, res, res_len); +} + + +/* GET_ENVIRONMENT_VARIABLE (name, [value, length, status, trim_name]) + is a F2003 intrinsic for getting an environment variable. */ + +/* Status codes specifyed by the standard. */ +#define GFC_SUCCESS 0 +#define GFC_VALUE_TOO_SHORT -1 +#define GFC_NAME_DOES_NOT_EXIST 1 + +/* This is also specified by the standard and means that the + processor doesn't support environment variables. At the moment, + gfortran doesn't use it. */ +#define GFC_NOT_SUPPORTED 2 + +/* Processor-specific failure code. */ +#define GFC_FAILURE 42 + +extern void get_environment_variable_i4 (char *, char *, GFC_INTEGER_4 *, + GFC_INTEGER_4 *, GFC_LOGICAL_4 *, + gfc_charlen_type, gfc_charlen_type); +iexport_proto(get_environment_variable_i4); + +void +get_environment_variable_i4 (char *name, char *value, GFC_INTEGER_4 *length, + GFC_INTEGER_4 *status, GFC_LOGICAL_4 *trim_name, + gfc_charlen_type name_len, + gfc_charlen_type value_len) +{ + int stat = GFC_SUCCESS, res_len = 0; + char *name_nt; + char *res; + + if (name == NULL) + runtime_error ("Name is required for get_environment_variable."); + + if (value == NULL && length == NULL && status == NULL && trim_name == NULL) + return; + + if (name_len < 1) + runtime_error ("Zero-length string passed as name to " + "get_environment_variable."); + + if (value != NULL) + { + if (value_len < 1) + runtime_error ("Zero-length string passed as value to " + "get_environment_variable."); + else + memset (value, ' ', value_len); /* Blank the string. */ + } + + if ((!trim_name) || *trim_name) + { + /* Trim trailing spaces from name. */ + while (name_len > 0 && name[name_len - 1] == ' ') + name_len--; + } + /* Make a null terminated copy of the name. */ + name_nt = gfc_alloca (name_len + 1); + memcpy (name_nt, name, name_len); + name_nt[name_len] = '\0'; + + res = getenv(name_nt); + + if (res == NULL) + stat = GFC_NAME_DOES_NOT_EXIST; + else + { + res_len = strlen(res); + if (value != NULL) + { + if (value_len < res_len) + { + memcpy (value, res, value_len); + stat = GFC_VALUE_TOO_SHORT; + } + else + memcpy (value, res, res_len); + } + } + + if (status != NULL) + *status = stat; + + if (length != NULL) + *length = res_len; +} +iexport(get_environment_variable_i4); + + +/* INTEGER*8 wrapper for get_environment_variable. */ + +extern void get_environment_variable_i8 (char *, char *, GFC_INTEGER_8 *, + GFC_INTEGER_8 *, GFC_LOGICAL_8 *, + gfc_charlen_type, gfc_charlen_type); +export_proto(get_environment_variable_i8); + +void +get_environment_variable_i8 (char *name, char *value, GFC_INTEGER_8 *length, + GFC_INTEGER_8 *status, GFC_LOGICAL_8 *trim_name, + gfc_charlen_type name_len, + gfc_charlen_type value_len) +{ + GFC_INTEGER_4 length4, status4; + GFC_LOGICAL_4 trim_name4; + + if (trim_name) + trim_name4 = *trim_name; + + get_environment_variable_i4 (name, value, &length4, &status4, + &trim_name4, name_len, value_len); + + if (length) + *length = length4; + + if (status) + *status = status4; +} diff --git a/gcc-4.4.0/libgfortran/intrinsics/eoshift0.c b/gcc-4.4.0/libgfortran/intrinsics/eoshift0.c new file mode 100644 index 000000000..6ac7c94a7 --- /dev/null +++ b/gcc-4.4.0/libgfortran/intrinsics/eoshift0.c @@ -0,0 +1,286 @@ +/* Generic implementation of the EOSHIFT intrinsic + Copyright 2002, 2005, 2007, 2009 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran 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 3 of the License, or (at your option) any later version. + +Libgfortran 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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. */ + +#include "libgfortran.h" +#include <stdlib.h> +#include <assert.h> +#include <string.h> + +/* TODO: make this work for large shifts when + sizeof(int) < sizeof (index_type). */ + +static void +eoshift0 (gfc_array_char * ret, const gfc_array_char * array, + int shift, const char * pbound, int which, index_type size, + const char *filler, index_type filler_len) +{ + /* r.* indicates the return array. */ + index_type rstride[GFC_MAX_DIMENSIONS]; + index_type rstride0; + index_type roffset; + char * restrict rptr; + char *dest; + /* s.* indicates the source array. */ + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type sstride0; + index_type soffset; + const char *sptr; + const char *src; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dim; + index_type len; + index_type n; + + /* The compiler cannot figure out that these are set, initialize + them to avoid warnings. */ + len = 0; + soffset = 0; + roffset = 0; + + if (ret->data == NULL) + { + int i; + + ret->data = internal_malloc_size (size * size0 ((array_t *)array)); + ret->offset = 0; + ret->dtype = array->dtype; + for (i = 0; i < GFC_DESCRIPTOR_RANK (array); i++) + { + ret->dim[i].lbound = 0; + ret->dim[i].ubound = array->dim[i].ubound - array->dim[i].lbound; + + if (i == 0) + ret->dim[i].stride = 1; + else + ret->dim[i].stride = (ret->dim[i-1].ubound + 1) * ret->dim[i-1].stride; + } + } + else + { + if (size0 ((array_t *) ret) == 0) + return; + } + + which = which - 1; + + extent[0] = 1; + count[0] = 0; + sstride[0] = -1; + rstride[0] = -1; + n = 0; + for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++) + { + if (dim == which) + { + roffset = ret->dim[dim].stride * size; + if (roffset == 0) + roffset = size; + soffset = array->dim[dim].stride * size; + if (soffset == 0) + soffset = size; + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + } + else + { + count[n] = 0; + extent[n] = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + rstride[n] = ret->dim[dim].stride * size; + sstride[n] = array->dim[dim].stride * size; + n++; + } + } + if (sstride[0] == 0) + sstride[0] = size; + if (rstride[0] == 0) + rstride[0] = size; + + dim = GFC_DESCRIPTOR_RANK (array); + rstride0 = rstride[0]; + sstride0 = sstride[0]; + rptr = ret->data; + sptr = array->data; + + if ((shift >= 0 ? shift : -shift) > len) + { + shift = len; + len = 0; + } + else + { + if (shift > 0) + len = len - shift; + else + len = len + shift; + } + + while (rptr) + { + /* Do the shift for this dimension. */ + if (shift > 0) + { + src = &sptr[shift * soffset]; + dest = rptr; + } + else + { + src = sptr; + dest = &rptr[-shift * roffset]; + } + for (n = 0; n < len; n++) + { + memcpy (dest, src, size); + dest += roffset; + src += soffset; + } + if (shift >= 0) + { + n = shift; + } + else + { + dest = rptr; + n = -shift; + } + + if (pbound) + while (n--) + { + memcpy (dest, pbound, size); + dest += roffset; + } + else + while (n--) + { + index_type i; + + if (filler_len == 1) + memset (dest, filler[0], size); + else + for (i = 0; i < size ; i += filler_len) + memcpy (&dest[i], filler, filler_len); + + dest += roffset; + } + + /* Advance to the next section. */ + rptr += rstride0; + sptr += sstride0; + count[0]++; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + rptr -= rstride[n] * extent[n]; + sptr -= sstride[n] * extent[n]; + n++; + if (n >= dim - 1) + { + /* Break out of the loop. */ + rptr = NULL; + break; + } + else + { + count[n]++; + rptr += rstride[n]; + sptr += sstride[n]; + } + } + } +} + + +#define DEFINE_EOSHIFT(N) \ + extern void eoshift0_##N (gfc_array_char *, const gfc_array_char *, \ + const GFC_INTEGER_##N *, const char *, \ + const GFC_INTEGER_##N *); \ + export_proto(eoshift0_##N); \ + \ + void \ + eoshift0_##N (gfc_array_char *ret, const gfc_array_char *array, \ + const GFC_INTEGER_##N *pshift, const char *pbound, \ + const GFC_INTEGER_##N *pdim) \ + { \ + eoshift0 (ret, array, *pshift, pbound, pdim ? *pdim : 1, \ + GFC_DESCRIPTOR_SIZE (array), "\0", 1); \ + } \ + \ + extern void eoshift0_##N##_char (gfc_array_char *, GFC_INTEGER_4, \ + const gfc_array_char *, \ + const GFC_INTEGER_##N *, const char *, \ + const GFC_INTEGER_##N *, GFC_INTEGER_4, \ + GFC_INTEGER_4); \ + export_proto(eoshift0_##N##_char); \ + \ + void \ + eoshift0_##N##_char (gfc_array_char *ret, \ + GFC_INTEGER_4 ret_length __attribute__((unused)), \ + const gfc_array_char *array, \ + const GFC_INTEGER_##N *pshift, \ + const char *pbound, \ + const GFC_INTEGER_##N *pdim, \ + GFC_INTEGER_4 array_length, \ + GFC_INTEGER_4 bound_length __attribute__((unused))) \ + { \ + eoshift0 (ret, array, *pshift, pbound, pdim ? *pdim : 1, \ + array_length, " ", 1); \ + } \ + \ + extern void eoshift0_##N##_char4 (gfc_array_char *, GFC_INTEGER_4, \ + const gfc_array_char *, \ + const GFC_INTEGER_##N *, const char *, \ + const GFC_INTEGER_##N *, GFC_INTEGER_4, \ + GFC_INTEGER_4); \ + export_proto(eoshift0_##N##_char4); \ + \ + void \ + eoshift0_##N##_char4 (gfc_array_char *ret, \ + GFC_INTEGER_4 ret_length __attribute__((unused)), \ + const gfc_array_char *array, \ + const GFC_INTEGER_##N *pshift, \ + const char *pbound, \ + const GFC_INTEGER_##N *pdim, \ + GFC_INTEGER_4 array_length, \ + GFC_INTEGER_4 bound_length __attribute__((unused))) \ + { \ + static const gfc_char4_t space = (unsigned char) ' '; \ + eoshift0 (ret, array, *pshift, pbound, pdim ? *pdim : 1, \ + array_length * sizeof (gfc_char4_t), (const char *) &space, \ + sizeof (gfc_char4_t)); \ + } + +DEFINE_EOSHIFT (1); +DEFINE_EOSHIFT (2); +DEFINE_EOSHIFT (4); +DEFINE_EOSHIFT (8); +#ifdef HAVE_GFC_INTEGER_16 +DEFINE_EOSHIFT (16); +#endif diff --git a/gcc-4.4.0/libgfortran/intrinsics/eoshift2.c b/gcc-4.4.0/libgfortran/intrinsics/eoshift2.c new file mode 100644 index 000000000..763545a63 --- /dev/null +++ b/gcc-4.4.0/libgfortran/intrinsics/eoshift2.c @@ -0,0 +1,314 @@ +/* Generic implementation of the EOSHIFT intrinsic + Copyright 2002, 2005, 2007, 2009 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran 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 3 of the License, or (at your option) any later version. + +Ligbfortran 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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. */ + +#include "libgfortran.h" +#include <stdlib.h> +#include <assert.h> +#include <string.h> + +/* TODO: make this work for large shifts when + sizeof(int) < sizeof (index_type). */ + +static void +eoshift2 (gfc_array_char *ret, const gfc_array_char *array, + int shift, const gfc_array_char *bound, int which, + index_type size, const char *filler, index_type filler_len) +{ + /* r.* indicates the return array. */ + index_type rstride[GFC_MAX_DIMENSIONS]; + index_type rstride0; + index_type roffset; + char * restrict rptr; + char *dest; + /* s.* indicates the source array. */ + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type sstride0; + index_type soffset; + const char *sptr; + const char *src; + /* b.* indicates the bound array. */ + index_type bstride[GFC_MAX_DIMENSIONS]; + index_type bstride0; + const char *bptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dim; + index_type len; + index_type n; + index_type arraysize; + + /* The compiler cannot figure out that these are set, initialize + them to avoid warnings. */ + len = 0; + soffset = 0; + roffset = 0; + + arraysize = size0 ((array_t *) array); + + if (ret->data == NULL) + { + int i; + + ret->data = internal_malloc_size (size * arraysize); + ret->offset = 0; + ret->dtype = array->dtype; + for (i = 0; i < GFC_DESCRIPTOR_RANK (array); i++) + { + ret->dim[i].lbound = 0; + ret->dim[i].ubound = array->dim[i].ubound - array->dim[i].lbound; + + if (i == 0) + ret->dim[i].stride = 1; + else + ret->dim[i].stride = (ret->dim[i-1].ubound + 1) * ret->dim[i-1].stride; + } + } + else + { + if (size0 ((array_t *) ret) == 0) + return; + } + + if (arraysize == 0 && filler == NULL) + return; + + which = which - 1; + + extent[0] = 1; + count[0] = 0; + sstride[0] = -1; + rstride[0] = -1; + bstride[0] = -1; + n = 0; + for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++) + { + if (dim == which) + { + roffset = ret->dim[dim].stride * size; + if (roffset == 0) + roffset = size; + soffset = array->dim[dim].stride * size; + if (soffset == 0) + soffset = size; + len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + } + else + { + count[n] = 0; + extent[n] = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + rstride[n] = ret->dim[dim].stride * size; + sstride[n] = array->dim[dim].stride * size; + if (bound) + bstride[n] = bound->dim[n].stride * size; + else + bstride[n] = 0; + n++; + } + } + if (sstride[0] == 0) + sstride[0] = size; + if (rstride[0] == 0) + rstride[0] = size; + if (bound && bstride[0] == 0) + bstride[0] = size; + + dim = GFC_DESCRIPTOR_RANK (array); + rstride0 = rstride[0]; + sstride0 = sstride[0]; + bstride0 = bstride[0]; + rptr = ret->data; + sptr = array->data; + + if ((shift >= 0 ? shift : -shift ) > len) + { + shift = len; + len = 0; + } + else + { + if (shift > 0) + len = len - shift; + else + len = len + shift; + } + + if (bound) + bptr = bound->data; + else + bptr = NULL; + + while (rptr) + { + /* Do the shift for this dimension. */ + if (shift > 0) + { + src = &sptr[shift * soffset]; + dest = rptr; + } + else + { + src = sptr; + dest = &rptr[-shift * roffset]; + } + for (n = 0; n < len; n++) + { + memcpy (dest, src, size); + dest += roffset; + src += soffset; + } + if (shift >= 0) + { + n = shift; + } + else + { + dest = rptr; + n = -shift; + } + + if (bptr) + while (n--) + { + memcpy (dest, bptr, size); + dest += roffset; + } + else + while (n--) + { + index_type i; + + if (filler_len == 1) + memset (dest, filler[0], size); + else + for (i = 0; i < size ; i += filler_len) + memcpy (&dest[i], filler, filler_len); + + dest += roffset; + } + + /* Advance to the next section. */ + rptr += rstride0; + sptr += sstride0; + bptr += bstride0; + count[0]++; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + rptr -= rstride[n] * extent[n]; + sptr -= sstride[n] * extent[n]; + bptr -= bstride[n] * extent[n]; + n++; + if (n >= dim - 1) + { + /* Break out of the loop. */ + rptr = NULL; + break; + } + else + { + count[n]++; + rptr += rstride[n]; + sptr += sstride[n]; + bptr += bstride[n]; + } + } + } +} + + +#define DEFINE_EOSHIFT(N) \ + extern void eoshift2_##N (gfc_array_char *, const gfc_array_char *, \ + const GFC_INTEGER_##N *, const gfc_array_char *, \ + const GFC_INTEGER_##N *); \ + export_proto(eoshift2_##N); \ + \ + void \ + eoshift2_##N (gfc_array_char *ret, const gfc_array_char *array, \ + const GFC_INTEGER_##N *pshift, const gfc_array_char *pbound, \ + const GFC_INTEGER_##N *pdim) \ + { \ + eoshift2 (ret, array, *pshift, pbound, pdim ? *pdim : 1, \ + GFC_DESCRIPTOR_SIZE (array), "\0", 1); \ + } \ + \ + extern void eoshift2_##N##_char (gfc_array_char *, GFC_INTEGER_4, \ + const gfc_array_char *, \ + const GFC_INTEGER_##N *, \ + const gfc_array_char *, \ + const GFC_INTEGER_##N *, \ + GFC_INTEGER_4, GFC_INTEGER_4); \ + export_proto(eoshift2_##N##_char); \ + \ + void \ + eoshift2_##N##_char (gfc_array_char *ret, \ + GFC_INTEGER_4 ret_length __attribute__((unused)), \ + const gfc_array_char *array, \ + const GFC_INTEGER_##N *pshift, \ + const gfc_array_char *pbound, \ + const GFC_INTEGER_##N *pdim, \ + GFC_INTEGER_4 array_length, \ + GFC_INTEGER_4 bound_length __attribute__((unused))) \ + { \ + eoshift2 (ret, array, *pshift, pbound, pdim ? *pdim : 1, \ + array_length, " ", 1); \ + } \ + \ + extern void eoshift2_##N##_char4 (gfc_array_char *, GFC_INTEGER_4, \ + const gfc_array_char *, \ + const GFC_INTEGER_##N *, \ + const gfc_array_char *, \ + const GFC_INTEGER_##N *, \ + GFC_INTEGER_4, GFC_INTEGER_4); \ + export_proto(eoshift2_##N##_char4); \ + \ + void \ + eoshift2_##N##_char4 (gfc_array_char *ret, \ + GFC_INTEGER_4 ret_length __attribute__((unused)), \ + const gfc_array_char *array, \ + const GFC_INTEGER_##N *pshift, \ + const gfc_array_char *pbound, \ + const GFC_INTEGER_##N *pdim, \ + GFC_INTEGER_4 array_length, \ + GFC_INTEGER_4 bound_length __attribute__((unused))) \ + { \ + static const gfc_char4_t space = (unsigned char) ' '; \ + eoshift2 (ret, array, *pshift, pbound, pdim ? *pdim : 1, \ + array_length * sizeof (gfc_char4_t), (const char *) &space, \ + sizeof (gfc_char4_t)); \ + } + +DEFINE_EOSHIFT (1); +DEFINE_EOSHIFT (2); +DEFINE_EOSHIFT (4); +DEFINE_EOSHIFT (8); +#ifdef HAVE_GFC_INTEGER_16 +DEFINE_EOSHIFT (16); +#endif diff --git a/gcc-4.4.0/libgfortran/intrinsics/erfc_scaled.c b/gcc-4.4.0/libgfortran/intrinsics/erfc_scaled.c new file mode 100644 index 000000000..7ffca40db --- /dev/null +++ b/gcc-4.4.0/libgfortran/intrinsics/erfc_scaled.c @@ -0,0 +1,52 @@ +/* Implementation of the ERFC_SCALED intrinsic. + Copyright (C) 2008, 2009 Free Software Foundation, Inc. + +This file is part of the GNU Fortran runtime library (libgfortran). + +Libgfortran 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 3 of the License, or (at your option) any later version. + +Libgfortran 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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. */ + +#include "libgfortran.h" + +/* This implementation of ERFC_SCALED is based on the netlib algorithm + available at http://www.netlib.org/specfun/erf */ + +#ifdef HAVE_GFC_REAL_4 +#undef KIND +#define KIND 4 +#include "erfc_scaled_inc.c" +#endif + +#ifdef HAVE_GFC_REAL_8 +#undef KIND +#define KIND 8 +#include "erfc_scaled_inc.c" +#endif + +#ifdef HAVE_GFC_REAL_10 +#undef KIND +#define KIND 10 +#include "erfc_scaled_inc.c" +#endif + +#ifdef HAVE_GFC_REAL_16 +#undef KIND +#define KIND 16 +#include "erfc_scaled_inc.c" +#endif diff --git a/gcc-4.4.0/libgfortran/intrinsics/erfc_scaled_inc.c b/gcc-4.4.0/libgfortran/intrinsics/erfc_scaled_inc.c new file mode 100644 index 000000000..7e4ba7ec8 --- /dev/null +++ b/gcc-4.4.0/libgfortran/intrinsics/erfc_scaled_inc.c @@ -0,0 +1,184 @@ +/* Implementation of the ERFC_SCALED intrinsic, to be included by erfc_scaled.c + Copyright (c) 2008 Free Software Foundation, Inc. + +This file is part of the GNU Fortran runtime library (libgfortran). + +Libgfortran 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 3 of the License, or (at your option) any later version. + +Libgfortran 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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. */ + +/* This implementation of ERFC_SCALED is based on the netlib algorithm + available at http://www.netlib.org/specfun/erf */ + +#define TYPE KIND_SUFFIX(GFC_REAL_,KIND) +#define CONCAT(x,y) x ## y +#define KIND_SUFFIX(x,y) CONCAT(x,y) + +#if (KIND == 4) + +# define EXP(x) expf(x) +# define TRUNC(x) truncf(x) + +#elif (KIND == 8) + +# define EXP(x) exp(x) +# define TRUNC(x) trunc(x) + +#else + +# ifdef HAVE_EXPL +# define EXP(x) expl(x) +# endif +# ifdef HAVE_TRUNCL +# define TRUNC(x) truncl(x) +# endif + +#endif + +#if defined(EXP) && defined(TRUNC) + +extern TYPE KIND_SUFFIX(erfc_scaled_r,KIND) (TYPE); +export_proto(KIND_SUFFIX(erfc_scaled_r,KIND)); + +TYPE +KIND_SUFFIX(erfc_scaled_r,KIND) (TYPE x) +{ + /* The main computation evaluates near-minimax approximations + from "Rational Chebyshev approximations for the error function" + by W. J. Cody, Math. Comp., 1969, PP. 631-638. This + transportable program uses rational functions that theoretically + approximate erf(x) and erfc(x) to at least 18 significant + decimal digits. The accuracy achieved depends on the arithmetic + system, the compiler, the intrinsic functions, and proper + selection of the machine-dependent constants. */ + + int i; + TYPE del, res, xden, xnum, y, ysq; + +#if (KIND == 4) + static TYPE xneg = -9.382, xsmall = 5.96e-8, + xbig = 9.194, xhuge = 2.90e+3, xmax = 4.79e+37; +#else + static TYPE xneg = -26.628, xsmall = 1.11e-16, + xbig = 26.543, xhuge = 6.71e+7, xmax = 2.53e+307; +#endif + +#define SQRPI ((TYPE) 0.56418958354775628695L) +#define THRESH ((TYPE) 0.46875L) + + static TYPE a[5] = { 3.16112374387056560l, 113.864154151050156l, + 377.485237685302021l, 3209.37758913846947l, 0.185777706184603153l }; + + static TYPE b[4] = { 23.6012909523441209l, 244.024637934444173l, + 1282.61652607737228l, 2844.23683343917062l }; + + static TYPE c[9] = { 0.564188496988670089l, 8.88314979438837594l, + 66.1191906371416295l, 298.635138197400131l, 881.952221241769090l, + 1712.04761263407058l, 2051.07837782607147l, 1230.33935479799725l, + 2.15311535474403846e-8l }; + + static TYPE d[8] = { 15.7449261107098347l, 117.693950891312499l, + 537.181101862009858l, 1621.38957456669019l, 3290.79923573345963l, + 4362.61909014324716l, 3439.36767414372164l, 1230.33935480374942l }; + + static TYPE p[6] = { 0.305326634961232344l, 0.360344899949804439l, + 0.125781726111229246l, 0.0160837851487422766l, + 0.000658749161529837803l, 0.0163153871373020978l }; + + static TYPE q[5] = { 2.56852019228982242l, 1.87295284992346047l, + 0.527905102951428412l, 0.0605183413124413191l, + 0.00233520497626869185l }; + + y = (x > 0 ? x : -x); + if (y <= THRESH) + { + ysq = 0; + if (y > xsmall) + ysq = y * y; + xnum = a[4]*ysq; + xden = ysq; + for (i = 0; i <= 2; i++) + { + xnum = (xnum + a[i]) * ysq; + xden = (xden + b[i]) * ysq; + } + res = x * (xnum + a[3]) / (xden + b[3]); + res = 1 - res; + res = EXP(ysq) * res; + return res; + } + else if (y <= 4) + { + xnum = c[8]*y; + xden = y; + for (i = 0; i <= 6; i++) + { + xnum = (xnum + c[i]) * y; + xden = (xden + d[i]) * y; + } + res = (xnum + c[7]) / (xden + d[7]); + } + else + { + res = 0; + if (y >= xbig) + { + if (y >= xmax) + goto finish; + if (y >= xhuge) + { + res = SQRPI / y; + goto finish; + } + } + ysq = ((TYPE) 1) / (y * y); + xnum = p[5]*ysq; + xden = ysq; + for (i = 0; i <= 3; i++) + { + xnum = (xnum + p[i]) * ysq; + xden = (xden + q[i]) * ysq; + } + res = ysq *(xnum + p[4]) / (xden + q[4]); + res = (SQRPI - res) / y; + } + +finish: + if (x < 0) + { + if (x < xneg) + res = __builtin_inf (); + else + { + ysq = TRUNC (x*((TYPE) 16))/((TYPE) 16); + del = (x-ysq)*(x+ysq); + y = EXP(ysq*ysq) * EXP(del); + res = (y+y) - res; + } + } + return res; +} + +#endif + +#undef EXP +#undef TRUNC + +#undef CONCAT +#undef TYPE +#undef KIND_SUFFIX diff --git a/gcc-4.4.0/libgfortran/intrinsics/etime.c b/gcc-4.4.0/libgfortran/intrinsics/etime.c new file mode 100644 index 000000000..1ae357ed5 --- /dev/null +++ b/gcc-4.4.0/libgfortran/intrinsics/etime.c @@ -0,0 +1,72 @@ +/* Implementation of the ETIME intrinsic. + Copyright (C) 2004, 2005, 2006, 2007, 2009 Free Software Foundation, Inc. + Contributed by Steven G. Kargl <kargls@comcast.net>. + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran 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 3 of the License, or (at your option) any later version. + +Libgfortran 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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. */ + +#include "libgfortran.h" +#include "time_1.h" + +extern void etime_sub (gfc_array_r4 *t, GFC_REAL_4 *result); +iexport_proto(etime_sub); + +void +etime_sub (gfc_array_r4 *t, GFC_REAL_4 *result) +{ + GFC_REAL_4 tu, ts, tt, *tp; + long user_sec, user_usec, system_sec, system_usec; + + if (((t->dim[0].ubound + 1 - t->dim[0].lbound)) < 2) + runtime_error ("Insufficient number of elements in TARRAY."); + + if (__time_1 (&user_sec, &user_usec, &system_sec, &system_usec) == 0) + { + tu = (GFC_REAL_4)(user_sec + 1.e-6 * user_usec); + ts = (GFC_REAL_4)(system_sec + 1.e-6 * system_usec); + tt = tu + ts; + } + else + { + tu = (GFC_REAL_4)-1.0; + ts = (GFC_REAL_4)-1.0; + tt = (GFC_REAL_4)-1.0; + } + + tp = t->data; + + *tp = tu; + tp += t->dim[0].stride; + *tp = ts; + *result = tt; +} +iexport(etime_sub); + +extern GFC_REAL_4 etime (gfc_array_r4 *t); +export_proto(etime); + +GFC_REAL_4 +etime (gfc_array_r4 *t) +{ + GFC_REAL_4 val; + etime_sub (t, &val); + return val; +} diff --git a/gcc-4.4.0/libgfortran/intrinsics/exit.c b/gcc-4.4.0/libgfortran/intrinsics/exit.c new file mode 100644 index 000000000..7787581d0 --- /dev/null +++ b/gcc-4.4.0/libgfortran/intrinsics/exit.c @@ -0,0 +1,52 @@ +/* Implementation of the EXIT intrinsic. + Copyright (C) 2004, 2007, 2009 Free Software Foundation, Inc. + Contributed by Steven G. Kargl <kargls@comcast.net>. + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran 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 3 of the License, or (at your option) any later version. + +Libgfortran 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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. */ + + +#include "libgfortran.h" + +#ifdef HAVE_STDLIB_H +#include <stdlib.h> +#endif + +/* SUBROUTINE EXIT(STATUS) + INTEGER, INTENT(IN), OPTIONAL :: STATUS */ + +extern void exit_i4 (GFC_INTEGER_4 *); +export_proto(exit_i4); + +void +exit_i4 (GFC_INTEGER_4 * status) +{ + exit (status ? *status : 0); +} + +extern void exit_i8 (GFC_INTEGER_8 *); +export_proto(exit_i8); + +void +exit_i8 (GFC_INTEGER_8 * status) +{ + exit (status ? *status : 0); +} diff --git a/gcc-4.4.0/libgfortran/intrinsics/f2c_specifics.F90 b/gcc-4.4.0/libgfortran/intrinsics/f2c_specifics.F90 new file mode 100644 index 000000000..dd7713a68 --- /dev/null +++ b/gcc-4.4.0/libgfortran/intrinsics/f2c_specifics.F90 @@ -0,0 +1,197 @@ +! Copyright 2002, 2005, 2009 Free Software Foundation, Inc. +! Contributed by Tobias Schl"uter +! +!This file is part of the GNU Fortran 95 runtime library (libgfortran). +! +!GNU libgfortran 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 3 of the License, or (at your option) any later version. +! +!GNU libgfortran 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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!<http://www.gnu.org/licenses/>. + +! Specifics for the intrinsics whose calling conventions change if +! -ff2c is used. +! +! There are two annoyances WRT the preprocessor: +! - we're using -traditional-cpp, so we can't use the ## operator. +! - macros expand to a single line, and Fortran lines can't be wider +! than 132 characters, therefore we use two macros to split the lines +! +! The cases we need to implement are functions returning default REAL +! or COMPLEX. The former need to return DOUBLE PRECISION instead of REAL, +! the latter become subroutines returning via a hidden first argument. + +! one argument functions +#define REAL_HEAD(NAME) \ +elemental function _gfortran_f2c_specific__/**/NAME/**/_r4 (parm) result(res); + +#define REAL_BODY(NAME) \ + REAL, intent (in) :: parm; \ + DOUBLE PRECISION :: res; \ + res = NAME (parm); \ +end function + +#define COMPLEX_HEAD(NAME) \ +subroutine _gfortran_f2c_specific__/**/NAME/**/_c4 (res, parm); + +#define COMPLEX_BODY(NAME) \ + COMPLEX, intent (in) :: parm; \ + COMPLEX, intent (out) :: res; \ + res = NAME (parm); \ +end subroutine + +#define DCOMPLEX_HEAD(NAME) \ +subroutine _gfortran_f2c_specific__/**/NAME/**/_c8 (res, parm); + +#define DCOMPLEX_BODY(NAME) \ + DOUBLE COMPLEX, intent (in) :: parm; \ + DOUBLE COMPLEX, intent (out) :: res; \ + res = NAME (parm); \ +end subroutine + +REAL_HEAD(abs) +REAL_BODY(abs) + +! abs is special in that the result is real +elemental function _gfortran_f2c_specific__abs_c4 (parm) result (res) + COMPLEX, intent(in) :: parm + DOUBLE PRECISION :: res + res = abs(parm) +end function + + +! aimag is special in that the result is real +elemental function _gfortran_f2c_specific__aimag_c4 (parm) + complex(kind=4), intent(in) :: parm + double precision :: _gfortran_f2c_specific__aimag_c4 + _gfortran_f2c_specific__aimag_c4 = aimag(parm) +end function + +elemental function _gfortran_f2c_specific__aimag_c8 (parm) + complex(kind=8), intent(in) :: parm + double precision :: _gfortran_f2c_specific__aimag_c8 + _gfortran_f2c_specific__aimag_c8 = aimag(parm) +end function + + +REAL_HEAD(exp) +REAL_BODY(exp) +COMPLEX_HEAD(exp) +COMPLEX_BODY(exp) +DCOMPLEX_HEAD(exp) +DCOMPLEX_BODY(exp) + +REAL_HEAD(log) +REAL_BODY(log) +COMPLEX_HEAD(log) +COMPLEX_BODY(log) +DCOMPLEX_HEAD(log) +DCOMPLEX_BODY(log) + +REAL_HEAD(log10) +REAL_BODY(log10) + +REAL_HEAD(sqrt) +REAL_BODY(sqrt) +COMPLEX_HEAD(sqrt) +COMPLEX_BODY(sqrt) +DCOMPLEX_HEAD(sqrt) +DCOMPLEX_BODY(sqrt) + +REAL_HEAD(asin) +REAL_BODY(asin) + +REAL_HEAD(acos) +REAL_BODY(acos) + +REAL_HEAD(atan) +REAL_BODY(atan) + +REAL_HEAD(asinh) +REAL_BODY(asinh) + +REAL_HEAD(acosh) +REAL_BODY(acosh) + +REAL_HEAD(atanh) +REAL_BODY(atanh) + +REAL_HEAD(sin) +REAL_BODY(sin) +COMPLEX_HEAD(sin) +COMPLEX_BODY(sin) +DCOMPLEX_HEAD(sin) +DCOMPLEX_BODY(sin) + +REAL_HEAD(cos) +REAL_BODY(cos) +COMPLEX_HEAD(cos) +COMPLEX_BODY(cos) +DCOMPLEX_HEAD(cos) +DCOMPLEX_BODY(cos) + +REAL_HEAD(tan) +REAL_BODY(tan) + +REAL_HEAD(sinh) +REAL_BODY(sinh) + +REAL_HEAD(cosh) +REAL_BODY(cosh) + +REAL_HEAD(tanh) +REAL_BODY(tanh) + +REAL_HEAD(aint) +REAL_BODY(aint) + +REAL_HEAD(anint) +REAL_BODY(anint) + +! two argument functions +#define REAL2_HEAD(NAME) \ +elemental function _gfortran_f2c_specific__/**/NAME/**/_r4 (p1, p2) result(res); + +#define REAL2_BODY(NAME) \ + REAL, intent (in) :: p1, p2; \ + DOUBLE PRECISION :: res; \ + res = NAME (p1, p2); \ +end function + +REAL2_HEAD(sign) +REAL2_BODY(sign) + +REAL2_HEAD(dim) +REAL2_BODY(dim) + +REAL2_HEAD(atan2) +REAL2_BODY(atan2) + +REAL2_HEAD(mod) +REAL2_BODY(mod) + +! conjg is special-cased because it is not suffixed _c4 but _4 +subroutine _gfortran_f2c_specific__conjg_4 (res, parm) + COMPLEX, intent (in) :: parm + COMPLEX, intent (out) :: res + res = conjg (parm) +end subroutine +subroutine _gfortran_f2c_specific__conjg_8 (res, parm) + DOUBLE COMPLEX, intent (in) :: parm + DOUBLE COMPLEX, intent (out) :: res + res = conjg (parm) +end subroutine + diff --git a/gcc-4.4.0/libgfortran/intrinsics/fnum.c b/gcc-4.4.0/libgfortran/intrinsics/fnum.c new file mode 100644 index 000000000..f155042a5 --- /dev/null +++ b/gcc-4.4.0/libgfortran/intrinsics/fnum.c @@ -0,0 +1,48 @@ +/* Implementation of the FNUM intrinsics. + Copyright (C) 2004, 2007, 2009 Free Software Foundation, Inc. + Contributed by Steven G. Kargl <kargls@comcast.net>. + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran 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 3 of the License, or (at your option) any later version. + +Libgfortran 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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. */ + +#include "libgfortran.h" + +/* FUNCTION FNUM(UNIT) + INTEGER FNUM + INTEGER, INTENT(IN), :: UNIT */ + +extern GFC_INTEGER_4 fnum_i4 (GFC_INTEGER_4 *); +export_proto(fnum_i4); + +GFC_INTEGER_4 +fnum_i4 (GFC_INTEGER_4 *unit) +{ + return unit_to_fd (*unit); +} + +extern GFC_INTEGER_8 fnum_i8 (GFC_INTEGER_8 *); +export_proto(fnum_i8); + +GFC_INTEGER_8 +fnum_i8 (GFC_INTEGER_8 * unit) +{ + return unit_to_fd (*unit); +} diff --git a/gcc-4.4.0/libgfortran/intrinsics/gerror.c b/gcc-4.4.0/libgfortran/intrinsics/gerror.c new file mode 100644 index 000000000..ccb5c3efd --- /dev/null +++ b/gcc-4.4.0/libgfortran/intrinsics/gerror.c @@ -0,0 +1,58 @@ +/* Implementation of the GERROR g77 intrinsic. + Copyright (C) 2005, 2007, 2009 Free Software Foundation, Inc. + Contributed by François-Xavier Coudert <coudert@clipper.ens.fr> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran 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 3 of the License, or (at your option) any later version. + +Libgfortran 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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. */ + +#include "libgfortran.h" + +#include <errno.h> +#include <string.h> + + +/* GERROR (MESSAGE), g77 intrinsic for retrieving the system error + message corresponding to the last system error (C errno). + CHARACTER(len=*), INTENT(OUT) :: MESSAGE */ + +#ifdef HAVE_STRERROR +void PREFIX(gerror) (char *, gfc_charlen_type); +export_proto_np(PREFIX(gerror)); + +void +PREFIX(gerror) (char * msg, gfc_charlen_type msg_len) +{ + int p_len; + char *p; + + memset (msg, ' ', msg_len); /* Blank the string. */ + + p = strerror (errno); + if (p == NULL) + return; + + p_len = strlen (p); + if (msg_len < p_len) + memcpy (msg, p, msg_len); + else + memcpy (msg, p, p_len); +} +#endif diff --git a/gcc-4.4.0/libgfortran/intrinsics/getXid.c b/gcc-4.4.0/libgfortran/intrinsics/getXid.c new file mode 100644 index 000000000..9eb60f039 --- /dev/null +++ b/gcc-4.4.0/libgfortran/intrinsics/getXid.c @@ -0,0 +1,67 @@ +/* Wrapper for the unix get{g,p,u}id functions. +Copyright (C) 2004, 2007, 2009 Free Software Foundation, Inc. + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran 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 3 of the License, or (at your option) any later version. + +Libgfortran 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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. */ + +#include "libgfortran.h" + +#if HAVE_UNISTD_H +#include <unistd.h> +#endif + +#ifdef __MINGW32__ +#define HAVE_GETPID 1 +#include <process.h> +#endif + +#ifdef HAVE_GETGID +extern GFC_INTEGER_4 PREFIX(getgid) (void); +export_proto_np(PREFIX(getgid)); + +GFC_INTEGER_4 +PREFIX(getgid) (void) +{ + return getgid (); +} +#endif + +#ifdef HAVE_GETPID +extern GFC_INTEGER_4 PREFIX(getpid) (void); +export_proto_np(PREFIX(getpid)); + +GFC_INTEGER_4 +PREFIX(getpid) (void) +{ + return getpid (); +} +#endif + +#ifdef HAVE_GETUID +extern GFC_INTEGER_4 PREFIX(getuid) (void); +export_proto_np(PREFIX(getuid)); + +GFC_INTEGER_4 +PREFIX(getuid) (void) +{ + return getuid (); +} +#endif diff --git a/gcc-4.4.0/libgfortran/intrinsics/getcwd.c b/gcc-4.4.0/libgfortran/intrinsics/getcwd.c new file mode 100644 index 000000000..15e8e8f7b --- /dev/null +++ b/gcc-4.4.0/libgfortran/intrinsics/getcwd.c @@ -0,0 +1,83 @@ +/* Implementation of the GETCWD intrinsic. + Copyright (C) 2004, 2005, 2007, 2009 Free Software Foundation, Inc. + Contributed by Steven G. Kargl <kargls@comcast.net>. + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran 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 3 of the License, or (at your option) any later version. + +Libgfortran 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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. */ + +#include "libgfortran.h" + +#include <string.h> +#include <errno.h> + +#ifdef HAVE_UNISTD_H +#include <unistd.h> +#endif + +#ifdef HAVE_GETCWD + +extern void getcwd_i4_sub (char *, GFC_INTEGER_4 *, gfc_charlen_type); +iexport_proto(getcwd_i4_sub); + +void +getcwd_i4_sub (char *cwd, GFC_INTEGER_4 *status, gfc_charlen_type cwd_len) +{ + char str[cwd_len + 1]; + GFC_INTEGER_4 stat; + + memset(cwd, ' ', (size_t) cwd_len); + + if (!getcwd (str, (size_t) cwd_len + 1)) + stat = errno; + else + { + stat = 0; + memcpy (cwd, str, strlen (str)); + } + if (status != NULL) + *status = stat; +} +iexport(getcwd_i4_sub); + +extern void getcwd_i8_sub (char *, GFC_INTEGER_8 *, gfc_charlen_type); +export_proto(getcwd_i8_sub); + +void +getcwd_i8_sub (char *cwd, GFC_INTEGER_8 *status, gfc_charlen_type cwd_len) +{ + GFC_INTEGER_4 status4; + getcwd_i4_sub (cwd, &status4, cwd_len); + if (status) + *status = status4; +} + +extern GFC_INTEGER_4 PREFIX(getcwd) (char *, gfc_charlen_type); +export_proto_np(PREFIX(getcwd)); + +GFC_INTEGER_4 +PREFIX(getcwd) (char *cwd, gfc_charlen_type cwd_len) +{ + GFC_INTEGER_4 status; + getcwd_i4_sub (cwd, &status, cwd_len); + return status; +} + +#endif diff --git a/gcc-4.4.0/libgfortran/intrinsics/getlog.c b/gcc-4.4.0/libgfortran/intrinsics/getlog.c new file mode 100644 index 000000000..0456c5796 --- /dev/null +++ b/gcc-4.4.0/libgfortran/intrinsics/getlog.c @@ -0,0 +1,99 @@ +/* Implementation of the GETLOG g77 intrinsic. + Copyright (C) 2005, 2007, 2009 Free Software Foundation, Inc. + Contributed by François-Xavier Coudert <coudert@clipper.ens.fr> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran 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 3 of the License, or (at your option) any later version. + +Libgfortran 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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. */ + +#include "libgfortran.h" + +#include <string.h> + +#ifdef HAVE_UNISTD_H +#include <unistd.h> +#endif +#ifdef HAVE_PWD_H +#include <pwd.h> +#endif + +/* Windows32 version */ +#if defined __MINGW32__ && !defined HAVE_GETLOGIN +#define WIN32_LEAN_AND_MEAN +#include <windows.h> +#include <lmcons.h> /* for UNLEN */ + +static char * +w32_getlogin (void) +{ + static char name [UNLEN + 1]; + DWORD namelen = sizeof (name); + + GetUserName (name, &namelen); + return (name[0] == 0 ? NULL : name); +} + +#undef getlogin +#define getlogin w32_getlogin +#define HAVE_GETLOGIN 1 + +#endif + + +/* GETLOG (LOGIN), g77 intrinsic for retrieving the login name for the + process. + CHARACTER(len=*), INTENT(OUT) :: LOGIN */ + +void PREFIX(getlog) (char *, gfc_charlen_type); +export_proto_np(PREFIX(getlog)); + +void +PREFIX(getlog) (char * login, gfc_charlen_type login_len) +{ + int p_len; + char *p; + + memset (login, ' ', login_len); /* Blank the string. */ + +#if defined(HAVE_GETPWUID) && defined(HAVE_GETEUID) + { + struct passwd *pw = getpwuid (geteuid ()); + if (pw) + p = pw->pw_name; + else + return; + } +#else +# ifdef HAVE_GETLOGIN + p = getlogin(); +# else + return; +# endif +#endif + + if (p == NULL) + return; + + p_len = strlen (p); + if (login_len < p_len) + memcpy (login, p, login_len); + else + memcpy (login, p, p_len); +} diff --git a/gcc-4.4.0/libgfortran/intrinsics/hostnm.c b/gcc-4.4.0/libgfortran/intrinsics/hostnm.c new file mode 100644 index 000000000..99ab18dcb --- /dev/null +++ b/gcc-4.4.0/libgfortran/intrinsics/hostnm.c @@ -0,0 +1,144 @@ +/* Implementation of the HOSTNM intrinsic. + Copyright (C) 2005, 2007, 2009 Free Software Foundation, Inc. + Contributed by François-Xavier Coudert <coudert@clipper.ens.fr> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran 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 3 of the License, or (at your option) any later version. + +Libgfortran 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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. */ + +#include "libgfortran.h" + +#include <errno.h> +#include <string.h> + +#ifdef HAVE_UNISTD_H +#include <unistd.h> +#endif + + +/* Windows32 version */ +#if defined __MINGW32__ && !defined HAVE_GETHOSTNAME +#define WIN32_LEAN_AND_MEAN +#include <windows.h> +#include <errno.h> + +static int +w32_gethostname (char *name, size_t len) +{ + /* We could try the WinSock API gethostname, but that will + fail if WSAStartup function has has not been called. We don't + really need a name that will be understood by socket API, so avoid + unnecessary dependence on WinSock libraries by using + GetComputerName instead. */ + + /* On Win9x GetComputerName fails if the input size is less + than MAX_COMPUTERNAME_LENGTH + 1. */ + char buffer[MAX_COMPUTERNAME_LENGTH + 1]; + DWORD size = sizeof (buffer); + + if (!GetComputerName (buffer, &size)) + return -1; + + if ((size = strlen (buffer) + 1) > len) + { + errno = EINVAL; + /* Truncate as per POSIX spec. We do not NUL-terminate. */ + size = len; + } + memcpy (name, buffer, (size_t) size); + + return 0; +} + +#undef gethostname +#define gethostname w32_gethostname +#define HAVE_GETHOSTNAME 1 + +#endif + + +/* SUBROUTINE HOSTNM(NAME, STATUS) + CHARACTER(len=*), INTENT(OUT) :: NAME + INTEGER, INTENT(OUT), OPTIONAL :: STATUS */ + +#ifdef HAVE_GETHOSTNAME +extern void hostnm_i4_sub (char *, GFC_INTEGER_4 *, gfc_charlen_type); +iexport_proto(hostnm_i4_sub); + +void +hostnm_i4_sub (char *name, GFC_INTEGER_4 *status, gfc_charlen_type name_len) +{ + int val, i; + char *p; + + memset (name, ' ', name_len); + p = gfc_alloca (name_len + 1); + + val = gethostname (p, name_len); + + if (val == 0) + { + i = -1; + while (i < name_len && p[++i] != '\0') + name[i] = p[i]; + } + + if (status != NULL) + *status = (val == 0) ? 0 : errno; +} +iexport(hostnm_i4_sub); + +extern void hostnm_i8_sub (char *, GFC_INTEGER_8 *, gfc_charlen_type); +iexport_proto(hostnm_i8_sub); + +void +hostnm_i8_sub (char *name, GFC_INTEGER_8 *status, gfc_charlen_type name_len) +{ + int val, i; + char *p; + + memset (name, ' ', name_len); + p = gfc_alloca (name_len + 1); + + val = gethostname (p, name_len); + + if (val == 0) + { + i = -1; + while (i < name_len && p[++i] != '\0') + name[i] = p[i]; + } + + if (status != NULL) + *status = (val == 0) ? 0 : errno; +} +iexport(hostnm_i8_sub); + +extern GFC_INTEGER_4 hostnm (char *, gfc_charlen_type); +export_proto(hostnm); + +GFC_INTEGER_4 +hostnm (char *name, gfc_charlen_type name_len) +{ + GFC_INTEGER_4 val; + hostnm_i4_sub (name, &val, name_len); + return val; +} +#endif diff --git a/gcc-4.4.0/libgfortran/intrinsics/ierrno.c b/gcc-4.4.0/libgfortran/intrinsics/ierrno.c new file mode 100644 index 000000000..2f5e44fa6 --- /dev/null +++ b/gcc-4.4.0/libgfortran/intrinsics/ierrno.c @@ -0,0 +1,49 @@ +/* Implementation of the IERRNO intrinsic. + Copyright (C) 2005, 2007, 2009 Free Software Foundation, Inc. + Contributed by François-Xavier Coudert <coudert@clipper.ens.fr> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran 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 3 of the License, or (at your option) any later version. + +Libgfortran 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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. */ + +#include "libgfortran.h" + +#include <errno.h> + + +/* INTEGER FUNCTION IERRNO() */ + +extern GFC_INTEGER_4 ierrno_i4 (void); +export_proto(ierrno_i4); + +GFC_INTEGER_4 +ierrno_i4 (void) +{ + return (GFC_INTEGER_4) errno; +} + +extern GFC_INTEGER_8 ierrno_i8 (void); +export_proto(ierrno_i8); + +GFC_INTEGER_8 +ierrno_i8 (void) +{ + return (GFC_INTEGER_8) errno; +} diff --git a/gcc-4.4.0/libgfortran/intrinsics/ishftc.c b/gcc-4.4.0/libgfortran/intrinsics/ishftc.c new file mode 100644 index 000000000..054c3167b --- /dev/null +++ b/gcc-4.4.0/libgfortran/intrinsics/ishftc.c @@ -0,0 +1,100 @@ +/* Implementation of ishftc intrinsic. + Copyright 2002, 2004, 2009 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran 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 3 of the License, or (at your option) any later version. + +Libgfortran 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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. */ + +#include "libgfortran.h" + +extern GFC_INTEGER_4 ishftc4 (GFC_INTEGER_4, GFC_INTEGER_4, GFC_INTEGER_4); +export_proto(ishftc4); + +GFC_INTEGER_4 +ishftc4 (GFC_INTEGER_4 i, GFC_INTEGER_4 shift, GFC_INTEGER_4 size) +{ + GFC_UINTEGER_4 mask, bits; + + if (shift < 0) + shift = shift + size; + + if (shift == 0 || shift == size) + return i; + + /* In C, the result of the shift operator is undefined if the right operand + is greater than or equal to the number of bits in the left operand. So we + have to special case it for fortran. */ + mask = ~((size == 32) ? (GFC_UINTEGER_4)0 : (~(GFC_UINTEGER_4)0 << size)); + + bits = i & mask; + + return (i & ~mask) | ((bits << shift) & mask) | (bits >> (size - shift)); +} + +extern GFC_INTEGER_8 ishftc8 (GFC_INTEGER_8, GFC_INTEGER_4, GFC_INTEGER_4); +export_proto(ishftc8); + +GFC_INTEGER_8 +ishftc8 (GFC_INTEGER_8 i, GFC_INTEGER_4 shift, GFC_INTEGER_4 size) +{ + GFC_UINTEGER_8 mask, bits; + + if (shift < 0) + shift = shift + size; + + if (shift == 0 || shift == size) + return i; + + /* In C, the result of the shift operator is undefined if the right operand + is greater than or equal to the number of bits in the left operand. So we + have to special case it for fortran. */ + mask = ~((size == 64) ? (GFC_UINTEGER_8)0 : (~(GFC_UINTEGER_8)0 << size)); + + bits = i & mask; + + return (i & ~mask) | ((bits << shift) & mask) | (bits >> (size - shift)); +} + +#ifdef HAVE_GFC_INTEGER_16 +extern GFC_INTEGER_16 ishftc16 (GFC_INTEGER_16, GFC_INTEGER_4, GFC_INTEGER_4); +export_proto(ishftc16); + +GFC_INTEGER_16 +ishftc16 (GFC_INTEGER_16 i, GFC_INTEGER_4 shift, GFC_INTEGER_4 size) +{ + GFC_UINTEGER_16 mask, bits; + + if (shift < 0) + shift = shift + size; + + if (shift == 0 || shift == size) + return i; + + /* In C, the result of the shift operator is undefined if the right operand + is greater than or equal to the number of bits in the left operand. So we + have to special case it for fortran. */ + mask = ~((size == 128) ? (GFC_UINTEGER_16)0 : (~(GFC_UINTEGER_16)0 << size)); + + bits = i & mask; + + return (i & ~mask) | ((bits << shift) & mask) | (bits >> (size - shift)); +} +#endif diff --git a/gcc-4.4.0/libgfortran/intrinsics/iso_c_binding.c b/gcc-4.4.0/libgfortran/intrinsics/iso_c_binding.c new file mode 100644 index 000000000..a8d876832 --- /dev/null +++ b/gcc-4.4.0/libgfortran/intrinsics/iso_c_binding.c @@ -0,0 +1,177 @@ +/* Implementation of the ISO_C_BINDING library helper functions. + Copyright (C) 2007, 2009 Free Software Foundation, Inc. + Contributed by Christopher Rickett. + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran 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 3 of the License, or (at your option) any later version. + +Libgfortran 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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. */ + + +/* Implement the functions and subroutines provided by the intrinsic + iso_c_binding module. */ + +#include "libgfortran.h" +#include "iso_c_binding.h" + +#include <stdlib.h> + + +/* Set the fields of a Fortran pointer descriptor to point to the + given C address. It uses c_f_pointer_u0 for the common + fields, and will set up the information necessary if this C address + is to an array (i.e., offset, type, element size). The parameter + c_ptr_in represents the C address to have Fortran point to. The + parameter f_ptr_out is the Fortran pointer to associate with the C + address. The parameter shape is a one-dimensional array of integers + specifying the upper bound(s) of the array pointed to by the given C + address, if applicable. The shape parameter is optional in Fortran, + which will cause it to come in here as NULL. The parameter type is + the type of the data being pointed to (i.e.,libgfortran.h). The + elem_size parameter is the size, in bytes, of the data element being + pointed to. If the address is for an array, then the size needs to + be the size of a single element (i.e., for an array of doubles, it + needs to be the number of bytes for the size of one double). */ + +void +ISO_C_BINDING_PREFIX (c_f_pointer) (void *c_ptr_in, + gfc_array_void *f_ptr_out, + const array_t *shape, + int type, int elemSize) +{ + if (shape != NULL) + { + f_ptr_out->offset = 0; + + /* Set the necessary dtype field for all pointers. */ + f_ptr_out->dtype = 0; + + /* Put in the element size. */ + f_ptr_out->dtype = f_ptr_out->dtype | (elemSize << GFC_DTYPE_SIZE_SHIFT); + + /* Set the data type (e.g., GFC_DTYPE_INTEGER). */ + f_ptr_out->dtype = f_ptr_out->dtype | (type << GFC_DTYPE_TYPE_SHIFT); + } + + /* Use the generic version of c_f_pointer to set common fields. */ + ISO_C_BINDING_PREFIX (c_f_pointer_u0) (c_ptr_in, f_ptr_out, shape); +} + + +/* A generic function to set the common fields of all descriptors, no + matter whether it's to a scalar or an array. Fields set are: data, + and if appropriate, rank, offset, dim[*].lbound, dim[*].ubound, and + dim[*].stride. Parameter shape is a rank 1 array of integers + containing the upper bound of each dimension of what f_ptr_out + points to. The length of this array must be EXACTLY the rank of + what f_ptr_out points to, as required by the draft (J3/04-007). If + f_ptr_out points to a scalar, then this parameter will be NULL. */ + +void +ISO_C_BINDING_PREFIX (c_f_pointer_u0) (void *c_ptr_in, + gfc_array_void *f_ptr_out, + const array_t *shape) +{ + int i = 0; + int shapeSize = 0; + + GFC_DESCRIPTOR_DATA (f_ptr_out) = c_ptr_in; + + if (shape != NULL) + { + f_ptr_out->offset = 0; + shapeSize = 0; + + /* shape's length (rank of the output array) */ + shapeSize = shape->dim[0].ubound + 1 - shape->dim[0].lbound; + for (i = 0; i < shapeSize; i++) + { + /* Lower bound is 1, as specified by the draft. */ + f_ptr_out->dim[i].lbound = 1; + /* Have to allow for the SHAPE array to be any valid kind for + an INTEGER type. */ +#ifdef HAVE_GFC_INTEGER_1 + if (GFC_DESCRIPTOR_SIZE (shape) == 1) + f_ptr_out->dim[i].ubound = ((GFC_INTEGER_1 *) (shape->data))[i]; +#endif +#ifdef HAVE_GFC_INTEGER_2 + if (GFC_DESCRIPTOR_SIZE (shape) == 2) + f_ptr_out->dim[i].ubound = ((GFC_INTEGER_2 *) (shape->data))[i]; +#endif +#ifdef HAVE_GFC_INTEGER_4 + if (GFC_DESCRIPTOR_SIZE (shape) == 4) + f_ptr_out->dim[i].ubound = ((GFC_INTEGER_4 *) (shape->data))[i]; +#endif +#ifdef HAVE_GFC_INTEGER_8 + if (GFC_DESCRIPTOR_SIZE (shape) == 8) + f_ptr_out->dim[i].ubound = ((GFC_INTEGER_8 *) (shape->data))[i]; +#endif +#ifdef HAVE_GFC_INTEGER_16 + if (GFC_DESCRIPTOR_SIZE (shape) == 16) + f_ptr_out->dim[i].ubound = ((GFC_INTEGER_16 *) (shape->data))[i]; +#endif + } + + /* Set the offset and strides. + offset is (sum of (dim[i].lbound * dim[i].stride) for all + dims) the -1 means we'll back the data pointer up that much + perhaps we could just realign the data pointer and not change + the offset? */ + f_ptr_out->dim[0].stride = 1; + f_ptr_out->offset = f_ptr_out->dim[0].lbound * f_ptr_out->dim[0].stride; + for (i = 1; i < shapeSize; i++) + { + f_ptr_out->dim[i].stride = (f_ptr_out->dim[i-1].ubound + 1) + - f_ptr_out->dim[i-1].lbound; + f_ptr_out->offset += f_ptr_out->dim[i].lbound + * f_ptr_out->dim[i].stride; + } + + f_ptr_out->offset *= -1; + + /* All we know is the rank, so set it, leaving the rest alone. + Make NO assumptions about the state of dtype coming in! If we + shift right by TYPE_SHIFT bits we'll throw away the existing + rank. Then, shift left by the same number to shift in zeros + and or with the new rank. */ + f_ptr_out->dtype = ((f_ptr_out->dtype >> GFC_DTYPE_TYPE_SHIFT) + << GFC_DTYPE_TYPE_SHIFT) | shapeSize; + } +} + + +/* Sets the descriptor fields for a Fortran pointer to a derived type, + using c_f_pointer_u0 for the majority of the work. */ + +void +ISO_C_BINDING_PREFIX (c_f_pointer_d0) (void *c_ptr_in, + gfc_array_void *f_ptr_out, + const array_t *shape) +{ + /* Set the common fields. */ + ISO_C_BINDING_PREFIX (c_f_pointer_u0) (c_ptr_in, f_ptr_out, shape); + + /* Preserve the size and rank bits, but reset the type. */ + if (shape != NULL) + { + f_ptr_out->dtype = f_ptr_out->dtype & (~GFC_DTYPE_TYPE_MASK); + f_ptr_out->dtype = f_ptr_out->dtype + | (GFC_DTYPE_DERIVED << GFC_DTYPE_TYPE_SHIFT); + } +} diff --git a/gcc-4.4.0/libgfortran/intrinsics/iso_c_binding.h b/gcc-4.4.0/libgfortran/intrinsics/iso_c_binding.h new file mode 100644 index 000000000..e09147a66 --- /dev/null +++ b/gcc-4.4.0/libgfortran/intrinsics/iso_c_binding.h @@ -0,0 +1,55 @@ +/* Copyright (C) 2007, 2009 Free Software Foundation, Inc. + Contributed by Christopher Rickett. + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran 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 3, or (at your option) +any later version. + +Libgfortran 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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. */ + + +/* Declarations for ISO_C_BINDING library helper functions. */ + +#ifndef GFOR_ISO_C_BINDING_H +#define GFOR_ISO_C_BINDING_H + +#include "libgfortran.h" + +typedef struct c_ptr +{ + void *c_address; +} +c_ptr_t; + +typedef struct c_funptr +{ + void *c_address; +} +c_funptr_t; + +#define ISO_C_BINDING_PREFIX(a) __iso_c_binding_##a + +void ISO_C_BINDING_PREFIX(c_f_pointer)(void *, gfc_array_void *, + const array_t *, int, int); + +void ISO_C_BINDING_PREFIX(c_f_pointer_u0) (void *, gfc_array_void *, + const array_t *); +void ISO_C_BINDING_PREFIX(c_f_pointer_d0) (void *, gfc_array_void *, + const array_t *); + +#endif diff --git a/gcc-4.4.0/libgfortran/intrinsics/iso_c_generated_procs.c b/gcc-4.4.0/libgfortran/intrinsics/iso_c_generated_procs.c new file mode 100644 index 000000000..e5ef7e183 --- /dev/null +++ b/gcc-4.4.0/libgfortran/intrinsics/iso_c_generated_procs.c @@ -0,0 +1,466 @@ +/* Implementation of the ISO_C_BINDING library helper generated functions. + Copyright (C) 2007, 2009 Free Software Foundation, Inc. + Contributed by Christopher Rickett. + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran 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 3 of the License, or (at your option) any later version. + +Libgfortran 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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. */ + + +#include "libgfortran.h" +#include "iso_c_binding.h" + + +/* TODO: This file needs to be finished so that a function is provided + for all possible type/kind combinations! */ + +#ifdef HAVE_GFC_INTEGER_1 +void ISO_C_BINDING_PREFIX (c_f_pointer_i1) (void *, gfc_array_void *, + const array_t *); +#endif + +#ifdef HAVE_GFC_INTEGER_2 +void ISO_C_BINDING_PREFIX (c_f_pointer_i2) (void *, gfc_array_void *, + const array_t *); +#endif + +#ifdef HAVE_GFC_INTEGER_4 +void ISO_C_BINDING_PREFIX (c_f_pointer_i4) (void *, gfc_array_void *, + const array_t *); +#endif + +#ifdef HAVE_GFC_INTEGER_8 +void ISO_C_BINDING_PREFIX (c_f_pointer_i8) (void *, gfc_array_void *, + const array_t *); +#endif + +#ifdef HAVE_GFC_INTEGER_16 +void ISO_C_BINDING_PREFIX (c_f_pointer_i16) (void *, gfc_array_void *, + const array_t *); +#endif + +#ifdef HAVE_GFC_REAL_4 +void ISO_C_BINDING_PREFIX (c_f_pointer_r4) (void *, gfc_array_void *, + const array_t *); +#endif + +#ifdef HAVE_GFC_REAL_8 +void ISO_C_BINDING_PREFIX (c_f_pointer_r8) (void *, gfc_array_void *, + const array_t *); +#endif + +#ifdef HAVE_GFC_REAL_10 +void ISO_C_BINDING_PREFIX (c_f_pointer_r10) (void *, gfc_array_void *, + const array_t *); +#endif + +#ifdef HAVE_GFC_REAL_16 +void ISO_C_BINDING_PREFIX (c_f_pointer_r16) (void *, gfc_array_void *, + const array_t *); +#endif + +#ifdef HAVE_GFC_COMPLEX_4 +void ISO_C_BINDING_PREFIX (c_f_pointer_c4) (void *, gfc_array_void *, + const array_t *); +#endif + +#ifdef HAVE_GFC_COMPLEX_8 +void ISO_C_BINDING_PREFIX (c_f_pointer_c8) (void *, gfc_array_void *, + const array_t *); +#endif + +#ifdef HAVE_GFC_COMPLEX_10 +void ISO_C_BINDING_PREFIX (c_f_pointer_c10) (void *, gfc_array_void *, + const array_t *); +#endif + +#ifdef HAVE_GFC_COMPLEX_16 +void ISO_C_BINDING_PREFIX (c_f_pointer_c16) (void *, gfc_array_void *, + const array_t *); +#endif + +#ifdef GFC_DEFAULT_CHAR +void ISO_C_BINDING_PREFIX (c_f_pointer_s0) (void *, gfc_array_void *, + const array_t *); +#endif + +#ifdef HAVE_GFC_LOGICAL_1 +void ISO_C_BINDING_PREFIX (c_f_pointer_l1) (void *, gfc_array_void *, + const array_t *); +#endif + +#ifdef HAVE_GFC_LOGICAL_2 +void ISO_C_BINDING_PREFIX (c_f_pointer_l2) (void *, gfc_array_void *, + const array_t *); +#endif + +#ifdef HAVE_GFC_LOGICAL_4 +void ISO_C_BINDING_PREFIX (c_f_pointer_l4) (void *, gfc_array_void *, + const array_t *); +#endif + +#ifdef HAVE_GFC_LOGICAL_8 +void ISO_C_BINDING_PREFIX (c_f_pointer_l8) (void *, gfc_array_void *, + const array_t *); +#endif + + +#ifdef HAVE_GFC_INTEGER_1 +/* Set the given Fortran pointer, 'f_ptr_out', to point to the given C + address, 'c_ptr_in'. The Fortran pointer is of type integer and + kind=1. The function c_f_pointer is used to set up the pointer + descriptor. shape is a one-dimensional array of integers + specifying the upper bounds of the array pointed to by the given C + address, if applicable. 'shape' is an optional parameter in + Fortran, so if the user does not provide it, it will come in here + as NULL. */ + +void +ISO_C_BINDING_PREFIX (c_f_pointer_i1) (void *c_ptr_in, + gfc_array_void *f_ptr_out, + const array_t *shape) +{ + /* Here we have an integer(kind=1). */ + ISO_C_BINDING_PREFIX (c_f_pointer) (c_ptr_in, f_ptr_out, shape, + (int) GFC_DTYPE_INTEGER, + (int) sizeof (GFC_INTEGER_1)); +} +#endif + + +#ifdef HAVE_GFC_INTEGER_2 +/* Set the given Fortran pointer, 'f_ptr_out', to point to the given C + address, 'c_ptr_in'. The Fortran pointer is of type integer and + kind=2. The function c_f_pointer is used to set up the pointer + descriptor. shape is a one-dimensional array of integers + specifying the upper bounds of the array pointed to by the given C + address, if applicable. 'shape' is an optional parameter in + Fortran, so if the user does not provide it, it will come in here + as NULL. */ + +void +ISO_C_BINDING_PREFIX (c_f_pointer_i2) (void *c_ptr_in, + gfc_array_void *f_ptr_out, + const array_t *shape) +{ + /* Here we have an integer(kind=2). */ + ISO_C_BINDING_PREFIX (c_f_pointer) (c_ptr_in, f_ptr_out, shape, + (int) GFC_DTYPE_INTEGER, + (int) sizeof (GFC_INTEGER_2)); +} +#endif + + +#ifdef HAVE_GFC_INTEGER_4 +/* Set the given Fortran pointer, f_ptr_out, to point to the given C + address, c_ptr_in. The Fortran pointer is of type integer and + kind=4. The function c_f_pointer is used to set up the pointer + descriptor. */ + +void +ISO_C_BINDING_PREFIX (c_f_pointer_i4) (void *c_ptr_in, + gfc_array_void *f_ptr_out, + const array_t *shape) +{ + /* Here we have an integer(kind=4). */ + ISO_C_BINDING_PREFIX (c_f_pointer) (c_ptr_in, f_ptr_out, shape, + (int) GFC_DTYPE_INTEGER, + (int) sizeof (GFC_INTEGER_4)); +} +#endif + + +#ifdef HAVE_GFC_INTEGER_8 +/* Set the given Fortran pointer, f_ptr_out, to point to the given C + address, c_ptr_in. The Fortran pointer is of type integer and + kind=8. The function c_f_pointer is used to set up the pointer + descriptor. */ + +void +ISO_C_BINDING_PREFIX (c_f_pointer_i8) (void *c_ptr_in, + gfc_array_void *f_ptr_out, + const array_t *shape) +{ + /* Here we have an integer(kind=8). */ + ISO_C_BINDING_PREFIX (c_f_pointer) (c_ptr_in, f_ptr_out, shape, + (int) GFC_DTYPE_INTEGER, + (int) sizeof (GFC_INTEGER_8)); +} +#endif + + +#ifdef HAVE_GFC_INTEGER_16 +/* Set the given Fortran pointer, 'f_ptr_out', to point to the given C + address, 'c_ptr_in'. The Fortran pointer is of type integer and + kind=16. The function c_f_pointer is used to set up the pointer + descriptor. shape is a one-dimensional array of integers + specifying the upper bounds of the array pointed to by the given C + address, if applicable. 'shape' is an optional parameter in + Fortran, so if the user does not provide it, it will come in here + as NULL. */ + +void +ISO_C_BINDING_PREFIX (c_f_pointer_i16) (void *c_ptr_in, + gfc_array_void *f_ptr_out, + const array_t *shape) +{ + /* Here we have an integer(kind=16). */ + ISO_C_BINDING_PREFIX (c_f_pointer) (c_ptr_in, f_ptr_out, shape, + (int) GFC_DTYPE_INTEGER, + (int) sizeof (GFC_INTEGER_16)); +} +#endif + + +#ifdef HAVE_GFC_REAL_4 +/* Set the given Fortran pointer, f_ptr_out, to point to the given C + address, c_ptr_in. The Fortran pointer is of type real and + kind=4. The function c_f_pointer is used to set up the pointer + descriptor. */ + +void +ISO_C_BINDING_PREFIX (c_f_pointer_r4) (void *c_ptr_in, + gfc_array_void *f_ptr_out, + const array_t *shape) +{ + /* Here we have an real(kind=4). */ + ISO_C_BINDING_PREFIX (c_f_pointer) (c_ptr_in, f_ptr_out, shape, + (int) GFC_DTYPE_REAL, + (int) sizeof (GFC_REAL_4)); +} +#endif + + +#ifdef HAVE_GFC_REAL_8 +/* Set the given Fortran pointer, f_ptr_out, to point to the given C + address, c_ptr_in. The Fortran pointer is of type real and + kind=8. The function c_f_pointer is used to set up the pointer + descriptor. */ + +void +ISO_C_BINDING_PREFIX (c_f_pointer_r8) (void *c_ptr_in, + gfc_array_void *f_ptr_out, + const array_t *shape) +{ + /* Here we have an real(kind=8). */ + ISO_C_BINDING_PREFIX (c_f_pointer) (c_ptr_in, f_ptr_out, shape, + (int) GFC_DTYPE_REAL, + (int) sizeof (GFC_REAL_8)); +} +#endif + + +#ifdef HAVE_GFC_REAL_10 +/* Set the given Fortran pointer, f_ptr_out, to point to the given C + address, c_ptr_in. The Fortran pointer is of type real and + kind=10. The function c_f_pointer is used to set up the pointer + descriptor. */ + +void +ISO_C_BINDING_PREFIX (c_f_pointer_r10) (void *c_ptr_in, + gfc_array_void *f_ptr_out, + const array_t *shape) +{ + /* Here we have an real(kind=10). */ + ISO_C_BINDING_PREFIX (c_f_pointer) (c_ptr_in, f_ptr_out, shape, + (int) GFC_DTYPE_REAL, + (int) sizeof (GFC_REAL_10)); +} +#endif + + +#ifdef HAVE_GFC_REAL_16 +/* Set the given Fortran pointer, f_ptr_out, to point to the given C + address, c_ptr_in. The Fortran pointer is of type real and + kind=16. The function c_f_pointer is used to set up the pointer + descriptor. */ + +void +ISO_C_BINDING_PREFIX (c_f_pointer_r16) (void *c_ptr_in, + gfc_array_void *f_ptr_out, + const array_t *shape) +{ + /* Here we have an real(kind=16). */ + ISO_C_BINDING_PREFIX (c_f_pointer) (c_ptr_in, f_ptr_out, shape, + (int) GFC_DTYPE_REAL, + (int) sizeof (GFC_REAL_16)); +} +#endif + + +#ifdef HAVE_GFC_COMPLEX_4 +/* Set the given Fortran pointer, f_ptr_out, to point to the given C + address, c_ptr_in. The Fortran pointer is of type complex and + kind=4. The function c_f_pointer is used to set up the pointer + descriptor. */ + +void +ISO_C_BINDING_PREFIX (c_f_pointer_c4) (void *c_ptr_in, + gfc_array_void *f_ptr_out, + const array_t *shape) +{ + /* Here we have an complex(kind=4). */ + ISO_C_BINDING_PREFIX (c_f_pointer) (c_ptr_in, f_ptr_out, shape, + (int) GFC_DTYPE_COMPLEX, + (int) sizeof (GFC_COMPLEX_4)); +} +#endif + + +#ifdef HAVE_GFC_COMPLEX_8 +/* Set the given Fortran pointer, f_ptr_out, to point to the given C + address, c_ptr_in. The Fortran pointer is of type complex and + kind=8. The function c_f_pointer is used to set up the pointer + descriptor. */ + +void +ISO_C_BINDING_PREFIX (c_f_pointer_c8) (void *c_ptr_in, + gfc_array_void *f_ptr_out, + const array_t *shape) +{ + /* Here we have an complex(kind=8). */ + ISO_C_BINDING_PREFIX (c_f_pointer) (c_ptr_in, f_ptr_out, shape, + (int) GFC_DTYPE_COMPLEX, + (int) sizeof (GFC_COMPLEX_8)); +} +#endif + + +#ifdef HAVE_GFC_COMPLEX_10 +/* Set the given Fortran pointer, f_ptr_out, to point to the given C + address, c_ptr_in. The Fortran pointer is of type complex and + kind=10. The function c_f_pointer is used to set up the pointer + descriptor. */ + +void +ISO_C_BINDING_PREFIX (c_f_pointer_c10) (void *c_ptr_in, + gfc_array_void *f_ptr_out, + const array_t *shape) +{ + /* Here we have an complex(kind=10). */ + ISO_C_BINDING_PREFIX (c_f_pointer) (c_ptr_in, f_ptr_out, shape, + (int) GFC_DTYPE_COMPLEX, + (int) sizeof (GFC_COMPLEX_10)); +} +#endif + + +#ifdef HAVE_GFC_COMPLEX_16 +/* Set the given Fortran pointer, f_ptr_out, to point to the given C + address, c_ptr_in. The Fortran pointer is of type complex and + kind=16. The function c_f_pointer is used to set up the pointer + descriptor. */ + +void +ISO_C_BINDING_PREFIX (c_f_pointer_c16) (void *c_ptr_in, + gfc_array_void *f_ptr_out, + const array_t *shape) +{ + /* Here we have an complex(kind=16). */ + ISO_C_BINDING_PREFIX (c_f_pointer) (c_ptr_in, f_ptr_out, shape, + (int) GFC_DTYPE_COMPLEX, + (int) sizeof (GFC_COMPLEX_16)); +} +#endif + + +#ifdef GFC_DEFAULT_CHAR +/* Set the given Fortran pointer, f_ptr_out, to point to the given C + address, c_ptr_in. The Fortran pointer is of type character. */ + +void +ISO_C_BINDING_PREFIX (c_f_pointer_s0) (void *c_ptr_in, + gfc_array_void *f_ptr_out, + const array_t *shape) +{ + /* Here we have a character string of len=1. */ + ISO_C_BINDING_PREFIX (c_f_pointer) (c_ptr_in, f_ptr_out, shape, + (int) GFC_DTYPE_CHARACTER, + (int) sizeof (char)); +} +#endif + + +#ifdef HAVE_GFC_LOGICAL_1 +/* Set the given Fortran pointer, f_ptr_out, to point to the given C + address, c_ptr_in. The Fortran pointer is of type logical, kind=1. */ + +void +ISO_C_BINDING_PREFIX (c_f_pointer_l1) (void *c_ptr_in, + gfc_array_void *f_ptr_out, + const array_t *shape) +{ + /* Here we have a logical of kind=1. */ + ISO_C_BINDING_PREFIX (c_f_pointer) (c_ptr_in, f_ptr_out, shape, + (int) GFC_DTYPE_LOGICAL, + (int) sizeof (GFC_LOGICAL_1)); +} +#endif + + +#ifdef HAVE_GFC_LOGICAL_2 +/* Set the given Fortran pointer, f_ptr_out, to point to the given C + address, c_ptr_in. The Fortran pointer is of type logical, kind=2. */ + +void +ISO_C_BINDING_PREFIX (c_f_pointer_l2) (void *c_ptr_in, + gfc_array_void *f_ptr_out, + const array_t *shape) +{ + /* Here we have a logical of kind=2. */ + ISO_C_BINDING_PREFIX (c_f_pointer) (c_ptr_in, f_ptr_out, shape, + (int) GFC_DTYPE_LOGICAL, + (int) sizeof (GFC_LOGICAL_2)); +} +#endif + + +#ifdef HAVE_GFC_LOGICAL_4 +/* Set the given Fortran pointer, f_ptr_out, to point to the given C + address, c_ptr_in. The Fortran pointer is of type logical, kind=4. */ + +void +ISO_C_BINDING_PREFIX (c_f_pointer_l4) (void *c_ptr_in, + gfc_array_void *f_ptr_out, + const array_t *shape) +{ + /* Here we have a logical of kind=4. */ + ISO_C_BINDING_PREFIX (c_f_pointer) (c_ptr_in, f_ptr_out, shape, + (int) GFC_DTYPE_LOGICAL, + (int) sizeof (GFC_LOGICAL_4)); +} +#endif + + +#ifdef HAVE_GFC_LOGICAL_8 +/* Set the given Fortran pointer, f_ptr_out, to point to the given C + address, c_ptr_in. The Fortran pointer is of type logical, kind=8. */ + +void +ISO_C_BINDING_PREFIX (c_f_pointer_l8) (void *c_ptr_in, + gfc_array_void *f_ptr_out, + const array_t *shape) +{ + /* Here we have a logical of kind=8. */ + ISO_C_BINDING_PREFIX (c_f_pointer) (c_ptr_in, f_ptr_out, shape, + (int) GFC_DTYPE_LOGICAL, + (int) sizeof (GFC_LOGICAL_8)); +} +#endif diff --git a/gcc-4.4.0/libgfortran/intrinsics/kill.c b/gcc-4.4.0/libgfortran/intrinsics/kill.c new file mode 100644 index 000000000..83e8b2838 --- /dev/null +++ b/gcc-4.4.0/libgfortran/intrinsics/kill.c @@ -0,0 +1,94 @@ +/* Implementation of the KILL g77 intrinsic. + Copyright (C) 2005, 2007, 2009 Free Software Foundation, Inc. + Contributed by François-Xavier Coudert <coudert@clipper.ens.fr> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran 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 3 of the License, or (at your option) any later version. + +Libgfortran 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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. */ + +#include "libgfortran.h" +#include <errno.h> + +#ifdef HAVE_SIGNAL_H +#include <signal.h> +#endif + +/* SUBROUTINE KILL(PID, SIGNAL, STATUS) + INTEGER, INTENT(IN) :: PID, SIGNAL + INTEGER(KIND=1), INTENT(OUT), OPTIONAL :: STATUS + + INTEGER(KIND=1) FUNCTION KILL(PID, SIGNAL) + INTEGER, INTENT(IN) :: PID, SIGNAL */ + +#ifdef HAVE_KILL +extern void kill_i4_sub (GFC_INTEGER_4 *, GFC_INTEGER_4 *, GFC_INTEGER_4 *); +iexport_proto(kill_i4_sub); + +void +kill_i4_sub (GFC_INTEGER_4 *pid, GFC_INTEGER_4 *signal, + GFC_INTEGER_4 *status) +{ + int val; + + val = kill (*pid, *signal); + + if (status != NULL) + *status = (val == 0) ? 0 : errno; +} +iexport(kill_i4_sub); + +extern void kill_i8_sub (GFC_INTEGER_8 *, GFC_INTEGER_8 *, GFC_INTEGER_8 *); +iexport_proto(kill_i8_sub); + +void +kill_i8_sub (GFC_INTEGER_8 *pid, GFC_INTEGER_8 *signal, + GFC_INTEGER_8 *status) +{ + int val; + + val = kill (*pid, *signal); + + if (status != NULL) + *status = (val == 0) ? 0 : errno; +} +iexport(kill_i8_sub); + +extern GFC_INTEGER_4 kill_i4 (GFC_INTEGER_4 *, GFC_INTEGER_4 *); +export_proto(kill_i4); + +GFC_INTEGER_4 +kill_i4 (GFC_INTEGER_4 *pid, GFC_INTEGER_4 *signal) +{ + GFC_INTEGER_4 val; + kill_i4_sub (pid, signal, &val); + return val; +} + +extern GFC_INTEGER_8 kill_i8 (GFC_INTEGER_8 *, GFC_INTEGER_8 *); +export_proto(kill_i8); + +GFC_INTEGER_8 +kill_i8 (GFC_INTEGER_8 *pid, GFC_INTEGER_8 *signal) +{ + GFC_INTEGER_8 val; + kill_i8_sub (pid, signal, &val); + return val; +} +#endif diff --git a/gcc-4.4.0/libgfortran/intrinsics/link.c b/gcc-4.4.0/libgfortran/intrinsics/link.c new file mode 100644 index 000000000..21bae400a --- /dev/null +++ b/gcc-4.4.0/libgfortran/intrinsics/link.c @@ -0,0 +1,131 @@ +/* Implementation of the LINK intrinsic. + Copyright (C) 2005, 2007, 2009 Free Software Foundation, Inc. + Contributed by François-Xavier Coudert <coudert@clipper.ens.fr> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran 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 3 of the License, or (at your option) any later version. + +Libgfortran 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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. */ + +#include "libgfortran.h" + +#include <errno.h> +#include <string.h> + +#ifdef HAVE_UNISTD_H +#include <unistd.h> +#endif + +/* SUBROUTINE LINK(PATH1, PATH2, STATUS) + CHARACTER(len=*), INTENT(IN) :: PATH1, PATH2 + INTEGER, INTENT(OUT), OPTIONAL :: STATUS */ + +#ifdef HAVE_LINK +extern void link_i4_sub (char *, char *, GFC_INTEGER_4 *, gfc_charlen_type, + gfc_charlen_type); +iexport_proto(link_i4_sub); + +void +link_i4_sub (char *path1, char *path2, GFC_INTEGER_4 *status, + gfc_charlen_type path1_len, gfc_charlen_type path2_len) +{ + int val; + char *str1, *str2; + + /* Trim trailing spaces from paths. */ + while (path1_len > 0 && path1[path1_len - 1] == ' ') + path1_len--; + while (path2_len > 0 && path2[path2_len - 1] == ' ') + path2_len--; + + /* Make a null terminated copy of the strings. */ + str1 = gfc_alloca (path1_len + 1); + memcpy (str1, path1, path1_len); + str1[path1_len] = '\0'; + + str2 = gfc_alloca (path2_len + 1); + memcpy (str2, path2, path2_len); + str2[path2_len] = '\0'; + + val = link (str1, str2); + + if (status != NULL) + *status = (val == 0) ? 0 : errno; +} +iexport(link_i4_sub); + +extern void link_i8_sub (char *, char *, GFC_INTEGER_8 *, gfc_charlen_type, + gfc_charlen_type); +iexport_proto(link_i8_sub); + +void +link_i8_sub (char *path1, char *path2, GFC_INTEGER_8 *status, + gfc_charlen_type path1_len, gfc_charlen_type path2_len) +{ + int val; + char *str1, *str2; + + /* Trim trailing spaces from paths. */ + while (path1_len > 0 && path1[path1_len - 1] == ' ') + path1_len--; + while (path2_len > 0 && path2[path2_len - 1] == ' ') + path2_len--; + + /* Make a null terminated copy of the strings. */ + str1 = gfc_alloca (path1_len + 1); + memcpy (str1, path1, path1_len); + str1[path1_len] = '\0'; + + str2 = gfc_alloca (path2_len + 1); + memcpy (str2, path2, path2_len); + str2[path2_len] = '\0'; + + val = link (str1, str2); + + if (status != NULL) + *status = (val == 0) ? 0 : errno; +} +iexport(link_i8_sub); + +extern GFC_INTEGER_4 link_i4 (char *, char *, gfc_charlen_type, + gfc_charlen_type); +export_proto(link_i4); + +GFC_INTEGER_4 +link_i4 (char *path1, char *path2, gfc_charlen_type path1_len, + gfc_charlen_type path2_len) +{ + GFC_INTEGER_4 val; + link_i4_sub (path1, path2, &val, path1_len, path2_len); + return val; +} + +extern GFC_INTEGER_8 link_i8 (char *, char *, gfc_charlen_type, + gfc_charlen_type); +export_proto(link_i8); + +GFC_INTEGER_8 +link_i8 (char *path1, char *path2, gfc_charlen_type path1_len, + gfc_charlen_type path2_len) +{ + GFC_INTEGER_8 val; + link_i8_sub (path1, path2, &val, path1_len, path2_len); + return val; +} +#endif diff --git a/gcc-4.4.0/libgfortran/intrinsics/malloc.c b/gcc-4.4.0/libgfortran/intrinsics/malloc.c new file mode 100644 index 000000000..19001aef8 --- /dev/null +++ b/gcc-4.4.0/libgfortran/intrinsics/malloc.c @@ -0,0 +1,49 @@ +/* Implementation of the MALLOC and FREE intrinsics + Copyright (C) 2005, 2007, 2009 Free Software Foundation, Inc. + Contributed by François-Xavier Coudert <coudert@clipper.ens.fr> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran 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 3 of the License, or (at your option) any later version. + +Libgfortran 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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. */ + +#include "libgfortran.h" + +#ifdef HAVE_STDLIB_H +#include <stdlib.h> +#endif + +extern void PREFIX(free) (void **); +export_proto_np(PREFIX(free)); + +void +PREFIX(free) (void ** ptr) +{ + free (*ptr); +} + + +extern void * PREFIX(malloc) (size_t *); +export_proto_np(PREFIX(malloc)); + +void * +PREFIX(malloc) (size_t * size) +{ + return malloc (*size); +} diff --git a/gcc-4.4.0/libgfortran/intrinsics/move_alloc.c b/gcc-4.4.0/libgfortran/intrinsics/move_alloc.c new file mode 100644 index 000000000..527aa6f25 --- /dev/null +++ b/gcc-4.4.0/libgfortran/intrinsics/move_alloc.c @@ -0,0 +1,69 @@ +/* Generic implementation of the MOVE_ALLOC intrinsic + Copyright (C) 2006, 2007, 2009 Free Software Foundation, Inc. + Contributed by Paul Thomas + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran 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 3 of the License, or (at your option) any later version. + +Ligbfortran 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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. */ + +#include "libgfortran.h" + +#ifdef HAVE_STDLIB_H +#include <stdlib.h> +#endif + +extern void move_alloc (gfc_array_char *, gfc_array_char *); +export_proto(move_alloc); + +void +move_alloc (gfc_array_char * from, gfc_array_char * to) +{ + int i; + + if (to->data) + free (to->data); + + for (i = 0; i < GFC_DESCRIPTOR_RANK (from); i++) + { + to->dim[i].lbound = from->dim[i].lbound; + to->dim[i].ubound = from->dim[i].ubound; + to->dim[i].stride = from->dim[i].stride; + from->dim[i].stride = 0; + from->dim[i].ubound = from->dim[i].lbound; + } + + to->offset = from->offset; + to->dtype = from->dtype; + to->data = from->data; + from->data = NULL; +} + +extern void move_alloc_c (gfc_array_char *, GFC_INTEGER_4, + gfc_array_char *, GFC_INTEGER_4); +export_proto(move_alloc_c); + +void +move_alloc_c (gfc_array_char * from, + GFC_INTEGER_4 from_length __attribute__((unused)), + gfc_array_char * to, + GFC_INTEGER_4 to_length __attribute__((unused))) +{ + move_alloc (from, to); +} diff --git a/gcc-4.4.0/libgfortran/intrinsics/mvbits.c b/gcc-4.4.0/libgfortran/intrinsics/mvbits.c new file mode 100644 index 000000000..7c45bfa41 --- /dev/null +++ b/gcc-4.4.0/libgfortran/intrinsics/mvbits.c @@ -0,0 +1,86 @@ +/* Implementation of the MVBITS intrinsic + Copyright (C) 2004, 2006, 2009 Free Software Foundation, Inc. + Contributed by Tobias Schlüter + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran 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 3 of the License, or (at your option) any later version. + +Libgfortran 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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. */ + +/* TODO: This should be replaced by a compiler builtin. */ + +#ifndef SUB_NAME +#include <libgfortran.h> +#endif + +#ifdef SUB_NAME +/* MVBITS copies LEN bits starting at bit position FROMPOS from FROM + into TO, starting at bit position TOPOS. */ + +extern void SUB_NAME (const TYPE *, const int *, const int *, TYPE *, + const int *); +export_proto(SUB_NAME); + +void +SUB_NAME (const TYPE *from, const int *frompos, const int *len, TYPE *to, + const int *topos) +{ + TYPE oldbits, newbits, lenmask; + + lenmask = (*len == sizeof (TYPE)*8) ? ~(TYPE)0 : ((TYPE)1 << *len) - 1; + newbits = (((UTYPE)(*from) >> *frompos) & lenmask) << *topos; + oldbits = *to & (~(lenmask << *topos)); + + *to = newbits | oldbits; +} +#endif + +#ifndef SUB_NAME +# define TYPE GFC_INTEGER_1 +# define UTYPE GFC_UINTEGER_1 +# define SUB_NAME mvbits_i1 +# include "mvbits.c" +# undef SUB_NAME +# undef TYPE +# undef UTYPE + +# define TYPE GFC_INTEGER_2 +# define UTYPE GFC_UINTEGER_2 +# define SUB_NAME mvbits_i2 +# include "mvbits.c" +# undef SUB_NAME +# undef TYPE +# undef UTYPE + +# define TYPE GFC_INTEGER_4 +# define UTYPE GFC_UINTEGER_4 +# define SUB_NAME mvbits_i4 +# include "mvbits.c" +# undef SUB_NAME +# undef TYPE +# undef UTYPE + +# define TYPE GFC_INTEGER_8 +# define UTYPE GFC_UINTEGER_8 +# define SUB_NAME mvbits_i8 +# include "mvbits.c" +# undef SUB_NAME +# undef TYPE +# undef UTYPE +#endif diff --git a/gcc-4.4.0/libgfortran/intrinsics/pack_generic.c b/gcc-4.4.0/libgfortran/intrinsics/pack_generic.c new file mode 100644 index 000000000..4c89dad31 --- /dev/null +++ b/gcc-4.4.0/libgfortran/intrinsics/pack_generic.c @@ -0,0 +1,690 @@ +/* Generic implementation of the PACK intrinsic + Copyright (C) 2002, 2004, 2005, 2006, 2007, 2009 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran 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 3 of the License, or (at your option) any later version. + +Ligbfortran 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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. */ + +#include "libgfortran.h" +#include <stdlib.h> +#include <assert.h> +#include <string.h> + +/* PACK is specified as follows: + + 13.14.80 PACK (ARRAY, MASK, [VECTOR]) + + Description: Pack an array into an array of rank one under the + control of a mask. + + Class: Transformational function. + + Arguments: + ARRAY may be of any type. It shall not be scalar. + MASK shall be of type LOGICAL. It shall be conformable with ARRAY. + VECTOR (optional) shall be of the same type and type parameters + as ARRAY. VECTOR shall have at least as many elements as + there are true elements in MASK. If MASK is a scalar + with the value true, VECTOR shall have at least as many + elements as there are in ARRAY. + + Result Characteristics: The result is an array of rank one with the + same type and type parameters as ARRAY. If VECTOR is present, the + result size is that of VECTOR; otherwise, the result size is the + number /t/ of true elements in MASK unless MASK is scalar with the + value true, in which case the result size is the size of ARRAY. + + Result Value: Element /i/ of the result is the element of ARRAY + that corresponds to the /i/th true element of MASK, taking elements + in array element order, for /i/ = 1, 2, ..., /t/. If VECTOR is + present and has size /n/ > /t/, element /i/ of the result has the + value VECTOR(/i/), for /i/ = /t/ + 1, ..., /n/. + + Examples: The nonzero elements of an array M with the value + | 0 0 0 | + | 9 0 0 | may be "gathered" by the function PACK. The result of + | 0 0 7 | + PACK (M, MASK = M.NE.0) is [9,7] and the result of PACK (M, M.NE.0, + VECTOR = (/ 2,4,6,8,10,12 /)) is [9,7,6,8,10,12]. + +There are two variants of the PACK intrinsic: one, where MASK is +array valued, and the other one where MASK is scalar. */ + +static void +pack_internal (gfc_array_char *ret, const gfc_array_char *array, + const gfc_array_l1 *mask, const gfc_array_char *vector, + index_type size) +{ + /* r.* indicates the return array. */ + index_type rstride0; + char * restrict rptr; + /* s.* indicates the source array. */ + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type sstride0; + const char *sptr; + /* m.* indicates the mask array. */ + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type mstride0; + const GFC_LOGICAL_1 *mptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + int zero_sized; + index_type n; + index_type dim; + index_type nelem; + index_type total; + int mask_kind; + + dim = GFC_DESCRIPTOR_RANK (array); + + sptr = array->data; + mptr = mask->data; + + /* Use the same loop for all logical types, by using GFC_LOGICAL_1 + and using shifting to address size and endian issues. */ + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + { + /* Don't convert a NULL pointer as we use test for NULL below. */ + if (mptr) + mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind); + } + else + runtime_error ("Funny sized logical array"); + + zero_sized = 0; + for (n = 0; n < dim; n++) + { + count[n] = 0; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + if (extent[n] <= 0) + zero_sized = 1; + sstride[n] = array->dim[n].stride * size; + mstride[n] = mask->dim[n].stride * mask_kind; + } + if (sstride[0] == 0) + sstride[0] = size; + if (mstride[0] == 0) + mstride[0] = mask_kind; + + if (ret->data == NULL || compile_options.bounds_check) + { + /* Count the elements, either for allocating memory or + for bounds checking. */ + + if (vector != NULL) + { + /* The return array will have as many + elements as there are in VECTOR. */ + total = vector->dim[0].ubound + 1 - vector->dim[0].lbound; + } + else + { + /* We have to count the true elements in MASK. */ + + /* TODO: We could speed up pack easily in the case of only + few .TRUE. entries in MASK, by keeping track of where we + would be in the source array during the initial traversal + of MASK, and caching the pointers to those elements. Then, + supposed the number of elements is small enough, we would + only have to traverse the list, and copy those elements + into the result array. In the case of datatypes which fit + in one of the integer types we could also cache the + value instead of a pointer to it. + This approach might be bad from the point of view of + cache behavior in the case where our cache is not big + enough to hold all elements that have to be copied. */ + + const GFC_LOGICAL_1 *m = mptr; + + total = 0; + if (zero_sized) + m = NULL; + + while (m) + { + /* Test this element. */ + if (*m) + total++; + + /* Advance to the next element. */ + m += mstride[0]; + count[0]++; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it + and increment the next dimension. */ + count[n] = 0; + /* We could precalculate this product, but this is a + less frequently used path so probably not worth + it. */ + m -= mstride[n] * extent[n]; + n++; + if (n >= dim) + { + /* Break out of the loop. */ + m = NULL; + break; + } + else + { + count[n]++; + m += mstride[n]; + } + } + } + } + + if (ret->data == NULL) + { + /* Setup the array descriptor. */ + ret->dim[0].lbound = 0; + ret->dim[0].ubound = total - 1; + ret->dim[0].stride = 1; + + ret->offset = 0; + if (total == 0) + { + /* In this case, nothing remains to be done. */ + ret->data = internal_malloc_size (1); + return; + } + else + ret->data = internal_malloc_size (size * total); + } + else + { + /* We come here because of range checking. */ + index_type ret_extent; + + ret_extent = ret->dim[0].ubound + 1 - ret->dim[0].lbound; + if (total != ret_extent) + runtime_error ("Incorrect extent in return value of PACK intrinsic;" + " is %ld, should be %ld", (long int) total, + (long int) ret_extent); + } + } + + rstride0 = ret->dim[0].stride * size; + if (rstride0 == 0) + rstride0 = size; + sstride0 = sstride[0]; + mstride0 = mstride[0]; + rptr = ret->data; + + while (sptr && mptr) + { + /* Test this element. */ + if (*mptr) + { + /* Add it. */ + memcpy (rptr, sptr, size); + rptr += rstride0; + } + /* Advance to the next element. */ + sptr += sstride0; + mptr += mstride0; + count[0]++; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + sptr -= sstride[n] * extent[n]; + mptr -= mstride[n] * extent[n]; + n++; + if (n >= dim) + { + /* Break out of the loop. */ + sptr = NULL; + break; + } + else + { + count[n]++; + sptr += sstride[n]; + mptr += mstride[n]; + } + } + } + + /* Add any remaining elements from VECTOR. */ + if (vector) + { + n = vector->dim[0].ubound + 1 - vector->dim[0].lbound; + nelem = ((rptr - ret->data) / rstride0); + if (n > nelem) + { + sstride0 = vector->dim[0].stride * size; + if (sstride0 == 0) + sstride0 = size; + + sptr = vector->data + sstride0 * nelem; + n -= nelem; + while (n--) + { + memcpy (rptr, sptr, size); + rptr += rstride0; + sptr += sstride0; + } + } + } +} + +extern void pack (gfc_array_char *, const gfc_array_char *, + const gfc_array_l1 *, const gfc_array_char *); +export_proto(pack); + +void +pack (gfc_array_char *ret, const gfc_array_char *array, + const gfc_array_l1 *mask, const gfc_array_char *vector) +{ + index_type type_size; + index_type size; + + type_size = GFC_DTYPE_TYPE_SIZE(array); + + switch(type_size) + { + case GFC_DTYPE_LOGICAL_1: + case GFC_DTYPE_INTEGER_1: + case GFC_DTYPE_DERIVED_1: + pack_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) array, + (gfc_array_l1 *) mask, (gfc_array_i1 *) vector); + return; + + case GFC_DTYPE_LOGICAL_2: + case GFC_DTYPE_INTEGER_2: + pack_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) array, + (gfc_array_l1 *) mask, (gfc_array_i2 *) vector); + return; + + case GFC_DTYPE_LOGICAL_4: + case GFC_DTYPE_INTEGER_4: + + pack_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) array, + (gfc_array_l1 *) mask, (gfc_array_i4 *) vector); + return; + + case GFC_DTYPE_LOGICAL_8: + case GFC_DTYPE_INTEGER_8: + + pack_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) array, + (gfc_array_l1 *) mask, (gfc_array_i8 *) vector); + return; + +#ifdef HAVE_GFC_INTEGER_16 + case GFC_DTYPE_LOGICAL_16: + case GFC_DTYPE_INTEGER_16: + + pack_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) array, + (gfc_array_l1 *) mask, (gfc_array_i16 *) vector); + return; +#endif + case GFC_DTYPE_REAL_4: + pack_r4 ((gfc_array_r4 *) ret, (gfc_array_r4 *) array, + (gfc_array_l1 *) mask, (gfc_array_r4 *) vector); + return; + + case GFC_DTYPE_REAL_8: + pack_r8 ((gfc_array_r8 *) ret, (gfc_array_r8 *) array, + (gfc_array_l1 *) mask, (gfc_array_r8 *) vector); + return; + +#ifdef HAVE_GFC_REAL_10 + case GFC_DTYPE_REAL_10: + pack_r10 ((gfc_array_r10 *) ret, (gfc_array_r10 *) array, + (gfc_array_l1 *) mask, (gfc_array_r10 *) vector); + return; +#endif + +#ifdef HAVE_GFC_REAL_16 + case GFC_DTYPE_REAL_16: + pack_r16 ((gfc_array_r16 *) ret, (gfc_array_r16 *) array, + (gfc_array_l1 *) mask, (gfc_array_r16 *) vector); + return; +#endif + case GFC_DTYPE_COMPLEX_4: + pack_c4 ((gfc_array_c4 *) ret, (gfc_array_c4 *) array, + (gfc_array_l1 *) mask, (gfc_array_c4 *) vector); + return; + + case GFC_DTYPE_COMPLEX_8: + pack_c8 ((gfc_array_c8 *) ret, (gfc_array_c8 *) array, + (gfc_array_l1 *) mask, (gfc_array_c8 *) vector); + return; + +#ifdef HAVE_GFC_COMPLEX_10 + case GFC_DTYPE_COMPLEX_10: + pack_c10 ((gfc_array_c10 *) ret, (gfc_array_c10 *) array, + (gfc_array_l1 *) mask, (gfc_array_c10 *) vector); + return; +#endif + +#ifdef HAVE_GFC_COMPLEX_16 + case GFC_DTYPE_COMPLEX_16: + pack_c16 ((gfc_array_c16 *) ret, (gfc_array_c16 *) array, + (gfc_array_l1 *) mask, (gfc_array_c16 *) vector); + return; +#endif + + /* For derived types, let's check the actual alignment of the + data pointers. If they are aligned, we can safely call + the unpack functions. */ + + case GFC_DTYPE_DERIVED_2: + if (GFC_UNALIGNED_2(ret->data) || GFC_UNALIGNED_2(array->data) + || GFC_UNALIGNED_2(vector->data)) + break; + else + { + pack_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) array, + (gfc_array_l1 *) mask, (gfc_array_i2 *) vector); + return; + } + + case GFC_DTYPE_DERIVED_4: + if (GFC_UNALIGNED_4(ret->data) || GFC_UNALIGNED_4(array->data) + || GFC_UNALIGNED_4(vector->data)) + break; + else + { + pack_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) array, + (gfc_array_l1 *) mask, (gfc_array_i4 *) vector); + return; + } + + case GFC_DTYPE_DERIVED_8: + if (GFC_UNALIGNED_8(ret->data) || GFC_UNALIGNED_8(array->data) + || GFC_UNALIGNED_8(vector->data)) + break; + else + { + pack_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) array, + (gfc_array_l1 *) mask, (gfc_array_i8 *) vector); + } + +#ifdef HAVE_GFC_INTEGER_16 + case GFC_DTYPE_DERIVED_16: + if (GFC_UNALIGNED_16(ret->data) || GFC_UNALIGNED_16(array->data) + || GFC_UNALIGNED_16(vector->data)) + break; + else + { + pack_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) array, + (gfc_array_l1 *) mask, (gfc_array_i16 *) vector); + return; + } +#endif + + } + + size = GFC_DESCRIPTOR_SIZE (array); + pack_internal (ret, array, mask, vector, size); +} + + +extern void pack_char (gfc_array_char *, GFC_INTEGER_4, const gfc_array_char *, + const gfc_array_l1 *, const gfc_array_char *, + GFC_INTEGER_4, GFC_INTEGER_4); +export_proto(pack_char); + +void +pack_char (gfc_array_char *ret, + GFC_INTEGER_4 ret_length __attribute__((unused)), + const gfc_array_char *array, const gfc_array_l1 *mask, + const gfc_array_char *vector, GFC_INTEGER_4 array_length, + GFC_INTEGER_4 vector_length __attribute__((unused))) +{ + pack_internal (ret, array, mask, vector, array_length); +} + + +extern void pack_char4 (gfc_array_char *, GFC_INTEGER_4, const gfc_array_char *, + const gfc_array_l1 *, const gfc_array_char *, + GFC_INTEGER_4, GFC_INTEGER_4); +export_proto(pack_char4); + +void +pack_char4 (gfc_array_char *ret, + GFC_INTEGER_4 ret_length __attribute__((unused)), + const gfc_array_char *array, const gfc_array_l1 *mask, + const gfc_array_char *vector, GFC_INTEGER_4 array_length, + GFC_INTEGER_4 vector_length __attribute__((unused))) +{ + pack_internal (ret, array, mask, vector, array_length * sizeof (gfc_char4_t)); +} + + +static void +pack_s_internal (gfc_array_char *ret, const gfc_array_char *array, + const GFC_LOGICAL_4 *mask, const gfc_array_char *vector, + index_type size) +{ + /* r.* indicates the return array. */ + index_type rstride0; + char *rptr; + /* s.* indicates the source array. */ + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type sstride0; + const char *sptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type n; + index_type dim; + index_type ssize; + index_type nelem; + index_type total; + + dim = GFC_DESCRIPTOR_RANK (array); + ssize = 1; + for (n = 0; n < dim; n++) + { + count[n] = 0; + extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; + if (extent[n] < 0) + extent[n] = 0; + + sstride[n] = array->dim[n].stride * size; + ssize *= extent[n]; + } + if (sstride[0] == 0) + sstride[0] = size; + + sstride0 = sstride[0]; + + if (ssize != 0) + sptr = array->data; + else + sptr = NULL; + + if (ret->data == NULL) + { + /* Allocate the memory for the result. */ + + if (vector != NULL) + { + /* The return array will have as many elements as there are + in vector. */ + total = vector->dim[0].ubound + 1 - vector->dim[0].lbound; + if (total <= 0) + { + total = 0; + vector = NULL; + } + } + else + { + if (*mask) + { + /* The result array will have as many elements as the input + array. */ + total = extent[0]; + for (n = 1; n < dim; n++) + total *= extent[n]; + } + else + /* The result array will be empty. */ + total = 0; + } + + /* Setup the array descriptor. */ + ret->dim[0].lbound = 0; + ret->dim[0].ubound = total - 1; + ret->dim[0].stride = 1; + ret->offset = 0; + + if (total == 0) + { + ret->data = internal_malloc_size (1); + return; + } + else + ret->data = internal_malloc_size (size * total); + } + + rstride0 = ret->dim[0].stride * size; + if (rstride0 == 0) + rstride0 = size; + rptr = ret->data; + + /* The remaining possibilities are now: + If MASK is .TRUE., we have to copy the source array into the + result array. We then have to fill it up with elements from VECTOR. + If MASK is .FALSE., we have to copy VECTOR into the result + array. If VECTOR were not present we would have already returned. */ + + if (*mask && ssize != 0) + { + while (sptr) + { + /* Add this element. */ + memcpy (rptr, sptr, size); + rptr += rstride0; + + /* Advance to the next element. */ + sptr += sstride0; + count[0]++; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and + increment the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a + less frequently used path so probably not worth it. */ + sptr -= sstride[n] * extent[n]; + n++; + if (n >= dim) + { + /* Break out of the loop. */ + sptr = NULL; + break; + } + else + { + count[n]++; + sptr += sstride[n]; + } + } + } + } + + /* Add any remaining elements from VECTOR. */ + if (vector) + { + n = vector->dim[0].ubound + 1 - vector->dim[0].lbound; + nelem = ((rptr - ret->data) / rstride0); + if (n > nelem) + { + sstride0 = vector->dim[0].stride * size; + if (sstride0 == 0) + sstride0 = size; + + sptr = vector->data + sstride0 * nelem; + n -= nelem; + while (n--) + { + memcpy (rptr, sptr, size); + rptr += rstride0; + sptr += sstride0; + } + } + } +} + +extern void pack_s (gfc_array_char *ret, const gfc_array_char *array, + const GFC_LOGICAL_4 *, const gfc_array_char *); +export_proto(pack_s); + +void +pack_s (gfc_array_char *ret, const gfc_array_char *array, + const GFC_LOGICAL_4 *mask, const gfc_array_char *vector) +{ + pack_s_internal (ret, array, mask, vector, GFC_DESCRIPTOR_SIZE (array)); +} + + +extern void pack_s_char (gfc_array_char *ret, GFC_INTEGER_4, + const gfc_array_char *array, const GFC_LOGICAL_4 *, + const gfc_array_char *, GFC_INTEGER_4, + GFC_INTEGER_4); +export_proto(pack_s_char); + +void +pack_s_char (gfc_array_char *ret, + GFC_INTEGER_4 ret_length __attribute__((unused)), + const gfc_array_char *array, const GFC_LOGICAL_4 *mask, + const gfc_array_char *vector, GFC_INTEGER_4 array_length, + GFC_INTEGER_4 vector_length __attribute__((unused))) +{ + pack_s_internal (ret, array, mask, vector, array_length); +} + + +extern void pack_s_char4 (gfc_array_char *ret, GFC_INTEGER_4, + const gfc_array_char *array, const GFC_LOGICAL_4 *, + const gfc_array_char *, GFC_INTEGER_4, + GFC_INTEGER_4); +export_proto(pack_s_char4); + +void +pack_s_char4 (gfc_array_char *ret, + GFC_INTEGER_4 ret_length __attribute__((unused)), + const gfc_array_char *array, const GFC_LOGICAL_4 *mask, + const gfc_array_char *vector, GFC_INTEGER_4 array_length, + GFC_INTEGER_4 vector_length __attribute__((unused))) +{ + pack_s_internal (ret, array, mask, vector, + array_length * sizeof (gfc_char4_t)); +} diff --git a/gcc-4.4.0/libgfortran/intrinsics/perror.c b/gcc-4.4.0/libgfortran/intrinsics/perror.c new file mode 100644 index 000000000..10348bd08 --- /dev/null +++ b/gcc-4.4.0/libgfortran/intrinsics/perror.c @@ -0,0 +1,55 @@ +/* Implementation of the PERROR intrinsic. + Copyright (C) 2005, 2007, 2009 Free Software Foundation, Inc. + Contributed by François-Xavier Coudert <coudert@clipper.ens.fr> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran 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 3 of the License, or (at your option) any later version. + +Libgfortran 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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. */ + +#include "libgfortran.h" + +#include <errno.h> +#include <string.h> + +/* SUBROUTINE PERROR(STRING) + CHARACTER(len=*), INTENT(IN) :: STRING */ + +#ifdef HAVE_PERROR +extern void perror_sub (char *, gfc_charlen_type); +iexport_proto(perror_sub); + +void +perror_sub (char *string, gfc_charlen_type string_len) +{ + char * str; + + /* Trim trailing spaces from paths. */ + while (string_len > 0 && string[string_len - 1] == ' ') + string_len--; + + /* Make a null terminated copy of the strings. */ + str = gfc_alloca (string_len + 1); + memcpy (str, string, string_len); + str[string_len] = '\0'; + + perror (str); +} +iexport(perror_sub); +#endif diff --git a/gcc-4.4.0/libgfortran/intrinsics/rand.c b/gcc-4.4.0/libgfortran/intrinsics/rand.c new file mode 100644 index 000000000..369feaeaf --- /dev/null +++ b/gcc-4.4.0/libgfortran/intrinsics/rand.c @@ -0,0 +1,136 @@ +/* Implementation of the IRAND, RAND, and SRAND intrinsics. + Copyright (C) 2004, 2005, 2007, 2009 Free Software Foundation, Inc. + Contributed by Steven G. Kargl <kargls@comcast.net>. + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran 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 3 of the License, or (at your option) any later version. + +Libgfortran 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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. */ + +/* Simple multiplicative congruent algorithm. + The period of this generator is approximately 2^31-1, which means that + it should not be used for anything serious. The implementation here + is based of an algorithm from S.K. Park and K.W. Miller, Comm. ACM, + 31, 1192-1201 (1988). It is also provided solely for compatibility + with G77. */ + +#include "libgfortran.h" +#include <gthr.h> + +#define GFC_RAND_A 16807 +#define GFC_RAND_M 2147483647 +#define GFC_RAND_M1 (GFC_RAND_M - 1) + +static GFC_UINTEGER_8 rand_seed = 1; +#ifdef __GTHREAD_MUTEX_INIT +static __gthread_mutex_t rand_seed_lock = __GTHREAD_MUTEX_INIT; +#else +static __gthread_mutex_t rand_seed_lock; +#endif + + +/* Set the seed of the irand generator. Note 0 is a bad seed. */ + +static void +srand_internal (GFC_INTEGER_8 i) +{ + rand_seed = i ? i : 123459876; +} + +extern void PREFIX(srand) (GFC_INTEGER_4 *i); +export_proto_np(PREFIX(srand)); + +void +PREFIX(srand) (GFC_INTEGER_4 *i) +{ + __gthread_mutex_lock (&rand_seed_lock); + srand_internal (*i); + __gthread_mutex_unlock (&rand_seed_lock); +} + +/* Return an INTEGER in the range [1,GFC_RAND_M-1]. */ + +extern GFC_INTEGER_4 irand (GFC_INTEGER_4 *); +iexport_proto(irand); + +GFC_INTEGER_4 +irand (GFC_INTEGER_4 *i) +{ + GFC_INTEGER_4 j; + if (i) + j = *i; + else + j = 0; + + __gthread_mutex_lock (&rand_seed_lock); + + switch (j) + { + /* Return the next RN. */ + case 0: + break; + + /* Reset the RN sequence to system-dependent sequence and return the + first value. */ + case 1: + srand_internal (0); + break; + + /* Seed the RN sequence with j and return the first value. */ + default: + srand_internal (j); + break; + } + + rand_seed = GFC_RAND_A * rand_seed % GFC_RAND_M; + j = (GFC_INTEGER_4) rand_seed; + + __gthread_mutex_unlock (&rand_seed_lock); + + return j; +} +iexport(irand); + + +/* Return a random REAL in the range [0,1). */ + +extern GFC_REAL_4 PREFIX(rand) (GFC_INTEGER_4 *i); +export_proto_np(PREFIX(rand)); + +GFC_REAL_4 +PREFIX(rand) (GFC_INTEGER_4 *i) +{ + GFC_UINTEGER_4 mask; +#if GFC_REAL_4_RADIX == 2 + mask = ~ (GFC_UINTEGER_4) 0u << (32 - GFC_REAL_4_DIGITS + 1); +#elif GFC_REAL_4_RADIX == 16 + mask = ~ (GFC_UINTEGER_4) 0u << ((8 - GFC_REAL_4_DIGITS) * 4 + 1); +#else +#error "GFC_REAL_4_RADIX has unknown value" +#endif + return ((GFC_UINTEGER_4) (irand(i) -1) & mask) * (GFC_REAL_4) 0x1.p-31f; +} + +#ifndef __GTHREAD_MUTEX_INIT +static void __attribute__((constructor)) +init (void) +{ + __GTHREAD_MUTEX_INIT_FUNCTION (&rand_seed_lock); +} +#endif diff --git a/gcc-4.4.0/libgfortran/intrinsics/random.c b/gcc-4.4.0/libgfortran/intrinsics/random.c new file mode 100644 index 000000000..0d1f25f70 --- /dev/null +++ b/gcc-4.4.0/libgfortran/intrinsics/random.c @@ -0,0 +1,797 @@ +/* Implementation of the RANDOM intrinsics + Copyright 2002, 2004, 2005, 2006, 2007, 2009 Free Software Foundation, Inc. + Contributed by Lars Segerlund <seger@linuxmail.org> + and Steve Kargl. + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran 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 3 of the License, or (at your option) any later version. + +Ligbfortran 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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. */ + +#include "libgfortran.h" +#include <gthr.h> +#include <string.h> + +extern void random_r4 (GFC_REAL_4 *); +iexport_proto(random_r4); + +extern void random_r8 (GFC_REAL_8 *); +iexport_proto(random_r8); + +extern void arandom_r4 (gfc_array_r4 *); +export_proto(arandom_r4); + +extern void arandom_r8 (gfc_array_r8 *); +export_proto(arandom_r8); + +#ifdef HAVE_GFC_REAL_10 + +extern void random_r10 (GFC_REAL_10 *); +iexport_proto(random_r10); + +extern void arandom_r10 (gfc_array_r10 *); +export_proto(arandom_r10); + +#endif + +#ifdef HAVE_GFC_REAL_16 + +extern void random_r16 (GFC_REAL_16 *); +iexport_proto(random_r16); + +extern void arandom_r16 (gfc_array_r16 *); +export_proto(arandom_r16); + +#endif + +#ifdef __GTHREAD_MUTEX_INIT +static __gthread_mutex_t random_lock = __GTHREAD_MUTEX_INIT; +#else +static __gthread_mutex_t random_lock; +#endif + +/* Helper routines to map a GFC_UINTEGER_* to the corresponding + GFC_REAL_* types in the range of [0,1). If GFC_REAL_*_RADIX are 2 + or 16, respectively, we mask off the bits that don't fit into the + correct GFC_REAL_*, convert to the real type, then multiply by the + correct offset. */ + + +static inline void +rnumber_4 (GFC_REAL_4 *f, GFC_UINTEGER_4 v) +{ + GFC_UINTEGER_4 mask; +#if GFC_REAL_4_RADIX == 2 + mask = ~ (GFC_UINTEGER_4) 0u << (32 - GFC_REAL_4_DIGITS); +#elif GFC_REAL_4_RADIX == 16 + mask = ~ (GFC_UINTEGER_4) 0u << ((8 - GFC_REAL_4_DIGITS) * 4); +#else +#error "GFC_REAL_4_RADIX has unknown value" +#endif + v = v & mask; + *f = (GFC_REAL_4) v * (GFC_REAL_4) 0x1.p-32f; +} + +static inline void +rnumber_8 (GFC_REAL_8 *f, GFC_UINTEGER_8 v) +{ + GFC_UINTEGER_8 mask; +#if GFC_REAL_8_RADIX == 2 + mask = ~ (GFC_UINTEGER_8) 0u << (64 - GFC_REAL_8_DIGITS); +#elif GFC_REAL_8_RADIX == 16 + mask = ~ (GFC_UINTEGER_8) 0u << (16 - GFC_REAL_8_DIGITS) * 4); +#else +#error "GFC_REAL_8_RADIX has unknown value" +#endif + v = v & mask; + *f = (GFC_REAL_8) v * (GFC_REAL_8) 0x1.p-64; +} + +#ifdef HAVE_GFC_REAL_10 + +static inline void +rnumber_10 (GFC_REAL_10 *f, GFC_UINTEGER_8 v) +{ + GFC_UINTEGER_8 mask; +#if GFC_REAL_10_RADIX == 2 + mask = ~ (GFC_UINTEGER_8) 0u << (64 - GFC_REAL_10_DIGITS); +#elif GFC_REAL_10_RADIX == 16 + mask = ~ (GFC_UINTEGER_10) 0u << ((16 - GFC_REAL_10_DIGITS) * 4); +#else +#error "GFC_REAL_10_RADIX has unknown value" +#endif + v = v & mask; + *f = (GFC_REAL_10) v * (GFC_REAL_10) 0x1.p-64; +} +#endif + +#ifdef HAVE_GFC_REAL_16 + +/* For REAL(KIND=16), we only need to mask off the lower bits. */ + +static inline void +rnumber_16 (GFC_REAL_16 *f, GFC_UINTEGER_8 v1, GFC_UINTEGER_8 v2) +{ + GFC_UINTEGER_8 mask; +#if GFC_REAL_16_RADIX == 2 + mask = ~ (GFC_UINTEGER_8) 0u << (128 - GFC_REAL_16_DIGITS); +#elif GFC_REAL_16_RADIX == 16 + mask = ~ (GFC_UINTEGER_8) 0u << ((32 - GFC_REAL_16_DIGITS) * 4); +#else +#error "GFC_REAL_16_RADIX has unknown value" +#endif + v2 = v2 & mask; + *f = (GFC_REAL_16) v1 * (GFC_REAL_16) 0x1.p-64 + + (GFC_REAL_16) v2 * (GFC_REAL_16) 0x1.p-128; +} +#endif +/* libgfortran previously had a Mersenne Twister, taken from the paper: + + Mersenne Twister: 623-dimensionally equidistributed + uniform pseudorandom generator. + + by Makoto Matsumoto & Takuji Nishimura + which appeared in the: ACM Transactions on Modelling and Computer + Simulations: Special Issue on Uniform Random Number + Generation. ( Early in 1998 ). + + The Mersenne Twister code was replaced due to + + (1) Simple user specified seeds lead to really bad sequences for + nearly 100000 random numbers. + (2) open(), read(), and close() were not properly declared via header + files. + (3) The global index i was abused and caused unexpected behavior with + GET and PUT. + (4) See PR 15619. + + + libgfortran currently uses George Marsaglia's KISS (Keep It Simple Stupid) + random number generator. This PRNG combines: + + (1) The congruential generator x(n)=69069*x(n-1)+1327217885 with a period + of 2^32, + (2) A 3-shift shift-register generator with a period of 2^32-1, + (3) Two 16-bit multiply-with-carry generators with a period of + 597273182964842497 > 2^59. + + The overall period exceeds 2^123. + + http://www.ciphersbyritter.com/NEWS4/RANDC.HTM#369F6FCA.74C7C041@stat.fsu.edu + + The above web site has an archive of a newsgroup posting from George + Marsaglia with the statement: + + Subject: Random numbers for C: Improvements. + Date: Fri, 15 Jan 1999 11:41:47 -0500 + From: George Marsaglia <geo@stat.fsu.edu> + Message-ID: <369F6FCA.74C7C041@stat.fsu.edu> + References: <369B5E30.65A55FD1@stat.fsu.edu> + Newsgroups: sci.stat.math,sci.math,sci.math.numer-analysis + Lines: 93 + + As I hoped, several suggestions have led to + improvements in the code for RNG's I proposed for + use in C. (See the thread "Random numbers for C: Some + suggestions" in previous postings.) The improved code + is listed below. + + A question of copyright has also been raised. Unlike + DIEHARD, there is no copyright on the code below. You + are free to use it in any way you want, but you may + wish to acknowledge the source, as a courtesy. + +"There is no copyright on the code below." included the original +KISS algorithm. */ + +/* We use three KISS random number generators, with different + seeds. + As a matter of Quality of Implementation, the random numbers + we generate for different REAL kinds, starting from the same + seed, are always the same up to the precision of these types. + We do this by using three generators with different seeds, the + first one always for the most significant bits, the second one + for bits 33..64 (if present in the REAL kind), and the third one + (called twice) for REAL(16). */ + +#define GFC_SL(k, n) ((k)^((k)<<(n))) +#define GFC_SR(k, n) ((k)^((k)>>(n))) + +/* Reference for the seed: + From: "George Marsaglia" <g...@stat.fsu.edu> + Newsgroups: sci.math + Message-ID: <e7CcnWxczriWssCjXTWc3A@comcast.com> + + The KISS RNG uses four seeds, x, y, z, c, + with 0<=x<2^32, 0<y<2^32, 0<=z<2^32, 0<=c<698769069 + except that the two pairs + z=0,c=0 and z=2^32-1,c=698769068 + should be avoided. */ + +/* Any modifications to the seeds that change kiss_size below need to be + reflected in check.c (gfc_check_random_seed) to enable correct + compile-time checking of PUT size for the RANDOM_SEED intrinsic. */ + +#define KISS_DEFAULT_SEED_1 123456789, 362436069, 521288629, 316191069 +#define KISS_DEFAULT_SEED_2 987654321, 458629013, 582859209, 438195021 +#ifdef HAVE_GFC_REAL_16 +#define KISS_DEFAULT_SEED_3 573658661, 185639104, 582619469, 296736107 +#endif + +static GFC_UINTEGER_4 kiss_seed[] = { + KISS_DEFAULT_SEED_1, + KISS_DEFAULT_SEED_2, +#ifdef HAVE_GFC_REAL_16 + KISS_DEFAULT_SEED_3 +#endif +}; + +static GFC_UINTEGER_4 kiss_default_seed[] = { + KISS_DEFAULT_SEED_1, + KISS_DEFAULT_SEED_2, +#ifdef HAVE_GFC_REAL_16 + KISS_DEFAULT_SEED_3 +#endif +}; + +static const GFC_INTEGER_4 kiss_size = sizeof(kiss_seed)/sizeof(kiss_seed[0]); + +static GFC_UINTEGER_4 * const kiss_seed_1 = kiss_seed; +static GFC_UINTEGER_4 * const kiss_seed_2 = kiss_seed + 4; + +#ifdef HAVE_GFC_REAL_16 +static GFC_UINTEGER_4 * const kiss_seed_3 = kiss_seed + 8; +#endif + +/* kiss_random_kernel() returns an integer value in the range of + (0, GFC_UINTEGER_4_HUGE]. The distribution of pseudorandom numbers + should be uniform. */ + +static GFC_UINTEGER_4 +kiss_random_kernel(GFC_UINTEGER_4 * seed) +{ + GFC_UINTEGER_4 kiss; + + seed[0] = 69069 * seed[0] + 1327217885; + seed[1] = GFC_SL(GFC_SR(GFC_SL(seed[1],13),17),5); + seed[2] = 18000 * (seed[2] & 65535) + (seed[2] >> 16); + seed[3] = 30903 * (seed[3] & 65535) + (seed[3] >> 16); + kiss = seed[0] + seed[1] + (seed[2] << 16) + seed[3]; + + return kiss; +} + +/* This function produces a REAL(4) value from the uniform distribution + with range [0,1). */ + +void +random_r4 (GFC_REAL_4 *x) +{ + GFC_UINTEGER_4 kiss; + + __gthread_mutex_lock (&random_lock); + kiss = kiss_random_kernel (kiss_seed_1); + rnumber_4 (x, kiss); + __gthread_mutex_unlock (&random_lock); +} +iexport(random_r4); + +/* This function produces a REAL(8) value from the uniform distribution + with range [0,1). */ + +void +random_r8 (GFC_REAL_8 *x) +{ + GFC_UINTEGER_8 kiss; + + __gthread_mutex_lock (&random_lock); + kiss = ((GFC_UINTEGER_8) kiss_random_kernel (kiss_seed_1)) << 32; + kiss += kiss_random_kernel (kiss_seed_2); + rnumber_8 (x, kiss); + __gthread_mutex_unlock (&random_lock); +} +iexport(random_r8); + +#ifdef HAVE_GFC_REAL_10 + +/* This function produces a REAL(10) value from the uniform distribution + with range [0,1). */ + +void +random_r10 (GFC_REAL_10 *x) +{ + GFC_UINTEGER_8 kiss; + + __gthread_mutex_lock (&random_lock); + kiss = ((GFC_UINTEGER_8) kiss_random_kernel (kiss_seed_1)) << 32; + kiss += kiss_random_kernel (kiss_seed_2); + rnumber_10 (x, kiss); + __gthread_mutex_unlock (&random_lock); +} +iexport(random_r10); + +#endif + +/* This function produces a REAL(16) value from the uniform distribution + with range [0,1). */ + +#ifdef HAVE_GFC_REAL_16 + +void +random_r16 (GFC_REAL_16 *x) +{ + GFC_UINTEGER_8 kiss1, kiss2; + + __gthread_mutex_lock (&random_lock); + kiss1 = ((GFC_UINTEGER_8) kiss_random_kernel (kiss_seed_1)) << 32; + kiss1 += kiss_random_kernel (kiss_seed_2); + + kiss2 = ((GFC_UINTEGER_8) kiss_random_kernel (kiss_seed_3)) << 32; + kiss2 += kiss_random_kernel (kiss_seed_3); + + rnumber_16 (x, kiss1, kiss2); + __gthread_mutex_unlock (&random_lock); +} +iexport(random_r16); + + +#endif +/* This function fills a REAL(4) array with values from the uniform + distribution with range [0,1). */ + +void +arandom_r4 (gfc_array_r4 *x) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type stride[GFC_MAX_DIMENSIONS]; + index_type stride0; + index_type dim; + GFC_REAL_4 *dest; + GFC_UINTEGER_4 kiss; + int n; + + dest = x->data; + + dim = GFC_DESCRIPTOR_RANK (x); + + for (n = 0; n < dim; n++) + { + count[n] = 0; + stride[n] = x->dim[n].stride; + extent[n] = x->dim[n].ubound + 1 - x->dim[n].lbound; + if (extent[n] <= 0) + return; + } + + stride0 = stride[0]; + + __gthread_mutex_lock (&random_lock); + + while (dest) + { + /* random_r4 (dest); */ + kiss = kiss_random_kernel (kiss_seed_1); + rnumber_4 (dest, kiss); + + /* Advance to the next element. */ + dest += stride0; + count[0]++; + /* Advance to the next source element. */ + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + dest -= stride[n] * extent[n]; + n++; + if (n == dim) + { + dest = NULL; + break; + } + else + { + count[n]++; + dest += stride[n]; + } + } + } + __gthread_mutex_unlock (&random_lock); +} + +/* This function fills a REAL(8) array with values from the uniform + distribution with range [0,1). */ + +void +arandom_r8 (gfc_array_r8 *x) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type stride[GFC_MAX_DIMENSIONS]; + index_type stride0; + index_type dim; + GFC_REAL_8 *dest; + GFC_UINTEGER_8 kiss; + int n; + + dest = x->data; + + dim = GFC_DESCRIPTOR_RANK (x); + + for (n = 0; n < dim; n++) + { + count[n] = 0; + stride[n] = x->dim[n].stride; + extent[n] = x->dim[n].ubound + 1 - x->dim[n].lbound; + if (extent[n] <= 0) + return; + } + + stride0 = stride[0]; + + __gthread_mutex_lock (&random_lock); + + while (dest) + { + /* random_r8 (dest); */ + kiss = ((GFC_UINTEGER_8) kiss_random_kernel (kiss_seed_1)) << 32; + kiss += kiss_random_kernel (kiss_seed_2); + rnumber_8 (dest, kiss); + + /* Advance to the next element. */ + dest += stride0; + count[0]++; + /* Advance to the next source element. */ + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + dest -= stride[n] * extent[n]; + n++; + if (n == dim) + { + dest = NULL; + break; + } + else + { + count[n]++; + dest += stride[n]; + } + } + } + __gthread_mutex_unlock (&random_lock); +} + +#ifdef HAVE_GFC_REAL_10 + +/* This function fills a REAL(10) array with values from the uniform + distribution with range [0,1). */ + +void +arandom_r10 (gfc_array_r10 *x) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type stride[GFC_MAX_DIMENSIONS]; + index_type stride0; + index_type dim; + GFC_REAL_10 *dest; + GFC_UINTEGER_8 kiss; + int n; + + dest = x->data; + + dim = GFC_DESCRIPTOR_RANK (x); + + for (n = 0; n < dim; n++) + { + count[n] = 0; + stride[n] = x->dim[n].stride; + extent[n] = x->dim[n].ubound + 1 - x->dim[n].lbound; + if (extent[n] <= 0) + return; + } + + stride0 = stride[0]; + + __gthread_mutex_lock (&random_lock); + + while (dest) + { + /* random_r10 (dest); */ + kiss = ((GFC_UINTEGER_8) kiss_random_kernel (kiss_seed_1)) << 32; + kiss += kiss_random_kernel (kiss_seed_2); + rnumber_10 (dest, kiss); + + /* Advance to the next element. */ + dest += stride0; + count[0]++; + /* Advance to the next source element. */ + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + dest -= stride[n] * extent[n]; + n++; + if (n == dim) + { + dest = NULL; + break; + } + else + { + count[n]++; + dest += stride[n]; + } + } + } + __gthread_mutex_unlock (&random_lock); +} + +#endif + +#ifdef HAVE_GFC_REAL_16 + +/* This function fills a REAL(16) array with values from the uniform + distribution with range [0,1). */ + +void +arandom_r16 (gfc_array_r16 *x) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type stride[GFC_MAX_DIMENSIONS]; + index_type stride0; + index_type dim; + GFC_REAL_16 *dest; + GFC_UINTEGER_8 kiss1, kiss2; + int n; + + dest = x->data; + + dim = GFC_DESCRIPTOR_RANK (x); + + for (n = 0; n < dim; n++) + { + count[n] = 0; + stride[n] = x->dim[n].stride; + extent[n] = x->dim[n].ubound + 1 - x->dim[n].lbound; + if (extent[n] <= 0) + return; + } + + stride0 = stride[0]; + + __gthread_mutex_lock (&random_lock); + + while (dest) + { + /* random_r16 (dest); */ + kiss1 = ((GFC_UINTEGER_8) kiss_random_kernel (kiss_seed_1)) << 32; + kiss1 += kiss_random_kernel (kiss_seed_2); + + kiss2 = ((GFC_UINTEGER_8) kiss_random_kernel (kiss_seed_3)) << 32; + kiss2 += kiss_random_kernel (kiss_seed_3); + + rnumber_16 (dest, kiss1, kiss2); + + /* Advance to the next element. */ + dest += stride0; + count[0]++; + /* Advance to the next source element. */ + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + dest -= stride[n] * extent[n]; + n++; + if (n == dim) + { + dest = NULL; + break; + } + else + { + count[n]++; + dest += stride[n]; + } + } + } + __gthread_mutex_unlock (&random_lock); +} + +#endif + + + +static void +scramble_seed (unsigned char *dest, unsigned char *src, int size) +{ + int i; + + for (i = 0; i < size; i++) + dest[(i % 2) * (size / 2) + i / 2] = src[i]; +} + + +static void +unscramble_seed (unsigned char *dest, unsigned char *src, int size) +{ + int i; + + for (i = 0; i < size; i++) + dest[i] = src[(i % 2) * (size / 2) + i / 2]; +} + + + +/* random_seed is used to seed the PRNG with either a default + set of seeds or user specified set of seeds. random_seed + must be called with no argument or exactly one argument. */ + +void +random_seed_i4 (GFC_INTEGER_4 *size, gfc_array_i4 *put, gfc_array_i4 *get) +{ + int i; + unsigned char seed[4*kiss_size]; + + __gthread_mutex_lock (&random_lock); + + /* Check that we only have one argument present. */ + if ((size ? 1 : 0) + (put ? 1 : 0) + (get ? 1 : 0) > 1) + runtime_error ("RANDOM_SEED should have at most one argument present."); + + /* From the standard: "If no argument is present, the processor assigns + a processor-dependent value to the seed." */ + if (size == NULL && put == NULL && get == NULL) + for (i = 0; i < kiss_size; i++) + kiss_seed[i] = kiss_default_seed[i]; + + if (size != NULL) + *size = kiss_size; + + if (put != NULL) + { + /* If the rank of the array is not 1, abort. */ + if (GFC_DESCRIPTOR_RANK (put) != 1) + runtime_error ("Array rank of PUT is not 1."); + + /* If the array is too small, abort. */ + if (((put->dim[0].ubound + 1 - put->dim[0].lbound)) < kiss_size) + runtime_error ("Array size of PUT is too small."); + + /* We copy the seed given by the user. */ + for (i = 0; i < kiss_size; i++) + memcpy (seed + i * sizeof(GFC_UINTEGER_4), + &(put->data[(kiss_size - 1 - i) * put->dim[0].stride]), + sizeof(GFC_UINTEGER_4)); + + /* We put it after scrambling the bytes, to paper around users who + provide seeds with quality only in the lower or upper part. */ + scramble_seed ((unsigned char *) kiss_seed, seed, 4*kiss_size); + } + + /* Return the seed to GET data. */ + if (get != NULL) + { + /* If the rank of the array is not 1, abort. */ + if (GFC_DESCRIPTOR_RANK (get) != 1) + runtime_error ("Array rank of GET is not 1."); + + /* If the array is too small, abort. */ + if (((get->dim[0].ubound + 1 - get->dim[0].lbound)) < kiss_size) + runtime_error ("Array size of GET is too small."); + + /* Unscramble the seed. */ + unscramble_seed (seed, (unsigned char *) kiss_seed, 4*kiss_size); + + /* Then copy it back to the user variable. */ + for (i = 0; i < kiss_size; i++) + memcpy (&(get->data[(kiss_size - 1 - i) * get->dim[0].stride]), + seed + i * sizeof(GFC_UINTEGER_4), + sizeof(GFC_UINTEGER_4)); + } + + __gthread_mutex_unlock (&random_lock); +} +iexport(random_seed_i4); + + +void +random_seed_i8 (GFC_INTEGER_8 *size, gfc_array_i8 *put, gfc_array_i8 *get) +{ + int i; + + __gthread_mutex_lock (&random_lock); + + /* Check that we only have one argument present. */ + if ((size ? 1 : 0) + (put ? 1 : 0) + (get ? 1 : 0) > 1) + runtime_error ("RANDOM_SEED should have at most one argument present."); + + /* From the standard: "If no argument is present, the processor assigns + a processor-dependent value to the seed." */ + if (size == NULL && put == NULL && get == NULL) + for (i = 0; i < kiss_size; i++) + kiss_seed[i] = kiss_default_seed[i]; + + if (size != NULL) + *size = kiss_size / 2; + + if (put != NULL) + { + /* If the rank of the array is not 1, abort. */ + if (GFC_DESCRIPTOR_RANK (put) != 1) + runtime_error ("Array rank of PUT is not 1."); + + /* If the array is too small, abort. */ + if (((put->dim[0].ubound + 1 - put->dim[0].lbound)) < kiss_size / 2) + runtime_error ("Array size of PUT is too small."); + + /* This code now should do correct strides. */ + for (i = 0; i < kiss_size / 2; i++) + memcpy (&kiss_seed[2*i], &(put->data[i * put->dim[0].stride]), + sizeof (GFC_UINTEGER_8)); + } + + /* Return the seed to GET data. */ + if (get != NULL) + { + /* If the rank of the array is not 1, abort. */ + if (GFC_DESCRIPTOR_RANK (get) != 1) + runtime_error ("Array rank of GET is not 1."); + + /* If the array is too small, abort. */ + if (((get->dim[0].ubound + 1 - get->dim[0].lbound)) < kiss_size / 2) + runtime_error ("Array size of GET is too small."); + + /* This code now should do correct strides. */ + for (i = 0; i < kiss_size / 2; i++) + memcpy (&(get->data[i * get->dim[0].stride]), &kiss_seed[2*i], + sizeof (GFC_UINTEGER_8)); + } + + __gthread_mutex_unlock (&random_lock); +} +iexport(random_seed_i8); + + +#ifndef __GTHREAD_MUTEX_INIT +static void __attribute__((constructor)) +init (void) +{ + __GTHREAD_MUTEX_INIT_FUNCTION (&random_lock); +} +#endif diff --git a/gcc-4.4.0/libgfortran/intrinsics/rename.c b/gcc-4.4.0/libgfortran/intrinsics/rename.c new file mode 100644 index 000000000..0d7dd166b --- /dev/null +++ b/gcc-4.4.0/libgfortran/intrinsics/rename.c @@ -0,0 +1,125 @@ +/* Implementation of the RENAME intrinsic. + Copyright (C) 2005, 2007, 2009 Free Software Foundation, Inc. + Contributed by François-Xavier Coudert <coudert@clipper.ens.fr> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran 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 3 of the License, or (at your option) any later version. + +Libgfortran 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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. */ + +#include "libgfortran.h" + +#include <errno.h> +#include <string.h> + +/* SUBROUTINE RENAME(PATH1, PATH2, STATUS) + CHARACTER(len=*), INTENT(IN) :: PATH1, PATH2 + INTEGER, INTENT(OUT), OPTIONAL :: STATUS */ + +extern void rename_i4_sub (char *, char *, GFC_INTEGER_4 *, gfc_charlen_type, + gfc_charlen_type); +iexport_proto(rename_i4_sub); + +void +rename_i4_sub (char *path1, char *path2, GFC_INTEGER_4 *status, + gfc_charlen_type path1_len, gfc_charlen_type path2_len) +{ + int val; + char *str1, *str2; + + /* Trim trailing spaces from paths. */ + while (path1_len > 0 && path1[path1_len - 1] == ' ') + path1_len--; + while (path2_len > 0 && path2[path2_len - 1] == ' ') + path2_len--; + + /* Make a null terminated copy of the strings. */ + str1 = gfc_alloca (path1_len + 1); + memcpy (str1, path1, path1_len); + str1[path1_len] = '\0'; + + str2 = gfc_alloca (path2_len + 1); + memcpy (str2, path2, path2_len); + str2[path2_len] = '\0'; + + val = rename (str1, str2); + + if (status != NULL) + *status = (val == 0) ? 0 : errno; +} +iexport(rename_i4_sub); + +extern void rename_i8_sub (char *, char *, GFC_INTEGER_8 *, gfc_charlen_type, + gfc_charlen_type); +iexport_proto(rename_i8_sub); + +void +rename_i8_sub (char *path1, char *path2, GFC_INTEGER_8 *status, + gfc_charlen_type path1_len, gfc_charlen_type path2_len) +{ + int val; + char *str1, *str2; + + /* Trim trailing spaces from paths. */ + while (path1_len > 0 && path1[path1_len - 1] == ' ') + path1_len--; + while (path2_len > 0 && path2[path2_len - 1] == ' ') + path2_len--; + + /* Make a null terminated copy of the strings. */ + str1 = gfc_alloca (path1_len + 1); + memcpy (str1, path1, path1_len); + str1[path1_len] = '\0'; + + str2 = gfc_alloca (path2_len + 1); + memcpy (str2, path2, path2_len); + str2[path2_len] = '\0'; + + val = rename (str1, str2); + + if (status != NULL) + *status = (val == 0) ? 0 : errno; +} +iexport(rename_i8_sub); + +extern GFC_INTEGER_4 rename_i4 (char *, char *, gfc_charlen_type, + gfc_charlen_type); +export_proto(rename_i4); + +GFC_INTEGER_4 +rename_i4 (char *path1, char *path2, gfc_charlen_type path1_len, + gfc_charlen_type path2_len) +{ + GFC_INTEGER_4 val; + rename_i4_sub (path1, path2, &val, path1_len, path2_len); + return val; +} + +extern GFC_INTEGER_8 rename_i8 (char *, char *, gfc_charlen_type, + gfc_charlen_type); +export_proto(rename_i8); + +GFC_INTEGER_8 +rename_i8 (char *path1, char *path2, gfc_charlen_type path1_len, + gfc_charlen_type path2_len) +{ + GFC_INTEGER_8 val; + rename_i8_sub (path1, path2, &val, path1_len, path2_len); + return val; +} diff --git a/gcc-4.4.0/libgfortran/intrinsics/reshape_generic.c b/gcc-4.4.0/libgfortran/intrinsics/reshape_generic.c new file mode 100644 index 000000000..0f3022701 --- /dev/null +++ b/gcc-4.4.0/libgfortran/intrinsics/reshape_generic.c @@ -0,0 +1,380 @@ +/* Generic implementation of the RESHAPE intrinsic + Copyright 2002, 2006, 2007, 2009 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran 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 3 of the License, or (at your option) any later version. + +Ligbfortran 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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. */ + +#include "libgfortran.h" +#include <stdlib.h> +#include <string.h> +#include <assert.h> + +typedef GFC_ARRAY_DESCRIPTOR(1, index_type) shape_type; +typedef GFC_ARRAY_DESCRIPTOR(GFC_MAX_DIMENSIONS, char) parray; + +static void +reshape_internal (parray *ret, parray *source, shape_type *shape, + parray *pad, shape_type *order, index_type size) +{ + /* r.* indicates the return array. */ + index_type rcount[GFC_MAX_DIMENSIONS]; + index_type rextent[GFC_MAX_DIMENSIONS]; + index_type rstride[GFC_MAX_DIMENSIONS]; + index_type rstride0; + index_type rdim; + index_type rsize; + index_type rs; + index_type rex; + char * restrict rptr; + /* s.* indicates the source array. */ + index_type scount[GFC_MAX_DIMENSIONS]; + index_type sextent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type sstride0; + index_type sdim; + index_type ssize; + const char *sptr; + /* p.* indicates the pad array. */ + index_type pcount[GFC_MAX_DIMENSIONS]; + index_type pextent[GFC_MAX_DIMENSIONS]; + index_type pstride[GFC_MAX_DIMENSIONS]; + index_type pdim; + index_type psize; + const char *pptr; + + const char *src; + int n; + int dim; + int sempty, pempty, shape_empty; + index_type shape_data[GFC_MAX_DIMENSIONS]; + + rdim = shape->dim[0].ubound - shape->dim[0].lbound + 1; + if (rdim != GFC_DESCRIPTOR_RANK(ret)) + runtime_error("rank of return array incorrect in RESHAPE intrinsic"); + + shape_empty = 0; + + for (n = 0; n < rdim; n++) + { + shape_data[n] = shape->data[n * shape->dim[0].stride]; + if (shape_data[n] <= 0) + { + shape_data[n] = 0; + shape_empty = 1; + } + } + + if (ret->data == NULL) + { + rdim = shape->dim[0].ubound - shape->dim[0].lbound + 1; + rs = 1; + for (n = 0; n < rdim; n++) + { + ret->dim[n].lbound = 0; + rex = shape_data[n]; + ret->dim[n].ubound = rex - 1; + ret->dim[n].stride = rs; + rs *= rex; + } + ret->offset = 0; + ret->data = internal_malloc_size ( rs * size ); + ret->dtype = (source->dtype & ~GFC_DTYPE_RANK_MASK) | rdim; + } + + if (shape_empty) + return; + + if (pad) + { + pdim = GFC_DESCRIPTOR_RANK (pad); + psize = 1; + pempty = 0; + for (n = 0; n < pdim; n++) + { + pcount[n] = 0; + pstride[n] = pad->dim[n].stride; + pextent[n] = pad->dim[n].ubound + 1 - pad->dim[n].lbound; + if (pextent[n] <= 0) + { + pempty = 1; + pextent[n] = 0; + } + + if (psize == pstride[n]) + psize *= pextent[n]; + else + psize = 0; + } + pptr = pad->data; + } + else + { + pdim = 0; + psize = 1; + pempty = 1; + pptr = NULL; + } + + if (unlikely (compile_options.bounds_check)) + { + index_type ret_extent, source_extent; + + rs = 1; + for (n = 0; n < rdim; n++) + { + rs *= shape_data[n]; + ret_extent = ret->dim[n].ubound + 1 - ret->dim[n].lbound; + if (ret_extent != shape_data[n]) + runtime_error("Incorrect extent in return value of RESHAPE" + " intrinsic in dimension %ld: is %ld," + " should be %ld", (long int) n+1, + (long int) ret_extent, (long int) shape_data[n]); + } + + source_extent = 1; + sdim = GFC_DESCRIPTOR_RANK (source); + for (n = 0; n < sdim; n++) + { + index_type se; + se = source->dim[n].ubound + 1 - source->dim[0].lbound; + source_extent *= se > 0 ? se : 0; + } + + if (rs > source_extent && (!pad || pempty)) + runtime_error("Incorrect size in SOURCE argument to RESHAPE" + " intrinsic: is %ld, should be %ld", + (long int) source_extent, (long int) rs); + + if (order) + { + int seen[GFC_MAX_DIMENSIONS]; + index_type v; + + for (n = 0; n < rdim; n++) + seen[n] = 0; + + for (n = 0; n < rdim; n++) + { + v = order->data[n * order->dim[0].stride] - 1; + + if (v < 0 || v >= rdim) + runtime_error("Value %ld out of range in ORDER argument" + " to RESHAPE intrinsic", (long int) v + 1); + + if (seen[v] != 0) + runtime_error("Duplicate value %ld in ORDER argument to" + " RESHAPE intrinsic", (long int) v + 1); + + seen[v] = 1; + } + } + } + + rsize = 1; + for (n = 0; n < rdim; n++) + { + if (order) + dim = order->data[n * order->dim[0].stride] - 1; + else + dim = n; + + rcount[n] = 0; + rstride[n] = ret->dim[dim].stride; + rextent[n] = ret->dim[dim].ubound + 1 - ret->dim[dim].lbound; + + if (rextent[n] != shape_data[dim]) + runtime_error ("shape and target do not conform"); + + if (rsize == rstride[n]) + rsize *= rextent[n]; + else + rsize = 0; + if (rextent[n] <= 0) + return; + } + + sdim = GFC_DESCRIPTOR_RANK (source); + ssize = 1; + sempty = 0; + for (n = 0; n < sdim; n++) + { + scount[n] = 0; + sstride[n] = source->dim[n].stride; + sextent[n] = source->dim[n].ubound + 1 - source->dim[n].lbound; + if (sextent[n] <= 0) + { + sempty = 1; + sextent[n] = 0; + } + + if (ssize == sstride[n]) + ssize *= sextent[n]; + else + ssize = 0; + } + + if (rsize != 0 && ssize != 0 && psize != 0) + { + rsize *= size; + ssize *= size; + psize *= size; + reshape_packed (ret->data, rsize, source->data, ssize, + pad ? pad->data : NULL, psize); + return; + } + rptr = ret->data; + src = sptr = source->data; + rstride0 = rstride[0] * size; + sstride0 = sstride[0] * size; + + if (sempty && pempty) + abort (); + + if (sempty) + { + /* Pretend we are using the pad array the first time around, too. */ + src = pptr; + sptr = pptr; + sdim = pdim; + for (dim = 0; dim < pdim; dim++) + { + scount[dim] = pcount[dim]; + sextent[dim] = pextent[dim]; + sstride[dim] = pstride[dim]; + sstride0 = pstride[0] * size; + } + } + + while (rptr) + { + /* Select between the source and pad arrays. */ + memcpy(rptr, src, size); + /* Advance to the next element. */ + rptr += rstride0; + src += sstride0; + rcount[0]++; + scount[0]++; + + /* Advance to the next destination element. */ + n = 0; + while (rcount[n] == rextent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + rcount[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + rptr -= rstride[n] * rextent[n] * size; + n++; + if (n == rdim) + { + /* Break out of the loop. */ + rptr = NULL; + break; + } + else + { + rcount[n]++; + rptr += rstride[n] * size; + } + } + + /* Advance to the next source element. */ + n = 0; + while (scount[n] == sextent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + scount[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + src -= sstride[n] * sextent[n] * size; + n++; + if (n == sdim) + { + if (sptr && pad) + { + /* Switch to the pad array. */ + sptr = NULL; + sdim = pdim; + for (dim = 0; dim < pdim; dim++) + { + scount[dim] = pcount[dim]; + sextent[dim] = pextent[dim]; + sstride[dim] = pstride[dim]; + sstride0 = sstride[0] * size; + } + } + /* We now start again from the beginning of the pad array. */ + src = pptr; + break; + } + else + { + scount[n]++; + src += sstride[n] * size; + } + } + } +} + +extern void reshape (parray *, parray *, shape_type *, parray *, shape_type *); +export_proto(reshape); + +void +reshape (parray *ret, parray *source, shape_type *shape, parray *pad, + shape_type *order) +{ + reshape_internal (ret, source, shape, pad, order, + GFC_DESCRIPTOR_SIZE (source)); +} + + +extern void reshape_char (parray *, gfc_charlen_type, parray *, shape_type *, + parray *, shape_type *, gfc_charlen_type, + gfc_charlen_type); +export_proto(reshape_char); + +void +reshape_char (parray *ret, gfc_charlen_type ret_length __attribute__((unused)), + parray *source, shape_type *shape, parray *pad, + shape_type *order, gfc_charlen_type source_length, + gfc_charlen_type pad_length __attribute__((unused))) +{ + reshape_internal (ret, source, shape, pad, order, source_length); +} + + +extern void reshape_char4 (parray *, gfc_charlen_type, parray *, shape_type *, + parray *, shape_type *, gfc_charlen_type, + gfc_charlen_type); +export_proto(reshape_char4); + +void +reshape_char4 (parray *ret, gfc_charlen_type ret_length __attribute__((unused)), + parray *source, shape_type *shape, parray *pad, + shape_type *order, gfc_charlen_type source_length, + gfc_charlen_type pad_length __attribute__((unused))) +{ + reshape_internal (ret, source, shape, pad, order, + source_length * sizeof (gfc_char4_t)); +} diff --git a/gcc-4.4.0/libgfortran/intrinsics/reshape_packed.c b/gcc-4.4.0/libgfortran/intrinsics/reshape_packed.c new file mode 100644 index 000000000..25cbcf7db --- /dev/null +++ b/gcc-4.4.0/libgfortran/intrinsics/reshape_packed.c @@ -0,0 +1,49 @@ +/* Implementation of the RESHAPE intrinsic for packed arrays + Copyright 2002, 2007, 2009 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran 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 3 of the License, or (at your option) any later version. + +Ligbfortran 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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. */ + +#include "libgfortran.h" + +#include <string.h> + +/* Reshape function where all arrays are packed. Basically just memcpy. */ + +void +reshape_packed (char * restrict ret, index_type rsize, const char * source, + index_type ssize, const char * pad, index_type psize) +{ + index_type size; + + size = (rsize > ssize) ? ssize : rsize; + memcpy (ret, source, size); + ret += size; + rsize -= size; + while (rsize > 0) + { + size = (rsize > psize) ? psize : rsize; + memcpy (ret, pad, size); + ret += size; + rsize -= size; + } +} diff --git a/gcc-4.4.0/libgfortran/intrinsics/selected_char_kind.c b/gcc-4.4.0/libgfortran/intrinsics/selected_char_kind.c new file mode 100644 index 000000000..35cf45340 --- /dev/null +++ b/gcc-4.4.0/libgfortran/intrinsics/selected_char_kind.c @@ -0,0 +1,46 @@ +/* Copyright 2008, 2009 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran 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 3 of the License, or (at your option) any later version. + +Libgfortran 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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. */ + + +#include "libgfortran.h" + +#include <string.h> + + +extern GFC_INTEGER_4 selected_char_kind (gfc_charlen_type, char *); +export_proto(selected_char_kind); + +GFC_INTEGER_4 +selected_char_kind (gfc_charlen_type name_len, char *name) +{ + gfc_charlen_type len = fstrlen (name, name_len); + + if ((len == 5 && strncasecmp (name, "ascii", 5) == 0) + || (len == 7 && strncasecmp (name, "default", 7) == 0)) + return 1; + else if (len == 9 && strncasecmp (name, "iso_10646", 9) == 0) + return 1; + else + return -1; +} diff --git a/gcc-4.4.0/libgfortran/intrinsics/selected_int_kind.f90 b/gcc-4.4.0/libgfortran/intrinsics/selected_int_kind.f90 new file mode 100644 index 000000000..8b5aa5466 --- /dev/null +++ b/gcc-4.4.0/libgfortran/intrinsics/selected_int_kind.f90 @@ -0,0 +1,46 @@ +! Copyright 2003, 2004, 2009 Free Software Foundation, Inc. +! Contributed by Kejia Zhao <kejia_zh@yahoo.com.cn> +! +!This file is part of the GNU Fortran 95 runtime library (libgfortran). +! +!Libgfortran 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 3 of the License, or (at your option) any later version. +! +!Libgfortran 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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!<http://www.gnu.org/licenses/>. + +function _gfortran_selected_int_kind (r) + implicit none + integer, intent (in) :: r + integer :: _gfortran_selected_int_kind + integer :: i + ! Integer kind_range table + type :: int_info + integer :: kind + integer :: range + end type int_info + + include "selected_int_kind.inc" + + do i = 1, c + if (r <= int_infos (i) % range) then + _gfortran_selected_int_kind = int_infos (i) % kind + return + end if + end do + _gfortran_selected_int_kind = -1 + return +end function diff --git a/gcc-4.4.0/libgfortran/intrinsics/selected_real_kind.f90 b/gcc-4.4.0/libgfortran/intrinsics/selected_real_kind.f90 new file mode 100644 index 000000000..ea3b46aab --- /dev/null +++ b/gcc-4.4.0/libgfortran/intrinsics/selected_real_kind.f90 @@ -0,0 +1,64 @@ +! Copyright 2003, 2004, 2009 Free Software Foundation, Inc. +! Contributed by Kejia Zhao <kejia_zh@yahoo.com.cn> +! +!This file is part of the GNU Fortran 95 runtime library (libgfortran). +! +!Libgfortran 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 3 of the License, or (at your option) any later version. +! +!Libgfortran 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. +! +!Under Section 7 of GPL version 3, you are granted additional +!permissions described in the GCC Runtime Library Exception, version +!3.1, as published by the Free Software Foundation. +! +!You should have received a copy of the GNU General Public License and +!a copy of the GCC Runtime Library Exception along with this program; +!see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +!<http://www.gnu.org/licenses/>. + +function _gfortran_selected_real_kind (p, r) + implicit none + integer, optional, intent (in) :: p, r + integer :: _gfortran_selected_real_kind + integer :: i, p2, r2 + logical :: found_p, found_r + ! Real kind_precision_range table + type :: real_info + integer :: kind + integer :: precision + integer :: range + end type real_info + + include "selected_real_kind.inc" + + _gfortran_selected_real_kind = 0 + p2 = 0 + r2 = 0 + found_p = .false. + found_r = .false. + + if (present (p)) p2 = p + if (present (r)) r2 = r + + ! Assumes each type has a greater precision and range than previous one. + + do i = 1, c + if (p2 <= real_infos (i) % precision) found_p = .true. + if (r2 <= real_infos (i) % range) found_r = .true. + if (found_p .and. found_r) then + _gfortran_selected_real_kind = real_infos (i) % kind + return + end if + end do + + if (.not. (found_p)) _gfortran_selected_real_kind = _gfortran_selected_real_kind - 1 + if (.not. (found_r)) _gfortran_selected_real_kind = _gfortran_selected_real_kind - 2 + + return +end function diff --git a/gcc-4.4.0/libgfortran/intrinsics/signal.c b/gcc-4.4.0/libgfortran/intrinsics/signal.c new file mode 100644 index 000000000..66e54f33a --- /dev/null +++ b/gcc-4.4.0/libgfortran/intrinsics/signal.c @@ -0,0 +1,243 @@ +/* Implementation of the SIGNAL and ALARM g77 intrinsics + Copyright (C) 2005, 2007, 2009 Free Software Foundation, Inc. + Contributed by François-Xavier Coudert <coudert@clipper.ens.fr> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran 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 3 of the License, or (at your option) any later version. + +Libgfortran 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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. */ + +#include "libgfortran.h" + +#ifdef HAVE_UNISTD_H +#include <unistd.h> +#endif + +#ifdef HAVE_SIGNAL_H +#include <signal.h> +#endif + +#ifdef HAVE_INTTYPES_H +#include <inttypes.h> +#endif + +#include <errno.h> + +/* SIGNAL subroutine with PROCEDURE as handler */ +extern void signal_sub (int *, void (*)(int), int *); +iexport_proto(signal_sub); + +void +signal_sub (int *number, void (*handler)(int), int *status) +{ +#ifdef HAVE_SIGNAL + intptr_t ret; + + if (status != NULL) + { + ret = (intptr_t) signal (*number, handler); + *status = (int) ret; + } + else + signal (*number, handler); +#else + errno = ENOSYS; + if (status != NULL) + *status = -1; +#endif +} +iexport(signal_sub); + + +/* SIGNAL subroutine with INTEGER as handler */ +extern void signal_sub_int (int *, int *, int *); +iexport_proto(signal_sub_int); + +void +signal_sub_int (int *number, int *handler, int *status) +{ +#ifdef HAVE_SIGNAL + intptr_t ptr = *handler, ret; + + if (status != NULL) + { + ret = (intptr_t) signal (*number, (void (*)(int)) ptr); + *status = (int) ret; + } + else + signal (*number, (void (*)(int)) ptr); +#else + errno = ENOSYS; + if (status != NULL) + *status = -1; +#endif +} +iexport(signal_sub_int); + + +/* SIGNAL function with PROCEDURE as handler */ +extern int signal_func (int *, void (*)(int)); +iexport_proto(signal_func); + +int +signal_func (int *number, void (*handler)(int)) +{ + int status; + signal_sub (number, handler, &status); + return status; +} +iexport(signal_func); + + +/* SIGNAL function with INTEGER as handler */ +extern int signal_func_int (int *, int *); +iexport_proto(signal_func_int); + +int +signal_func_int (int *number, int *handler) +{ + int status; + signal_sub_int (number, handler, &status); + return status; +} +iexport(signal_func_int); + + + +/* ALARM intrinsic with PROCEDURE as handler */ +extern void alarm_sub_i4 (int *, void (*)(int), GFC_INTEGER_4 *); +iexport_proto(alarm_sub_i4); + +void +alarm_sub_i4 (int * seconds __attribute__ ((unused)), + void (*handler)(int) __attribute__ ((unused)), + GFC_INTEGER_4 *status) +{ +#if defined (SIGALRM) && defined (HAVE_ALARM) && defined (HAVE_SIGNAL) + if (status != NULL) + { + if (signal (SIGALRM, handler) == SIG_ERR) + *status = -1; + else + *status = alarm (*seconds); + } + else + { + signal (SIGALRM, handler); + alarm (*seconds); + } +#else + errno = ENOSYS; + if (status != NULL) + *status = -1; +#endif +} +iexport(alarm_sub_i4); + + +extern void alarm_sub_i8 (int *, void (*)(int), GFC_INTEGER_8 *); +iexport_proto(alarm_sub_i8); + +void +alarm_sub_i8 (int *seconds __attribute__ ((unused)), + void (*handler)(int) __attribute__ ((unused)), + GFC_INTEGER_8 *status) +{ +#if defined (SIGALRM) && defined (HAVE_ALARM) && defined (HAVE_SIGNAL) + if (status != NULL) + { + if (signal (SIGALRM, handler) == SIG_ERR) + *status = -1; + else + *status = alarm (*seconds); + } + else + { + signal (SIGALRM, handler); + alarm (*seconds); + } +#else + errno = ENOSYS; + if (status != NULL) + *status = -1; +#endif +} +iexport(alarm_sub_i8); + + +/* ALARM intrinsic with INTEGER as handler */ +extern void alarm_sub_int_i4 (int *, int *, GFC_INTEGER_4 *); +iexport_proto(alarm_sub_int_i4); + +void +alarm_sub_int_i4 (int *seconds __attribute__ ((unused)), + int *handler __attribute__ ((unused)), + GFC_INTEGER_4 *status) +{ +#if defined (SIGALRM) && defined (HAVE_ALARM) && defined (HAVE_SIGNAL) + if (status != NULL) + { + if (signal (SIGALRM, (void (*)(int)) (intptr_t) *handler) == SIG_ERR) + *status = -1; + else + *status = alarm (*seconds); + } + else + { + signal (SIGALRM, (void (*)(int)) (intptr_t) *handler); + alarm (*seconds); + } +#else + errno = ENOSYS; + if (status != NULL) + *status = -1; +#endif +} +iexport(alarm_sub_int_i4); + + +extern void alarm_sub_int_i8 (int *, int *, GFC_INTEGER_8 *); +iexport_proto(alarm_sub_int_i8); + +void +alarm_sub_int_i8 (int *seconds __attribute__ ((unused)), + int *handler __attribute__ ((unused)), + GFC_INTEGER_8 *status) +{ +#if defined (SIGALRM) && defined (HAVE_ALARM) && defined (HAVE_SIGNAL) + if (status != NULL) + { + if (signal (SIGALRM, (void (*)(int)) (intptr_t) *handler) == SIG_ERR) + *status = -1; + else + *status = alarm (*seconds); + } + else + { + signal (SIGALRM, (void (*)(int)) (intptr_t) *handler); + alarm (*seconds); + } +#else + errno = ENOSYS; + if (status != NULL) + *status = -1; +#endif +} +iexport(alarm_sub_int_i8); + diff --git a/gcc-4.4.0/libgfortran/intrinsics/size.c b/gcc-4.4.0/libgfortran/intrinsics/size.c new file mode 100644 index 000000000..9aa4cd933 --- /dev/null +++ b/gcc-4.4.0/libgfortran/intrinsics/size.c @@ -0,0 +1,61 @@ +/* Implementation of the size intrinsic. + Copyright 2002, 2009 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran 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 3 of the License, or (at your option) any later version. + +Libgfortran 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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. */ + +#include "libgfortran.h" + +index_type +size0 (const array_t * array) +{ + int n; + index_type size; + index_type len; + + size = 1; + for (n = 0; n < GFC_DESCRIPTOR_RANK (array); n++) + { + len = array->dim[n].ubound + 1 - array->dim[n].lbound; + if (len < 0) + len = 0; + size *= len; + } + return size; +} +iexport(size0); + +extern index_type size1 (const array_t * array, index_type dim); +export_proto(size1); + +index_type +size1 (const array_t * array, index_type dim) +{ + index_type size; + + dim--; + + size = array->dim[dim].ubound + 1 - array->dim[dim].lbound; + if (size < 0) + size = 0; + return size; +} diff --git a/gcc-4.4.0/libgfortran/intrinsics/sleep.c b/gcc-4.4.0/libgfortran/intrinsics/sleep.c new file mode 100644 index 000000000..6f7ea227d --- /dev/null +++ b/gcc-4.4.0/libgfortran/intrinsics/sleep.c @@ -0,0 +1,67 @@ +/* Implementation of the SLEEP intrinsic. + Copyright (C) 2005, 2007, 2009 Free Software Foundation, Inc. + Contributed by François-Xavier Coudert <coudert@clipper.ens.fr> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran 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 3 of the License, or (at your option) any later version. + +Libgfortran 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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. */ + +#include "libgfortran.h" + +#include <errno.h> + +#ifdef HAVE_UNISTD_H +#include <unistd.h> +#endif + +#ifdef __MINGW32__ +# include <windows.h> +# undef sleep +# define sleep(x) Sleep(1000*(x)) +# define HAVE_SLEEP 1 +#endif + +/* SUBROUTINE SLEEP(SECONDS) + INTEGER, INTENT(IN) :: SECONDS + + A choice had to be made if SECONDS is negative. For g77, this is + equivalent to SLEEP(0). */ + +#ifdef HAVE_SLEEP +extern void sleep_i4_sub (GFC_INTEGER_4 *); +iexport_proto(sleep_i4_sub); + +void +sleep_i4_sub (GFC_INTEGER_4 *seconds) +{ + sleep (*seconds < 0 ? 0 : (unsigned int) *seconds); +} +iexport(sleep_i4_sub); + +extern void sleep_i8_sub (GFC_INTEGER_8 *); +iexport_proto(sleep_i8_sub); + +void +sleep_i8_sub (GFC_INTEGER_8 *seconds) +{ + sleep (*seconds < 0 ? 0 : (unsigned int) *seconds); +} +iexport(sleep_i8_sub); +#endif diff --git a/gcc-4.4.0/libgfortran/intrinsics/spread_generic.c b/gcc-4.4.0/libgfortran/intrinsics/spread_generic.c new file mode 100644 index 000000000..9fb4b11b2 --- /dev/null +++ b/gcc-4.4.0/libgfortran/intrinsics/spread_generic.c @@ -0,0 +1,617 @@ +/* Generic implementation of the SPREAD intrinsic + Copyright 2002, 2005, 2006, 2007, 2009 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran 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 3 of the License, or (at your option) any later version. + +Ligbfortran 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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. */ + +#include "libgfortran.h" +#include <stdlib.h> +#include <assert.h> +#include <string.h> + +static void +spread_internal (gfc_array_char *ret, const gfc_array_char *source, + const index_type *along, const index_type *pncopies, + index_type size) +{ + /* r.* indicates the return array. */ + index_type rstride[GFC_MAX_DIMENSIONS]; + index_type rstride0; + index_type rdelta = 0; + index_type rrank; + index_type rs; + char *rptr; + char *dest; + /* s.* indicates the source array. */ + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type sstride0; + index_type srank; + const char *sptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type n; + index_type dim; + index_type ncopies; + + srank = GFC_DESCRIPTOR_RANK(source); + + rrank = srank + 1; + if (rrank > GFC_MAX_DIMENSIONS) + runtime_error ("return rank too large in spread()"); + + if (*along > rrank) + runtime_error ("dim outside of rank in spread()"); + + ncopies = *pncopies; + + if (ret->data == NULL) + { + /* The front end has signalled that we need to populate the + return array descriptor. */ + ret->dtype = (source->dtype & ~GFC_DTYPE_RANK_MASK) | rrank; + dim = 0; + rs = 1; + for (n = 0; n < rrank; n++) + { + ret->dim[n].stride = rs; + ret->dim[n].lbound = 0; + if (n == *along - 1) + { + ret->dim[n].ubound = ncopies - 1; + rdelta = rs * size; + rs *= ncopies; + } + else + { + count[dim] = 0; + extent[dim] = source->dim[dim].ubound + 1 + - source->dim[dim].lbound; + sstride[dim] = source->dim[dim].stride * size; + rstride[dim] = rs * size; + + ret->dim[n].ubound = extent[dim]-1; + rs *= extent[dim]; + dim++; + } + } + ret->offset = 0; + if (rs > 0) + ret->data = internal_malloc_size (rs * size); + else + { + ret->data = internal_malloc_size (1); + return; + } + } + else + { + int zero_sized; + + zero_sized = 0; + + dim = 0; + if (GFC_DESCRIPTOR_RANK(ret) != rrank) + runtime_error ("rank mismatch in spread()"); + + if (compile_options.bounds_check) + { + for (n = 0; n < rrank; n++) + { + index_type ret_extent; + + ret_extent = ret->dim[n].ubound + 1 - ret->dim[n].lbound; + if (n == *along - 1) + { + rdelta = ret->dim[n].stride * size; + + if (ret_extent != ncopies) + runtime_error("Incorrect extent in return value of SPREAD" + " intrinsic in dimension %ld: is %ld," + " should be %ld", (long int) n+1, + (long int) ret_extent, (long int) ncopies); + } + else + { + count[dim] = 0; + extent[dim] = source->dim[dim].ubound + 1 + - source->dim[dim].lbound; + if (ret_extent != extent[dim]) + runtime_error("Incorrect extent in return value of SPREAD" + " intrinsic in dimension %ld: is %ld," + " should be %ld", (long int) n+1, + (long int) ret_extent, + (long int) extent[dim]); + + if (extent[dim] <= 0) + zero_sized = 1; + sstride[dim] = source->dim[dim].stride * size; + rstride[dim] = ret->dim[n].stride * size; + dim++; + } + } + } + else + { + for (n = 0; n < rrank; n++) + { + if (n == *along - 1) + { + rdelta = ret->dim[n].stride * size; + } + else + { + count[dim] = 0; + extent[dim] = source->dim[dim].ubound + 1 + - source->dim[dim].lbound; + if (extent[dim] <= 0) + zero_sized = 1; + sstride[dim] = source->dim[dim].stride * size; + rstride[dim] = ret->dim[n].stride * size; + dim++; + } + } + } + + if (zero_sized) + return; + + if (sstride[0] == 0) + sstride[0] = size; + } + sstride0 = sstride[0]; + rstride0 = rstride[0]; + rptr = ret->data; + sptr = source->data; + + while (sptr) + { + /* Spread this element. */ + dest = rptr; + for (n = 0; n < ncopies; n++) + { + memcpy (dest, sptr, size); + dest += rdelta; + } + /* Advance to the next element. */ + sptr += sstride0; + rptr += rstride0; + count[0]++; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + sptr -= sstride[n] * extent[n]; + rptr -= rstride[n] * extent[n]; + n++; + if (n >= srank) + { + /* Break out of the loop. */ + sptr = NULL; + break; + } + else + { + count[n]++; + sptr += sstride[n]; + rptr += rstride[n]; + } + } + } +} + +/* This version of spread_internal treats the special case of a scalar + source. This is much simpler than the more general case above. */ + +static void +spread_internal_scalar (gfc_array_char *ret, const char *source, + const index_type *along, const index_type *pncopies, + index_type size) +{ + int n; + int ncopies = *pncopies; + char * dest; + + if (GFC_DESCRIPTOR_RANK (ret) != 1) + runtime_error ("incorrect destination rank in spread()"); + + if (*along > 1) + runtime_error ("dim outside of rank in spread()"); + + if (ret->data == NULL) + { + ret->data = internal_malloc_size (ncopies * size); + ret->offset = 0; + ret->dim[0].stride = 1; + ret->dim[0].lbound = 0; + ret->dim[0].ubound = ncopies - 1; + } + else + { + if (ncopies - 1 > (ret->dim[0].ubound - ret->dim[0].lbound) + / ret->dim[0].stride) + runtime_error ("dim too large in spread()"); + } + + for (n = 0; n < ncopies; n++) + { + dest = (char*)(ret->data + n*size*ret->dim[0].stride); + memcpy (dest , source, size); + } +} + +extern void spread (gfc_array_char *, const gfc_array_char *, + const index_type *, const index_type *); +export_proto(spread); + +void +spread (gfc_array_char *ret, const gfc_array_char *source, + const index_type *along, const index_type *pncopies) +{ + index_type type_size; + + type_size = GFC_DTYPE_TYPE_SIZE(ret); + switch(type_size) + { + case GFC_DTYPE_DERIVED_1: + case GFC_DTYPE_LOGICAL_1: + case GFC_DTYPE_INTEGER_1: + spread_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) source, + *along, *pncopies); + return; + + case GFC_DTYPE_LOGICAL_2: + case GFC_DTYPE_INTEGER_2: + spread_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) source, + *along, *pncopies); + return; + + case GFC_DTYPE_LOGICAL_4: + case GFC_DTYPE_INTEGER_4: + spread_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) source, + *along, *pncopies); + return; + + case GFC_DTYPE_LOGICAL_8: + case GFC_DTYPE_INTEGER_8: + spread_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) source, + *along, *pncopies); + return; + +#ifdef HAVE_GFC_INTEGER_16 + case GFC_DTYPE_LOGICAL_16: + case GFC_DTYPE_INTEGER_16: + spread_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) source, + *along, *pncopies); + return; +#endif + + case GFC_DTYPE_REAL_4: + spread_r4 ((gfc_array_r4 *) ret, (gfc_array_r4 *) source, + *along, *pncopies); + return; + + case GFC_DTYPE_REAL_8: + spread_r8 ((gfc_array_r8 *) ret, (gfc_array_r8 *) source, + *along, *pncopies); + return; + +#ifdef GFC_HAVE_REAL_10 + case GFC_DTYPE_REAL_10: + spread_r10 ((gfc_array_r10 *) ret, (gfc_array_r10 *) source, + *along, *pncopies); + return; +#endif + +#ifdef GFC_HAVE_REAL_16 + case GFC_DTYPE_REAL_16: + spread_r16 ((gfc_array_r16 *) ret, (gfc_array_r16 *) source, + *along, *pncopies); + return; +#endif + + case GFC_DTYPE_COMPLEX_4: + spread_c4 ((gfc_array_c4 *) ret, (gfc_array_c4 *) source, + *along, *pncopies); + return; + + case GFC_DTYPE_COMPLEX_8: + spread_c8 ((gfc_array_c8 *) ret, (gfc_array_c8 *) source, + *along, *pncopies); + return; + +#ifdef GFC_HAVE_COMPLEX_10 + case GFC_DTYPE_COMPLEX_10: + spread_c10 ((gfc_array_c10 *) ret, (gfc_array_c10 *) source, + *along, *pncopies); + return; +#endif + +#ifdef GFC_HAVE_COMPLEX_16 + case GFC_DTYPE_COMPLEX_16: + spread_c16 ((gfc_array_c16 *) ret, (gfc_array_c16 *) source, + *along, *pncopies); + return; +#endif + + case GFC_DTYPE_DERIVED_2: + if (GFC_UNALIGNED_2(ret->data) || GFC_UNALIGNED_2(source->data)) + break; + else + { + spread_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) source, + *along, *pncopies); + return; + } + + case GFC_DTYPE_DERIVED_4: + if (GFC_UNALIGNED_4(ret->data) || GFC_UNALIGNED_4(source->data)) + break; + else + { + spread_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) source, + *along, *pncopies); + return; + } + + case GFC_DTYPE_DERIVED_8: + if (GFC_UNALIGNED_8(ret->data) || GFC_UNALIGNED_8(source->data)) + break; + else + { + spread_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) source, + *along, *pncopies); + return; + } + +#ifdef HAVE_GFC_INTEGER_16 + case GFC_DTYPE_DERIVED_16: + if (GFC_UNALIGNED_16(ret->data) || GFC_UNALIGNED_16(source->data)) + break; + else + { + spread_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) source, + *along, *pncopies); + return; + } +#endif + } + + spread_internal (ret, source, along, pncopies, GFC_DESCRIPTOR_SIZE (source)); +} + + +extern void spread_char (gfc_array_char *, GFC_INTEGER_4, + const gfc_array_char *, const index_type *, + const index_type *, GFC_INTEGER_4); +export_proto(spread_char); + +void +spread_char (gfc_array_char *ret, + GFC_INTEGER_4 ret_length __attribute__((unused)), + const gfc_array_char *source, const index_type *along, + const index_type *pncopies, GFC_INTEGER_4 source_length) +{ + spread_internal (ret, source, along, pncopies, source_length); +} + + +extern void spread_char4 (gfc_array_char *, GFC_INTEGER_4, + const gfc_array_char *, const index_type *, + const index_type *, GFC_INTEGER_4); +export_proto(spread_char4); + +void +spread_char4 (gfc_array_char *ret, + GFC_INTEGER_4 ret_length __attribute__((unused)), + const gfc_array_char *source, const index_type *along, + const index_type *pncopies, GFC_INTEGER_4 source_length) +{ + spread_internal (ret, source, along, pncopies, + source_length * sizeof (gfc_char4_t)); +} + + +/* The following are the prototypes for the versions of spread with a + scalar source. */ + +extern void spread_scalar (gfc_array_char *, const char *, + const index_type *, const index_type *); +export_proto(spread_scalar); + +void +spread_scalar (gfc_array_char *ret, const char *source, + const index_type *along, const index_type *pncopies) +{ + index_type type_size; + + if (!ret->dtype) + runtime_error ("return array missing descriptor in spread()"); + + type_size = GFC_DTYPE_TYPE_SIZE(ret); + switch(type_size) + { + case GFC_DTYPE_DERIVED_1: + case GFC_DTYPE_LOGICAL_1: + case GFC_DTYPE_INTEGER_1: + spread_scalar_i1 ((gfc_array_i1 *) ret, (GFC_INTEGER_1 *) source, + *along, *pncopies); + return; + + case GFC_DTYPE_LOGICAL_2: + case GFC_DTYPE_INTEGER_2: + spread_scalar_i2 ((gfc_array_i2 *) ret, (GFC_INTEGER_2 *) source, + *along, *pncopies); + return; + + case GFC_DTYPE_LOGICAL_4: + case GFC_DTYPE_INTEGER_4: + spread_scalar_i4 ((gfc_array_i4 *) ret, (GFC_INTEGER_4 *) source, + *along, *pncopies); + return; + + case GFC_DTYPE_LOGICAL_8: + case GFC_DTYPE_INTEGER_8: + spread_scalar_i8 ((gfc_array_i8 *) ret, (GFC_INTEGER_8 *) source, + *along, *pncopies); + return; + +#ifdef HAVE_GFC_INTEGER_16 + case GFC_DTYPE_LOGICAL_16: + case GFC_DTYPE_INTEGER_16: + spread_scalar_i16 ((gfc_array_i16 *) ret, (GFC_INTEGER_16 *) source, + *along, *pncopies); + return; +#endif + + case GFC_DTYPE_REAL_4: + spread_scalar_r4 ((gfc_array_r4 *) ret, (GFC_REAL_4 *) source, + *along, *pncopies); + return; + + case GFC_DTYPE_REAL_8: + spread_scalar_r8 ((gfc_array_r8 *) ret, (GFC_REAL_8 *) source, + *along, *pncopies); + return; + +#ifdef HAVE_GFC_REAL_10 + case GFC_DTYPE_REAL_10: + spread_scalar_r10 ((gfc_array_r10 *) ret, (GFC_REAL_10 *) source, + *along, *pncopies); + return; +#endif + +#ifdef HAVE_GFC_REAL_16 + case GFC_DTYPE_REAL_16: + spread_scalar_r16 ((gfc_array_r16 *) ret, (GFC_REAL_16 *) source, + *along, *pncopies); + return; +#endif + + case GFC_DTYPE_COMPLEX_4: + spread_scalar_c4 ((gfc_array_c4 *) ret, (GFC_COMPLEX_4 *) source, + *along, *pncopies); + return; + + case GFC_DTYPE_COMPLEX_8: + spread_scalar_c8 ((gfc_array_c8 *) ret, (GFC_COMPLEX_8 *) source, + *along, *pncopies); + return; + +#ifdef HAVE_GFC_COMPLEX_10 + case GFC_DTYPE_COMPLEX_10: + spread_scalar_c10 ((gfc_array_c10 *) ret, (GFC_COMPLEX_10 *) source, + *along, *pncopies); + return; +#endif + +#ifdef HAVE_GFC_COMPLEX_16 + case GFC_DTYPE_COMPLEX_16: + spread_scalar_c16 ((gfc_array_c16 *) ret, (GFC_COMPLEX_16 *) source, + *along, *pncopies); + return; +#endif + + case GFC_DTYPE_DERIVED_2: + if (GFC_UNALIGNED_2(ret->data) || GFC_UNALIGNED_2(source)) + break; + else + { + spread_scalar_i2 ((gfc_array_i2 *) ret, (GFC_INTEGER_2 *) source, + *along, *pncopies); + return; + } + + case GFC_DTYPE_DERIVED_4: + if (GFC_UNALIGNED_4(ret->data) || GFC_UNALIGNED_4(source)) + break; + else + { + spread_scalar_i4 ((gfc_array_i4 *) ret, (GFC_INTEGER_4 *) source, + *along, *pncopies); + return; + } + + case GFC_DTYPE_DERIVED_8: + if (GFC_UNALIGNED_8(ret->data) || GFC_UNALIGNED_8(source)) + break; + else + { + spread_scalar_i8 ((gfc_array_i8 *) ret, (GFC_INTEGER_8 *) source, + *along, *pncopies); + return; + } +#ifdef HAVE_GFC_INTEGER_16 + case GFC_DTYPE_DERIVED_16: + if (GFC_UNALIGNED_16(ret->data) || GFC_UNALIGNED_16(source)) + break; + else + { + spread_scalar_i16 ((gfc_array_i16 *) ret, (GFC_INTEGER_16 *) source, + *along, *pncopies); + return; + } +#endif + } + + spread_internal_scalar (ret, source, along, pncopies, GFC_DESCRIPTOR_SIZE (ret)); +} + + +extern void spread_char_scalar (gfc_array_char *, GFC_INTEGER_4, + const char *, const index_type *, + const index_type *, GFC_INTEGER_4); +export_proto(spread_char_scalar); + +void +spread_char_scalar (gfc_array_char *ret, + GFC_INTEGER_4 ret_length __attribute__((unused)), + const char *source, const index_type *along, + const index_type *pncopies, GFC_INTEGER_4 source_length) +{ + if (!ret->dtype) + runtime_error ("return array missing descriptor in spread()"); + spread_internal_scalar (ret, source, along, pncopies, source_length); +} + + +extern void spread_char4_scalar (gfc_array_char *, GFC_INTEGER_4, + const char *, const index_type *, + const index_type *, GFC_INTEGER_4); +export_proto(spread_char4_scalar); + +void +spread_char4_scalar (gfc_array_char *ret, + GFC_INTEGER_4 ret_length __attribute__((unused)), + const char *source, const index_type *along, + const index_type *pncopies, GFC_INTEGER_4 source_length) +{ + if (!ret->dtype) + runtime_error ("return array missing descriptor in spread()"); + spread_internal_scalar (ret, source, along, pncopies, + source_length * sizeof (gfc_char4_t)); +} + diff --git a/gcc-4.4.0/libgfortran/intrinsics/stat.c b/gcc-4.4.0/libgfortran/intrinsics/stat.c new file mode 100644 index 000000000..5d0f3b63b --- /dev/null +++ b/gcc-4.4.0/libgfortran/intrinsics/stat.c @@ -0,0 +1,549 @@ +/* Implementation of the STAT and FSTAT intrinsics. + Copyright (C) 2004, 2005, 2006, 2007, 2009 Free Software Foundation, Inc. + Contributed by Steven G. Kargl <kargls@comcast.net>. + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran 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 3 of the License, or (at your option) any later version. + +Libgfortran 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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. */ + +#include "libgfortran.h" + +#include <string.h> +#include <errno.h> + +#ifdef HAVE_SYS_STAT_H +#include <sys/stat.h> +#endif + +#ifdef HAVE_STDLIB_H +#include <stdlib.h> +#endif + + +#ifdef HAVE_STAT + +/* SUBROUTINE STAT(FILE, SARRAY, STATUS) + CHARACTER(len=*), INTENT(IN) :: FILE + INTEGER, INTENT(OUT), :: SARRAY(13) + INTEGER, INTENT(OUT), OPTIONAL :: STATUS + + FUNCTION STAT(FILE, SARRAY) + INTEGER STAT + CHARACTER(len=*), INTENT(IN) :: FILE + INTEGER, INTENT(OUT), :: SARRAY(13) */ + +/*extern void stat_i4_sub_0 (char *, gfc_array_i4 *, GFC_INTEGER_4 *, + gfc_charlen_type, int); +internal_proto(stat_i4_sub_0);*/ + +static void +stat_i4_sub_0 (char *name, gfc_array_i4 *sarray, GFC_INTEGER_4 *status, + gfc_charlen_type name_len, int is_lstat __attribute__ ((unused))) +{ + int val; + char *str; + struct stat sb; + + /* If the rank of the array is not 1, abort. */ + if (GFC_DESCRIPTOR_RANK (sarray) != 1) + runtime_error ("Array rank of SARRAY is not 1."); + + /* If the array is too small, abort. */ + if (sarray->dim[0].ubound + 1 - sarray->dim[0].lbound < 13) + runtime_error ("Array size of SARRAY is too small."); + + /* Trim trailing spaces from name. */ + while (name_len > 0 && name[name_len - 1] == ' ') + name_len--; + + /* Make a null terminated copy of the string. */ + str = gfc_alloca (name_len + 1); + memcpy (str, name, name_len); + str[name_len] = '\0'; + + /* On platforms that don't provide lstat(), we use stat() instead. */ +#ifdef HAVE_LSTAT + if (is_lstat) + val = lstat(str, &sb); + else +#endif + val = stat(str, &sb); + + if (val == 0) + { + /* Device ID */ + sarray->data[0 * sarray->dim[0].stride] = sb.st_dev; + + /* Inode number */ + sarray->data[1 * sarray->dim[0].stride] = sb.st_ino; + + /* File mode */ + sarray->data[2 * sarray->dim[0].stride] = sb.st_mode; + + /* Number of (hard) links */ + sarray->data[3 * sarray->dim[0].stride] = sb.st_nlink; + + /* Owner's uid */ + sarray->data[4 * sarray->dim[0].stride] = sb.st_uid; + + /* Owner's gid */ + sarray->data[5 * sarray->dim[0].stride] = sb.st_gid; + + /* ID of device containing directory entry for file (0 if not available) */ +#if HAVE_STRUCT_STAT_ST_RDEV + sarray->data[6 * sarray->dim[0].stride] = sb.st_rdev; +#else + sarray->data[6 * sarray->dim[0].stride] = 0; +#endif + + /* File size (bytes) */ + sarray->data[7 * sarray->dim[0].stride] = sb.st_size; + + /* Last access time */ + sarray->data[8 * sarray->dim[0].stride] = sb.st_atime; + + /* Last modification time */ + sarray->data[9 * sarray->dim[0].stride] = sb.st_mtime; + + /* Last file status change time */ + sarray->data[10 * sarray->dim[0].stride] = sb.st_ctime; + + /* Preferred I/O block size (-1 if not available) */ +#if HAVE_STRUCT_STAT_ST_BLKSIZE + sarray->data[11 * sarray->dim[0].stride] = sb.st_blksize; +#else + sarray->data[11 * sarray->dim[0].stride] = -1; +#endif + + /* Number of blocks allocated (-1 if not available) */ +#if HAVE_STRUCT_STAT_ST_BLOCKS + sarray->data[12 * sarray->dim[0].stride] = sb.st_blocks; +#else + sarray->data[12 * sarray->dim[0].stride] = -1; +#endif + } + + if (status != NULL) + *status = (val == 0) ? 0 : errno; +} + + +extern void stat_i4_sub (char *, gfc_array_i4 *, GFC_INTEGER_4 *, + gfc_charlen_type); +iexport_proto(stat_i4_sub); + +void +stat_i4_sub (char *name, gfc_array_i4 *sarray, GFC_INTEGER_4 *status, + gfc_charlen_type name_len) +{ + stat_i4_sub_0 (name, sarray, status, name_len, 0); +} +iexport(stat_i4_sub); + + +extern void lstat_i4_sub (char *, gfc_array_i4 *, GFC_INTEGER_4 *, + gfc_charlen_type); +iexport_proto(lstat_i4_sub); + +void +lstat_i4_sub (char *name, gfc_array_i4 *sarray, GFC_INTEGER_4 *status, + gfc_charlen_type name_len) +{ + stat_i4_sub_0 (name, sarray, status, name_len, 1); +} +iexport(lstat_i4_sub); + + + +static void +stat_i8_sub_0 (char *name, gfc_array_i8 *sarray, GFC_INTEGER_8 *status, + gfc_charlen_type name_len, int is_lstat __attribute__ ((unused))) +{ + int val; + char *str; + struct stat sb; + + /* If the rank of the array is not 1, abort. */ + if (GFC_DESCRIPTOR_RANK (sarray) != 1) + runtime_error ("Array rank of SARRAY is not 1."); + + /* If the array is too small, abort. */ + if (sarray->dim[0].ubound + 1 - sarray->dim[0].lbound < 13) + runtime_error ("Array size of SARRAY is too small."); + + /* Trim trailing spaces from name. */ + while (name_len > 0 && name[name_len - 1] == ' ') + name_len--; + + /* Make a null terminated copy of the string. */ + str = gfc_alloca (name_len + 1); + memcpy (str, name, name_len); + str[name_len] = '\0'; + + /* On platforms that don't provide lstat(), we use stat() instead. */ +#ifdef HAVE_LSTAT + if (is_lstat) + val = lstat(str, &sb); + else +#endif + val = stat(str, &sb); + + if (val == 0) + { + /* Device ID */ + sarray->data[0] = sb.st_dev; + + /* Inode number */ + sarray->data[sarray->dim[0].stride] = sb.st_ino; + + /* File mode */ + sarray->data[2 * sarray->dim[0].stride] = sb.st_mode; + + /* Number of (hard) links */ + sarray->data[3 * sarray->dim[0].stride] = sb.st_nlink; + + /* Owner's uid */ + sarray->data[4 * sarray->dim[0].stride] = sb.st_uid; + + /* Owner's gid */ + sarray->data[5 * sarray->dim[0].stride] = sb.st_gid; + + /* ID of device containing directory entry for file (0 if not available) */ +#if HAVE_STRUCT_STAT_ST_RDEV + sarray->data[6 * sarray->dim[0].stride] = sb.st_rdev; +#else + sarray->data[6 * sarray->dim[0].stride] = 0; +#endif + + /* File size (bytes) */ + sarray->data[7 * sarray->dim[0].stride] = sb.st_size; + + /* Last access time */ + sarray->data[8 * sarray->dim[0].stride] = sb.st_atime; + + /* Last modification time */ + sarray->data[9 * sarray->dim[0].stride] = sb.st_mtime; + + /* Last file status change time */ + sarray->data[10 * sarray->dim[0].stride] = sb.st_ctime; + + /* Preferred I/O block size (-1 if not available) */ +#if HAVE_STRUCT_STAT_ST_BLKSIZE + sarray->data[11 * sarray->dim[0].stride] = sb.st_blksize; +#else + sarray->data[11 * sarray->dim[0].stride] = -1; +#endif + + /* Number of blocks allocated (-1 if not available) */ +#if HAVE_STRUCT_STAT_ST_BLOCKS + sarray->data[12 * sarray->dim[0].stride] = sb.st_blocks; +#else + sarray->data[12 * sarray->dim[0].stride] = -1; +#endif + } + + if (status != NULL) + *status = (val == 0) ? 0 : errno; +} + + +extern void stat_i8_sub (char *, gfc_array_i8 *, GFC_INTEGER_8 *, + gfc_charlen_type); +iexport_proto(stat_i8_sub); + +void +stat_i8_sub (char *name, gfc_array_i8 *sarray, GFC_INTEGER_8 *status, + gfc_charlen_type name_len) +{ + stat_i8_sub_0 (name, sarray, status, name_len, 0); +} + +iexport(stat_i8_sub); + + +extern void lstat_i8_sub (char *, gfc_array_i8 *, GFC_INTEGER_8 *, + gfc_charlen_type); +iexport_proto(lstat_i8_sub); + +void +lstat_i8_sub (char *name, gfc_array_i8 *sarray, GFC_INTEGER_8 *status, + gfc_charlen_type name_len) +{ + stat_i8_sub_0 (name, sarray, status, name_len, 1); +} + +iexport(lstat_i8_sub); + + +extern GFC_INTEGER_4 stat_i4 (char *, gfc_array_i4 *, gfc_charlen_type); +export_proto(stat_i4); + +GFC_INTEGER_4 +stat_i4 (char *name, gfc_array_i4 *sarray, gfc_charlen_type name_len) +{ + GFC_INTEGER_4 val; + stat_i4_sub (name, sarray, &val, name_len); + return val; +} + +extern GFC_INTEGER_8 stat_i8 (char *, gfc_array_i8 *, gfc_charlen_type); +export_proto(stat_i8); + +GFC_INTEGER_8 +stat_i8 (char *name, gfc_array_i8 *sarray, gfc_charlen_type name_len) +{ + GFC_INTEGER_8 val; + stat_i8_sub (name, sarray, &val, name_len); + return val; +} + + +/* SUBROUTINE LSTAT(FILE, SARRAY, STATUS) + CHARACTER(len=*), INTENT(IN) :: FILE + INTEGER, INTENT(OUT), :: SARRAY(13) + INTEGER, INTENT(OUT), OPTIONAL :: STATUS + + FUNCTION LSTAT(FILE, SARRAY) + INTEGER LSTAT + CHARACTER(len=*), INTENT(IN) :: FILE + INTEGER, INTENT(OUT), :: SARRAY(13) */ + +extern GFC_INTEGER_4 lstat_i4 (char *, gfc_array_i4 *, gfc_charlen_type); +export_proto(lstat_i4); + +GFC_INTEGER_4 +lstat_i4 (char *name, gfc_array_i4 *sarray, gfc_charlen_type name_len) +{ + GFC_INTEGER_4 val; + lstat_i4_sub (name, sarray, &val, name_len); + return val; +} + +extern GFC_INTEGER_8 lstat_i8 (char *, gfc_array_i8 *, gfc_charlen_type); +export_proto(lstat_i8); + +GFC_INTEGER_8 +lstat_i8 (char *name, gfc_array_i8 *sarray, gfc_charlen_type name_len) +{ + GFC_INTEGER_8 val; + lstat_i8_sub (name, sarray, &val, name_len); + return val; +} + +#endif + + +#ifdef HAVE_FSTAT + +/* SUBROUTINE FSTAT(UNIT, SARRAY, STATUS) + INTEGER, INTENT(IN) :: UNIT + INTEGER, INTENT(OUT) :: SARRAY(13) + INTEGER, INTENT(OUT), OPTIONAL :: STATUS + + FUNCTION FSTAT(UNIT, SARRAY) + INTEGER FSTAT + INTEGER, INTENT(IN) :: UNIT + INTEGER, INTENT(OUT) :: SARRAY(13) */ + +extern void fstat_i4_sub (GFC_INTEGER_4 *, gfc_array_i4 *, GFC_INTEGER_4 *); +iexport_proto(fstat_i4_sub); + +void +fstat_i4_sub (GFC_INTEGER_4 *unit, gfc_array_i4 *sarray, GFC_INTEGER_4 *status) +{ + int val; + struct stat sb; + + /* If the rank of the array is not 1, abort. */ + if (GFC_DESCRIPTOR_RANK (sarray) != 1) + runtime_error ("Array rank of SARRAY is not 1."); + + /* If the array is too small, abort. */ + if (sarray->dim[0].ubound + 1 - sarray->dim[0].lbound < 13) + runtime_error ("Array size of SARRAY is too small."); + + /* Convert Fortran unit number to C file descriptor. */ + val = unit_to_fd (*unit); + if (val >= 0) + val = fstat(val, &sb); + + if (val == 0) + { + /* Device ID */ + sarray->data[0 * sarray->dim[0].stride] = sb.st_dev; + + /* Inode number */ + sarray->data[1 * sarray->dim[0].stride] = sb.st_ino; + + /* File mode */ + sarray->data[2 * sarray->dim[0].stride] = sb.st_mode; + + /* Number of (hard) links */ + sarray->data[3 * sarray->dim[0].stride] = sb.st_nlink; + + /* Owner's uid */ + sarray->data[4 * sarray->dim[0].stride] = sb.st_uid; + + /* Owner's gid */ + sarray->data[5 * sarray->dim[0].stride] = sb.st_gid; + + /* ID of device containing directory entry for file (0 if not available) */ +#if HAVE_STRUCT_STAT_ST_RDEV + sarray->data[6 * sarray->dim[0].stride] = sb.st_rdev; +#else + sarray->data[6 * sarray->dim[0].stride] = 0; +#endif + + /* File size (bytes) */ + sarray->data[7 * sarray->dim[0].stride] = sb.st_size; + + /* Last access time */ + sarray->data[8 * sarray->dim[0].stride] = sb.st_atime; + + /* Last modification time */ + sarray->data[9 * sarray->dim[0].stride] = sb.st_mtime; + + /* Last file status change time */ + sarray->data[10 * sarray->dim[0].stride] = sb.st_ctime; + + /* Preferred I/O block size (-1 if not available) */ +#if HAVE_STRUCT_STAT_ST_BLKSIZE + sarray->data[11 * sarray->dim[0].stride] = sb.st_blksize; +#else + sarray->data[11 * sarray->dim[0].stride] = -1; +#endif + + /* Number of blocks allocated (-1 if not available) */ +#if HAVE_STRUCT_STAT_ST_BLOCKS + sarray->data[12 * sarray->dim[0].stride] = sb.st_blocks; +#else + sarray->data[12 * sarray->dim[0].stride] = -1; +#endif + } + + if (status != NULL) + *status = (val == 0) ? 0 : errno; +} +iexport(fstat_i4_sub); + +extern void fstat_i8_sub (GFC_INTEGER_8 *, gfc_array_i8 *, GFC_INTEGER_8 *); +iexport_proto(fstat_i8_sub); + +void +fstat_i8_sub (GFC_INTEGER_8 *unit, gfc_array_i8 *sarray, GFC_INTEGER_8 *status) +{ + int val; + struct stat sb; + + /* If the rank of the array is not 1, abort. */ + if (GFC_DESCRIPTOR_RANK (sarray) != 1) + runtime_error ("Array rank of SARRAY is not 1."); + + /* If the array is too small, abort. */ + if (sarray->dim[0].ubound + 1 - sarray->dim[0].lbound < 13) + runtime_error ("Array size of SARRAY is too small."); + + /* Convert Fortran unit number to C file descriptor. */ + val = unit_to_fd ((int) *unit); + if (val >= 0) + val = fstat(val, &sb); + + if (val == 0) + { + /* Device ID */ + sarray->data[0] = sb.st_dev; + + /* Inode number */ + sarray->data[sarray->dim[0].stride] = sb.st_ino; + + /* File mode */ + sarray->data[2 * sarray->dim[0].stride] = sb.st_mode; + + /* Number of (hard) links */ + sarray->data[3 * sarray->dim[0].stride] = sb.st_nlink; + + /* Owner's uid */ + sarray->data[4 * sarray->dim[0].stride] = sb.st_uid; + + /* Owner's gid */ + sarray->data[5 * sarray->dim[0].stride] = sb.st_gid; + + /* ID of device containing directory entry for file (0 if not available) */ +#if HAVE_STRUCT_STAT_ST_RDEV + sarray->data[6 * sarray->dim[0].stride] = sb.st_rdev; +#else + sarray->data[6 * sarray->dim[0].stride] = 0; +#endif + + /* File size (bytes) */ + sarray->data[7 * sarray->dim[0].stride] = sb.st_size; + + /* Last access time */ + sarray->data[8 * sarray->dim[0].stride] = sb.st_atime; + + /* Last modification time */ + sarray->data[9 * sarray->dim[0].stride] = sb.st_mtime; + + /* Last file status change time */ + sarray->data[10 * sarray->dim[0].stride] = sb.st_ctime; + + /* Preferred I/O block size (-1 if not available) */ +#if HAVE_STRUCT_STAT_ST_BLKSIZE + sarray->data[11 * sarray->dim[0].stride] = sb.st_blksize; +#else + sarray->data[11 * sarray->dim[0].stride] = -1; +#endif + + /* Number of blocks allocated (-1 if not available) */ +#if HAVE_STRUCT_STAT_ST_BLOCKS + sarray->data[12 * sarray->dim[0].stride] = sb.st_blocks; +#else + sarray->data[12 * sarray->dim[0].stride] = -1; +#endif + } + + if (status != NULL) + *status = (val == 0) ? 0 : errno; +} +iexport(fstat_i8_sub); + +extern GFC_INTEGER_4 fstat_i4 (GFC_INTEGER_4 *, gfc_array_i4 *); +export_proto(fstat_i4); + +GFC_INTEGER_4 +fstat_i4 (GFC_INTEGER_4 *unit, gfc_array_i4 *sarray) +{ + GFC_INTEGER_4 val; + fstat_i4_sub (unit, sarray, &val); + return val; +} + +extern GFC_INTEGER_8 fstat_i8 (GFC_INTEGER_8 *, gfc_array_i8 *); +export_proto(fstat_i8); + +GFC_INTEGER_8 +fstat_i8 (GFC_INTEGER_8 *unit, gfc_array_i8 *sarray) +{ + GFC_INTEGER_8 val; + fstat_i8_sub (unit, sarray, &val); + return val; +} + +#endif diff --git a/gcc-4.4.0/libgfortran/intrinsics/string_intrinsics.c b/gcc-4.4.0/libgfortran/intrinsics/string_intrinsics.c new file mode 100644 index 000000000..953ec39d4 --- /dev/null +++ b/gcc-4.4.0/libgfortran/intrinsics/string_intrinsics.c @@ -0,0 +1,80 @@ +/* String intrinsics helper functions. + Copyright 2008, 2009 Free Software Foundation, Inc. + +This file is part of the GNU Fortran runtime library (libgfortran). + +Libgfortran 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 3 of the License, or (at your option) any later version. + +Libgfortran 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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. */ + + +/* Unlike what the name of this file suggests, we don't actually + implement the Fortran intrinsics here. At least, not with the + names they have in the standard. The functions here provide all + the support we need for the standard string intrinsics, and the + compiler translates the actual intrinsics calls to calls to + functions in this file. */ + +#include "libgfortran.h" + +#include <stdlib.h> +#include <string.h> + + +/* Helper function to set parts of wide strings to a constant (usually + spaces). */ + +static gfc_char4_t * +memset_char4 (gfc_char4_t *b, gfc_char4_t c, size_t len) +{ + size_t i; + + for (i = 0; i < len; i++) + b[i] = c; + + return b; +} + + +/* All other functions are defined using a few generic macros in + string_intrinsics_inc.c, so we avoid code duplication between the + various character type kinds. */ + +#undef CHARTYPE +#define CHARTYPE char +#undef UCHARTYPE +#define UCHARTYPE unsigned char +#undef SUFFIX +#define SUFFIX(x) x +#undef MEMSET +#define MEMSET memset + +#include "string_intrinsics_inc.c" + + +#undef CHARTYPE +#define CHARTYPE gfc_char4_t +#undef UCHARTYPE +#define UCHARTYPE gfc_char4_t +#undef SUFFIX +#define SUFFIX(x) x ## _char4 +#undef MEMSET +#define MEMSET memset_char4 + +#include "string_intrinsics_inc.c" + diff --git a/gcc-4.4.0/libgfortran/intrinsics/string_intrinsics_inc.c b/gcc-4.4.0/libgfortran/intrinsics/string_intrinsics_inc.c new file mode 100644 index 000000000..9ad2df46c --- /dev/null +++ b/gcc-4.4.0/libgfortran/intrinsics/string_intrinsics_inc.c @@ -0,0 +1,413 @@ +/* String intrinsics helper functions. + Copyright 2002, 2005, 2007, 2008, 2009 Free Software Foundation, Inc. + +This file is part of the GNU Fortran runtime library (libgfortran). + +Libgfortran 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 3 of the License, or (at your option) any later version. + +Libgfortran 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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. */ + + +/* Rename the functions. */ +#define concat_string SUFFIX(concat_string) +#define string_len_trim SUFFIX(string_len_trim) +#define adjustl SUFFIX(adjustl) +#define adjustr SUFFIX(adjustr) +#define string_index SUFFIX(string_index) +#define string_scan SUFFIX(string_scan) +#define string_verify SUFFIX(string_verify) +#define string_trim SUFFIX(string_trim) +#define string_minmax SUFFIX(string_minmax) +#define zero_length_string SUFFIX(zero_length_string) +#define compare_string SUFFIX(compare_string) + + +/* The prototypes. */ + +extern void concat_string (gfc_charlen_type, CHARTYPE *, + gfc_charlen_type, const CHARTYPE *, + gfc_charlen_type, const CHARTYPE *); +export_proto(concat_string); + +extern gfc_charlen_type string_len_trim (gfc_charlen_type, const CHARTYPE *); +export_proto(string_len_trim); + +extern void adjustl (CHARTYPE *, gfc_charlen_type, const CHARTYPE *); +export_proto(adjustl); + +extern void adjustr (CHARTYPE *, gfc_charlen_type, const CHARTYPE *); +export_proto(adjustr); + +extern gfc_charlen_type string_index (gfc_charlen_type, const CHARTYPE *, + gfc_charlen_type, const CHARTYPE *, + GFC_LOGICAL_4); +export_proto(string_index); + +extern gfc_charlen_type string_scan (gfc_charlen_type, const CHARTYPE *, + gfc_charlen_type, const CHARTYPE *, + GFC_LOGICAL_4); +export_proto(string_scan); + +extern gfc_charlen_type string_verify (gfc_charlen_type, const CHARTYPE *, + gfc_charlen_type, const CHARTYPE *, + GFC_LOGICAL_4); +export_proto(string_verify); + +extern void string_trim (gfc_charlen_type *, CHARTYPE **, gfc_charlen_type, + const CHARTYPE *); +export_proto(string_trim); + +extern void string_minmax (gfc_charlen_type *, CHARTYPE **, int, int, ...); +export_proto(string_minmax); + + +/* Use for functions which can return a zero-length string. */ +static CHARTYPE zero_length_string = 0; + + +/* Strings of unequal length are extended with pad characters. */ + +int +compare_string (gfc_charlen_type len1, const CHARTYPE *s1, + gfc_charlen_type len2, const CHARTYPE *s2) +{ + const UCHARTYPE *s; + gfc_charlen_type len; + int res; + + res = memcmp (s1, s2, ((len1 < len2) ? len1 : len2) * sizeof (CHARTYPE)); + if (res != 0) + return res; + + if (len1 == len2) + return 0; + + if (len1 < len2) + { + len = len2 - len1; + s = (UCHARTYPE *) &s2[len1]; + res = -1; + } + else + { + len = len1 - len2; + s = (UCHARTYPE *) &s1[len2]; + res = 1; + } + + while (len--) + { + if (*s != ' ') + { + if (*s > ' ') + return res; + else + return -res; + } + s++; + } + + return 0; +} +iexport(compare_string); + + +/* The destination and source should not overlap. */ + +void +concat_string (gfc_charlen_type destlen, CHARTYPE * dest, + gfc_charlen_type len1, const CHARTYPE * s1, + gfc_charlen_type len2, const CHARTYPE * s2) +{ + if (len1 >= destlen) + { + memcpy (dest, s1, destlen * sizeof (CHARTYPE)); + return; + } + memcpy (dest, s1, len1 * sizeof (CHARTYPE)); + dest += len1; + destlen -= len1; + + if (len2 >= destlen) + { + memcpy (dest, s2, destlen * sizeof (CHARTYPE)); + return; + } + + memcpy (dest, s2, len2 * sizeof (CHARTYPE)); + MEMSET (&dest[len2], ' ', destlen - len2); +} + + +/* Return string with all trailing blanks removed. */ + +void +string_trim (gfc_charlen_type *len, CHARTYPE **dest, gfc_charlen_type slen, + const CHARTYPE *src) +{ + gfc_charlen_type i; + + /* Determine length of result string. */ + for (i = slen - 1; i >= 0; i--) + { + if (src[i] != ' ') + break; + } + *len = i + 1; + + if (*len == 0) + *dest = &zero_length_string; + else + { + /* Allocate space for result string. */ + *dest = internal_malloc_size (*len * sizeof (CHARTYPE)); + + /* Copy string if necessary. */ + memcpy (*dest, src, *len * sizeof (CHARTYPE)); + } +} + + +/* The length of a string not including trailing blanks. */ + +gfc_charlen_type +string_len_trim (gfc_charlen_type len, const CHARTYPE *s) +{ + gfc_charlen_type i; + + for (i = len - 1; i >= 0; i--) + { + if (s[i] != ' ') + break; + } + return i + 1; +} + + +/* Find a substring within a string. */ + +gfc_charlen_type +string_index (gfc_charlen_type slen, const CHARTYPE *str, + gfc_charlen_type sslen, const CHARTYPE *sstr, + GFC_LOGICAL_4 back) +{ + gfc_charlen_type start, last, delta, i; + + if (sslen == 0) + return back ? (slen + 1) : 1; + + if (sslen > slen) + return 0; + + if (!back) + { + last = slen + 1 - sslen; + start = 0; + delta = 1; + } + else + { + last = -1; + start = slen - sslen; + delta = -1; + } + + for (; start != last; start+= delta) + { + for (i = 0; i < sslen; i++) + { + if (str[start + i] != sstr[i]) + break; + } + if (i == sslen) + return (start + 1); + } + return 0; +} + + +/* Remove leading blanks from a string, padding at end. The src and dest + should not overlap. */ + +void +adjustl (CHARTYPE *dest, gfc_charlen_type len, const CHARTYPE *src) +{ + gfc_charlen_type i; + + i = 0; + while (i < len && src[i] == ' ') + i++; + + if (i < len) + memcpy (dest, &src[i], (len - i) * sizeof (CHARTYPE)); + if (i > 0) + MEMSET (&dest[len - i], ' ', i); +} + + +/* Remove trailing blanks from a string. */ + +void +adjustr (CHARTYPE *dest, gfc_charlen_type len, const CHARTYPE *src) +{ + gfc_charlen_type i; + + i = len; + while (i > 0 && src[i - 1] == ' ') + i--; + + if (i < len) + MEMSET (dest, ' ', len - i); + memcpy (&dest[len - i], src, i * sizeof (CHARTYPE)); +} + + +/* Scan a string for any one of the characters in a set of characters. */ + +gfc_charlen_type +string_scan (gfc_charlen_type slen, const CHARTYPE *str, + gfc_charlen_type setlen, const CHARTYPE *set, GFC_LOGICAL_4 back) +{ + gfc_charlen_type i, j; + + if (slen == 0 || setlen == 0) + return 0; + + if (back) + { + for (i = slen - 1; i >= 0; i--) + { + for (j = 0; j < setlen; j++) + { + if (str[i] == set[j]) + return (i + 1); + } + } + } + else + { + for (i = 0; i < slen; i++) + { + for (j = 0; j < setlen; j++) + { + if (str[i] == set[j]) + return (i + 1); + } + } + } + + return 0; +} + + +/* Verify that a set of characters contains all the characters in a + string by identifying the position of the first character in a + characters that does not appear in a given set of characters. */ + +gfc_charlen_type +string_verify (gfc_charlen_type slen, const CHARTYPE *str, + gfc_charlen_type setlen, const CHARTYPE *set, + GFC_LOGICAL_4 back) +{ + gfc_charlen_type start, last, delta, i; + + if (slen == 0) + return 0; + + if (back) + { + last = -1; + start = slen - 1; + delta = -1; + } + else + { + last = slen; + start = 0; + delta = 1; + } + for (; start != last; start += delta) + { + for (i = 0; i < setlen; i++) + { + if (str[start] == set[i]) + break; + } + if (i == setlen) + return (start + 1); + } + + return 0; +} + + +/* MIN and MAX intrinsics for strings. The front-end makes sure that + nargs is at least 2. */ + +void +string_minmax (gfc_charlen_type *rlen, CHARTYPE **dest, int op, int nargs, ...) +{ + va_list ap; + int i; + CHARTYPE *next, *res; + gfc_charlen_type nextlen, reslen; + + va_start (ap, nargs); + reslen = va_arg (ap, gfc_charlen_type); + res = va_arg (ap, CHARTYPE *); + *rlen = reslen; + + if (res == NULL) + runtime_error ("First argument of '%s' intrinsic should be present", + op > 0 ? "MAX" : "MIN"); + + for (i = 1; i < nargs; i++) + { + nextlen = va_arg (ap, gfc_charlen_type); + next = va_arg (ap, CHARTYPE *); + + if (next == NULL) + { + if (i == 1) + runtime_error ("Second argument of '%s' intrinsic should be " + "present", op > 0 ? "MAX" : "MIN"); + else + continue; + } + + if (nextlen > *rlen) + *rlen = nextlen; + + if (op * compare_string (reslen, res, nextlen, next) < 0) + { + reslen = nextlen; + res = next; + } + } + va_end (ap); + + if (*rlen == 0) + *dest = &zero_length_string; + else + { + CHARTYPE *tmp = internal_malloc_size (*rlen * sizeof (CHARTYPE)); + memcpy (tmp, res, reslen * sizeof (CHARTYPE)); + MEMSET (&tmp[reslen], ' ', *rlen - reslen); + *dest = tmp; + } +} diff --git a/gcc-4.4.0/libgfortran/intrinsics/symlnk.c b/gcc-4.4.0/libgfortran/intrinsics/symlnk.c new file mode 100644 index 000000000..095520f05 --- /dev/null +++ b/gcc-4.4.0/libgfortran/intrinsics/symlnk.c @@ -0,0 +1,131 @@ +/* Implementation of the SYMLNK intrinsic. + Copyright (C) 2005, 2007, 2009 Free Software Foundation, Inc. + Contributed by François-Xavier Coudert <coudert@clipper.ens.fr> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran 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 3 of the License, or (at your option) any later version. + +Libgfortran 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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. */ + +#include "libgfortran.h" + +#include <errno.h> +#include <string.h> + +#ifdef HAVE_UNISTD_H +#include <unistd.h> +#endif + +/* SUBROUTINE SYMLNK(PATH1, PATH2, STATUS) + CHARACTER(len=*), INTENT(IN) :: PATH1, PATH2 + INTEGER, INTENT(OUT), OPTIONAL :: STATUS */ + +#ifdef HAVE_SYMLINK +extern void symlnk_i4_sub (char *, char *, GFC_INTEGER_4 *, gfc_charlen_type, + gfc_charlen_type); +iexport_proto(symlnk_i4_sub); + +void +symlnk_i4_sub (char *path1, char *path2, GFC_INTEGER_4 *status, + gfc_charlen_type path1_len, gfc_charlen_type path2_len) +{ + int val; + char *str1, *str2; + + /* Trim trailing spaces from paths. */ + while (path1_len > 0 && path1[path1_len - 1] == ' ') + path1_len--; + while (path2_len > 0 && path2[path2_len - 1] == ' ') + path2_len--; + + /* Make a null terminated copy of the strings. */ + str1 = gfc_alloca (path1_len + 1); + memcpy (str1, path1, path1_len); + str1[path1_len] = '\0'; + + str2 = gfc_alloca (path2_len + 1); + memcpy (str2, path2, path2_len); + str2[path2_len] = '\0'; + + val = symlink (str1, str2); + + if (status != NULL) + *status = (val == 0) ? 0 : errno; +} +iexport(symlnk_i4_sub); + +extern void symlnk_i8_sub (char *, char *, GFC_INTEGER_8 *, gfc_charlen_type, + gfc_charlen_type); +iexport_proto(symlnk_i8_sub); + +void +symlnk_i8_sub (char *path1, char *path2, GFC_INTEGER_8 *status, + gfc_charlen_type path1_len, gfc_charlen_type path2_len) +{ + int val; + char *str1, *str2; + + /* Trim trailing spaces from paths. */ + while (path1_len > 0 && path1[path1_len - 1] == ' ') + path1_len--; + while (path2_len > 0 && path2[path2_len - 1] == ' ') + path2_len--; + + /* Make a null terminated copy of the strings. */ + str1 = gfc_alloca (path1_len + 1); + memcpy (str1, path1, path1_len); + str1[path1_len] = '\0'; + + str2 = gfc_alloca (path2_len + 1); + memcpy (str2, path2, path2_len); + str2[path2_len] = '\0'; + + val = symlink (str1, str2); + + if (status != NULL) + *status = (val == 0) ? 0 : errno; +} +iexport(symlnk_i8_sub); + +extern GFC_INTEGER_4 symlnk_i4 (char *, char *, gfc_charlen_type, + gfc_charlen_type); +export_proto(symlnk_i4); + +GFC_INTEGER_4 +symlnk_i4 (char *path1, char *path2, gfc_charlen_type path1_len, + gfc_charlen_type path2_len) +{ + GFC_INTEGER_4 val; + symlnk_i4_sub (path1, path2, &val, path1_len, path2_len); + return val; +} + +extern GFC_INTEGER_8 symlnk_i8 (char *, char *, gfc_charlen_type, + gfc_charlen_type); +export_proto(symlnk_i8); + +GFC_INTEGER_8 +symlnk_i8 (char *path1, char *path2, gfc_charlen_type path1_len, + gfc_charlen_type path2_len) +{ + GFC_INTEGER_8 val; + symlnk_i8_sub (path1, path2, &val, path1_len, path2_len); + return val; +} +#endif diff --git a/gcc-4.4.0/libgfortran/intrinsics/system.c b/gcc-4.4.0/libgfortran/intrinsics/system.c new file mode 100644 index 000000000..831823ffc --- /dev/null +++ b/gcc-4.4.0/libgfortran/intrinsics/system.c @@ -0,0 +1,64 @@ +/* Implementation of the SYSTEM intrinsic. + Copyright (C) 2004, 2007, 2009 Free Software Foundation, Inc. + Contributed by Tobias Schlüter. + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran 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 3, or (at your option) any later +version. + +Libgfortran 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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. */ + +#include "libgfortran.h" +#include <string.h> + +#ifdef HAVE_STDLIB_H +#include <stdlib.h> +#endif + +extern void system_sub (const char *fcmd, GFC_INTEGER_4 * status, + gfc_charlen_type cmd_len); +iexport_proto(system_sub); + +void +system_sub (const char *fcmd, GFC_INTEGER_4 *status, gfc_charlen_type cmd_len) +{ + char cmd[cmd_len + 1]; + int stat; + + /* Flush all I/O units before executing the command. */ + flush_all_units(); + + memcpy (cmd, fcmd, cmd_len); + cmd[cmd_len] = '\0'; + + stat = system (cmd); + if (status) + *status = stat; +} +iexport(system_sub); + +extern GFC_INTEGER_4 PREFIX(system) (const char *, gfc_charlen_type); +export_proto_np(PREFIX(system)); + +GFC_INTEGER_4 +PREFIX(system) (const char *fcmd, gfc_charlen_type cmd_len) +{ + GFC_INTEGER_4 stat; + system_sub (fcmd, &stat, cmd_len); + return stat; +} diff --git a/gcc-4.4.0/libgfortran/intrinsics/system_clock.c b/gcc-4.4.0/libgfortran/intrinsics/system_clock.c new file mode 100644 index 000000000..cf32b8d83 --- /dev/null +++ b/gcc-4.4.0/libgfortran/intrinsics/system_clock.c @@ -0,0 +1,192 @@ +/* Implementation of the SYSTEM_CLOCK intrinsic. + Copyright (C) 2004, 2005, 2007, 2009 Free Software Foundation, Inc. + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran 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 3 of the License, or (at your option) any later version. + +Libgfortran 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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. */ + +#include "libgfortran.h" + +#include <limits.h> + +#if defined(HAVE_SYS_TIME_H) && defined(HAVE_GETTIMEOFDAY) +# include <sys/time.h> +# define TCK 1000 +#elif defined(HAVE_TIME_H) +# include <time.h> +# define TCK 1 +#else +#define TCK 0 +#endif + + +extern void system_clock_4 (GFC_INTEGER_4 *, GFC_INTEGER_4 *, GFC_INTEGER_4 *); +export_proto(system_clock_4); + +extern void system_clock_8 (GFC_INTEGER_8 *, GFC_INTEGER_8 *, GFC_INTEGER_8 *); +export_proto(system_clock_8); + + +/* prefix(system_clock_4) is the INTEGER(4) version of the SYSTEM_CLOCK + intrinsic subroutine. It returns the number of clock ticks for the current + system time, the number of ticks per second, and the maximum possible value + for COUNT. On the first call to SYSTEM_CLOCK, COUNT is set to zero. */ + +void +system_clock_4(GFC_INTEGER_4 *count, GFC_INTEGER_4 *count_rate, + GFC_INTEGER_4 *count_max) +{ + GFC_INTEGER_4 cnt; + GFC_INTEGER_4 mx; + +#if defined(HAVE_SYS_TIME_H) && defined(HAVE_GETTIMEOFDAY) + struct timeval tp1; + struct timezone tzp; + + if (sizeof (tp1.tv_sec) < sizeof (GFC_INTEGER_4)) + internal_error (NULL, "tv_sec too small"); + + if (gettimeofday(&tp1, &tzp) == 0) + { + GFC_UINTEGER_4 ucnt = (GFC_UINTEGER_4) tp1.tv_sec * TCK; + ucnt += (tp1.tv_usec + 500000 / TCK) / (1000000 / TCK); + if (ucnt > GFC_INTEGER_4_HUGE) + cnt = ucnt - GFC_INTEGER_4_HUGE - 1; + else + cnt = ucnt; + mx = GFC_INTEGER_4_HUGE; + } + else + { + if (count != NULL) + *count = - GFC_INTEGER_4_HUGE; + if (count_rate != NULL) + *count_rate = 0; + if (count_max != NULL) + *count_max = 0; + return; + } +#elif defined(HAVE_TIME_H) + GFC_UINTEGER_4 ucnt; + + if (sizeof (time_t) < sizeof (GFC_INTEGER_4)) + internal_error (NULL, "time_t too small"); + + ucnt = time (NULL); + if (ucnt > GFC_INTEGER_4_HUGE) + cnt = ucnt - GFC_INTEGER_4_HUGE - 1; + else + cnt = ucnt; + mx = GFC_INTEGER_4_HUGE; +#else + cnt = - GFC_INTEGER_4_HUGE; + mx = 0; +#endif + if (count != NULL) + *count = cnt; + if (count_rate != NULL) + *count_rate = TCK; + if (count_max != NULL) + *count_max = mx; +} + + +/* INTEGER(8) version of the above routine. */ + +void +system_clock_8 (GFC_INTEGER_8 *count, GFC_INTEGER_8 *count_rate, + GFC_INTEGER_8 *count_max) +{ + GFC_INTEGER_8 cnt; + GFC_INTEGER_8 mx; + +#if defined(HAVE_SYS_TIME_H) && defined(HAVE_GETTIMEOFDAY) + struct timeval tp1; + struct timezone tzp; + + if (sizeof (tp1.tv_sec) < sizeof (GFC_INTEGER_4)) + internal_error (NULL, "tv_sec too small"); + + if (gettimeofday(&tp1, &tzp) == 0) + { + if (sizeof (tp1.tv_sec) < sizeof (GFC_INTEGER_8)) + { + GFC_UINTEGER_4 ucnt = (GFC_UINTEGER_4) tp1.tv_sec * TCK; + ucnt += (tp1.tv_usec + 500000 / TCK) / (1000000 / TCK); + if (ucnt > GFC_INTEGER_4_HUGE) + cnt = ucnt - GFC_INTEGER_4_HUGE - 1; + else + cnt = ucnt; + mx = GFC_INTEGER_4_HUGE; + } + else + { + GFC_UINTEGER_8 ucnt = (GFC_UINTEGER_8) tp1.tv_sec * TCK; + ucnt += (tp1.tv_usec + 500000 / TCK) / (1000000 / TCK); + if (ucnt > GFC_INTEGER_8_HUGE) + cnt = ucnt - GFC_INTEGER_8_HUGE - 1; + else + cnt = ucnt; + mx = GFC_INTEGER_8_HUGE; + } + } + else + { + if (count != NULL) + *count = - GFC_INTEGER_8_HUGE; + if (count_rate != NULL) + *count_rate = 0; + if (count_max != NULL) + *count_max = 0; + + return; + } +#elif defined(HAVE_TIME_H) + if (sizeof (time_t) < sizeof (GFC_INTEGER_4)) + internal_error (NULL, "time_t too small"); + else if (sizeof (time_t) == sizeof (GFC_INTEGER_4)) + { + GFC_UINTEGER_4 ucnt = time (NULL); + if (ucnt > GFC_INTEGER_4_HUGE) + cnt = ucnt - GFC_INTEGER_4_HUGE - 1; + else + cnt = ucnt; + mx = GFC_INTEGER_4_HUGE; + } + else + { + GFC_UINTEGER_8 ucnt = time (NULL); + if (ucnt > GFC_INTEGER_8_HUGE) + cnt = ucnt - GFC_INTEGER_8_HUGE - 1; + else + cnt = ucnt; + mx = GFC_INTEGER_8_HUGE; + } +#else + cnt = - GFC_INTEGER_8_HUGE; + mx = 0; +#endif + if (count != NULL) + *count = cnt; + if (count_rate != NULL) + *count_rate = TCK; + if (count_max != NULL) + *count_max = mx; +} diff --git a/gcc-4.4.0/libgfortran/intrinsics/time.c b/gcc-4.4.0/libgfortran/intrinsics/time.c new file mode 100644 index 000000000..d046e87ec --- /dev/null +++ b/gcc-4.4.0/libgfortran/intrinsics/time.c @@ -0,0 +1,64 @@ +/* Implementation of the TIME and TIME8 g77 intrinsics. + Copyright (C) 2005, 2007, 2009 Free Software Foundation, Inc. + Contributed by François-Xavier Coudert <coudert@clipper.ens.fr> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran 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 3 of the License, or (at your option) any later version. + +Libgfortran 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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. */ + +#include "libgfortran.h" + +#ifdef TIME_WITH_SYS_TIME +# include <sys/time.h> +# include <time.h> +#else +# if HAVE_SYS_TIME_H +# include <sys/time.h> +# else +# ifdef HAVE_TIME_H +# include <time.h> +# endif +# endif +#endif + + +/* INTEGER(KIND=4) FUNCTION TIME() */ + +#ifdef HAVE_TIME +extern GFC_INTEGER_4 time_func (void); +export_proto(time_func); + +GFC_INTEGER_4 +time_func (void) +{ + return (GFC_INTEGER_4) time (NULL); +} + +/* INTEGER(KIND=8) FUNCTION TIME8() */ + +extern GFC_INTEGER_8 time8_func (void); +export_proto(time8_func); + +GFC_INTEGER_8 +time8_func (void) +{ + return (GFC_INTEGER_8) time (NULL); +} +#endif diff --git a/gcc-4.4.0/libgfortran/intrinsics/time_1.h b/gcc-4.4.0/libgfortran/intrinsics/time_1.h new file mode 100644 index 000000000..a93b7e020 --- /dev/null +++ b/gcc-4.4.0/libgfortran/intrinsics/time_1.h @@ -0,0 +1,136 @@ +/* Implementation of the CPU_TIME intrinsic. + Copyright (C) 2003, 2007, 2009 Free Software Foundation, Inc. + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran 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 3 of the License, or (at your option) any later version. + +Libgfortran 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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. */ + +#ifndef LIBGFORTRAN_TIME_H +#define LIBGFORTRAN_TIME_H + +#ifdef HAVE_UNISTD_H +#include <unistd.h> +#endif + +/* The time related intrinsics (DTIME, ETIME, CPU_TIME) to "compare + different algorithms on the same computer or discover which parts + are the most expensive", need a way to get the CPU time with the + finest resolution possible. We can only be accurate up to + microseconds. + + As usual with UNIX systems, unfortunately no single way is + available for all systems. */ + +#ifdef TIME_WITH_SYS_TIME +# include <sys/time.h> +# include <time.h> +#else +# if HAVE_SYS_TIME_H +# include <sys/time.h> +# else +# ifdef HAVE_TIME_H +# include <time.h> +# endif +# endif +#endif + +/* The most accurate way to get the CPU time is getrusage (). */ +#if defined (HAVE_GETRUSAGE) && defined (HAVE_SYS_RESOURCE_H) +# include <sys/resource.h> +#endif /* HAVE_GETRUSAGE && HAVE_SYS_RESOURCE_H */ + +#if defined (__GNUC__) && (__GNUC__ >= 3) +# define ATTRIBUTE_ALWAYS_INLINE __attribute__ ((__always_inline__)) +#else +# define ATTRIBUTE_ALWAYS_INLINE +#endif + +static inline int __time_1 (long *, long *, long *, long *) ATTRIBUTE_ALWAYS_INLINE; + +/* Helper function for the actual implementation of the DTIME, ETIME and + CPU_TIME intrinsics. Returns a CPU time in microseconds or -1 if no + CPU time could be computed. */ + +#ifdef __MINGW32__ + +#define WIN32_LEAN_AND_MEAN +#include <windows.h> + +static int +__time_1 (long *user_sec, long *user_usec, long *system_sec, long *system_usec) +{ + union { + FILETIME ft; + unsigned long long ulltime; + } kernel_time, user_time; + + FILETIME unused1, unused2; + + /* No support for Win9x. The high order bit of the DWORD + returned by GetVersion is 0 for NT and higher. */ + if (GetVersion () >= 0x80000000) + { + *user_sec = *system_sec = 0; + *user_usec = *system_usec = 0; + return -1; + } + + /* The FILETIME structs filled in by GetProcessTimes represent + time in 100 nanosecond units. */ + GetProcessTimes (GetCurrentProcess (), &unused1, &unused2, + &kernel_time.ft, &user_time.ft); + + *user_sec = user_time.ulltime / 10000000; + *user_usec = (user_time.ulltime % 10000000) / 10; + + *system_sec = kernel_time.ulltime / 10000000; + *system_usec = (kernel_time.ulltime % 10000000) / 10; + return 0; +} + +#else + +static inline int +__time_1 (long *user_sec, long *user_usec, long *system_sec, long *system_usec) +{ +#if defined (HAVE_GETRUSAGE) && defined (HAVE_SYS_RESOURCE_H) + struct rusage usage; + getrusage (0, &usage); + + *user_sec = usage.ru_utime.tv_sec; + *user_usec = usage.ru_utime.tv_usec; + *system_sec = usage.ru_stime.tv_sec; + *system_usec = usage.ru_stime.tv_usec; + return 0; + +#else /* ! HAVE_GETRUSAGE || ! HAVE_SYS_RESOURCE_H */ + + /* We have nothing to go on. Return -1. */ + *user_sec = *system_sec = 0; + *user_usec = *system_usec = 0; + return -1; + +#endif +} + +#endif + + +#endif /* LIBGFORTRAN_TIME_H */ diff --git a/gcc-4.4.0/libgfortran/intrinsics/transpose_generic.c b/gcc-4.4.0/libgfortran/intrinsics/transpose_generic.c new file mode 100644 index 000000000..25856192a --- /dev/null +++ b/gcc-4.4.0/libgfortran/intrinsics/transpose_generic.c @@ -0,0 +1,149 @@ +/* Implementation of the TRANSPOSE intrinsic + Copyright 2003, 2006, 2007, 2009 Free Software Foundation, Inc. + Contributed by Tobias Schlüter + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran 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 3 of the License, or (at your option) any later version. + +Libgfortran 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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. */ + +#include "libgfortran.h" +#include <stdlib.h> +#include <string.h> +#include <assert.h> + +extern void transpose (gfc_array_char *, gfc_array_char *); +export_proto(transpose); + +static void +transpose_internal (gfc_array_char *ret, gfc_array_char *source, + index_type size) +{ + /* r.* indicates the return array. */ + index_type rxstride, rystride; + char *rptr; + /* s.* indicates the source array. */ + index_type sxstride, systride; + const char *sptr; + + index_type xcount, ycount; + index_type x, y; + + assert (GFC_DESCRIPTOR_RANK (source) == 2 + && GFC_DESCRIPTOR_RANK (ret) == 2); + + if (ret->data == NULL) + { + assert (ret->dtype == source->dtype); + + ret->dim[0].lbound = 0; + ret->dim[0].ubound = source->dim[1].ubound - source->dim[1].lbound; + ret->dim[0].stride = 1; + + ret->dim[1].lbound = 0; + ret->dim[1].ubound = source->dim[0].ubound - source->dim[0].lbound; + ret->dim[1].stride = ret->dim[0].ubound+1; + + ret->data = internal_malloc_size (size * size0 ((array_t*)ret)); + ret->offset = 0; + } + else if (unlikely (compile_options.bounds_check)) + { + index_type ret_extent, src_extent; + + ret_extent = ret->dim[0].ubound + 1 - ret->dim[0].lbound; + src_extent = source->dim[1].ubound + 1 - source->dim[1].lbound; + + if (src_extent != ret_extent) + runtime_error ("Incorrect extent in return value of TRANSPOSE" + " intrinsic in dimension 1: is %ld," + " should be %ld", (long int) src_extent, + (long int) ret_extent); + + ret_extent = ret->dim[1].ubound + 1 - ret->dim[1].lbound; + src_extent = source->dim[0].ubound + 1 - source->dim[0].lbound; + + if (src_extent != ret_extent) + runtime_error ("Incorrect extent in return value of TRANSPOSE" + " intrinsic in dimension 2: is %ld," + " should be %ld", (long int) src_extent, + (long int) ret_extent); + + } + + sxstride = source->dim[0].stride * size; + systride = source->dim[1].stride * size; + xcount = source->dim[0].ubound + 1 - source->dim[0].lbound; + ycount = source->dim[1].ubound + 1 - source->dim[1].lbound; + + rxstride = ret->dim[0].stride * size; + rystride = ret->dim[1].stride * size; + + rptr = ret->data; + sptr = source->data; + + for (y = 0; y < ycount; y++) + { + for (x = 0; x < xcount; x++) + { + memcpy (rptr, sptr, size); + + sptr += sxstride; + rptr += rystride; + } + sptr += systride - (sxstride * xcount); + rptr += rxstride - (rystride * xcount); + } +} + + +extern void transpose (gfc_array_char *, gfc_array_char *); +export_proto(transpose); + +void +transpose (gfc_array_char *ret, gfc_array_char *source) +{ + transpose_internal (ret, source, GFC_DESCRIPTOR_SIZE (source)); +} + + +extern void transpose_char (gfc_array_char *, GFC_INTEGER_4, + gfc_array_char *, GFC_INTEGER_4); +export_proto(transpose_char); + +void +transpose_char (gfc_array_char *ret, + GFC_INTEGER_4 ret_length __attribute__((unused)), + gfc_array_char *source, GFC_INTEGER_4 source_length) +{ + transpose_internal (ret, source, source_length); +} + + +extern void transpose_char4 (gfc_array_char *, GFC_INTEGER_4, + gfc_array_char *, GFC_INTEGER_4); +export_proto(transpose_char4); + +void +transpose_char4 (gfc_array_char *ret, + GFC_INTEGER_4 ret_length __attribute__((unused)), + gfc_array_char *source, GFC_INTEGER_4 source_length) +{ + transpose_internal (ret, source, source_length * sizeof (gfc_char4_t)); +} diff --git a/gcc-4.4.0/libgfortran/intrinsics/umask.c b/gcc-4.4.0/libgfortran/intrinsics/umask.c new file mode 100644 index 000000000..9df684bfc --- /dev/null +++ b/gcc-4.4.0/libgfortran/intrinsics/umask.c @@ -0,0 +1,93 @@ +/* Implementation of the UMASK intrinsic. + Copyright (C) 2004, 2007, 2009 Free Software Foundation, Inc. + Contributed by Steven G. Kargl <kargls@comcast.net>. + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran 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 3 of the License, or (at your option) any later version. + +Libgfortran 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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. */ + + +#include "libgfortran.h" + +#ifdef HAVE_STDLIB_H +#include <stdlib.h> +#endif + +#ifdef HAVE_SYS_STAT_H +#include <sys/stat.h> +#endif + +#ifdef HAVE_UNISTD_H +#include <unistd.h> +#endif + + +/* SUBROUTINE UMASK(MASK, OLD) + INTEGER, INTENT(IN) :: MASK + INTEGER, INTENT(OUT), OPTIONAL :: OLD */ + +extern void umask_i4_sub (GFC_INTEGER_4 *, GFC_INTEGER_4 *); +iexport_proto(umask_i4_sub); + +void +umask_i4_sub (GFC_INTEGER_4 *mask, GFC_INTEGER_4 *old) +{ + mode_t val = umask((mode_t) *mask); + if (old != NULL) + *old = (GFC_INTEGER_4) val; +} +iexport(umask_i4_sub); + +extern void umask_i8_sub (GFC_INTEGER_8 *, GFC_INTEGER_8 *); +iexport_proto(umask_i8_sub); + +void +umask_i8_sub (GFC_INTEGER_8 *mask, GFC_INTEGER_8 *old) +{ + mode_t val = umask((mode_t) *mask); + if (old != NULL) + *old = (GFC_INTEGER_8) val; +} +iexport(umask_i8_sub); + +/* INTEGER FUNCTION UMASK(MASK) + INTEGER, INTENT(IN) :: MASK */ + +extern GFC_INTEGER_4 umask_i4 (GFC_INTEGER_4 *); +export_proto(umask_i4); + +GFC_INTEGER_4 +umask_i4 (GFC_INTEGER_4 *mask) +{ + GFC_INTEGER_4 old; + umask_i4_sub (mask, &old); + return old; +} + +extern GFC_INTEGER_8 umask_i8 (GFC_INTEGER_8 *); +export_proto(umask_i8); + +GFC_INTEGER_8 +umask_i8 (GFC_INTEGER_8 *mask) +{ + GFC_INTEGER_8 old; + umask_i8_sub (mask, &old); + return old; +} diff --git a/gcc-4.4.0/libgfortran/intrinsics/unlink.c b/gcc-4.4.0/libgfortran/intrinsics/unlink.c new file mode 100644 index 000000000..7b17dfe3f --- /dev/null +++ b/gcc-4.4.0/libgfortran/intrinsics/unlink.c @@ -0,0 +1,91 @@ +/* Implementation of the UNLINK intrinsic. + Copyright (C) 2004, 2005, 2007, 2009 Free Software Foundation, Inc. + Contributed by Steven G. Kargl <kargls@comcast.net>. + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran 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 3 of the License, or (at your option) any later version. + +Libgfortran 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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. */ + +#include "libgfortran.h" + +#include <string.h> +#include <errno.h> + +#ifdef HAVE_UNISTD_H +#include <unistd.h> +#endif + +/* SUBROUTINE UNLINK(NAME, STATUS) + CHARACTER(LEN= ), INTENT(IN) :: NAME + INTEGER, INTENT(OUT), OPTIONAL :: STATUS) */ + +extern void unlink_i4_sub (char *name, GFC_INTEGER_4 *status, + gfc_charlen_type name_len); +iexport_proto(unlink_i4_sub); + +void +unlink_i4_sub (char *name, GFC_INTEGER_4 *status, gfc_charlen_type name_len) +{ + char *str; + GFC_INTEGER_4 stat; + + /* Trim trailing spaces from name. */ + while (name_len > 0 && name[name_len - 1] == ' ') + name_len--; + + /* Make a null terminated copy of the string. */ + str = gfc_alloca (name_len + 1); + memcpy (str, name, name_len); + str[name_len] = '\0'; + + stat = unlink (str); + + if (status != NULL) + *status = (stat == 0) ? stat : errno; +} +iexport(unlink_i4_sub); + +extern void unlink_i8_sub (char *name, GFC_INTEGER_8 *status, + gfc_charlen_type name_len); +export_proto(unlink_i8_sub); + +void +unlink_i8_sub (char *name, GFC_INTEGER_8 *status, gfc_charlen_type name_len) +{ + GFC_INTEGER_4 status4; + unlink_i4_sub (name, &status4, name_len); + if (status) + *status = status4; +} + + +/* INTEGER FUNCTION UNLINK(NAME) + CHARACTER(LEN= ), INTENT(IN) :: NAME */ + +extern GFC_INTEGER_4 PREFIX(unlink) (char *, gfc_charlen_type); +export_proto_np(PREFIX(unlink)); + +GFC_INTEGER_4 +PREFIX(unlink) (char *name, gfc_charlen_type name_len) +{ + GFC_INTEGER_4 status; + unlink_i4_sub (name, &status, name_len); + return status; +} diff --git a/gcc-4.4.0/libgfortran/intrinsics/unpack_generic.c b/gcc-4.4.0/libgfortran/intrinsics/unpack_generic.c new file mode 100644 index 000000000..a27e37c72 --- /dev/null +++ b/gcc-4.4.0/libgfortran/intrinsics/unpack_generic.c @@ -0,0 +1,560 @@ +/* Generic implementation of the UNPACK intrinsic + Copyright 2002, 2003, 2004, 2005, 2007, 2009 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran 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 3 of the License, or (at your option) any later version. + +Ligbfortran 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. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. */ + +#include "libgfortran.h" +#include <stdlib.h> +#include <assert.h> +#include <string.h> + +static void +unpack_internal (gfc_array_char *ret, const gfc_array_char *vector, + const gfc_array_l1 *mask, const gfc_array_char *field, + index_type size, index_type fsize) +{ + /* r.* indicates the return array. */ + index_type rstride[GFC_MAX_DIMENSIONS]; + index_type rstride0; + index_type rs; + char * restrict rptr; + /* v.* indicates the vector array. */ + index_type vstride0; + char *vptr; + /* f.* indicates the field array. */ + index_type fstride[GFC_MAX_DIMENSIONS]; + index_type fstride0; + const char *fptr; + /* m.* indicates the mask array. */ + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type mstride0; + const GFC_LOGICAL_1 *mptr; + + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type n; + index_type dim; + + int empty; + int mask_kind; + + empty = 0; + + mptr = mask->data; + + /* Use the same loop for all logical types, by using GFC_LOGICAL_1 + and using shifting to address size and endian issues. */ + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + { + /* Don't convert a NULL pointer as we use test for NULL below. */ + if (mptr) + mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind); + } + else + runtime_error ("Funny sized logical array"); + + if (ret->data == NULL) + { + /* The front end has signalled that we need to populate the + return array descriptor. */ + dim = GFC_DESCRIPTOR_RANK (mask); + rs = 1; + for (n = 0; n < dim; n++) + { + count[n] = 0; + ret->dim[n].stride = rs; + ret->dim[n].lbound = 0; + ret->dim[n].ubound = mask->dim[n].ubound - mask->dim[n].lbound; + extent[n] = ret->dim[n].ubound + 1; + empty = empty || extent[n] <= 0; + rstride[n] = ret->dim[n].stride * size; + fstride[n] = field->dim[n].stride * fsize; + mstride[n] = mask->dim[n].stride * mask_kind; + rs *= extent[n]; + } + ret->offset = 0; + ret->data = internal_malloc_size (rs * size); + } + else + { + dim = GFC_DESCRIPTOR_RANK (ret); + for (n = 0; n < dim; n++) + { + count[n] = 0; + extent[n] = ret->dim[n].ubound + 1 - ret->dim[n].lbound; + empty = empty || extent[n] <= 0; + rstride[n] = ret->dim[n].stride * size; + fstride[n] = field->dim[n].stride * fsize; + mstride[n] = mask->dim[n].stride * mask_kind; + } + if (rstride[0] == 0) + rstride[0] = size; + } + + if (empty) + return; + + if (fstride[0] == 0) + fstride[0] = fsize; + if (mstride[0] == 0) + mstride[0] = 1; + + vstride0 = vector->dim[0].stride * size; + if (vstride0 == 0) + vstride0 = size; + rstride0 = rstride[0]; + fstride0 = fstride[0]; + mstride0 = mstride[0]; + rptr = ret->data; + fptr = field->data; + vptr = vector->data; + + while (rptr) + { + if (*mptr) + { + /* From vector. */ + memcpy (rptr, vptr, size); + vptr += vstride0; + } + else + { + /* From field. */ + memcpy (rptr, fptr, size); + } + /* Advance to the next element. */ + rptr += rstride0; + fptr += fstride0; + mptr += mstride0; + count[0]++; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + rptr -= rstride[n] * extent[n]; + fptr -= fstride[n] * extent[n]; + mptr -= mstride[n] * extent[n]; + n++; + if (n >= dim) + { + /* Break out of the loop. */ + rptr = NULL; + break; + } + else + { + count[n]++; + rptr += rstride[n]; + fptr += fstride[n]; + mptr += mstride[n]; + } + } + } +} + +extern void unpack1 (gfc_array_char *, const gfc_array_char *, + const gfc_array_l1 *, const gfc_array_char *); +export_proto(unpack1); + +void +unpack1 (gfc_array_char *ret, const gfc_array_char *vector, + const gfc_array_l1 *mask, const gfc_array_char *field) +{ + index_type type_size; + index_type size; + + type_size = GFC_DTYPE_TYPE_SIZE (vector); + size = GFC_DESCRIPTOR_SIZE (vector); + + switch(type_size) + { + case GFC_DTYPE_LOGICAL_1: + case GFC_DTYPE_INTEGER_1: + case GFC_DTYPE_DERIVED_1: + unpack1_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) vector, + mask, (gfc_array_i1 *) field); + return; + + case GFC_DTYPE_LOGICAL_2: + case GFC_DTYPE_INTEGER_2: + unpack1_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) vector, + mask, (gfc_array_i2 *) field); + return; + + case GFC_DTYPE_LOGICAL_4: + case GFC_DTYPE_INTEGER_4: + unpack1_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) vector, + mask, (gfc_array_i4 *) field); + return; + + case GFC_DTYPE_LOGICAL_8: + case GFC_DTYPE_INTEGER_8: + unpack1_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) vector, + mask, (gfc_array_i8 *) field); + return; + +#ifdef HAVE_GFC_INTEGER_16 + case GFC_DTYPE_LOGICAL_16: + case GFC_DTYPE_INTEGER_16: + unpack1_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) vector, + mask, (gfc_array_i16 *) field); + return; +#endif + case GFC_DTYPE_REAL_4: + unpack1_r4 ((gfc_array_r4 *) ret, (gfc_array_r4 *) vector, + mask, (gfc_array_r4 *) field); + return; + + case GFC_DTYPE_REAL_8: + unpack1_r8 ((gfc_array_r8 *) ret, (gfc_array_r8 *) vector, + mask, (gfc_array_r8 *) field); + return; + +#ifdef HAVE_GFC_REAL_10 + case GFC_DTYPE_REAL_10: + unpack1_r10 ((gfc_array_r10 *) ret, (gfc_array_r10 *) vector, + mask, (gfc_array_r10 *) field); + return; +#endif + +#ifdef HAVE_GFC_REAL_16 + case GFC_DTYPE_REAL_16: + unpack1_r16 ((gfc_array_r16 *) ret, (gfc_array_r16 *) vector, + mask, (gfc_array_r16 *) field); + return; +#endif + + case GFC_DTYPE_COMPLEX_4: + unpack1_c4 ((gfc_array_c4 *) ret, (gfc_array_c4 *) vector, + mask, (gfc_array_c4 *) field); + return; + + case GFC_DTYPE_COMPLEX_8: + unpack1_c8 ((gfc_array_c8 *) ret, (gfc_array_c8 *) vector, + mask, (gfc_array_c8 *) field); + return; + +#ifdef HAVE_GFC_COMPLEX_10 + case GFC_DTYPE_COMPLEX_10: + unpack1_c10 ((gfc_array_c10 *) ret, (gfc_array_c10 *) vector, + mask, (gfc_array_c10 *) field); + return; +#endif + +#ifdef HAVE_GFC_COMPLEX_16 + case GFC_DTYPE_COMPLEX_16: + unpack1_c16 ((gfc_array_c16 *) ret, (gfc_array_c16 *) vector, + mask, (gfc_array_c16 *) field); + return; +#endif + + case GFC_DTYPE_DERIVED_2: + if (GFC_UNALIGNED_2(ret->data) || GFC_UNALIGNED_2(vector->data) + || GFC_UNALIGNED_2(field->data)) + break; + else + { + unpack1_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) vector, + mask, (gfc_array_i2 *) field); + return; + } + + case GFC_DTYPE_DERIVED_4: + if (GFC_UNALIGNED_4(ret->data) || GFC_UNALIGNED_4(vector->data) + || GFC_UNALIGNED_4(field->data)) + break; + else + { + unpack1_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) vector, + mask, (gfc_array_i4 *) field); + return; + } + + case GFC_DTYPE_DERIVED_8: + if (GFC_UNALIGNED_8(ret->data) || GFC_UNALIGNED_8(vector->data) + || GFC_UNALIGNED_8(field->data)) + break; + else + { + unpack1_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) vector, + mask, (gfc_array_i8 *) field); + return; + } + +#ifdef HAVE_GFC_INTEGER_16 + case GFC_DTYPE_DERIVED_16: + if (GFC_UNALIGNED_16(ret->data) || GFC_UNALIGNED_16(vector->data) + || GFC_UNALIGNED_16(field->data)) + break; + else + { + unpack1_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) vector, + mask, (gfc_array_i16 *) field); + return; + } +#endif + } + + unpack_internal (ret, vector, mask, field, size, + GFC_DESCRIPTOR_SIZE (field)); +} + + +extern void unpack1_char (gfc_array_char *, GFC_INTEGER_4, + const gfc_array_char *, const gfc_array_l1 *, + const gfc_array_char *, GFC_INTEGER_4, + GFC_INTEGER_4); +export_proto(unpack1_char); + +void +unpack1_char (gfc_array_char *ret, + GFC_INTEGER_4 ret_length __attribute__((unused)), + const gfc_array_char *vector, const gfc_array_l1 *mask, + const gfc_array_char *field, GFC_INTEGER_4 vector_length, + GFC_INTEGER_4 field_length) +{ + unpack_internal (ret, vector, mask, field, vector_length, field_length); +} + + +extern void unpack1_char4 (gfc_array_char *, GFC_INTEGER_4, + const gfc_array_char *, const gfc_array_l1 *, + const gfc_array_char *, GFC_INTEGER_4, + GFC_INTEGER_4); +export_proto(unpack1_char4); + +void +unpack1_char4 (gfc_array_char *ret, + GFC_INTEGER_4 ret_length __attribute__((unused)), + const gfc_array_char *vector, const gfc_array_l1 *mask, + const gfc_array_char *field, GFC_INTEGER_4 vector_length, + GFC_INTEGER_4 field_length) +{ + unpack_internal (ret, vector, mask, field, + vector_length * sizeof (gfc_char4_t), + field_length * sizeof (gfc_char4_t)); +} + + +extern void unpack0 (gfc_array_char *, const gfc_array_char *, + const gfc_array_l1 *, char *); +export_proto(unpack0); + +void +unpack0 (gfc_array_char *ret, const gfc_array_char *vector, + const gfc_array_l1 *mask, char *field) +{ + gfc_array_char tmp; + + index_type type_size; + index_type size; + + type_size = GFC_DTYPE_TYPE_SIZE (vector); + size = GFC_DESCRIPTOR_SIZE (vector); + + switch(type_size) + { + case GFC_DTYPE_LOGICAL_1: + case GFC_DTYPE_INTEGER_1: + case GFC_DTYPE_DERIVED_1: + unpack0_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) vector, + mask, (GFC_INTEGER_1 *) field); + return; + + case GFC_DTYPE_LOGICAL_2: + case GFC_DTYPE_INTEGER_2: + unpack0_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) vector, + mask, (GFC_INTEGER_2 *) field); + return; + + case GFC_DTYPE_LOGICAL_4: + case GFC_DTYPE_INTEGER_4: + unpack0_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) vector, + mask, (GFC_INTEGER_4 *) field); + return; + + case GFC_DTYPE_LOGICAL_8: + case GFC_DTYPE_INTEGER_8: + unpack0_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) vector, + mask, (GFC_INTEGER_8 *) field); + return; + +#ifdef HAVE_GFC_INTEGER_16 + case GFC_DTYPE_LOGICAL_16: + case GFC_DTYPE_INTEGER_16: + unpack0_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) vector, + mask, (GFC_INTEGER_16 *) field); + return; +#endif + case GFC_DTYPE_REAL_4: + unpack0_r4 ((gfc_array_r4 *) ret, (gfc_array_r4 *) vector, + mask, (GFC_REAL_4 *) field); + return; + + case GFC_DTYPE_REAL_8: + unpack0_r8 ((gfc_array_r8 *) ret, (gfc_array_r8*) vector, + mask, (GFC_REAL_8 *) field); + return; + +#ifdef HAVE_GFC_REAL_10 + case GFC_DTYPE_REAL_10: + unpack0_r10 ((gfc_array_r10 *) ret, (gfc_array_r10 *) vector, + mask, (GFC_REAL_10 *) field); + return; +#endif + +#ifdef HAVE_GFC_REAL_16 + case GFC_DTYPE_REAL_16: + unpack0_r16 ((gfc_array_r16 *) ret, (gfc_array_r16 *) vector, + mask, (GFC_REAL_16 *) field); + return; +#endif + + case GFC_DTYPE_COMPLEX_4: + unpack0_c4 ((gfc_array_c4 *) ret, (gfc_array_c4 *) vector, + mask, (GFC_COMPLEX_4 *) field); + return; + + case GFC_DTYPE_COMPLEX_8: + unpack0_c8 ((gfc_array_c8 *) ret, (gfc_array_c8 *) vector, + mask, (GFC_COMPLEX_8 *) field); + return; + +#ifdef HAVE_GFC_COMPLEX_10 + case GFC_DTYPE_COMPLEX_10: + unpack0_c10 ((gfc_array_c10 *) ret, (gfc_array_c10 *) vector, + mask, (GFC_COMPLEX_10 *) field); + return; +#endif + +#ifdef HAVE_GFC_COMPLEX_16 + case GFC_DTYPE_COMPLEX_16: + unpack0_c16 ((gfc_array_c16 *) ret, (gfc_array_c16 *) vector, + mask, (GFC_COMPLEX_16 *) field); + return; +#endif + case GFC_DTYPE_DERIVED_2: + if (GFC_UNALIGNED_2(ret->data) || GFC_UNALIGNED_2(vector->data) + || GFC_UNALIGNED_2(field)) + break; + else + { + unpack0_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) vector, + mask, (GFC_INTEGER_2 *) field); + return; + } + + case GFC_DTYPE_DERIVED_4: + if (GFC_UNALIGNED_4(ret->data) || GFC_UNALIGNED_4(vector->data) + || GFC_UNALIGNED_4(field)) + break; + else + { + unpack0_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) vector, + mask, (GFC_INTEGER_4 *) field); + return; + } + + case GFC_DTYPE_DERIVED_8: + if (GFC_UNALIGNED_8(ret->data) || GFC_UNALIGNED_8(vector->data) + || GFC_UNALIGNED_8(field)) + break; + else + { + unpack0_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) vector, + mask, (GFC_INTEGER_8 *) field); + return; + } +#ifdef HAVE_GFC_INTEGER_16 + case GFC_DTYPE_DERIVED_16: + if (GFC_UNALIGNED_16(ret->data) || GFC_UNALIGNED_16(vector->data) + || GFC_UNALIGNED_16(field)) + break; + else + { + unpack0_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) vector, + mask, (GFC_INTEGER_16 *) field); + return; + } +#endif + } + + memset (&tmp, 0, sizeof (tmp)); + tmp.dtype = 0; + tmp.data = field; + unpack_internal (ret, vector, mask, &tmp, GFC_DESCRIPTOR_SIZE (vector), 0); +} + + +extern void unpack0_char (gfc_array_char *, GFC_INTEGER_4, + const gfc_array_char *, const gfc_array_l1 *, + char *, GFC_INTEGER_4, GFC_INTEGER_4); +export_proto(unpack0_char); + +void +unpack0_char (gfc_array_char *ret, + GFC_INTEGER_4 ret_length __attribute__((unused)), + const gfc_array_char *vector, const gfc_array_l1 *mask, + char *field, GFC_INTEGER_4 vector_length, + GFC_INTEGER_4 field_length __attribute__((unused))) +{ + gfc_array_char tmp; + + memset (&tmp, 0, sizeof (tmp)); + tmp.dtype = 0; + tmp.data = field; + unpack_internal (ret, vector, mask, &tmp, vector_length, 0); +} + + +extern void unpack0_char4 (gfc_array_char *, GFC_INTEGER_4, + const gfc_array_char *, const gfc_array_l1 *, + char *, GFC_INTEGER_4, GFC_INTEGER_4); +export_proto(unpack0_char4); + +void +unpack0_char4 (gfc_array_char *ret, + GFC_INTEGER_4 ret_length __attribute__((unused)), + const gfc_array_char *vector, const gfc_array_l1 *mask, + char *field, GFC_INTEGER_4 vector_length, + GFC_INTEGER_4 field_length __attribute__((unused))) +{ + gfc_array_char tmp; + + memset (&tmp, 0, sizeof (tmp)); + tmp.dtype = 0; + tmp.data = field; + unpack_internal (ret, vector, mask, &tmp, + vector_length * sizeof (gfc_char4_t), 0); +} |