OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

Compare Revisions

  • This comparison shows the changes necessary to convert path 
    /openrisc/tags/gnu-dev/fsf-gcc-snapshot-1-mar-12/or1k-gcc/libgfortran/intrinsics
    from Rev 733 to Rev 783
    ↔ Reverse comparison
  •

Rev 733 → Rev 783

/extends_type_of.c
0,0 → 1,58
/* Implementation of the EXTENDS_TYPE_OF intrinsic.
Copyright (C) 2004, 2007, 2009, 2011 Free Software Foundation, Inc.
Contributed by Janus Weil <janus@gcc.gnu.org>.
 
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"
#include <stdlib.h>
 
 
typedef struct vtype
{
GFC_INTEGER_4 hash;
GFC_INTEGER_4 size;
struct vtype *extends;
}
vtype;
 
 
extern GFC_LOGICAL_4 is_extension_of (struct vtype *, struct vtype *);
export_proto(is_extension_of);
 
 
/* This is a helper function for the F2003 intrinsic EXTENDS_TYPE_OF.
While EXTENDS_TYPE_OF accepts CLASS or TYPE arguments, this one here gets
passed the corresponding vtabs. Each call to EXTENDS_TYPE_OF is translated
to a call to is_extension_of. */
 
GFC_LOGICAL_4
is_extension_of (struct vtype *v1, struct vtype *v2)
{
while (v1)
{
if (v1->hash == v2->hash) return 1;
v1 = v1->extends;
}
return 0;
}
/dtime.c
0,0 → 1,87
/* Implementation of the dtime intrinsic.
Copyright (C) 2004, 2005, 2006, 2007, 2009, 2011 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"
#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)
{
GFC_REAL_4 *tp;
long user_sec, user_usec, system_sec, system_usec;
static long us = 0, uu = 0, ss = 0 , su = 0;
GFC_REAL_4 tu, ts, tt;
 
if (((GFC_DESCRIPTOR_EXTENT(t,0))) < 2)
runtime_error ("Insufficient number of elements in TARRAY.");
 
__gthread_mutex_lock (&dtime_update_lock);
if (gf_cputime (&user_sec, &user_usec, &system_sec, &system_usec) == 0)
{
tu = (GFC_REAL_4) ((user_sec - us) + 1.e-6 * (user_usec - uu));
ts = (GFC_REAL_4) ((system_sec - ss) + 1.e-6 * (system_usec - su));
tt = tu + ts;
us = user_sec;
uu = user_usec;
ss = system_sec;
su = system_usec;
}
else
{
tu = -1;
ts = -1;
tt = -1;
}
 
tp = t->data;
 
*tp = tu;
tp += GFC_DESCRIPTOR_STRIDE(t,0);
*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;
}
/string_intrinsics_inc.c
0,0 → 1,453
/* 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));
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)
{
*len = string_len_trim (slen, src);
 
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)
{
const gfc_charlen_type long_len = (gfc_charlen_type) sizeof (unsigned long);
gfc_charlen_type i;
 
i = len - 1;
 
/* If we've got the standard (KIND=1) character type, we scan the string in
long word chunks to speed it up (until a long word is hit that does not
consist of ' 's). */
if (sizeof (CHARTYPE) == 1 && i >= long_len)
{
int starting;
unsigned long blank_longword;
 
/* Handle the first characters until we're aligned on a long word
boundary. Actually, s + i + 1 must be properly aligned, because
s + i will be the last byte of a long word read. */
starting = ((unsigned long)
#ifdef __INTPTR_TYPE__
(__INTPTR_TYPE__)
#endif
(s + i + 1)) % long_len;
i -= starting;
for (; starting > 0; --starting)
if (s[i + starting] != ' ')
return i + starting + 1;
 
/* Handle the others in a batch until first non-blank long word is
found. Here again, s + i is the last byte of the current chunk,
to it starts at s + i - sizeof (long) + 1. */
 
#if __SIZEOF_LONG__ == 4
blank_longword = 0x20202020L;
#elif __SIZEOF_LONG__ == 8
blank_longword = 0x2020202020202020L;
#else
#error Invalid size of long!
#endif
 
while (i >= long_len)
{
i -= long_len;
if (*((unsigned long*) (s + i + 1)) != blank_longword)
{
i += long_len;
break;
}
}
 
/* Now continue for the last characters with naive approach below. */
assert (i >= 0);
}
 
/* Simply look for the first non-blank character. */
while (i >= 0 && s[i] == ' ')
--i;
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;
}
}
/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
/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
/perror.c
0,0 → 1,53
/* Implementation of the PERROR intrinsic.
Copyright (C) 2005, 2007, 2009, 2011 Free Software Foundation, Inc.
Contributed by François-Xavier Coudert <coudert@clipper.ens.fr>
 
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"
 
#include <errno.h>
#include <string.h>
 
/* SUBROUTINE PERROR(STRING)
CHARACTER(len=*), INTENT(IN) :: STRING */
 
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);
/exit.c
0,0 → 1,50
/* Implementation of the EXIT intrinsic.
Copyright (C) 2004, 2007, 2009, 2011 Free Software Foundation, Inc.
Contributed by Steven G. Kargl <kargls@comcast.net>.
 
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"
#include <stdlib.h>
 
 
/* 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);
}
/transpose_generic.c
0,0 → 1,151
/* Implementation of the TRANSPOSE intrinsic
Copyright 2003, 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>
#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)
{
/* 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;
index_type size;
 
assert (GFC_DESCRIPTOR_RANK (source) == 2
&& GFC_DESCRIPTOR_RANK (ret) == 2);
 
size = GFC_DESCRIPTOR_SIZE(ret);
 
if (ret->data == NULL)
{
assert (ret->dtype == source->dtype);
 
GFC_DIMENSION_SET(ret->dim[0], 0, GFC_DESCRIPTOR_EXTENT(source,1) - 1,
1);
 
GFC_DIMENSION_SET(ret->dim[1], 0, GFC_DESCRIPTOR_EXTENT(source,0) - 1,
GFC_DESCRIPTOR_EXTENT(source, 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 = GFC_DESCRIPTOR_EXTENT(ret,0);
src_extent = GFC_DESCRIPTOR_EXTENT(source,1);
 
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 = GFC_DESCRIPTOR_EXTENT(ret,1);
src_extent = GFC_DESCRIPTOR_EXTENT(source,0);
 
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 = GFC_DESCRIPTOR_STRIDE_BYTES(source,0);
systride = GFC_DESCRIPTOR_STRIDE_BYTES(source,1);
xcount = GFC_DESCRIPTOR_EXTENT(source,0);
ycount = GFC_DESCRIPTOR_EXTENT(source,1);
 
rxstride = GFC_DESCRIPTOR_STRIDE_BYTES(ret,0);
rystride = GFC_DESCRIPTOR_STRIDE_BYTES(ret,1);
 
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);
}
 
 
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 __attribute__((unused)))
{
transpose_internal (ret, source);
}
 
 
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 __attribute__((unused)))
{
transpose_internal (ret, source);
}
/pack_generic.c
0,0 → 1,643
/* Generic implementation of the PACK intrinsic
Copyright (C) 2002, 2004, 2005, 2006, 2007, 2009, 2010
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];
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");
 
for (n = 0; n < dim; n++)
{
count[n] = 0;
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,n);
mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
}
if (sstride[0] == 0)
sstride[0] = size;
if (mstride[0] == 0)
mstride[0] = mask_kind;
 
if (ret->data == NULL || unlikely (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 = GFC_DESCRIPTOR_EXTENT(vector,0);
}
else
{
/* We have to count the true elements in MASK. */
 
total = count_0 (mask);
}
 
if (ret->data == NULL)
{
/* Setup the array descriptor. */
GFC_DIMENSION_SET(ret->dim[0], 0, total-1, 1);
 
ret->offset = 0;
/* internal_malloc_size allocates a single byte for zero size. */
ret->data = internal_malloc_size (size * total);
 
if (total == 0)
return; /* In this case, nothing remains to be done. */
}
else
{
/* We come here because of range checking. */
index_type ret_extent;
 
ret_extent = GFC_DESCRIPTOR_EXTENT(ret,0);
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 = GFC_DESCRIPTOR_STRIDE_BYTES(ret,0);
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 = GFC_DESCRIPTOR_EXTENT(vector,0);
nelem = ((rptr - ret->data) / rstride0);
if (n > nelem)
{
sstride0 = GFC_DESCRIPTOR_STRIDE_BYTES(vector,0);
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;
 
/* FIXME: This here is a hack, which will have to be removed when
the array descriptor is reworked. Currently, we don't store the
kind value for the type, but only the size. Because on targets with
__float128, we have sizeof(logn double) == sizeof(__float128),
we cannot discriminate here and have to fall back to the generic
handling (which is suboptimal). */
#if !defined(GFC_REAL_16_IS_FLOAT128)
# 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
#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;
 
/* FIXME: This here is a hack, which will have to be removed when
the array descriptor is reworked. Currently, we don't store the
kind value for the type, but only the size. Because on targets with
__float128, we have sizeof(logn double) == sizeof(__float128),
we cannot discriminate here and have to fall back to the generic
handling (which is suboptimal). */
#if !defined(GFC_REAL_16_IS_FLOAT128)
# 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
#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)
|| (vector && 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)
|| (vector && 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)
|| (vector && 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);
return;
}
 
#ifdef HAVE_GFC_INTEGER_16
case GFC_DTYPE_DERIVED_16:
if (GFC_UNALIGNED_16(ret->data) || GFC_UNALIGNED_16(array->data)
|| (vector && 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] = GFC_DESCRIPTOR_EXTENT(array,n);
if (extent[n] < 0)
extent[n] = 0;
 
sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,n);
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 = GFC_DESCRIPTOR_EXTENT(vector,0);
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. */
GFC_DIMENSION_SET(ret->dim[0],0,total-1,1);
 
ret->offset = 0;
 
ret->data = internal_malloc_size (size * total);
 
if (total == 0)
return;
}
 
rstride0 = GFC_DESCRIPTOR_STRIDE_BYTES(ret,0);
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 = GFC_DESCRIPTOR_EXTENT(vector,0);
nelem = ((rptr - ret->data) / rstride0);
if (n > nelem)
{
sstride0 = GFC_DESCRIPTOR_STRIDE_BYTES(vector,0);
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));
}
/string_intrinsics.c
0,0 → 1,102
/* 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>
#include <assert.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;
}
 
/* Compare wide character types, which are handled internally as
unsigned 4-byte integers. */
int
memcmp_char4 (const void *a, const void *b, size_t len)
{
const GFC_UINTEGER_4 *pa = a;
const GFC_UINTEGER_4 *pb = b;
while (len-- > 0)
{
if (*pa != *pb)
return *pa < *pb ? -1 : 1;
pa ++;
pb ++;
}
return 0;
}
 
 
/* 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
#undef MEMCMP
#define MEMCMP memcmp
 
#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
#undef MEMCMP
#define MEMCMP memcmp_char4
 
#include "string_intrinsics_inc.c"
 
/move_alloc.c
0,0 → 1,66
/* Generic implementation of the MOVE_ALLOC intrinsic
Copyright (C) 2006, 2007, 2009, 2011 Free Software Foundation, Inc.
Contributed by Paul Thomas
 
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.
 
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>
 
 
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;
 
free (to->data);
 
for (i = 0; i < GFC_DESCRIPTOR_RANK (from); i++)
{
GFC_DIMENSION_SET(to->dim[i],GFC_DESCRIPTOR_LBOUND(from,i),
GFC_DESCRIPTOR_UBOUND(from,i),
GFC_DESCRIPTOR_STRIDE(from,i));
GFC_DIMENSION_SET(from->dim[i],GFC_DESCRIPTOR_LBOUND(from,i),
GFC_DESCRIPTOR_LBOUND(from,i), 0);
}
 
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);
}
/iso_c_generated_procs.c
0,0 → 1,466
/* Implementation of the ISO_C_BINDING library helper generated functions.
Copyright (C) 2007, 2009, 2010 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) BT_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) BT_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) BT_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) BT_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) BT_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) BT_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) BT_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) BT_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) BT_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) BT_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) BT_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) BT_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) BT_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) BT_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) BT_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) BT_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) BT_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) BT_LOGICAL,
(int) sizeof (GFC_LOGICAL_8));
}
#endif
/getlog.c
0,0 → 1,122
/* Implementation of the GETLOG g77 intrinsic.
Copyright (C) 2005, 2007, 2009, 2011 Free Software Foundation, Inc.
Contributed by François-Xavier Coudert <coudert@clipper.ens.fr>
 
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"
 
#include <stdlib.h>
#include <string.h>
 
#ifdef HAVE_UNISTD_H
# if defined __MINGW32__ && defined HAVE_GETLOGIN
# define _POSIX 1
# endif
#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_POSIX_GETPWUID_R) && defined(HAVE_GETEUID)
struct passwd pwd;
struct passwd *result;
char *buf;
int err;
/* To be pedantic, buflen should be determined by
sysconf(_SC_GETPW_R_SIZE_MAX), which is 1024 on some tested
targets; we do something simple in case the target doesn't
support sysconf. */
static const size_t buflen = 1024;
buf = get_mem (buflen);
err = getpwuid_r (geteuid (), &pwd, buf, buflen, &result);
if (err != 0 || result == NULL)
goto cleanup;
p = pwd.pw_name;
#elif defined(HAVE_GETPWUID) && defined(HAVE_GETEUID)
{
struct passwd *pw = getpwuid (geteuid ());
if (pw)
p = pw->pw_name;
else
return;
}
#elif HAVE_GETLOGIN
p = getlogin();
# else
return;
#endif
 
if (p == NULL)
goto cleanup;
 
p_len = strlen (p);
if (login_len < p_len)
p_len = login_len;
memcpy (login, p, p_len);
 
cleanup:
#if defined (HAVE_POSIX_GETPWUID_R) && defined(HAVE_GETEUID)
free (buf);
#else
;
#endif
}
/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
/time.c
0,0 → 1,50
/* Implementation of the TIME and TIME8 g77 intrinsics.
Copyright (C) 2005, 2007, 2009, 2011 Free Software Foundation, Inc.
Contributed by François-Xavier Coudert <coudert@clipper.ens.fr>
 
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"
#include <time.h>
 
 
/* INTEGER(KIND=4) FUNCTION 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);
}
/gerror.c
0,0 → 1,57
/* Implementation of the GERROR g77 intrinsic.
Copyright (C) 2005, 2007, 2009, 2011 Free Software Foundation, Inc.
Contributed by François-Xavier Coudert <coudert@clipper.ens.fr>
 
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"
 
#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 */
 
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;
 
p = gf_strerror (errno, msg, msg_len);
p_len = strlen (p);
/* The returned pointer p might or might not be the same as the msg
argument. */
if (p != msg)
{
if (msg_len < p_len)
p_len = msg_len;
memcpy (msg, p, p_len);
}
if (msg_len > p_len)
memset (&msg[p_len], ' ', msg_len - p_len);
}
/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
/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;
}
/abort.c
0,0 → 1,34
/* 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)
{
sys_abort ();
}
/selected_real_kind.f90
0,0 → 1,95
! Copyright 2003, 2004, 2009, 2010 Free Software Foundation, Inc.
! Contributed by Kejia Zhao <kejia_zh@yahoo.com.cn>
!
!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/>.
 
function _gfortran_selected_real_kind2008 (p, r, rdx)
implicit none
integer, optional, intent (in) :: p, r, rdx
integer :: _gfortran_selected_real_kind2008
integer :: i, p2, r2, radix2
logical :: found_p, found_r, found_radix
! Real kind_precision_range table
type :: real_info
integer :: kind
integer :: precision
integer :: range
integer :: radix
end type real_info
 
include "selected_real_kind.inc"
 
_gfortran_selected_real_kind2008 = 0
p2 = 0
r2 = 0
radix2 = 0
found_p = .false.
found_r = .false.
found_radix = .false.
 
if (present (p)) p2 = p
if (present (r)) r2 = r
if (present (rdx)) radix2 = rdx
 
! 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 (radix2 <= real_infos (i) % radix) found_radix = .true.
 
if (p2 <= real_infos (i) % precision &
.and. r2 <= real_infos (i) % range &
.and. radix2 <= real_infos (i) % radix) then
_gfortran_selected_real_kind2008 = real_infos (i) % kind
return
end if
end do
 
if (found_radix .and. found_r .and. .not. found_p) then
_gfortran_selected_real_kind2008 = -1
elseif (found_radix .and. found_p .and. .not. found_r) then
_gfortran_selected_real_kind2008 = -2
elseif (found_radix .and. .not. found_p .and. .not. found_r) then
_gfortran_selected_real_kind2008 = -3
elseif (found_radix) then
_gfortran_selected_real_kind2008 = -4
else
_gfortran_selected_real_kind2008 = -5
end if
end function _gfortran_selected_real_kind2008
 
function _gfortran_selected_real_kind (p, r)
implicit none
integer, optional, intent (in) :: p, r
integer :: _gfortran_selected_real_kind
 
interface
function _gfortran_selected_real_kind2008 (p, r, rdx)
implicit none
integer, optional, intent (in) :: p, r, rdx
integer :: _gfortran_selected_real_kind2008
end function _gfortran_selected_real_kind2008
end interface
 
_gfortran_selected_real_kind = _gfortran_selected_real_kind2008 (p, r)
end function
/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
 
/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
/umask.c
0,0 → 1,90
/* Implementation of the UMASK intrinsic.
Copyright (C) 2004, 2007, 2009, 2011 Free Software Foundation, Inc.
Contributed by Steven G. Kargl <kargls@comcast.net>.
 
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"
#include <stdlib.h>
 
#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;
}
/bit_intrinsics.c
0,0 → 1,138
/* Implementation of the bit intrinsics not implemented as GCC builtins.
Copyright (C) 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"
 
 
#ifdef HAVE_GFC_INTEGER_16
extern int clz128 (GFC_INTEGER_16);
export_proto(clz128);
 
int
clz128 (GFC_INTEGER_16 x)
{
int res = 127;
 
// We can't write 0xFFFFFFFFFFFFFFFF0000000000000000, so we work around it
if (x & ((__uint128_t) 0xFFFFFFFFFFFFFFFF << 64))
{
res -= 64;
x >>= 64;
}
 
if (x & 0xFFFFFFFF00000000)
{
res -= 32;
x >>= 32;
}
 
if (x & 0xFFFF0000)
{
res -= 16;
x >>= 16;
}
 
if (x & 0xFF00)
{
res -= 8;
x >>= 8;
}
 
if (x & 0xF0)
{
res -= 4;
x >>= 4;
}
 
if (x & 0xC)
{
res -= 2;
x >>= 2;
}
 
if (x & 0x2)
{
res -= 1;
x >>= 1;
}
 
return res;
}
#endif
 
 
#ifdef HAVE_GFC_INTEGER_16
extern int ctz128 (GFC_INTEGER_16);
export_proto(ctz128);
 
int
ctz128 (GFC_INTEGER_16 x)
{
int res = 0;
 
if ((x & 0xFFFFFFFFFFFFFFFF) == 0)
{
res += 64;
x >>= 64;
}
 
if ((x & 0xFFFFFFFF) == 0)
{
res += 32;
x >>= 32;
}
 
if ((x & 0xFFFF) == 0)
{
res += 16;
x >>= 16;
}
 
if ((x & 0xFF) == 0)
{
res += 8;
x >>= 8;
}
 
if ((x & 0xF) == 0)
{
res += 4;
x >>= 4;
}
 
if ((x & 0x3) == 0)
{
res += 2;
x >>= 2;
}
 
if ((x & 0x1) == 0)
{
res += 1;
x >>= 1;
}
 
return res;
}
#endif
/erfc_scaled_inc.c
0,0 → 1,193
/* Implementation of the ERFC_SCALED intrinsic, to be included by erfc_scaled.c
Copyright (c) 2008, 2010 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)
 
#elif (KIND == 10) || (KIND == 16 && defined(GFC_REAL_16_IS_LONG_DOUBLE))
 
# ifdef HAVE_EXPL
# define EXP(x) expl(x)
# endif
# ifdef HAVE_TRUNCL
# define TRUNC(x) truncl(x)
# endif
 
#elif (KIND == 16 && defined(GFC_REAL_16_IS_FLOAT128))
 
# define EXP(x) expq(x)
# define TRUNC(x) truncq(x)
 
#else
 
# error "What exactly is it that you want me to do?"
 
#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
/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
/chmod.c
0,0 → 1,525
/* Implementation of the CHMOD intrinsic.
Copyright (C) 2006, 2007, 2009, 2012 Free Software Foundation, Inc.
Contributed by François-Xavier Coudert <coudert@clipper.ens.fr>
 
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"
 
#if defined(HAVE_SYS_STAT_H)
 
#include <stdbool.h>
#include <string.h> /* For memcpy. */
#include <sys/stat.h> /* For stat, chmod and umask. */
 
 
/* INTEGER FUNCTION CHMOD (NAME, MODE)
CHARACTER(len=*), INTENT(IN) :: NAME, MODE
 
Sets the file permission "chmod" using a mode string.
 
For MinGW, only _S_IWRITE and _S_IREAD are supported. To set those,
only the user attributes are used.
 
The mode string allows for the same arguments as POSIX's chmod utility.
a) string containing an octal number.
b) Comma separated list of clauses of the form:
[<who-list>]<op>[<perm-list>|<permcopy>][<op>[<perm-list>|<permcopy>],...]
<who> - 'u', 'g', 'o', 'a'
<op> - '+', '-', '='
<perm> - 'r', 'w', 'x', 'X', 's', t'
If <op> is not followed by a perm-list or permcopy, '-' and '+' do not
change the mode while '=' clears all file mode bits. 'u' stands for the
user permissions, 'g' for the group and 'o' for the permissions for others.
'a' is equivalent to 'ugo'. '+' sets the given permission in addition to
the ones of the file, '-' unsets the given permissions of the file, while
'=' sets the file to that mode. 'r' sets the read, 'w' the write, and
'x' the execute mode. 'X' sets the execute bit if the file is a directory
or if the user, group or other executable bit is set. 't' sets the sticky
bit, 's' (un)sets the and/or S_ISUID/S_ISGID bit.
 
Note that if <who> is omitted, the permissions are filtered by the umask.
 
A return value of 0 indicates success, -1 an error of chmod() while 1
indicates a mode parsing error. */
 
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;
int i;
bool ugo[3];
bool rwxXstugo[9];
int set_mode, part;
bool is_dir, honor_umask, continue_clause = false;
mode_t mode_mask, file_mode, new_mode;
struct stat stat_buf;
 
/* Trim trailing spaces of the file name. */
while (name_len > 0 && name[name_len - 1] == ' ')
name_len--;
 
/* Make a null terminated copy of the file name. */
file = gfc_alloca (name_len + 1);
memcpy (file, name, name_len);
file[name_len] = '\0';
 
if (mode_len == 0)
return 1;
 
if (mode[0] >= '0' && mode[0] <= '9')
{
#ifdef __MINGW32__
unsigned mode;
if (sscanf (mode, "%o", &mode) != 1)
return 1;
file_mode = (mode_t) mode;
#else
if (sscanf (mode, "%o", &file_mode) != 1)
return 1;
#endif
return chmod (file, file_mode);
}
 
/* Read the current file mode. */
if (stat (file, &stat_buf))
return 1;
 
file_mode = stat_buf.st_mode & ~S_IFMT;
is_dir = stat_buf.st_mode & S_IFDIR;
 
#ifdef HAVE_UMASK
/* Obtain the umask without distroying the setting. */
mode_mask = 0;
mode_mask = umask (mode_mask);
(void) umask (mode_mask);
#else
honor_umask = false;
#endif
 
for (i = 0; i < mode_len; i++)
{
if (!continue_clause)
{
ugo[0] = false;
ugo[1] = false;
ugo[2] = false;
#ifdef HAVE_UMASK
honor_umask = true;
#endif
}
continue_clause = false;
rwxXstugo[0] = false;
rwxXstugo[1] = false;
rwxXstugo[2] = false;
rwxXstugo[3] = false;
rwxXstugo[4] = false;
rwxXstugo[5] = false;
rwxXstugo[6] = false;
rwxXstugo[7] = false;
rwxXstugo[8] = false;
rwxXstugo[9] = false;
part = 0;
set_mode = -1;
for (; i < mode_len; i++)
{
switch (mode[i])
{
/* User setting: a[ll]/u[ser]/g[roup]/o[ther]. */
case 'a':
if (part > 1)
return 1;
ugo[0] = true;
ugo[1] = true;
ugo[2] = true;
part = 1;
#ifdef HAVE_UMASK
honor_umask = false;
#endif
break;
case 'u':
if (part == 2)
{
rwxXstugo[6] = true;
part = 4;
break;
}
if (part > 1)
return 1;
ugo[0] = true;
part = 1;
#ifdef HAVE_UMASK
honor_umask = false;
#endif
break;
case 'g':
if (part == 2)
{
rwxXstugo[7] = true;
part = 4;
break;
}
if (part > 1)
return 1;
ugo[1] = true;
part = 1;
#ifdef HAVE_UMASK
honor_umask = false;
#endif
break;
case 'o':
if (part == 2)
{
rwxXstugo[8] = true;
part = 4;
break;
}
if (part > 1)
return 1;
ugo[2] = true;
part = 1;
#ifdef HAVE_UMASK
honor_umask = false;
#endif
break;
 
/* Mode setting: =+-. */
case '=':
if (part > 2)
{
continue_clause = true;
i--;
part = 2;
goto clause_done;
}
set_mode = 1;
part = 2;
break;
 
case '-':
if (part > 2)
{
continue_clause = true;
i--;
part = 2;
goto clause_done;
}
set_mode = 2;
part = 2;
break;
 
case '+':
if (part > 2)
{
continue_clause = true;
i--;
part = 2;
goto clause_done;
}
set_mode = 3;
part = 2;
break;
 
/* Permissions: rwxXst - for ugo see above. */
case 'r':
if (part != 2 && part != 3)
return 1;
rwxXstugo[0] = true;
part = 3;
break;
 
case 'w':
if (part != 2 && part != 3)
return 1;
rwxXstugo[1] = true;
part = 3;
break;
 
case 'x':
if (part != 2 && part != 3)
return 1;
rwxXstugo[2] = true;
part = 3;
break;
 
case 'X':
if (part != 2 && part != 3)
return 1;
rwxXstugo[3] = true;
part = 3;
break;
 
case 's':
if (part != 2 && part != 3)
return 1;
rwxXstugo[4] = true;
part = 3;
break;
 
case 't':
if (part != 2 && part != 3)
return 1;
rwxXstugo[5] = true;
part = 3;
break;
 
/* Tailing blanks are valid in Fortran. */
case ' ':
for (i++; i < mode_len; i++)
if (mode[i] != ' ')
break;
if (i != mode_len)
return 1;
goto clause_done;
 
case ',':
goto clause_done;
 
default:
return 1;
}
}
 
clause_done:
if (part < 2)
return 1;
 
new_mode = 0;
 
#ifdef __MINGW32__
 
/* Read. */
if (rwxXstugo[0] && (ugo[0] || honor_umask))
new_mode |= _S_IREAD;
 
/* Write. */
if (rwxXstugo[1] && (ugo[0] || honor_umask))
new_mode |= _S_IWRITE;
 
#else
 
/* Read. */
if (rwxXstugo[0])
{
if (ugo[0] || honor_umask)
new_mode |= S_IRUSR;
if (ugo[1] || honor_umask)
new_mode |= S_IRGRP;
if (ugo[2] || honor_umask)
new_mode |= S_IROTH;
}
 
/* Write. */
if (rwxXstugo[1])
{
if (ugo[0] || honor_umask)
new_mode |= S_IWUSR;
if (ugo[1] || honor_umask)
new_mode |= S_IWGRP;
if (ugo[2] || honor_umask)
new_mode |= S_IWOTH;
}
 
/* Execute. */
if (rwxXstugo[2])
{
if (ugo[0] || honor_umask)
new_mode |= S_IXUSR;
if (ugo[1] || honor_umask)
new_mode |= S_IXGRP;
if (ugo[2] || honor_umask)
new_mode |= S_IXOTH;
}
 
/* 'X' execute. */
if (rwxXstugo[3]
&& (is_dir || (file_mode & (S_IXUSR | S_IXGRP | S_IXOTH))))
new_mode |= (S_IXUSR | S_IXGRP | S_IXOTH);
 
/* 's'. */
if (rwxXstugo[4])
{
if (ugo[0] || honor_umask)
new_mode |= S_ISUID;
if (ugo[1] || honor_umask)
new_mode |= S_ISGID;
}
 
/* As original 'u'. */
if (rwxXstugo[6])
{
if (ugo[1] || honor_umask)
{
if (file_mode & S_IRUSR)
new_mode |= S_IRGRP;
if (file_mode & S_IWUSR)
new_mode |= S_IWGRP;
if (file_mode & S_IXUSR)
new_mode |= S_IXGRP;
}
if (ugo[2] || honor_umask)
{
if (file_mode & S_IRUSR)
new_mode |= S_IROTH;
if (file_mode & S_IWUSR)
new_mode |= S_IWOTH;
if (file_mode & S_IXUSR)
new_mode |= S_IXOTH;
}
}
 
/* As original 'g'. */
if (rwxXstugo[7])
{
if (ugo[0] || honor_umask)
{
if (file_mode & S_IRGRP)
new_mode |= S_IRUSR;
if (file_mode & S_IWGRP)
new_mode |= S_IWUSR;
if (file_mode & S_IXGRP)
new_mode |= S_IXUSR;
}
if (ugo[2] || honor_umask)
{
if (file_mode & S_IRGRP)
new_mode |= S_IROTH;
if (file_mode & S_IWGRP)
new_mode |= S_IWOTH;
if (file_mode & S_IXGRP)
new_mode |= S_IXOTH;
}
}
 
/* As original 'o'. */
if (rwxXstugo[8])
{
if (ugo[0] || honor_umask)
{
if (file_mode & S_IROTH)
new_mode |= S_IRUSR;
if (file_mode & S_IWOTH)
new_mode |= S_IWUSR;
if (file_mode & S_IXOTH)
new_mode |= S_IXUSR;
}
if (ugo[1] || honor_umask)
{
if (file_mode & S_IROTH)
new_mode |= S_IRGRP;
if (file_mode & S_IWOTH)
new_mode |= S_IWGRP;
if (file_mode & S_IXOTH)
new_mode |= S_IXGRP;
}
}
#endif /* __MINGW32__ */
 
#ifdef HAVE_UMASK
if (honor_umask)
new_mode &= ~mode_mask;
#endif
 
if (set_mode == 1)
{
#ifdef __MINGW32__
if (ugo[0] || honor_umask)
file_mode = (file_mode & ~(_S_IWRITE | _S_IREAD))
| (new_mode & (_S_IWRITE | _S_IREAD));
#else
/* Set '='. */
if ((ugo[0] || honor_umask) && !rwxXstugo[6])
file_mode = (file_mode & ~(S_ISUID | S_IRUSR | S_IWUSR | S_IXUSR))
| (new_mode & (S_ISUID | S_IRUSR | S_IWUSR | S_IXUSR));
if ((ugo[1] || honor_umask) && !rwxXstugo[7])
file_mode = (file_mode & ~(S_ISGID | S_IRGRP | S_IWGRP | S_IXGRP))
| (new_mode & (S_ISGID | S_IRGRP | S_IWGRP | S_IXGRP));
if ((ugo[2] || honor_umask) && !rwxXstugo[8])
file_mode = (file_mode & ~(S_IROTH | S_IWOTH | S_IXOTH))
| (new_mode & (S_IROTH | S_IWOTH | S_IXOTH));
if (is_dir && rwxXstugo[5])
file_mode |= S_ISVTX;
else if (!is_dir)
file_mode &= ~S_ISVTX;
#endif
}
else if (set_mode == 2)
{
/* Clear '-'. */
file_mode &= ~new_mode;
#ifndef __MINGW32__
if (rwxXstugo[5] || !is_dir)
file_mode &= ~S_ISVTX;
#endif
}
else if (set_mode == 3)
{
file_mode |= new_mode;
#ifndef __MINGW32__
if (rwxXstugo[5] && is_dir)
file_mode |= S_ISVTX;
else if (!is_dir)
file_mode &= ~S_ISVTX;
#endif
}
}
 
return chmod (file, file_mode);
}
 
 
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
/selected_char_kind.c
0,0 → 1,46
/* Copyright 2008, 2009, 2010 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 4;
else
return -1;
}
/c99_functions.c
0,0 → 1,2136
/* Implementation of various C99 functions
Copyright (C) 2004, 2009, 2010 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
 
/* On a C99 system "I" (with I*I = -1) should be defined in complex.h;
if not, we define a fallback version here. */
#ifndef I
# if defined(_Imaginary_I)
# define I _Imaginary_I
# elif defined(_Complex_I)
# define I _Complex_I
# else
# define I (1.0fi)
# endif
#endif
 
/* Prototypes are included to silence -Wstrict-prototypes
-Wmissing-prototypes. */
 
 
/* Wrappers for systems without the various C99 single precision Bessel
functions. */
 
#if defined(HAVE_J0) && ! defined(HAVE_J0F)
#define HAVE_J0F 1
float j0f (float);
 
float
j0f (float x)
{
return (float) j0 ((double) x);
}
#endif
 
#if defined(HAVE_J1) && !defined(HAVE_J1F)
#define HAVE_J1F 1
float j1f (float);
 
float j1f (float x)
{
return (float) j1 ((double) x);
}
#endif
 
#if defined(HAVE_JN) && !defined(HAVE_JNF)
#define HAVE_JNF 1
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
float y0f (float);
 
float
y0f (float x)
{
return (float) y0 ((double) x);
}
#endif
 
#if defined(HAVE_Y1) && !defined(HAVE_Y1F)
#define HAVE_Y1F 1
float y1f (float);
 
float
y1f (float x)
{
return (float) y1 ((double) x);
}
#endif
 
#if defined(HAVE_YN) && !defined(HAVE_YNF)
#define HAVE_YNF 1
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
float erff (float);
 
float
erff (float x)
{
return (float) erf ((double) x);
}
#endif
 
#if defined(HAVE_ERFC) && !defined(HAVE_ERFCF)
#define HAVE_ERFCF 1
float erfcf (float);
 
float
erfcf (float x)
{
return (float) erfc ((double) x);
}
#endif
 
 
#ifndef HAVE_ACOSF
#define HAVE_ACOSF 1
float acosf (float x);
 
float
acosf (float x)
{
return (float) acos (x);
}
#endif
 
#if HAVE_ACOSH && !HAVE_ACOSHF
float acoshf (float x);
 
float
acoshf (float x)
{
return (float) acosh ((double) x);
}
#endif
 
#ifndef HAVE_ASINF
#define HAVE_ASINF 1
float asinf (float x);
 
float
asinf (float x)
{
return (float) asin (x);
}
#endif
 
#if HAVE_ASINH && !HAVE_ASINHF
float asinhf (float x);
 
float
asinhf (float x)
{
return (float) asinh ((double) x);
}
#endif
 
#ifndef HAVE_ATAN2F
#define HAVE_ATAN2F 1
float atan2f (float y, float x);
 
float
atan2f (float y, float x)
{
return (float) atan2 (y, x);
}
#endif
 
#ifndef HAVE_ATANF
#define HAVE_ATANF 1
float atanf (float x);
 
float
atanf (float x)
{
return (float) atan (x);
}
#endif
 
#if HAVE_ATANH && !HAVE_ATANHF
float atanhf (float x);
 
float
atanhf (float x)
{
return (float) atanh ((double) x);
}
#endif
 
#ifndef HAVE_CEILF
#define HAVE_CEILF 1
float ceilf (float x);
 
float
ceilf (float x)
{
return (float) ceil (x);
}
#endif
 
#ifndef HAVE_COPYSIGNF
#define HAVE_COPYSIGNF 1
float copysignf (float x, float y);
 
float
copysignf (float x, float y)
{
return (float) copysign (x, y);
}
#endif
 
#ifndef HAVE_COSF
#define HAVE_COSF 1
float cosf (float x);
 
float
cosf (float x)
{
return (float) cos (x);
}
#endif
 
#ifndef HAVE_COSHF
#define HAVE_COSHF 1
float coshf (float x);
 
float
coshf (float x)
{
return (float) cosh (x);
}
#endif
 
#ifndef HAVE_EXPF
#define HAVE_EXPF 1
float expf (float x);
 
float
expf (float x)
{
return (float) exp (x);
}
#endif
 
#ifndef HAVE_FABSF
#define HAVE_FABSF 1
float fabsf (float x);
 
float
fabsf (float x)
{
return (float) fabs (x);
}
#endif
 
#ifndef HAVE_FLOORF
#define HAVE_FLOORF 1
float floorf (float x);
 
float
floorf (float x)
{
return (float) floor (x);
}
#endif
 
#ifndef HAVE_FMODF
#define HAVE_FMODF 1
float fmodf (float x, float y);
 
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);
 
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);
 
float
hypotf (float x, float y)
{
return (float) hypot (x, y);
}
#endif
 
#ifndef HAVE_LOGF
#define HAVE_LOGF 1
float logf (float x);
 
float
logf (float x)
{
return (float) log (x);
}
#endif
 
#ifndef HAVE_LOG10F
#define HAVE_LOG10F 1
float log10f (float x);
 
float
log10f (float x)
{
return (float) log10 (x);
}
#endif
 
#ifndef HAVE_SCALBN
#define HAVE_SCALBN 1
double scalbn (double x, int y);
 
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);
 
float
scalbnf (float x, int y)
{
return (float) scalbn (x, y);
}
#endif
 
#ifndef HAVE_SINF
#define HAVE_SINF 1
float sinf (float x);
 
float
sinf (float x)
{
return (float) sin (x);
}
#endif
 
#ifndef HAVE_SINHF
#define HAVE_SINHF 1
float sinhf (float x);
 
float
sinhf (float x)
{
return (float) sinh (x);
}
#endif
 
#ifndef HAVE_SQRTF
#define HAVE_SQRTF 1
float sqrtf (float x);
 
float
sqrtf (float x)
{
return (float) sqrt (x);
}
#endif
 
#ifndef HAVE_TANF
#define HAVE_TANF 1
float tanf (float x);
 
float
tanf (float x)
{
return (float) tan (x);
}
#endif
 
#ifndef HAVE_TANHF
#define HAVE_TANHF 1
float tanhf (float x);
 
float
tanhf (float x)
{
return (float) tanh (x);
}
#endif
 
#ifndef HAVE_TRUNC
#define HAVE_TRUNC 1
double trunc (double x);
 
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);
 
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);
 
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);
 
float
powf (float x, float y)
{
return (float) pow (x, y);
}
#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
round (double x)
{
double t;
if (!isfinite (x))
return (x);
 
if (x >= 0.0)
{
t = floor (x);
if (t - x <= -0.5)
t += 1.0;
return (t);
}
else
{
t = floor (-x);
if (t + x <= -0.5)
t += 1.0;
return (-t);
}
}
#endif
 
 
/* Algorithm by Steven G. Kargl. */
 
#if !defined(HAVE_ROUNDL)
#define HAVE_ROUNDL 1
long double roundl (long double x);
 
#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
long double prechalf = nextafterl (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_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
roundf (float x)
{
float t;
if (!isfinite (x))
return (x);
 
if (x >= 0.0)
{
t = floorf (x);
if (t - x <= -0.5)
t += 1.0;
return (t);
}
else
{
t = floorf (-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);
 
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);
 
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);
 
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);
 
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);
 
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);
 
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);
 
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);
 
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);
 
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);
 
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);
 
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);
 
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);
 
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);
 
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);
 
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 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 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 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
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
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
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
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
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
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);
 
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);
 
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);
 
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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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
 
 
/* Complex ASIN. Returns wrongly NaN for infinite arguments.
Algorithm taken from Abramowitz & Stegun. */
 
#if !defined(HAVE_CASINF) && defined(HAVE_CLOGF) && defined(HAVE_CSQRTF)
#define HAVE_CASINF 1
complex float casinf (complex float z);
 
complex float
casinf (complex float z)
{
return -I*clogf (I*z + csqrtf (1.0f-z*z));
}
#endif
 
 
#if !defined(HAVE_CASIN) && defined(HAVE_CLOG) && defined(HAVE_CSQRT)
#define HAVE_CASIN 1
complex double casin (complex double z);
 
complex double
casin (complex double z)
{
return -I*clog (I*z + csqrt (1.0-z*z));
}
#endif
 
 
#if !defined(HAVE_CASINL) && defined(HAVE_CLOGL) && defined(HAVE_CSQRTL)
#define HAVE_CASINL 1
complex long double casinl (complex long double z);
 
complex long double
casinl (complex long double z)
{
return -I*clogl (I*z + csqrtl (1.0L-z*z));
}
#endif
 
 
/* Complex ACOS. Returns wrongly NaN for infinite arguments.
Algorithm taken from Abramowitz & Stegun. */
 
#if !defined(HAVE_CACOSF) && defined(HAVE_CLOGF) && defined(HAVE_CSQRTF)
#define HAVE_CACOSF 1
complex float cacosf (complex float z);
 
complex float
cacosf (complex float z)
{
return -I*clogf (z + I*csqrtf (1.0f-z*z));
}
#endif
 
 
#if !defined(HAVE_CACOS) && defined(HAVE_CLOG) && defined(HAVE_CSQRT)
#define HAVE_CACOS 1
complex double cacos (complex double z);
 
complex double
cacos (complex double z)
{
return -I*clog (z + I*csqrt (1.0-z*z));
}
#endif
 
 
#if !defined(HAVE_CACOSL) && defined(HAVE_CLOGL) && defined(HAVE_CSQRTL)
#define HAVE_CACOSL 1
complex long double cacosl (complex long double z);
 
complex long double
cacosl (complex long double z)
{
return -I*clogl (z + I*csqrtl (1.0L-z*z));
}
#endif
 
 
/* Complex ATAN. Returns wrongly NaN for infinite arguments.
Algorithm taken from Abramowitz & Stegun. */
 
#if !defined(HAVE_CATANF) && defined(HAVE_CLOGF)
#define HAVE_CACOSF 1
complex float catanf (complex float z);
 
complex float
catanf (complex float z)
{
return I*clogf ((I+z)/(I-z))/2.0f;
}
#endif
 
 
#if !defined(HAVE_CATAN) && defined(HAVE_CLOG)
#define HAVE_CACOS 1
complex double catan (complex double z);
 
complex double
catan (complex double z)
{
return I*clog ((I+z)/(I-z))/2.0;
}
#endif
 
 
#if !defined(HAVE_CATANL) && defined(HAVE_CLOGL)
#define HAVE_CACOSL 1
complex long double catanl (complex long double z);
 
complex long double
catanl (complex long double z)
{
return I*clogl ((I+z)/(I-z))/2.0L;
}
#endif
 
 
/* Complex ASINH. Returns wrongly NaN for infinite arguments.
Algorithm taken from Abramowitz & Stegun. */
 
#if !defined(HAVE_CASINHF) && defined(HAVE_CLOGF) && defined(HAVE_CSQRTF)
#define HAVE_CASINHF 1
complex float casinhf (complex float z);
 
complex float
casinhf (complex float z)
{
return clogf (z + csqrtf (z*z+1.0f));
}
#endif
 
 
#if !defined(HAVE_CASINH) && defined(HAVE_CLOG) && defined(HAVE_CSQRT)
#define HAVE_CASINH 1
complex double casinh (complex double z);
 
complex double
casinh (complex double z)
{
return clog (z + csqrt (z*z+1.0));
}
#endif
 
 
#if !defined(HAVE_CASINHL) && defined(HAVE_CLOGL) && defined(HAVE_CSQRTL)
#define HAVE_CASINHL 1
complex long double casinhl (complex long double z);
 
complex long double
casinhl (complex long double z)
{
return clogl (z + csqrtl (z*z+1.0L));
}
#endif
 
 
/* Complex ACOSH. Returns wrongly NaN for infinite arguments.
Algorithm taken from Abramowitz & Stegun. */
 
#if !defined(HAVE_CACOSHF) && defined(HAVE_CLOGF) && defined(HAVE_CSQRTF)
#define HAVE_CACOSHF 1
complex float cacoshf (complex float z);
 
complex float
cacoshf (complex float z)
{
return clogf (z + csqrtf (z-1.0f) * csqrtf (z+1.0f));
}
#endif
 
 
#if !defined(HAVE_CACOSH) && defined(HAVE_CLOG) && defined(HAVE_CSQRT)
#define HAVE_CACOSH 1
complex double cacosh (complex double z);
 
complex double
cacosh (complex double z)
{
return clog (z + csqrt (z-1.0) * csqrt (z+1.0));
}
#endif
 
 
#if !defined(HAVE_CACOSHL) && defined(HAVE_CLOGL) && defined(HAVE_CSQRTL)
#define HAVE_CACOSHL 1
complex long double cacoshl (complex long double z);
 
complex long double
cacoshl (complex long double z)
{
return clogl (z + csqrtl (z-1.0L) * csqrtl (z+1.0L));
}
#endif
 
 
/* Complex ATANH. Returns wrongly NaN for infinite arguments.
Algorithm taken from Abramowitz & Stegun. */
 
#if !defined(HAVE_CATANHF) && defined(HAVE_CLOGF)
#define HAVE_CATANHF 1
complex float catanhf (complex float z);
 
complex float
catanhf (complex float z)
{
return clogf ((1.0f+z)/(1.0f-z))/2.0f;
}
#endif
 
 
#if !defined(HAVE_CATANH) && defined(HAVE_CLOG)
#define HAVE_CATANH 1
complex double catanh (complex double z);
 
complex double
catanh (complex double z)
{
return clog ((1.0+z)/(1.0-z))/2.0;
}
#endif
 
#if !defined(HAVE_CATANHL) && defined(HAVE_CLOGL)
#define HAVE_CATANHL 1
complex long double catanhl (complex long double z);
 
complex long double
catanhl (complex long double z)
{
return clogl ((1.0L+z)/(1.0L-z))/2.0L;
}
#endif
 
 
#if !defined(HAVE_TGAMMA)
#define HAVE_TGAMMA 1
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 (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
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
float tgammaf (float);
 
float
tgammaf (float x)
{
return (float) tgamma ((double) x);
}
#endif
 
#if defined(HAVE_LGAMMA) && !defined(HAVE_LGAMMAF)
#define HAVE_LGAMMAF 1
float lgammaf (float);
 
float
lgammaf (float x)
{
return (float) lgamma ((double) x);
}
#endif
/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
/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;
}
/system_clock.c
0,0 → 1,207
/* Implementation of the SYSTEM_CLOCK intrinsic.
Copyright (C) 2004, 2005, 2007, 2009, 2010, 2011 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"
 
#include <limits.h>
 
#include "time_1.h"
 
 
/* POSIX states that CLOCK_REALTIME must be present if clock_gettime
is available, others are optional. */
#if defined(HAVE_CLOCK_GETTIME) || defined(HAVE_CLOCK_GETTIME_LIBRT)
#ifdef CLOCK_MONOTONIC
#define GF_CLOCK_MONOTONIC CLOCK_MONOTONIC
#else
#define GF_CLOCK_MONOTONIC CLOCK_REALTIME
#endif
#endif
 
/* Weakref trickery for clock_gettime(). On Glibc, clock_gettime()
requires us to link in librt, which also pulls in libpthread. In
order to avoid this by default, only call clock_gettime() through a
weak reference.
 
Some targets don't support weak undefined references; on these
GTHREAD_USE_WEAK is 0. So we need to define it to 1 on other
targets. */
#ifndef GTHREAD_USE_WEAK
#define GTHREAD_USE_WEAK 1
#endif
 
#if SUPPORTS_WEAK && GTHREAD_USE_WEAK && defined(HAVE_CLOCK_GETTIME_LIBRT)
static int weak_gettime (clockid_t, struct timespec *)
__attribute__((__weakref__("clock_gettime")));
#endif
 
 
/* High resolution monotonic clock, falling back to the realtime clock
if the target does not support such a clock.
 
Arguments:
secs - OUTPUT, seconds
nanosecs - OUTPUT, nanoseconds
 
If the target supports a monotonic clock, the OUTPUT arguments
represent a monotonically incrementing clock starting from some
unspecified time in the past.
 
If a monotonic clock is not available, falls back to the realtime
clock which is not monotonic.
 
Return value: 0 for success, -1 for error. In case of error, errno
is set.
*/
static int
gf_gettime_mono (time_t * secs, long * nanosecs)
{
int err;
#ifdef HAVE_CLOCK_GETTIME
struct timespec ts;
err = clock_gettime (GF_CLOCK_MONOTONIC, &ts);
*secs = ts.tv_sec;
*nanosecs = ts.tv_nsec;
return err;
#else
#if defined(HAVE_CLOCK_GETTIME_LIBRT) && SUPPORTS_WEAK && GTHREAD_USE_WEAK
if (weak_gettime)
{
struct timespec ts;
err = weak_gettime (GF_CLOCK_MONOTONIC, &ts);
*secs = ts.tv_sec;
*nanosecs = ts.tv_nsec;
return err;
}
#endif
err = gf_gettime (secs, nanosecs);
*nanosecs *= 1000;
return err;
#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)
{
#undef TCK
#define TCK 1000
GFC_INTEGER_4 cnt;
GFC_INTEGER_4 mx;
 
time_t secs;
long nanosecs;
 
if (sizeof (secs) < sizeof (GFC_INTEGER_4))
internal_error (NULL, "secs too small");
 
if (gf_gettime_mono (&secs, &nanosecs) == 0)
{
GFC_UINTEGER_4 ucnt = (GFC_UINTEGER_4) secs * TCK;
ucnt += (nanosecs + 500000000 / TCK) / (1000000000 / 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;
}
 
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)
{
#undef TCK
#define TCK 1000000000
GFC_INTEGER_8 cnt;
GFC_INTEGER_8 mx;
 
time_t secs;
long nanosecs;
 
if (sizeof (secs) < sizeof (GFC_INTEGER_4))
internal_error (NULL, "secs too small");
 
if (gf_gettime_mono (&secs, &nanosecs) == 0)
{
GFC_UINTEGER_8 ucnt = (GFC_UINTEGER_8) secs * TCK;
ucnt += (nanosecs + 500000000 / TCK) / (1000000000 / 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;
}
 
if (count != NULL)
*count = cnt;
if (count_rate != NULL)
*count_rate = TCK;
if (count_max != NULL)
*count_max = mx;
}
/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;
}
/cshift0.c
0,0 → 1,452
/* Generic implementation of the CSHIFT intrinsic
Copyright 2003, 2005, 2006, 2007, 2010 Free Software Foundation, Inc.
Contributed by Feng Wang <wf_cs@yahoo.com>
 
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"
#include <stdlib.h>
#include <assert.h>
#include <string.h>
 
static void
cshift0 (gfc_array_char * ret, const gfc_array_char * array,
ptrdiff_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++)
{
index_type ub, str;
 
ub = GFC_DESCRIPTOR_EXTENT(array,i) - 1;
 
if (i == 0)
str = 1;
else
str = GFC_DESCRIPTOR_EXTENT(ret,i-1) *
GFC_DESCRIPTOR_STRIDE(ret,i-1);
 
GFC_DIMENSION_SET(ret->dim[i], 0, ub, str);
}
 
/* internal_malloc_size allocates a single byte for zero size. */
ret->data = internal_malloc_size (size * arraysize);
}
else if (unlikely (compile_options.bounds_check))
{
bounds_equal_extents ((array_t *) ret, (array_t *) array,
"return value", "CSHIFT");
}
 
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;
 
/* FIXME: This here is a hack, which will have to be removed when
the array descriptor is reworked. Currently, we don't store the
kind value for the type, but only the size. Because on targets with
__float128, we have sizeof(logn double) == sizeof(__float128),
we cannot discriminate here and have to fall back to the generic
handling (which is suboptimal). */
#if !defined(GFC_REAL_16_IS_FLOAT128)
# 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
#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;
 
/* FIXME: This here is a hack, which will have to be removed when
the array descriptor is reworked. Currently, we don't store the
kind value for the type, but only the size. Because on targets with
__float128, we have sizeof(logn double) == sizeof(__float128),
we cannot discriminate here and have to fall back to the generic
handling (which is suboptimal). */
#if !defined(GFC_REAL_16_IS_FLOAT128)
# 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
#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 = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim);
if (roffset == 0)
roffset = size;
soffset = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim);
if (soffset == 0)
soffset = size;
len = GFC_DESCRIPTOR_EXTENT(array,dim);
}
else
{
count[n] = 0;
extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim);
rstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim);
sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim);
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 % (ptrdiff_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
/ctime.c
0,0 → 1,110
/* Implementation of the CTIME and FDATE g77 intrinsics.
Copyright (C) 2005, 2007, 2009, 2011 Free Software Foundation, Inc.
Contributed by François-Xavier Coudert <coudert@clipper.ens.fr>
 
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"
 
#include "time_1.h"
 
#include <stdlib.h>
#include <string.h>
 
 
/* strftime-like function that fills a C string with %c format which
is identical to ctime in the default locale. As ctime and ctime_r
are poorly specified and their usage not recommended, the
implementation instead uses strftime. */
 
static size_t
strctime (char *s, size_t max, const time_t *timep)
{
struct tm ltm;
int failed;
/* Some targets provide a localtime_r based on a draft of the POSIX
standard where the return type is int rather than the
standardized struct tm*. */
__builtin_choose_expr (__builtin_classify_type (localtime_r (timep, &ltm))
== 5,
failed = localtime_r (timep, &ltm) == NULL,
failed = localtime_r (timep, &ltm) != 0);
if (failed)
return 0;
return strftime (s, max, "%c", &ltm);
}
 
/* In the default locale, the date and time representation fits in 26
bytes. However, other locales might need more space. */
#define CSZ 100
 
extern void fdate (char **, gfc_charlen_type *);
export_proto(fdate);
 
void
fdate (char ** date, gfc_charlen_type * date_len)
{
time_t now = time(NULL);
*date = get_mem (CSZ);
*date_len = strctime (*date, CSZ, &now);
}
 
 
extern void fdate_sub (char *, gfc_charlen_type);
export_proto(fdate_sub);
 
void
fdate_sub (char * date, gfc_charlen_type date_len)
{
time_t now = time(NULL);
char *s = get_mem (date_len + 1);
size_t n = strctime (s, date_len + 1, &now);
fstrcpy (date, date_len, s, n);
free (s);
}
 
 
 
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)
{
time_t now = t;
*date = get_mem (CSZ);
*date_len = strctime (*date, CSZ, &now);
}
 
 
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)
{
time_t now = *t;
char *s = get_mem (date_len + 1);
size_t n = strctime (s, date_len + 1, &now);
fstrcpy (date, date_len, s, n);
free (s);
}
/etime.c
0,0 → 1,73
/* Implementation of the ETIME intrinsic.
Copyright (C) 2004, 2005, 2006, 2007, 2009, 2011 Free Software
Foundation, Inc.
Contributed by Steven G. Kargl <kargls@comcast.net>.
 
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"
#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 (((GFC_DESCRIPTOR_EXTENT(t,0))) < 2)
runtime_error ("Insufficient number of elements in TARRAY.");
 
if (gf_cputime (&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 += GFC_DESCRIPTOR_STRIDE(t,0);
*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;
}
/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
/cpu_time.c
0,0 → 1,109
/* Implementation of the CPU_TIME intrinsic.
Copyright (C) 2003, 2007, 2009, 2010, 2011 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"
#include "time_1.h"
 
 
static void
__cpu_time_1 (long *sec, long *usec)
{
long user_sec, user_usec, system_sec, system_usec;
if (gf_cputime (&user_sec, &user_usec, &system_sec, &system_usec) == 0)
{
*sec = user_sec + system_sec;
*usec = user_usec + system_usec;
}
else
{
*sec = -1;
*usec = 0;
}
}
 
 
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_LITERAL(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_LITERAL(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_LITERAL(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_LITERAL(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;
}
/malloc.c
0,0 → 1,47
/* Implementation of the MALLOC and FREE intrinsics
Copyright (C) 2005, 2007, 2009, 2011 Free Software Foundation, Inc.
Contributed by François-Xavier Coudert <coudert@clipper.ens.fr>
 
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"
#include <stdlib.h>
 
 
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);
}
/spread_generic.c
0,0 → 1,652
/* Generic implementation of the SPREAD intrinsic
Copyright 2002, 2005, 2006, 2007, 2009, 2010 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)
{
/* 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;
index_type size;
 
size = GFC_DESCRIPTOR_SIZE(source);
 
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. */
 
size_t ub, stride;
 
ret->dtype = (source->dtype & ~GFC_DTYPE_RANK_MASK) | rrank;
dim = 0;
rs = 1;
for (n = 0; n < rrank; n++)
{
stride = rs;
if (n == *along - 1)
{
ub = ncopies - 1;
rdelta = rs * size;
rs *= ncopies;
}
else
{
count[dim] = 0;
extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim);
sstride[dim] = GFC_DESCRIPTOR_STRIDE_BYTES(source,dim);
rstride[dim] = rs * size;
 
ub = extent[dim]-1;
rs *= extent[dim];
dim++;
}
 
GFC_DIMENSION_SET(ret->dim[n], 0, ub, stride);
}
ret->offset = 0;
ret->data = internal_malloc_size (rs * size);
 
if (rs <= 0)
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 = GFC_DESCRIPTOR_EXTENT(ret,n);
if (n == *along - 1)
{
rdelta = GFC_DESCRIPTOR_STRIDE_BYTES(ret,n);
 
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] = GFC_DESCRIPTOR_EXTENT(source,dim);
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] = GFC_DESCRIPTOR_STRIDE_BYTES(source,dim);
rstride[dim] = GFC_DESCRIPTOR_STRIDE_BYTES(ret,n);
dim++;
}
}
}
else
{
for (n = 0; n < rrank; n++)
{
if (n == *along - 1)
{
rdelta = GFC_DESCRIPTOR_STRIDE_BYTES(ret,n);
}
else
{
count[dim] = 0;
extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim);
if (extent[dim] <= 0)
zero_sized = 1;
sstride[dim] = GFC_DESCRIPTOR_STRIDE_BYTES(source,dim);
rstride[dim] = GFC_DESCRIPTOR_STRIDE_BYTES(ret,n);
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)
{
int n;
int ncopies = *pncopies;
char * dest;
size_t size;
 
size = GFC_DESCRIPTOR_SIZE(ret);
 
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;
GFC_DIMENSION_SET(ret->dim[0], 0, ncopies - 1, 1);
}
else
{
if (ncopies - 1 > (GFC_DESCRIPTOR_EXTENT(ret,0) - 1)
/ GFC_DESCRIPTOR_STRIDE(ret,0))
runtime_error ("dim too large in spread()");
}
 
for (n = 0; n < ncopies; n++)
{
dest = (char*)(ret->data + n * GFC_DESCRIPTOR_STRIDE_BYTES(ret,0));
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;
 
/* FIXME: This here is a hack, which will have to be removed when
the array descriptor is reworked. Currently, we don't store the
kind value for the type, but only the size. Because on targets with
__float128, we have sizeof(logn double) == sizeof(__float128),
we cannot discriminate here and have to fall back to the generic
handling (which is suboptimal). */
#if !defined(GFC_REAL_16_IS_FLOAT128)
# 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
#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;
 
/* FIXME: This here is a hack, which will have to be removed when
the array descriptor is reworked. Currently, we don't store the
kind value for the type, but only the size. Because on targets with
__float128, we have sizeof(logn double) == sizeof(__float128),
we cannot discriminate here and have to fall back to the generic
handling (which is suboptimal). */
#if !defined(GFC_REAL_16_IS_FLOAT128)
# 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
#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);
}
 
 
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 __attribute__((unused)))
{
spread_internal (ret, source, along, pncopies);
}
 
 
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 __attribute__((unused)))
{
spread_internal (ret, source, along, pncopies);
}
 
 
/* 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;
 
/* FIXME: This here is a hack, which will have to be removed when
the array descriptor is reworked. Currently, we don't store the
kind value for the type, but only the size. Because on targets with
__float128, we have sizeof(logn double) == sizeof(__float128),
we cannot discriminate here and have to fall back to the generic
handling (which is suboptimal). */
#if !defined(GFC_REAL_16_IS_FLOAT128)
# 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
#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;
 
/* FIXME: This here is a hack, which will have to be removed when
the array descriptor is reworked. Currently, we don't store the
kind value for the type, but only the size. Because on targets with
__float128, we have sizeof(logn double) == sizeof(__float128),
we cannot discriminate here and have to fall back to the generic
handling (which is suboptimal). */
#if !defined(GFC_REAL_16_IS_FLOAT128)
# 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
#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);
}
 
 
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 __attribute__((unused)))
{
if (!ret->dtype)
runtime_error ("return array missing descriptor in spread()");
spread_internal_scalar (ret, source, along, pncopies);
}
 
 
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 __attribute__((unused)))
{
if (!ret->dtype)
runtime_error ("return array missing descriptor in spread()");
spread_internal_scalar (ret, source, along, pncopies);
 
}
 
/stat.c
0,0 → 1,556
/* Implementation of the STAT and FSTAT intrinsics.
Copyright (C) 2004, 2005, 2006, 2007, 2009, 2011
Free Software Foundation, Inc.
Contributed by Steven G. Kargl <kargls@comcast.net>.
 
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"
 
#include <string.h>
#include <errno.h>
 
#ifdef HAVE_SYS_STAT_H
#include <sys/stat.h>
#endif
 
#include <stdlib.h>
 
 
#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 (GFC_DESCRIPTOR_EXTENT(sarray,0) < 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)
{
index_type stride = GFC_DESCRIPTOR_STRIDE(sarray,0);
 
/* Device ID */
sarray->data[0 * stride] = sb.st_dev;
 
/* Inode number */
sarray->data[1 * stride] = sb.st_ino;
 
/* File mode */
sarray->data[2 * stride] = sb.st_mode;
 
/* Number of (hard) links */
sarray->data[3 * stride] = sb.st_nlink;
 
/* Owner's uid */
sarray->data[4 * stride] = sb.st_uid;
 
/* Owner's gid */
sarray->data[5 * 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 * stride] = sb.st_rdev;
#else
sarray->data[6 * stride] = 0;
#endif
 
/* File size (bytes) */
sarray->data[7 * stride] = sb.st_size;
 
/* Last access time */
sarray->data[8 * stride] = sb.st_atime;
 
/* Last modification time */
sarray->data[9 * stride] = sb.st_mtime;
 
/* Last file status change time */
sarray->data[10 * stride] = sb.st_ctime;
 
/* Preferred I/O block size (-1 if not available) */
#if HAVE_STRUCT_STAT_ST_BLKSIZE
sarray->data[11 * stride] = sb.st_blksize;
#else
sarray->data[11 * stride] = -1;
#endif
 
/* Number of blocks allocated (-1 if not available) */
#if HAVE_STRUCT_STAT_ST_BLOCKS
sarray->data[12 * stride] = sb.st_blocks;
#else
sarray->data[12 * 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 (GFC_DESCRIPTOR_EXTENT(sarray,0) < 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)
{
index_type stride = GFC_DESCRIPTOR_STRIDE(sarray,0);
 
/* Device ID */
sarray->data[0] = sb.st_dev;
 
/* Inode number */
sarray->data[stride] = sb.st_ino;
 
/* File mode */
sarray->data[2 * stride] = sb.st_mode;
 
/* Number of (hard) links */
sarray->data[3 * stride] = sb.st_nlink;
 
/* Owner's uid */
sarray->data[4 * stride] = sb.st_uid;
 
/* Owner's gid */
sarray->data[5 * 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 * stride] = sb.st_rdev;
#else
sarray->data[6 * stride] = 0;
#endif
 
/* File size (bytes) */
sarray->data[7 * stride] = sb.st_size;
 
/* Last access time */
sarray->data[8 * stride] = sb.st_atime;
 
/* Last modification time */
sarray->data[9 * stride] = sb.st_mtime;
 
/* Last file status change time */
sarray->data[10 * stride] = sb.st_ctime;
 
/* Preferred I/O block size (-1 if not available) */
#if HAVE_STRUCT_STAT_ST_BLKSIZE
sarray->data[11 * stride] = sb.st_blksize;
#else
sarray->data[11 * stride] = -1;
#endif
 
/* Number of blocks allocated (-1 if not available) */
#if HAVE_STRUCT_STAT_ST_BLOCKS
sarray->data[12 * stride] = sb.st_blocks;
#else
sarray->data[12 * 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 (GFC_DESCRIPTOR_EXTENT(sarray,0) < 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)
{
index_type stride = GFC_DESCRIPTOR_STRIDE(sarray,0);
 
/* Device ID */
sarray->data[0 * stride] = sb.st_dev;
 
/* Inode number */
sarray->data[1 * stride] = sb.st_ino;
 
/* File mode */
sarray->data[2 * stride] = sb.st_mode;
 
/* Number of (hard) links */
sarray->data[3 * stride] = sb.st_nlink;
 
/* Owner's uid */
sarray->data[4 * stride] = sb.st_uid;
 
/* Owner's gid */
sarray->data[5 * 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 * stride] = sb.st_rdev;
#else
sarray->data[6 * stride] = 0;
#endif
 
/* File size (bytes) */
sarray->data[7 * stride] = sb.st_size;
 
/* Last access time */
sarray->data[8 * stride] = sb.st_atime;
 
/* Last modification time */
sarray->data[9 * stride] = sb.st_mtime;
 
/* Last file status change time */
sarray->data[10 * stride] = sb.st_ctime;
 
/* Preferred I/O block size (-1 if not available) */
#if HAVE_STRUCT_STAT_ST_BLKSIZE
sarray->data[11 * stride] = sb.st_blksize;
#else
sarray->data[11 * stride] = -1;
#endif
 
/* Number of blocks allocated (-1 if not available) */
#if HAVE_STRUCT_STAT_ST_BLOCKS
sarray->data[12 * stride] = sb.st_blocks;
#else
sarray->data[12 * 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 (GFC_DESCRIPTOR_EXTENT(sarray,0) < 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)
{
index_type stride = GFC_DESCRIPTOR_STRIDE(sarray,0);
 
/* Device ID */
sarray->data[0] = sb.st_dev;
 
/* Inode number */
sarray->data[stride] = sb.st_ino;
 
/* File mode */
sarray->data[2 * stride] = sb.st_mode;
 
/* Number of (hard) links */
sarray->data[3 * stride] = sb.st_nlink;
 
/* Owner's uid */
sarray->data[4 * stride] = sb.st_uid;
 
/* Owner's gid */
sarray->data[5 * 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 * stride] = sb.st_rdev;
#else
sarray->data[6 * stride] = 0;
#endif
 
/* File size (bytes) */
sarray->data[7 * stride] = sb.st_size;
 
/* Last access time */
sarray->data[8 * stride] = sb.st_atime;
 
/* Last modification time */
sarray->data[9 * stride] = sb.st_mtime;
 
/* Last file status change time */
sarray->data[10 * stride] = sb.st_ctime;
 
/* Preferred I/O block size (-1 if not available) */
#if HAVE_STRUCT_STAT_ST_BLKSIZE
sarray->data[11 * stride] = sb.st_blksize;
#else
sarray->data[11 * stride] = -1;
#endif
 
/* Number of blocks allocated (-1 if not available) */
#if HAVE_STRUCT_STAT_ST_BLOCKS
sarray->data[12 * stride] = sb.st_blocks;
#else
sarray->data[12 * 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
/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
/date_and_time.c
0,0 → 1,631
/* Implementation of the DATE_AND_TIME intrinsic.
Copyright (C) 2003, 2004, 2005, 2006, 2007, 2009, 2010, 2011
Free Software Foundation, Inc.
Contributed by Steven Bosscher.
 
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"
#include <string.h>
#include <assert.h>
#include <stdlib.h>
 
#include "time_1.h"
 
 
/* If the re-entrant version of gmtime is not available, provide a
fallback implementation. On some targets where the _r version is
not available, gmtime uses thread-local storage so it's
threadsafe. */
 
#ifndef HAVE_GMTIME_R
/* If _POSIX is defined gmtime_r gets defined by mingw-w64 headers. */
#ifdef gmtime_r
#undef gmtime_r
#endif
 
static struct tm *
gmtime_r (const time_t * timep, struct tm * result)
{
*result = *gmtime (timep);
return result;
}
#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.
It is an INTENT(OUT) argument. It is 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.
It is an INTENT(OUT) argument. It is 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.
It is an INTENT(OUT) argument. It is 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];
 
time_t lt;
struct tm local_time;
struct tm UTC_time;
 
long usecs;
 
if (!gf_gettime (&lt, &usecs))
{
values[7] = usecs / 1000;
 
localtime_r (&lt, &local_time);
gmtime_r (&lt, &UTC_time);
 
/* 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 (__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
{
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;
}
 
/* Copy the values into the arguments. */
if (__values)
{
index_type len, delta, elt_size;
 
elt_size = GFC_DESCRIPTOR_SIZE (__values);
len = GFC_DESCRIPTOR_EXTENT(__values,0);
delta = GFC_DESCRIPTOR_STRIDE(__values,0);
if (delta == 0)
delta = 1;
if (unlikely (len < VALUES_SIZE))
runtime_error ("Incorrect extent in VALUE argument to"
" DATE_AND_TIME intrinsic: is %ld, should"
" be >=%ld", (long int) len, (long int) 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)
fstrcpy (__zone, __zone_len, zone, ZONE_LEN);
 
if (__time)
fstrcpy (__time, __time_len, timec, TIME_LEN);
 
if (__date)
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) = ((BT_REAL << GFC_DTYPE_TYPE_SHIFT)
& GFC_DTYPE_TYPE_MASK) +
(4 << GFC_DTYPE_SIZE_SHIFT);
 
GFC_DIMENSION_SET(avalues->dim[0], 0, 7, 1);
 
date_and_time (NULL, NULL, NULL, avalues, 0, 0, 0);
 
free (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])
{
time_t lt;
struct tm local_time;
 
lt = time (NULL);
 
if (lt != (time_t) -1)
{
localtime_r (&lt, &local_time);
 
x[0] = local_time.tm_hour;
x[1] = local_time.tm_min;
x[2] = local_time.tm_sec;
}
}
 
extern void itime_i4 (gfc_array_i4 *);
export_proto(itime_i4);
 
void
itime_i4 (gfc_array_i4 *__values)
{
int x[3], i;
index_type len, delta;
GFC_INTEGER_4 *vptr;
/* Call helper function. */
itime0(x);
 
/* Copy the value into the array. */
len = GFC_DESCRIPTOR_EXTENT(__values,0);
assert (len >= 3);
delta = GFC_DESCRIPTOR_STRIDE(__values,0);
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;
index_type len, delta;
GFC_INTEGER_8 *vptr;
/* Call helper function. */
itime0(x);
 
/* Copy the value into the array. */
len = GFC_DESCRIPTOR_EXTENT(__values,0);
assert (len >= 3);
delta = GFC_DESCRIPTOR_STRIDE(__values,0);
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])
{
time_t lt;
struct tm local_time;
 
lt = time (NULL);
 
if (lt != (time_t) -1)
{
localtime_r (&lt, &local_time);
 
x[0] = local_time.tm_mday;
x[1] = 1 + local_time.tm_mon;
x[2] = 1900 + local_time.tm_year;
}
}
 
extern void idate_i4 (gfc_array_i4 *);
export_proto(idate_i4);
 
void
idate_i4 (gfc_array_i4 *__values)
{
int x[3], i;
index_type len, delta;
GFC_INTEGER_4 *vptr;
/* Call helper function. */
idate0(x);
 
/* Copy the value into the array. */
len = GFC_DESCRIPTOR_EXTENT(__values,0);
assert (len >= 3);
delta = GFC_DESCRIPTOR_STRIDE(__values,0);
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;
index_type len, delta;
GFC_INTEGER_8 *vptr;
/* Call helper function. */
idate0(x);
 
/* Copy the value into the array. */
len = GFC_DESCRIPTOR_EXTENT(__values,0);
assert (len >= 3);
delta = GFC_DESCRIPTOR_STRIDE(__values,0);
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_r(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;
 
gmtime_r (t, &lt);
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;
index_type 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 = GFC_DESCRIPTOR_EXTENT(tarray,0);
assert (len >= 9);
delta = GFC_DESCRIPTOR_STRIDE(tarray,0);
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;
index_type 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 = GFC_DESCRIPTOR_EXTENT(tarray,0);
assert (len >= 9);
delta = GFC_DESCRIPTOR_STRIDE(tarray,0);
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_r(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;
 
localtime_r (t, &lt);
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;
index_type 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 = GFC_DESCRIPTOR_EXTENT(tarray,0);
assert (len >= 9);
delta = GFC_DESCRIPTOR_STRIDE(tarray,0);
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;
index_type 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 = GFC_DESCRIPTOR_EXTENT(tarray,0);
assert (len >= 9);
delta = GFC_DESCRIPTOR_STRIDE(tarray,0);
if (delta == 0)
delta = 1;
 
vptr = tarray->data;
for (i = 0; i < 9; i++, vptr += delta)
*vptr = x[i];
}
 
 
/unpack_generic.c
0,0 → 1,630
/* Generic implementation of the UNPACK intrinsic
Copyright 2002, 2003, 2004, 2005, 2007, 2009, 2010
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>
 
/* All the bounds checking for unpack in one function. If field is NULL,
we don't check it, for the unpack0 functions. */
 
static void
unpack_bounds (gfc_array_char *ret, const gfc_array_char *vector,
const gfc_array_l1 *mask, const gfc_array_char *field)
{
index_type vec_size, mask_count;
vec_size = size0 ((array_t *) vector);
mask_count = count_0 (mask);
if (vec_size < mask_count)
runtime_error ("Incorrect size of return value in UNPACK"
" intrinsic: should be at least %ld, is"
" %ld", (long int) mask_count,
(long int) vec_size);
 
if (field != NULL)
bounds_equal_extents ((array_t *) field, (array_t *) mask,
"FIELD", "UNPACK");
 
if (ret->data != NULL)
bounds_equal_extents ((array_t *) ret, (array_t *) mask,
"return value", "UNPACK");
 
}
 
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)
{
/* 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;
GFC_DIMENSION_SET(ret->dim[n], 0,
GFC_DESCRIPTOR_EXTENT(mask,n) - 1, rs);
extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n);
empty = empty || extent[n] <= 0;
rstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(ret, n);
fstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(field, n);
mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n);
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] = GFC_DESCRIPTOR_EXTENT(ret,n);
empty = empty || extent[n] <= 0;
rstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(ret, n);
fstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(field, n);
mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n);
}
}
 
if (empty)
return;
 
vstride0 = GFC_DESCRIPTOR_STRIDE_BYTES(vector,0);
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;
 
if (unlikely(compile_options.bounds_check))
unpack_bounds (ret, vector, mask, field);
 
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;
 
/* FIXME: This here is a hack, which will have to be removed when
the array descriptor is reworked. Currently, we don't store the
kind value for the type, but only the size. Because on targets with
__float128, we have sizeof(logn double) == sizeof(__float128),
we cannot discriminate here and have to fall back to the generic
handling (which is suboptimal). */
#if !defined(GFC_REAL_16_IS_FLOAT128)
# 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
#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;
 
/* FIXME: This here is a hack, which will have to be removed when
the array descriptor is reworked. Currently, we don't store the
kind value for the type, but only the size. Because on targets with
__float128, we have sizeof(logn double) == sizeof(__float128),
we cannot discriminate here and have to fall back to the generic
handling (which is suboptimal). */
#if !defined(GFC_REAL_16_IS_FLOAT128)
# 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
#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);
}
 
 
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 __attribute__((unused)))
{
 
if (unlikely(compile_options.bounds_check))
unpack_bounds (ret, vector, mask, field);
 
unpack_internal (ret, vector, mask, field, vector_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 __attribute__((unused)))
{
 
if (unlikely(compile_options.bounds_check))
unpack_bounds (ret, vector, mask, field);
 
unpack_internal (ret, vector, mask, field,
vector_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;
 
if (unlikely(compile_options.bounds_check))
unpack_bounds (ret, vector, mask, NULL);
 
type_size = GFC_DTYPE_TYPE_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;
 
/* FIXME: This here is a hack, which will have to be removed when
the array descriptor is reworked. Currently, we don't store the
kind value for the type, but only the size. Because on targets with
__float128, we have sizeof(logn double) == sizeof(__float128),
we cannot discriminate here and have to fall back to the generic
handling (which is suboptimal). */
#if !defined(GFC_REAL_16_IS_FLOAT128)
# 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
#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;
 
/* FIXME: This here is a hack, which will have to be removed when
the array descriptor is reworked. Currently, we don't store the
kind value for the type, but only the size. Because on targets with
__float128, we have sizeof(logn double) == sizeof(__float128),
we cannot discriminate here and have to fall back to the generic
handling (which is suboptimal). */
#if !defined(GFC_REAL_16_IS_FLOAT128)
# 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
#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));
}
 
 
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;
 
if (unlikely(compile_options.bounds_check))
unpack_bounds (ret, vector, mask, NULL);
 
memset (&tmp, 0, sizeof (tmp));
tmp.dtype = 0;
tmp.data = field;
unpack_internal (ret, vector, mask, &tmp, vector_length);
}
 
 
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;
 
if (unlikely(compile_options.bounds_check))
unpack_bounds (ret, vector, mask, NULL);
 
memset (&tmp, 0, sizeof (tmp));
tmp.dtype = 0;
tmp.data = field;
unpack_internal (ret, vector, mask, &tmp,
vector_length * sizeof (gfc_char4_t));
}
/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 extent;
extent = GFC_DESCRIPTOR_EXTENT(pointer,n);
 
if (extent != GFC_DESCRIPTOR_EXTENT(target,n))
return 0;
if (GFC_DESCRIPTOR_STRIDE(pointer,n) != GFC_DESCRIPTOR_STRIDE(target,n) && extent != 1)
return 0;
if (extent <= 0)
return 0;
}
 
return 1;
}
/eoshift0.c
0,0 → 1,299
/* 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;
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->offset = 0;
ret->dtype = array->dtype;
for (i = 0; i < GFC_DESCRIPTOR_RANK (array); i++)
{
index_type ub, str;
 
ub = GFC_DESCRIPTOR_EXTENT(array,i) - 1;
 
if (i == 0)
str = 1;
else
str = GFC_DESCRIPTOR_EXTENT(ret,i-1)
* GFC_DESCRIPTOR_STRIDE(ret,i-1);
 
GFC_DIMENSION_SET(ret->dim[i], 0, ub, str);
 
}
 
/* internal_malloc_size allocates a single byte for zero size. */
ret->data = internal_malloc_size (size * arraysize);
}
else if (unlikely (compile_options.bounds_check))
{
bounds_equal_extents ((array_t *) ret, (array_t *) array,
"return value", "EOSHIFT");
}
 
if (arraysize == 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 = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim);
if (roffset == 0)
roffset = size;
soffset = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim);
if (soffset == 0)
soffset = size;
len = GFC_DESCRIPTOR_EXTENT(array,dim);
}
else
{
count[n] = 0;
extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim);
rstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim);
sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim);
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
/reshape_generic.c
0,0 → 1,388
/* 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 = GFC_DESCRIPTOR_EXTENT(shape,0);
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 * GFC_DESCRIPTOR_STRIDE(shape,0)];
if (shape_data[n] <= 0)
{
shape_data[n] = 0;
shape_empty = 1;
}
}
 
if (ret->data == NULL)
{
index_type alloc_size;
 
rs = 1;
for (n = 0; n < rdim; n++)
{
rex = shape_data[n];
 
GFC_DIMENSION_SET(ret->dim[n],0,rex - 1,rs);
 
rs *= rex;
}
ret->offset = 0;
 
if (unlikely (rs < 1))
alloc_size = 1;
else
alloc_size = rs * size;
 
ret->data = internal_malloc_size (alloc_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] = GFC_DESCRIPTOR_STRIDE(pad,n);
pextent[n] = GFC_DESCRIPTOR_EXTENT(pad,n);
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 = GFC_DESCRIPTOR_EXTENT(ret,n);
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 = GFC_DESCRIPTOR_EXTENT(source,n);
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 * GFC_DESCRIPTOR_STRIDE(order,0)] - 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 * GFC_DESCRIPTOR_STRIDE(order,0)] - 1;
else
dim = n;
 
rcount[n] = 0;
rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,dim);
rextent[n] = GFC_DESCRIPTOR_EXTENT(ret,dim);
 
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] = GFC_DESCRIPTOR_STRIDE(source,n);
sextent[n] = GFC_DESCRIPTOR_EXTENT(source,n);
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));
}
/eoshift2.c
0,0 → 1,324
/* 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,
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;
index_type size;
 
/* The compiler cannot figure out that these are set, initialize
them to avoid warnings. */
len = 0;
soffset = 0;
roffset = 0;
 
size = GFC_DESCRIPTOR_SIZE (array);
 
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++)
{
index_type ub, str;
 
ub = GFC_DESCRIPTOR_EXTENT(array,i) - 1;
 
if (i == 0)
str = 1;
else
str = GFC_DESCRIPTOR_EXTENT(ret,i-1)
* GFC_DESCRIPTOR_STRIDE(ret,i-1);
 
GFC_DIMENSION_SET(ret->dim[i], 0, ub, str);
 
/* internal_malloc_size allocates a single byte for zero size. */
ret->data = internal_malloc_size (size * arraysize);
 
}
}
else if (unlikely (compile_options.bounds_check))
{
bounds_equal_extents ((array_t *) ret, (array_t *) array,
"return value", "EOSHIFT");
}
 
if (arraysize == 0)
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 = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim);
if (roffset == 0)
roffset = size;
soffset = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim);
if (soffset == 0)
soffset = size;
len = GFC_DESCRIPTOR_EXTENT(array,dim);
}
else
{
count[n] = 0;
extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim);
rstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(ret,dim);
sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim);
if (bound)
bstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(bound,n);
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, \
"\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 __attribute__((unused)), \
GFC_INTEGER_4 bound_length __attribute__((unused))) \
{ \
eoshift2 (ret, array, *pshift, pbound, pdim ? *pdim : 1, \
" ", 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 __attribute__((unused)), \
GFC_INTEGER_4 bound_length __attribute__((unused))) \
{ \
static const gfc_char4_t space = (unsigned char) ' '; \
eoshift2 (ret, array, *pshift, pbound, pdim ? *pdim : 1, \
(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
/time_1.h
0,0 → 1,218
/* Wrappers for platform timing functions.
Copyright (C) 2003, 2007, 2009, 2011 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/>. */
 
#ifndef LIBGFORTRAN_TIME_H
#define LIBGFORTRAN_TIME_H
 
#ifdef HAVE_UNISTD_H
#include <unistd.h>
#endif
 
#include <errno.h>
 
/* 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 HAVE_SYS_TIME_H
#include <sys/time.h>
#endif
 
#include <time.h>
 
#ifdef HAVE_SYS_TYPES_H
#include <sys/types.h>
#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 */
 
/* 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 */
 
 
/* If the re-entrant version of localtime is not available, provide a
fallback implementation. On some targets where the _r version is
not available, localtime uses thread-local storage so it's
threadsafe. */
 
#ifndef HAVE_LOCALTIME_R
/* If _POSIX is defined localtime_r gets defined by mingw-w64 headers. */
#ifdef localtime_r
#undef localtime_r
#endif
 
static inline struct tm *
localtime_r (const time_t * timep, struct tm * result)
{
*result = *localtime (timep);
return result;
}
#endif
 
 
/* Helper function for the actual implementation of the DTIME, ETIME and
CPU_TIME intrinsics. Returns 0 for success or -1 if no
CPU time could be computed. */
 
#ifdef __MINGW32__
 
#define WIN32_LEAN_AND_MEAN
#include <windows.h>
 
static inline int
gf_cputime (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
gf_cputime (long *user_sec, long *user_usec, long *system_sec, long *system_usec)
{
#if defined (HAVE_GETRUSAGE) && defined (HAVE_SYS_RESOURCE_H)
struct rusage usage;
int err;
err = getrusage (RUSAGE_SELF, &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 err;
 
#elif defined HAVE_TIMES
struct tms buf;
clock_t err;
err = times (&buf);
*user_sec = buf.tms_utime / HZ;
*user_usec = buf.tms_utime % HZ * (1000000. / HZ);
*system_sec = buf.tms_stime / HZ;
*system_usec = buf.tms_stime % HZ * (1000000. / HZ);
if ((err == (clock_t) -1) && errno != 0)
return -1;
return 0;
 
#else
clock_t c = clock ();
*user_sec = c / CLOCKS_PER_SEC;
*user_usec = c % CLOCKS_PER_SEC * (1000000. / CLOCKS_PER_SEC);
*system_sec = *system_usec = 0;
if (c == (clock_t) -1)
return -1;
return 0;
 
#endif
}
 
#endif
 
 
/* Realtime clock with microsecond resolution, falling back to less
precise functions if the target does not support gettimeofday().
 
Arguments:
secs - OUTPUT, seconds
usecs - OUTPUT, microseconds
 
The OUTPUT arguments shall represent the number of seconds and
nanoseconds since the Epoch.
 
Return value: 0 for success, -1 for error. In case of error, errno
is set.
*/
static inline int
gf_gettime (time_t * secs, long * usecs)
{
#ifdef HAVE_GETTIMEOFDAY
struct timeval tv;
int err;
err = gettimeofday (&tv, NULL);
*secs = tv.tv_sec;
*usecs = tv.tv_usec;
return err;
#else
time_t t = time (NULL);
*secs = t;
*usecs = 0;
if (t == ((time_t)-1))
return -1;
return 0;
#endif
}
 
 
#endif /* LIBGFORTRAN_TIME_H */
/system.c
0,0 → 1,61
/* Implementation of the SYSTEM intrinsic.
Copyright (C) 2004, 2007, 2009, 2011 Free Software Foundation, Inc.
Contributed by Tobias Schlüter.
 
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, 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 <stdlib.h>
 
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;
}
/iso_c_binding.c
0,0 → 1,189
/* Implementation of the ISO_C_BINDING library helper functions.
Copyright (C) 2007, 2009, 2010 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., BT_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. Access is via the array
descrptor macros. 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)
{
index_type source_stride, size;
index_type str = 1;
char *p;
 
f_ptr_out->offset = str;
shapeSize = 0;
p = shape->data;
size = GFC_DESCRIPTOR_SIZE(shape);
 
source_stride = GFC_DESCRIPTOR_STRIDE_BYTES(shape,0);
 
/* shape's length (rank of the output array) */
shapeSize = GFC_DESCRIPTOR_EXTENT(shape,0);
for (i = 0; i < shapeSize; i++)
{
index_type ub;
 
/* Have to allow for the SHAPE array to be any valid kind for
an INTEGER type. */
switch (size)
{
#ifdef HAVE_GFC_INTEGER_1
case 1:
ub = *((GFC_INTEGER_1 *) p);
break;
#endif
#ifdef HAVE_GFC_INTEGER_2
case 2:
ub = *((GFC_INTEGER_2 *) p);
break;
#endif
#ifdef HAVE_GFC_INTEGER_4
case 4:
ub = *((GFC_INTEGER_4 *) p);
break;
#endif
#ifdef HAVE_GFC_INTEGER_8
case 8:
ub = *((GFC_INTEGER_8 *) p);
break;
#endif
#ifdef HAVE_GFC_INTEGER_16
case 16:
ub = *((GFC_INTEGER_16 *) p);
break;
#endif
default:
internal_error (NULL, "c_f_pointer_u0: Invalid size");
}
p += source_stride;
 
if (i != 0)
{
str = str * GFC_DESCRIPTOR_EXTENT(f_ptr_out,i-1);
f_ptr_out->offset += str;
}
 
/* Lower bound is 1, as specified by the draft. */
GFC_DIMENSION_SET(f_ptr_out->dim[i], 1, ub, str);
}
 
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
| (BT_DERIVED << GFC_DTYPE_TYPE_SHIFT);
}
}
/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;
}
/kill.c
0,0 → 1,92
/* Implementation of the KILL g77 intrinsic.
Copyright (C) 2005, 2007, 2009, 2011 Free Software Foundation, Inc.
Contributed by François-Xavier Coudert <coudert@clipper.ens.fr>
 
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"
#include <errno.h>
#include <signal.h>
 
 
/* 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
/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
/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;
}
}
/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);
}
/execute_command_line.c
0,0 → 1,180
/* Implementation of the EXECUTE_COMMAND_LINE intrinsic.
Copyright (C) 2009, 2011 Free Software Foundation, Inc.
Contributed by François-Xavier Coudert.
 
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, 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 <stdbool.h>
#include <stdlib.h>
 
#ifdef HAVE_UNISTD_H
#include <unistd.h>
#endif
#ifdef HAVE_SYS_WAIT_H
#include <sys/wait.h>
#endif
 
 
enum { EXEC_SYNCHRONOUS = -2, EXEC_NOERROR = 0, EXEC_SYSTEMFAILED,
EXEC_CHILDFAILED };
static const char *cmdmsg_values[] =
{ "",
"Termination status of the command-language interpreter cannot be obtained",
"Execution of child process impossible" };
 
 
 
static void
set_cmdstat (int *cmdstat, int value)
{
if (cmdstat)
*cmdstat = value;
else if (value > EXEC_NOERROR)
runtime_error ("Could not execute command line");
}
 
 
static void
execute_command_line (const char *command, bool wait, int *exitstat,
int *cmdstat, char *cmdmsg,
gfc_charlen_type command_len,
gfc_charlen_type cmdmsg_len)
{
/* Transform the Fortran string to a C string. */
char cmd[command_len + 1];
memcpy (cmd, command, command_len);
cmd[command_len] = '\0';
 
/* Flush all I/O units before executing the command. */
flush_all_units();
 
#if defined(HAVE_FORK)
if (!wait)
{
/* Asynchronous execution. */
pid_t pid;
 
set_cmdstat (cmdstat, EXEC_NOERROR);
 
if ((pid = fork()) < 0)
set_cmdstat (cmdstat, EXEC_CHILDFAILED);
else if (pid == 0)
{
/* Child process. */
int res = system (cmd);
_exit (WIFEXITED(res) ? WEXITSTATUS(res) : res);
}
}
else
#endif
{
/* Synchronous execution. */
int res = system (cmd);
 
if (res == -1)
set_cmdstat (cmdstat, EXEC_SYSTEMFAILED);
else if (!wait)
set_cmdstat (cmdstat, EXEC_SYNCHRONOUS);
else
set_cmdstat (cmdstat, EXEC_NOERROR);
 
if (res != -1)
{
#if defined(WEXITSTATUS) && defined(WIFEXITED)
*exitstat = WIFEXITED(res) ? WEXITSTATUS(res) : res;
#else
*exitstat = res;
#endif
}
}
 
/* Now copy back to the Fortran string if needed. */
if (cmdstat && *cmdstat > EXEC_NOERROR)
{
if (cmdmsg)
fstrcpy (cmdmsg, cmdmsg_len, cmdmsg_values[*cmdstat],
strlen (cmdmsg_values[*cmdstat]));
else
runtime_error ("Failure in EXECUTE_COMMAND_LINE: %s",
cmdmsg_values[*cmdstat]);
}
}
 
 
extern void
execute_command_line_i4 (const char *command, GFC_LOGICAL_4 *wait,
GFC_INTEGER_4 *exitstat, GFC_INTEGER_4 *cmdstat,
char *cmdmsg, gfc_charlen_type command_len,
gfc_charlen_type cmdmsg_len);
export_proto(execute_command_line_i4);
 
void
execute_command_line_i4 (const char *command, GFC_LOGICAL_4 *wait,
GFC_INTEGER_4 *exitstat, GFC_INTEGER_4 *cmdstat,
char *cmdmsg, gfc_charlen_type command_len,
gfc_charlen_type cmdmsg_len)
{
bool w = wait ? *wait : true;
int estat, estat_initial, cstat;
 
if (exitstat)
estat_initial = estat = *exitstat;
 
execute_command_line (command, w, &estat, cmdstat ? &cstat : NULL,
cmdmsg, command_len, cmdmsg_len);
 
if (exitstat && estat != estat_initial)
*exitstat = estat;
if (cmdstat)
*cmdstat = cstat;
}
 
 
extern void
execute_command_line_i8 (const char *command, GFC_LOGICAL_8 *wait,
GFC_INTEGER_8 *exitstat, GFC_INTEGER_8 *cmdstat,
char *cmdmsg, gfc_charlen_type command_len,
gfc_charlen_type cmdmsg_len);
export_proto(execute_command_line_i8);
 
void
execute_command_line_i8 (const char *command, GFC_LOGICAL_8 *wait,
GFC_INTEGER_8 *exitstat, GFC_INTEGER_8 *cmdstat,
char *cmdmsg, gfc_charlen_type command_len,
gfc_charlen_type cmdmsg_len)
{
bool w = wait ? *wait : true;
int estat, estat_initial, cstat;
 
if (exitstat)
estat_initial = estat = *exitstat;
 
execute_command_line (command, w, &estat, cmdstat ? &cstat : NULL,
cmdmsg, command_len, cmdmsg_len);
 
if (exitstat && estat != estat_initial)
*exitstat = estat;
if (cmdstat)
*cmdstat = cstat;
}
/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 = GFC_DESCRIPTOR_EXTENT(array,n);
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 = GFC_DESCRIPTOR_EXTENT(array,dim);
if (size < 0)
size = 0;
return size;
}
/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
/signal.c
0,0 → 1,229
/* Implementation of the SIGNAL and ALARM g77 intrinsics
Copyright (C) 2005, 2007, 2009, 2011 Free Software Foundation, Inc.
Contributed by François-Xavier Coudert <coudert@clipper.ens.fr>
 
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"
 
#ifdef HAVE_UNISTD_H
#include <unistd.h>
#endif
 
#include <signal.h>
 
#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)
{
intptr_t ret;
 
if (status != NULL)
{
ret = (intptr_t) signal (*number, handler);
*status = (int) ret;
}
else
signal (*number, handler);
}
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)
{
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);
}
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)
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)
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)
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)
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);
 
/random.c
0,0 → 1,798
/* Implementation of the RANDOM intrinsics
Copyright 2002, 2004, 2005, 2006, 2007, 2009, 2010
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 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_LITERAL(0x1.p-32);
}
 
static 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_LITERAL(0x1.p-64);
}
 
#ifdef HAVE_GFC_REAL_10
 
static 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_LITERAL(0x1.p-64);
}
#endif
 
#ifdef HAVE_GFC_REAL_16
 
/* For REAL(KIND=16), we only need to mask off the lower bits. */
 
static 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_LITERAL(0x1.p-64)
+ (GFC_REAL_16) v2 * GFC_REAL_16_LITERAL(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] = GFC_DESCRIPTOR_STRIDE(x,n);
extent[n] = GFC_DESCRIPTOR_EXTENT(x,n);
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] = GFC_DESCRIPTOR_STRIDE(x,n);
extent[n] = GFC_DESCRIPTOR_EXTENT(x,n);
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] = GFC_DESCRIPTOR_STRIDE(x,n);
extent[n] = GFC_DESCRIPTOR_EXTENT(x,n);
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] = GFC_DESCRIPTOR_STRIDE(x,n);
extent[n] = GFC_DESCRIPTOR_EXTENT(x,n);
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 (GFC_DESCRIPTOR_EXTENT(put,0) < 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) * GFC_DESCRIPTOR_STRIDE(put,0)]),
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 (GFC_DESCRIPTOR_EXTENT(get,0) < 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) * GFC_DESCRIPTOR_STRIDE(get,0)]),
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 (GFC_DESCRIPTOR_EXTENT(put,0) < 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 * GFC_DESCRIPTOR_STRIDE(put,0)]),
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 (GFC_DESCRIPTOR_EXTENT(get,0) < 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 * GFC_DESCRIPTOR_STRIDE(get,0)]), &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
/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
/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
/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
/clock.c
0,0 → 1,52
/* Implementation of the MCLOCK and MCLOCK8 g77 intrinsics.
Copyright (C) 2006, 2007, 2009, 2011 Free Software Foundation, Inc.
Contributed by François-Xavier Coudert <coudert@clipper.ens.fr>
 
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"
#include <time.h>
 
 
/* INTEGER(KIND=4) FUNCTION MCLOCK() */
 
extern GFC_INTEGER_4 mclock (void);
export_proto(mclock);
 
GFC_INTEGER_4
mclock (void)
{
return (GFC_INTEGER_4) clock ();
}
 
 
/* INTEGER(KIND=8) FUNCTION MCLOCK8() */
 
extern GFC_INTEGER_8 mclock8 (void);
export_proto(mclock8);
 
GFC_INTEGER_8
mclock8 (void)
{
return (GFC_INTEGER_8) clock ();
}
 
/args.c
0,0 → 1,270
/* Implementation of the GETARG and IARGC g77, and
corresponding F2003, intrinsics.
Copyright (C) 2004, 2005, 2007, 2009, 2010
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)
stat_flag = GFC_GC_VALUE_TOO_SHORT;
 
memcpy (value, argv[*number], arglen <= value_len ? arglen : value_len);
}
 
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;
}
/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

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.