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/runtime
    from Rev 733 to Rev 783
    ↔ Reverse comparison
  •

Rev 733 → Rev 783

/in_pack_generic.c
0,0 → 1,218
/* Generic helper function for repacking arrays.
Copyright 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.
 
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>
 
extern void *internal_pack (gfc_array_char *);
export_proto(internal_pack);
 
void *
internal_pack (gfc_array_char * source)
{
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type stride[GFC_MAX_DIMENSIONS];
index_type stride0;
index_type dim;
index_type ssize;
const char *src;
char *dest;
void *destptr;
int n;
int packed;
index_type size;
index_type type_size;
 
type_size = GFC_DTYPE_TYPE_SIZE(source);
size = GFC_DESCRIPTOR_SIZE (source);
switch (type_size)
{
case GFC_DTYPE_INTEGER_1:
case GFC_DTYPE_LOGICAL_1:
case GFC_DTYPE_DERIVED_1:
return internal_pack_1 ((gfc_array_i1 *) source);
 
case GFC_DTYPE_INTEGER_2:
case GFC_DTYPE_LOGICAL_2:
return internal_pack_2 ((gfc_array_i2 *) source);
 
case GFC_DTYPE_INTEGER_4:
case GFC_DTYPE_LOGICAL_4:
return internal_pack_4 ((gfc_array_i4 *) source);
case GFC_DTYPE_INTEGER_8:
case GFC_DTYPE_LOGICAL_8:
return internal_pack_8 ((gfc_array_i8 *) source);
 
#if defined(HAVE_GFC_INTEGER_16)
case GFC_DTYPE_INTEGER_16:
case GFC_DTYPE_LOGICAL_16:
return internal_pack_16 ((gfc_array_i16 *) source);
#endif
case GFC_DTYPE_REAL_4:
return internal_pack_r4 ((gfc_array_r4 *) source);
 
case GFC_DTYPE_REAL_8:
return internal_pack_r8 ((gfc_array_r8 *) source);
 
/* 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)
# if defined (HAVE_GFC_REAL_10)
case GFC_DTYPE_REAL_10:
return internal_pack_r10 ((gfc_array_r10 *) source);
# endif
 
# if defined (HAVE_GFC_REAL_16)
case GFC_DTYPE_REAL_16:
return internal_pack_r16 ((gfc_array_r16 *) source);
# endif
#endif
 
case GFC_DTYPE_COMPLEX_4:
return internal_pack_c4 ((gfc_array_c4 *) source);
case GFC_DTYPE_COMPLEX_8:
return internal_pack_c8 ((gfc_array_c8 *) source);
 
/* 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)
# if defined (HAVE_GFC_COMPLEX_10)
case GFC_DTYPE_COMPLEX_10:
return internal_pack_c10 ((gfc_array_c10 *) source);
# endif
 
# if defined (HAVE_GFC_COMPLEX_16)
case GFC_DTYPE_COMPLEX_16:
return internal_pack_c16 ((gfc_array_c16 *) source);
# endif
#endif
 
case GFC_DTYPE_DERIVED_2:
if (GFC_UNALIGNED_2(source->data))
break;
else
return internal_pack_2 ((gfc_array_i2 *) source);
 
case GFC_DTYPE_DERIVED_4:
if (GFC_UNALIGNED_4(source->data))
break;
else
return internal_pack_4 ((gfc_array_i4 *) source);
 
case GFC_DTYPE_DERIVED_8:
if (GFC_UNALIGNED_8(source->data))
break;
else
return internal_pack_8 ((gfc_array_i8 *) source);
 
#ifdef HAVE_GFC_INTEGER_16
case GFC_DTYPE_DERIVED_16:
if (GFC_UNALIGNED_16(source->data))
break;
else
return internal_pack_16 ((gfc_array_i16 *) source);
#endif
 
default:
break;
}
 
dim = GFC_DESCRIPTOR_RANK (source);
ssize = 1;
packed = 1;
for (n = 0; n < dim; n++)
{
count[n] = 0;
stride[n] = GFC_DESCRIPTOR_STRIDE(source,n);
extent[n] = GFC_DESCRIPTOR_EXTENT(source,n);
if (extent[n] <= 0)
{
/* Do nothing. */
packed = 1;
break;
}
 
if (ssize != stride[n])
packed = 0;
 
ssize *= extent[n];
}
 
if (packed)
return source->data;
 
/* Allocate storage for the destination. */
destptr = internal_malloc_size (ssize * size);
dest = (char *)destptr;
src = source->data;
stride0 = stride[0] * size;
 
while (src)
{
/* Copy the data. */
memcpy(dest, src, size);
/* Advance to the next element. */
dest += size;
src += 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. */
src -= stride[n] * extent[n] * size;
n++;
if (n == dim)
{
src = NULL;
break;
}
else
{
count[n]++;
src += stride[n] * size;
}
}
}
return destptr;
}
/in_unpack_generic.c
0,0 → 1,242
/* Generic helper function for repacking arrays.
Copyright 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.
 
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>
 
extern void internal_unpack (gfc_array_char *, const void *);
export_proto(internal_unpack);
 
void
internal_unpack (gfc_array_char * d, const void * s)
{
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type stride[GFC_MAX_DIMENSIONS];
index_type stride0;
index_type dim;
index_type dsize;
char *dest;
const char *src;
int n;
int size;
int type_size;
 
dest = d->data;
/* This check may be redundant, but do it anyway. */
if (s == dest || !s)
return;
 
type_size = GFC_DTYPE_TYPE_SIZE (d);
switch (type_size)
{
case GFC_DTYPE_INTEGER_1:
case GFC_DTYPE_LOGICAL_1:
case GFC_DTYPE_DERIVED_1:
internal_unpack_1 ((gfc_array_i1 *) d, (const GFC_INTEGER_1 *) s);
return;
 
case GFC_DTYPE_INTEGER_2:
case GFC_DTYPE_LOGICAL_2:
internal_unpack_2 ((gfc_array_i2 *) d, (const GFC_INTEGER_2 *) s);
return;
 
case GFC_DTYPE_INTEGER_4:
case GFC_DTYPE_LOGICAL_4:
internal_unpack_4 ((gfc_array_i4 *) d, (const GFC_INTEGER_4 *) s);
return;
 
case GFC_DTYPE_INTEGER_8:
case GFC_DTYPE_LOGICAL_8:
internal_unpack_8 ((gfc_array_i8 *) d, (const GFC_INTEGER_8 *) s);
return;
 
#if defined (HAVE_GFC_INTEGER_16)
case GFC_DTYPE_INTEGER_16:
case GFC_DTYPE_LOGICAL_16:
internal_unpack_16 ((gfc_array_i16 *) d, (const GFC_INTEGER_16 *) s);
return;
#endif
 
case GFC_DTYPE_REAL_4:
internal_unpack_r4 ((gfc_array_r4 *) d, (const GFC_REAL_4 *) s);
return;
 
case GFC_DTYPE_REAL_8:
internal_unpack_r8 ((gfc_array_r8 *) d, (const GFC_REAL_8 *) s);
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)
# if defined(HAVE_GFC_REAL_10)
case GFC_DTYPE_REAL_10:
internal_unpack_r10 ((gfc_array_r10 *) d, (const GFC_REAL_10 *) s);
return;
# endif
 
# if defined(HAVE_GFC_REAL_16)
case GFC_DTYPE_REAL_16:
internal_unpack_r16 ((gfc_array_r16 *) d, (const GFC_REAL_16 *) s);
return;
# endif
#endif
 
case GFC_DTYPE_COMPLEX_4:
internal_unpack_c4 ((gfc_array_c4 *)d, (const GFC_COMPLEX_4 *)s);
return;
 
case GFC_DTYPE_COMPLEX_8:
internal_unpack_c8 ((gfc_array_c8 *)d, (const GFC_COMPLEX_8 *)s);
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)
# if defined(HAVE_GFC_COMPLEX_10)
case GFC_DTYPE_COMPLEX_10:
internal_unpack_c10 ((gfc_array_c10 *) d, (const GFC_COMPLEX_10 *) s);
return;
# endif
 
# if defined(HAVE_GFC_COMPLEX_16)
case GFC_DTYPE_COMPLEX_16:
internal_unpack_c16 ((gfc_array_c16 *) d, (const GFC_COMPLEX_16 *) s);
return;
# endif
#endif
 
case GFC_DTYPE_DERIVED_2:
if (GFC_UNALIGNED_2(d->data) || GFC_UNALIGNED_2(s))
break;
else
{
internal_unpack_2 ((gfc_array_i2 *) d, (const GFC_INTEGER_2 *) s);
return;
}
case GFC_DTYPE_DERIVED_4:
if (GFC_UNALIGNED_4(d->data) || GFC_UNALIGNED_4(s))
break;
else
{
internal_unpack_4 ((gfc_array_i4 *) d, (const GFC_INTEGER_4 *) s);
return;
}
 
case GFC_DTYPE_DERIVED_8:
if (GFC_UNALIGNED_8(d->data) || GFC_UNALIGNED_8(s))
break;
else
{
internal_unpack_8 ((gfc_array_i8 *) d, (const GFC_INTEGER_8 *) s);
return;
}
 
#ifdef HAVE_GFC_INTEGER_16
case GFC_DTYPE_DERIVED_16:
if (GFC_UNALIGNED_16(d->data) || GFC_UNALIGNED_16(s))
break;
else
{
internal_unpack_16 ((gfc_array_i16 *) d, (const GFC_INTEGER_16 *) s);
return;
}
#endif
 
default:
break;
}
 
size = GFC_DESCRIPTOR_SIZE (d);
 
dim = GFC_DESCRIPTOR_RANK (d);
dsize = 1;
for (n = 0; n < dim; n++)
{
count[n] = 0;
stride[n] = GFC_DESCRIPTOR_STRIDE(d,n);
extent[n] = GFC_DESCRIPTOR_EXTENT(d,n);
if (extent[n] <= 0)
return;
 
if (dsize == stride[n])
dsize *= extent[n];
else
dsize = 0;
}
 
src = s;
 
if (dsize != 0)
{
memcpy (dest, src, dsize * size);
return;
}
 
stride0 = stride[0] * size;
 
while (dest)
{
/* Copy the data. */
memcpy (dest, src, size);
/* Advance to the next element. */
src += size;
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] * size;
n++;
if (n == dim)
{
dest = NULL;
break;
}
else
{
count[n]++;
dest += stride[n] * size;
}
}
}
}
/compile_options.c
0,0 → 1,277
/* Handling of compile-time options that influence the library.
Copyright (C) 2005, 2007, 2009, 2010, 2011, 2012
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, 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 <signal.h>
 
 
/* Useful compile-time options will be stored in here. */
compile_options_t compile_options;
 
 
volatile sig_atomic_t fatal_error_in_progress = 0;
 
 
/* Helper function for backtrace_handler to write information about the
received signal to stderr before actually giving the backtrace. */
static void
show_signal (int signum)
{
const char * name = NULL, * desc = NULL;
 
switch (signum)
{
#if defined(SIGQUIT)
case SIGQUIT:
name = "SIGQUIT";
desc = "Terminal quit signal";
break;
#endif
 
/* The following 4 signals are defined by C89. */
case SIGILL:
name = "SIGILL";
desc = "Illegal instruction";
break;
 
case SIGABRT:
name = "SIGABRT";
desc = "Process abort signal";
break;
 
case SIGFPE:
name = "SIGFPE";
desc = "Floating-point exception - erroneous arithmetic operation";
break;
 
case SIGSEGV:
name = "SIGSEGV";
desc = "Segmentation fault - invalid memory reference";
break;
 
#if defined(SIGBUS)
case SIGBUS:
name = "SIGBUS";
desc = "Access to an undefined portion of a memory object";
break;
#endif
 
#if defined(SIGSYS)
case SIGSYS:
name = "SIGSYS";
desc = "Bad system call";
break;
#endif
 
#if defined(SIGTRAP)
case SIGTRAP:
name = "SIGTRAP";
desc = "Trace/breakpoint trap";
break;
#endif
 
#if defined(SIGXCPU)
case SIGXCPU:
name = "SIGXCPU";
desc = "CPU time limit exceeded";
break;
#endif
 
#if defined(SIGXFSZ)
case SIGXFSZ:
name = "SIGXFSZ";
desc = "File size limit exceeded";
break;
#endif
}
 
if (name)
st_printf ("\nProgram received signal %s: %s.\n", name, desc);
else
st_printf ("\nProgram received signal %d.\n", signum);
}
 
 
/* A signal handler to allow us to output a backtrace. */
void
backtrace_handler (int signum)
{
/* Since this handler is established for more than one kind of signal,
it might still get invoked recursively by delivery of some other kind
of signal. Use a static variable to keep track of that. */
if (fatal_error_in_progress)
raise (signum);
fatal_error_in_progress = 1;
 
show_signal (signum);
show_backtrace();
 
/* Now reraise the signal. We reactivate the signal's
default handling, which is to terminate the process.
We could just call exit or abort,
but reraising the signal sets the return status
from the process correctly. */
signal (signum, SIG_DFL);
raise (signum);
}
 
 
/* Helper function for set_options because we need to access the
global variable options which is not seen in set_options. */
static void
maybe_find_addr2line (void)
{
if (options.backtrace == -1)
find_addr2line ();
}
 
/* Set the usual compile-time options. */
extern void set_options (int , int []);
export_proto(set_options);
 
void
set_options (int num, int options[])
{
if (num >= 1)
compile_options.warn_std = options[0];
if (num >= 2)
compile_options.allow_std = options[1];
if (num >= 3)
compile_options.pedantic = options[2];
/* options[3] is the removed -fdump-core option. It's place in the
options array is retained due to ABI compatibility. Remove when
bumping the library ABI. */
if (num >= 5)
compile_options.backtrace = options[4];
if (num >= 6)
compile_options.sign_zero = options[5];
if (num >= 7)
compile_options.bounds_check = options[6];
if (num >= 8)
compile_options.range_check = options[7];
 
/* If backtrace is required, we set signal handlers on the POSIX
2001 signals with core action. */
if (compile_options.backtrace)
{
#if defined(SIGQUIT)
signal (SIGQUIT, backtrace_handler);
#endif
 
/* The following 4 signals are defined by C89. */
signal (SIGILL, backtrace_handler);
signal (SIGABRT, backtrace_handler);
signal (SIGFPE, backtrace_handler);
signal (SIGSEGV, backtrace_handler);
 
#if defined(SIGBUS)
signal (SIGBUS, backtrace_handler);
#endif
 
#if defined(SIGSYS)
signal (SIGSYS, backtrace_handler);
#endif
 
#if defined(SIGTRAP)
signal (SIGTRAP, backtrace_handler);
#endif
 
#if defined(SIGXCPU)
signal (SIGXCPU, backtrace_handler);
#endif
 
#if defined(SIGXFSZ)
signal (SIGXFSZ, backtrace_handler);
#endif
 
maybe_find_addr2line ();
}
}
 
 
/* Default values for the compile-time options. Keep in sync with
gcc/fortran/options.c (gfc_init_options). */
void
init_compile_options (void)
{
compile_options.warn_std = GFC_STD_F95_DEL | GFC_STD_LEGACY;
compile_options.allow_std = GFC_STD_F95_OBS | GFC_STD_F95_DEL
| GFC_STD_F2003 | GFC_STD_F2008 | GFC_STD_F95 | GFC_STD_F77
| GFC_STD_F2008_OBS | GFC_STD_GNU | GFC_STD_LEGACY;
compile_options.pedantic = 0;
compile_options.backtrace = 0;
compile_options.sign_zero = 1;
compile_options.range_check = 1;
}
 
/* Function called by the front-end to tell us the
default for unformatted data conversion. */
 
extern void set_convert (int);
export_proto (set_convert);
 
void
set_convert (int conv)
{
compile_options.convert = conv;
}
 
extern void set_record_marker (int);
export_proto (set_record_marker);
 
 
void
set_record_marker (int val)
{
 
switch(val)
{
case 4:
compile_options.record_marker = sizeof (GFC_INTEGER_4);
break;
 
case 8:
compile_options.record_marker = sizeof (GFC_INTEGER_8);
break;
 
default:
runtime_error ("Invalid value for record marker");
break;
}
}
 
extern void set_max_subrecord_length (int);
export_proto (set_max_subrecord_length);
 
void set_max_subrecord_length(int val)
{
if (val > GFC_MAX_SUBRECORD_LENGTH || val < 1)
{
runtime_error ("Invalid value for maximum subrecord length");
return;
}
 
compile_options.max_subrecord_length = val;
}
/string.c
0,0 → 1,112
/* Copyright (C) 2002, 2003, 2005, 2007, 2009, 2010
Free Software Foundation, Inc.
Contributed by Paul Brook
 
This file is part of the GNU Fortran 95 runtime library (libgfortran).
 
Libgfortran is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 3, or (at your option)
any later version.
 
Libgfortran is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
 
Under Section 7 of GPL version 3, you are granted additional
permissions described in the GCC Runtime Library Exception, version
3.1, as published by the Free Software Foundation.
 
You should have received a copy of the GNU General Public License and
a copy of the GCC Runtime Library Exception along with this program;
see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
<http://www.gnu.org/licenses/>. */
 
#include "libgfortran.h"
#include <string.h>
 
 
/* Given a fortran string, return its length exclusive of the trailing
spaces. */
 
gfc_charlen_type
fstrlen (const char *string, gfc_charlen_type len)
{
for (; len > 0; len--)
if (string[len-1] != ' ')
break;
 
return len;
}
 
 
/* Copy a Fortran string (not null-terminated, hence length arguments
for both source and destination strings. Returns the non-padded
length of the destination. */
 
gfc_charlen_type
fstrcpy (char *dest, gfc_charlen_type destlen,
const char *src, gfc_charlen_type srclen)
{
if (srclen >= destlen)
{
/* This will truncate if too long. */
memcpy (dest, src, destlen);
return destlen;
}
else
{
memcpy (dest, src, srclen);
/* Pad with spaces. */
memset (&dest[srclen], ' ', destlen - srclen);
return srclen;
}
}
 
 
/* Copy a null-terminated C string to a non-null-terminated Fortran
string. Returns the non-padded length of the destination string. */
 
gfc_charlen_type
cf_strcpy (char *dest, gfc_charlen_type dest_len, const char *src)
{
size_t src_len;
 
src_len = strlen (src);
 
if (src_len >= (size_t) dest_len)
{
/* This will truncate if too long. */
memcpy (dest, src, dest_len);
return dest_len;
}
else
{
memcpy (dest, src, src_len);
/* Pad with spaces. */
memset (&dest[src_len], ' ', dest_len - src_len);
return src_len;
}
}
 
 
/* Given a fortran string and an array of st_option structures, search through
the array to find a match. If the option is not found, we generate an error
if no default is provided. */
 
int
find_option (st_parameter_common *cmp, const char *s1, gfc_charlen_type s1_len,
const st_option * opts, const char *error_message)
{
/* Strip trailing blanks from the Fortran string. */
size_t len = (size_t) fstrlen (s1, s1_len);
 
for (; opts->name; opts++)
if (len == strlen(opts->name) && strncasecmp (s1, opts->name, len) == 0)
return opts->value;
 
generate_error (cmp, LIBERROR_BAD_OPTION, error_message);
 
return -1;
}
/memory.c
0,0 → 1,61
/* Memory management routines.
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 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>
 
/* If GFC_CLEAR_MEMORY is defined, the memory allocation routines will
return memory that is guaranteed to be set to zero. This can have
a severe efficiency penalty, so it should never be set if good
performance is desired, but it can help when you're debugging code. */
/* #define GFC_CLEAR_MEMORY */
 
void *
get_mem (size_t n)
{
void *p;
 
#ifdef GFC_CLEAR_MEMORY
p = (void *) calloc (1, n);
#else
p = (void *) malloc (n);
#endif
if (p == NULL)
os_error ("Memory allocation failed");
 
return p;
}
 
 
/* Allocate memory for internal (compiler generated) use. */
 
void *
internal_malloc_size (size_t size)
{
if (unlikely (size == 0))
size = 1;
 
return get_mem (size);
}
/select_inc.c
0,0 → 1,133
/* Implement the SELECT statement for character variables.
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, 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/>. */
 
#define select_string SUFFIX(select_string)
#define select_struct SUFFIX(select_struct)
#define compare_string SUFFIX(compare_string)
 
typedef struct
{
CHARTYPE *low;
gfc_charlen_type low_len;
CHARTYPE *high;
gfc_charlen_type high_len;
int address;
}
select_struct;
 
extern int select_string (select_struct *table, int table_len,
const CHARTYPE *selector,
gfc_charlen_type selector_len);
export_proto(select_string);
 
 
/* select_string()-- Given a selector string and a table of
* select_struct structures, return the address to jump to. */
 
int
select_string (select_struct *table, int table_len, const CHARTYPE *selector,
gfc_charlen_type selector_len)
{
select_struct *t;
int i, low, high, mid;
int default_jump = -1;
 
if (table_len == 0)
return -1;
 
/* Record the default address if present */
 
if (table->low == NULL && table->high == NULL)
{
default_jump = table->address;
 
table++;
table_len--;
if (table_len == 0)
return default_jump;
}
 
/* Try the high and low bounds if present. */
 
if (table->low == NULL)
{
if (compare_string (table->high_len, table->high,
selector_len, selector) >= 0)
return table->address;
 
table++;
table_len--;
if (table_len == 0)
return default_jump;
}
 
t = table + table_len - 1;
 
if (t->high == NULL)
{
if (compare_string (t->low_len, t->low, selector_len, selector) <= 0)
return t->address;
 
table_len--;
if (table_len == 0)
return default_jump;
}
 
/* At this point, the only table entries are bounded entries. Find
the right entry with a binary chop. */
 
low = -1;
high = table_len;
 
while (low + 1 < high)
{
mid = (low + high) / 2;
 
t = table + mid;
i = compare_string (t->low_len, t->low, selector_len, selector);
 
if (i == 0)
return t->address;
 
if (i < 0)
low = mid;
else
high = mid;
}
 
/* The string now lies between the low indeces of the now-adjacent
high and low entries. Because it is less than the low entry of
'high', it can't be that one. If low is still -1, then no
entries match. Otherwise, we have to check the high entry of
'low'. */
 
if (low == -1)
return default_jump;
 
t = table + low;
if (compare_string (selector_len, selector, t->high_len, t->high) <= 0)
return t->address;
 
return default_jump;
}
/pause.c
0,0 → 1,70
/* Implementation of the PAUSE statement.
Copyright 2002, 2005, 2007, 2009, 2010, 2011 Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.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 <string.h>
#include <unistd.h>
 
static void
do_pause (void)
{
char buff[4];
estr_write ("To resume execution, type go. "
"Other input will terminate the job.\n");
 
fgets(buff, 4, stdin);
if (strncmp(buff, "go\n", 3) != 0)
stop_string ('\0', 0);
estr_write ("RESUMED\n");
}
 
/* A numeric PAUSE statement. */
 
extern void pause_numeric (GFC_INTEGER_4);
export_proto(pause_numeric);
 
void
pause_numeric (GFC_INTEGER_4 code)
{
st_printf ("PAUSE %d\n", (int) code);
do_pause ();
}
 
/* A character string or blank PAUSE statement. */
 
extern void pause_string (char *string, GFC_INTEGER_4 len);
export_proto(pause_string);
 
void
pause_string (char *string, GFC_INTEGER_4 len)
{
estr_write ("PAUSE ");
ssize_t w = write (STDERR_FILENO, string, len);
(void) sizeof (w); /* Avoid compiler warning about not using write
return val. */
estr_write ("\n");
 
do_pause ();
}
/convert_char.c
0,0 → 1,69
/* Runtime conversion of strings from one character kind to another.
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/>. */
 
#include "libgfortran.h"
 
#include <stdlib.h>
#include <string.h>
 
 
extern void convert_char1_to_char4 (gfc_char4_t **, gfc_charlen_type,
const unsigned char *);
export_proto(convert_char1_to_char4);
 
extern void convert_char4_to_char1 (unsigned char **, gfc_charlen_type,
const gfc_char4_t *);
export_proto(convert_char4_to_char1);
 
 
void
convert_char1_to_char4 (gfc_char4_t **dst, gfc_charlen_type len,
const unsigned char *src)
{
gfc_charlen_type i, l;
 
l = len > 0 ? len : 0;
*dst = get_mem ((l + 1) * sizeof (gfc_char4_t));
 
for (i = 0; i < l; i++)
(*dst)[i] = src[i];
 
(*dst)[l] = '\0';
}
 
 
void
convert_char4_to_char1 (unsigned char **dst, gfc_charlen_type len,
const gfc_char4_t *src)
{
gfc_charlen_type i, l;
 
l = len > 0 ? len : 0;
*dst = get_mem ((l + 1) * sizeof (unsigned char));
 
for (i = 0; i < l; i++)
(*dst)[i] = src[i];
 
(*dst)[l] = '\0';
}
/select.c
0,0 → 1,46
/* Implement the SELECT statement for character variables.
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/>. */
 
#include "libgfortran.h"
 
 
/* The string selection function is defined using a few generic macros
in select_inc.c, so we avoid code duplication between the various
character type kinds. */
 
#undef CHARTYPE
#define CHARTYPE char
#undef SUFFIX
#define SUFFIX(x) x
 
#include "select_inc.c"
 
 
#undef CHARTYPE
#define CHARTYPE gfc_char4_t
#undef SUFFIX
#define SUFFIX(x) x ## _char4
 
#include "select_inc.c"
 
/backtrace.c
0,0 → 1,279
/* Copyright (C) 2006, 2007, 2009, 2011, 2012 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 <stdlib.h>
 
#ifdef HAVE_UNISTD_H
#include <unistd.h>
#endif
 
#ifdef HAVE_SYS_WAIT_H
#include <sys/wait.h>
#endif
 
#include <limits.h>
 
#include "unwind.h"
 
 
/* Macros for common sets of capabilities: can we fork and exec, and
can we use pipes to communicate with the subprocess. */
#define CAN_FORK (defined(HAVE_FORK) && defined(HAVE_EXECVE) \
&& defined(HAVE_WAIT))
#define CAN_PIPE (CAN_FORK && defined(HAVE_PIPE) \
&& defined(HAVE_DUP2) && defined(HAVE_CLOSE))
 
#ifndef PATH_MAX
#define PATH_MAX 4096
#endif
 
 
/* GDB style #NUM index for each stack frame. */
 
static void
bt_header (int num)
{
st_printf ("#%d ", num);
}
 
 
/* fgets()-like function that reads a line from a fd, without
needing to malloc() a buffer, and does not use locks, hence should
be async-signal-safe. */
 
static char *
fd_gets (char *s, int size, int fd)
{
for (int i = 0; i < size; i++)
{
char c;
ssize_t nread = read (fd, &c, 1);
if (nread == 1)
{
s[i] = c;
if (c == '\n')
{
if (i + 1 < size)
s[i+1] = '\0';
else
s[i] = '\0';
break;
}
}
else
{
s[i] = '\0';
if (i == 0)
return NULL;
break;
}
}
return s;
}
 
 
extern char *addr2line_path;
 
/* Struct containing backtrace state. */
typedef struct
{
int frame_number;
int direct_output;
int outfd;
int infd;
int error;
}
bt_state;
 
static _Unwind_Reason_Code
trace_function (struct _Unwind_Context *context, void *state_ptr)
{
bt_state* state = (bt_state*) state_ptr;
_Unwind_Ptr ip;
#ifdef HAVE_GETIPINFO
int ip_before_insn = 0;
ip = _Unwind_GetIPInfo (context, &ip_before_insn);
/* If the unwinder gave us a 'return' address, roll it back a little
to ensure we get the correct line number for the call itself. */
if (! ip_before_insn)
--ip;
#else
ip = _Unwind_GetIP (context);
#endif
 
if (state->direct_output)
{
bt_header(state->frame_number);
st_printf ("%p\n", (void*) ip);
}
else
{
char addr_buf[GFC_XTOA_BUF_SIZE], func[1024], file[PATH_MAX];
char *p;
const char* addr = gfc_xtoa (ip, addr_buf, sizeof (addr_buf));
write (state->outfd, addr, strlen (addr));
write (state->outfd, "\n", 1);
 
if (! fd_gets (func, sizeof(func), state->infd))
{
state->error = 1;
goto done;
}
if (! fd_gets (file, sizeof(file), state->infd))
{
state->error = 1;
goto done;
}
for (p = func; *p != '\n' && *p != '\r'; p++)
;
*p = '\0';
/* _start is a setup routine that calls main(), and main() is
the frontend routine that calls some setup stuff and then
calls MAIN__, so at this point we should stop. */
if (strcmp (func, "_start") == 0 || strcmp (func, "main") == 0)
return _URC_END_OF_STACK;
bt_header (state->frame_number);
estr_write ("0x");
estr_write (addr);
 
if (func[0] != '?' && func[1] != '?')
{
estr_write (" in ");
estr_write (func);
}
if (strncmp (file, "??", 2) == 0)
estr_write ("\n");
else
{
estr_write (" at ");
estr_write (file);
}
}
 
done:
 
state->frame_number++;
return _URC_NO_REASON;
}
 
 
/* Display the backtrace. */
 
void
show_backtrace (void)
{
bt_state state;
state.frame_number = 0;
state.error = 0;
 
estr_write ("\nBacktrace for this error:\n");
 
#if CAN_PIPE
 
if (addr2line_path == NULL)
goto fallback_noerr;
 
/* We attempt to extract file and line information from addr2line. */
do
{
/* Local variables. */
int f[2], pid, inp[2];
 
/* Don't output an error message if something goes wrong, we'll simply
fall back to printing the addresses. */
if (pipe (f) != 0)
break;
if (pipe (inp) != 0)
break;
if ((pid = fork ()) == -1)
break;
 
if (pid == 0)
{
/* Child process. */
#define NUM_FIXEDARGS 7
char *arg[NUM_FIXEDARGS];
char *newenv[] = { NULL };
 
close (f[0]);
 
close (inp[1]);
if (dup2 (inp[0], STDIN_FILENO) == -1)
_exit (1);
close (inp[0]);
 
close (STDERR_FILENO);
 
if (dup2 (f[1], STDOUT_FILENO) == -1)
_exit (1);
close (f[1]);
 
arg[0] = addr2line_path;
arg[1] = (char *) "-e";
arg[2] = full_exe_path ();
arg[3] = (char *) "-f";
arg[4] = (char *) "-s";
arg[5] = (char *) "-C";
arg[6] = NULL;
execve (addr2line_path, arg, newenv);
_exit (1);
#undef NUM_FIXEDARGS
}
 
/* Father process. */
close (f[1]);
close (inp[0]);
 
state.outfd = inp[1];
state.infd = f[0];
state.direct_output = 0;
_Unwind_Backtrace (trace_function, &state);
if (state.error)
goto fallback;
close (inp[1]);
wait (NULL);
return;
 
fallback:
estr_write ("** Something went wrong while running addr2line. **\n"
"** Falling back to a simpler backtrace scheme. **\n");
}
while (0);
 
#endif /* CAN_PIPE */
 
fallback_noerr:
/* Fallback to the simple backtrace without addr2line. */
state.direct_output = 1;
_Unwind_Backtrace (trace_function, &state);
}
/environ.c
0,0 → 1,830
/* Copyright (C) 2002, 2003, 2005, 2007, 2009 Free Software Foundation, Inc.
Contributed by Andy Vaught
 
This file is part of the GNU Fortran 95 runtime library (libgfortran).
 
Libgfortran is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 3, or (at your option)
any later version.
 
Libgfortran is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
 
Under Section 7 of GPL version 3, you are granted additional
permissions described in the GCC Runtime Library Exception, version
3.1, as published by the Free Software Foundation.
 
You should have received a copy of the GNU General Public License and
a copy of the GCC Runtime Library Exception along with this program;
see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
<http://www.gnu.org/licenses/>. */
 
#include "libgfortran.h"
 
#include <string.h>
#include <stdlib.h>
#include <ctype.h>
 
 
/* Environment scanner. Examine the environment for controlling minor
* aspects of the program's execution. Our philosophy here that the
* environment should not prevent the program from running, so an
* environment variable with a messed-up value will be interpreted in
* the default way.
*
* Most of the environment is checked early in the startup sequence,
* but other variables are checked during execution of the user's
* program. */
 
options_t options;
 
 
typedef struct variable
{
const char *name;
int value, *var;
void (*init) (struct variable *);
void (*show) (struct variable *);
const char *desc;
int bad;
}
variable;
 
static void init_unformatted (variable *);
 
/* print_spaces()-- Print a particular number of spaces. */
 
static void
print_spaces (int n)
{
char buffer[80];
int i;
 
if (n <= 0)
return;
 
for (i = 0; i < n; i++)
buffer[i] = ' ';
 
buffer[i] = '\0';
 
estr_write (buffer);
}
 
 
/* var_source()-- Return a string that describes where the value of a
* variable comes from */
 
static const char *
var_source (variable * v)
{
if (getenv (v->name) == NULL)
return "Default";
 
if (v->bad)
return "Bad ";
 
return "Set ";
}
 
 
/* init_integer()-- Initialize an integer environment variable. */
 
static void
init_integer (variable * v)
{
char *p, *q;
 
p = getenv (v->name);
if (p == NULL)
goto set_default;
 
for (q = p; *q; q++)
if (!isdigit (*q) && (p != q || *q != '-'))
{
v->bad = 1;
goto set_default;
}
 
*v->var = atoi (p);
return;
 
set_default:
*v->var = v->value;
return;
}
 
 
/* init_unsigned_integer()-- Initialize an integer environment variable
which has to be positive. */
 
static void
init_unsigned_integer (variable * v)
{
char *p, *q;
 
p = getenv (v->name);
if (p == NULL)
goto set_default;
 
for (q = p; *q; q++)
if (!isdigit (*q))
{
v->bad = 1;
goto set_default;
}
 
*v->var = atoi (p);
return;
 
set_default:
*v->var = v->value;
return;
}
 
 
/* show_integer()-- Show an integer environment variable */
 
static void
show_integer (variable * v)
{
st_printf ("%s %d\n", var_source (v), *v->var);
}
 
 
/* init_boolean()-- Initialize a boolean environment variable. We
* only look at the first letter of the variable. */
 
static void
init_boolean (variable * v)
{
char *p;
 
p = getenv (v->name);
if (p == NULL)
goto set_default;
 
if (*p == '1' || *p == 'Y' || *p == 'y')
{
*v->var = 1;
return;
}
 
if (*p == '0' || *p == 'N' || *p == 'n')
{
*v->var = 0;
return;
}
 
v->bad = 1;
 
set_default:
*v->var = v->value;
return;
}
 
 
/* show_boolean()-- Show a boolean environment variable */
 
static void
show_boolean (variable * v)
{
st_printf ("%s %s\n", var_source (v), *v->var ? "Yes" : "No");
}
 
 
static void
init_sep (variable * v)
{
int seen_comma;
char *p;
 
p = getenv (v->name);
if (p == NULL)
goto set_default;
 
v->bad = 1;
options.separator = p;
options.separator_len = strlen (p);
 
/* Make sure the separator is valid */
 
if (options.separator_len == 0)
goto set_default;
seen_comma = 0;
 
while (*p)
{
if (*p == ',')
{
if (seen_comma)
goto set_default;
seen_comma = 1;
p++;
continue;
}
 
if (*p++ != ' ')
goto set_default;
}
 
v->bad = 0;
return;
 
set_default:
options.separator = " ";
options.separator_len = 1;
}
 
 
static void
show_sep (variable * v)
{
st_printf ("%s \"%s\"\n", var_source (v), options.separator);
}
 
 
static void
init_string (variable * v __attribute__ ((unused)))
{
}
 
static void
show_string (variable * v)
{
const char *p;
 
p = getenv (v->name);
if (p == NULL)
p = "";
 
estr_write (var_source (v));
estr_write (" \"");
estr_write (p);
estr_write ("\"\n");
}
 
 
static variable variable_table[] = {
{"GFORTRAN_STDIN_UNIT", GFC_STDIN_UNIT_NUMBER, &options.stdin_unit,
init_integer, show_integer,
"Unit number that will be preconnected to standard input\n"
"(No preconnection if negative)", 0},
 
{"GFORTRAN_STDOUT_UNIT", GFC_STDOUT_UNIT_NUMBER, &options.stdout_unit,
init_integer, show_integer,
"Unit number that will be preconnected to standard output\n"
"(No preconnection if negative)", 0},
 
{"GFORTRAN_STDERR_UNIT", GFC_STDERR_UNIT_NUMBER, &options.stderr_unit,
init_integer, show_integer,
"Unit number that will be preconnected to standard error\n"
"(No preconnection if negative)", 0},
 
{"GFORTRAN_TMPDIR", 0, NULL, init_string, show_string,
"Directory for scratch files. Overrides the TMP environment variable\n"
"If TMP is not set " DEFAULT_TEMPDIR " is used.", 0},
 
{"GFORTRAN_UNBUFFERED_ALL", 0, &options.all_unbuffered, init_boolean,
show_boolean,
"If TRUE, all output is unbuffered. This will slow down large writes "
"but can be\nuseful for forcing data to be displayed immediately.", 0},
 
{"GFORTRAN_UNBUFFERED_PRECONNECTED", 0, &options.unbuffered_preconnected,
init_boolean, show_boolean,
"If TRUE, output to preconnected units is unbuffered.", 0},
 
{"GFORTRAN_SHOW_LOCUS", 1, &options.locus, init_boolean, show_boolean,
"If TRUE, print filename and line number where runtime errors happen.", 0},
 
{"GFORTRAN_OPTIONAL_PLUS", 0, &options.optional_plus, init_boolean, show_boolean,
"Print optional plus signs in numbers where permitted. Default FALSE.", 0},
 
{"GFORTRAN_DEFAULT_RECL", DEFAULT_RECL, &options.default_recl,
init_unsigned_integer, show_integer,
"Default maximum record length for sequential files. Most useful for\n"
"adjusting line length of preconnected units. Default "
stringize (DEFAULT_RECL), 0},
 
{"GFORTRAN_LIST_SEPARATOR", 0, NULL, init_sep, show_sep,
"Separator to use when writing list output. May contain any number of "
"spaces\nand at most one comma. Default is a single space.", 0},
 
/* GFORTRAN_CONVERT_UNIT - Set the default data conversion for
unformatted I/O. */
{"GFORTRAN_CONVERT_UNIT", 0, 0, init_unformatted, show_string,
"Set format for unformatted files", 0},
 
{"GFORTRAN_ERROR_BACKTRACE", -1, &options.backtrace,
init_boolean, show_boolean,
"Print out a backtrace (if possible) on runtime error", -1},
 
{NULL, 0, NULL, NULL, NULL, NULL, 0}
};
 
 
/* init_variables()-- Initialize most runtime variables from
* environment variables. */
 
void
init_variables (void)
{
variable *v;
 
for (v = variable_table; v->name; v++)
v->init (v);
}
 
 
void
show_variables (void)
{
variable *v;
int n;
 
/* TODO: print version number. */
estr_write ("GNU Fortran runtime library version "
"UNKNOWN" "\n\n");
 
estr_write ("Environment variables:\n");
estr_write ("----------------------\n");
 
for (v = variable_table; v->name; v++)
{
n = estr_write (v->name);
print_spaces (25 - n);
 
if (v->show == show_integer)
estr_write ("Integer ");
else if (v->show == show_boolean)
estr_write ("Boolean ");
else
estr_write ("String ");
 
v->show (v);
estr_write (v->desc);
estr_write ("\n\n");
}
 
/* System error codes */
 
estr_write ("\nRuntime error codes:");
estr_write ("\n--------------------\n");
 
for (n = LIBERROR_FIRST + 1; n < LIBERROR_LAST; n++)
if (n < 0 || n > 9)
st_printf ("%d %s\n", n, translate_error (n));
else
st_printf (" %d %s\n", n, translate_error (n));
 
estr_write ("\nCommand line arguments:\n");
estr_write (" --help Print this list\n");
 
exit (0);
}
 
/* This is the handling of the GFORTRAN_CONVERT_UNITS environment variable.
It is called from environ.c to parse this variable, and from
open.c to determine if the user specified a default for an
unformatted file.
The syntax of the environment variable is, in bison grammar:
 
GFORTRAN_CONVERT_UNITS: mode | mode ';' exception ;
mode: 'native' | 'swap' | 'big_endian' | 'little_endian' ;
exception: mode ':' unit_list | unit_list ;
unit_list: unit_spec | unit_list unit_spec ;
unit_spec: INTEGER | INTEGER '-' INTEGER ;
*/
 
/* Defines for the tokens. Other valid tokens are ',', ':', '-'. */
 
 
#define NATIVE 257
#define SWAP 258
#define BIG 259
#define LITTLE 260
/* Some space for additional tokens later. */
#define INTEGER 273
#define END (-1)
#define ILLEGAL (-2)
 
typedef struct
{
int unit;
unit_convert conv;
} exception_t;
 
 
static char *p; /* Main character pointer for parsing. */
static char *lastpos; /* Auxiliary pointer, for backing up. */
static int unit_num; /* The last unit number read. */
static int unit_count; /* The number of units found. */
static int do_count; /* Parsing is done twice - first to count the number
of units, then to fill in the table. This
variable controls what to do. */
static exception_t *elist; /* The list of exceptions to the default. This is
sorted according to unit number. */
static int n_elist; /* Number of exceptions to the default. */
 
static unit_convert endian; /* Current endianness. */
 
static unit_convert def; /* Default as specified (if any). */
 
/* Search for a unit number, using a binary search. The
first argument is the unit number to search for. The second argument
is a pointer to an index.
If the unit number is found, the function returns 1, and the index
is that of the element.
If the unit number is not found, the function returns 0, and the
index is the one where the element would be inserted. */
 
static int
search_unit (int unit, int *ip)
{
int low, high, mid;
 
low = -1;
high = n_elist;
while (high - low > 1)
{
mid = (low + high) / 2;
if (unit <= elist[mid].unit)
high = mid;
else
low = mid;
}
*ip = high;
if (elist[high].unit == unit)
return 1;
else
return 0;
}
 
/* This matches a keyword. If it is found, return the token supplied,
otherwise return ILLEGAL. */
 
static int
match_word (const char *word, int tok)
{
int res;
 
if (strncasecmp (p, word, strlen (word)) == 0)
{
p += strlen (word);
res = tok;
}
else
res = ILLEGAL;
return res;
 
}
 
/* Match an integer and store its value in unit_num. This only works
if p actually points to the start of an integer. The caller has
to ensure this. */
 
static int
match_integer (void)
{
unit_num = 0;
while (isdigit (*p))
unit_num = unit_num * 10 + (*p++ - '0');
return INTEGER;
 
}
 
/* This reads the next token from the GFORTRAN_CONVERT_UNITS variable.
Returned values are the different tokens. */
 
static int
next_token (void)
{
int result;
 
lastpos = p;
switch (*p)
{
case '\0':
result = END;
break;
case ':':
case ',':
case '-':
case ';':
result = *p;
p++;
break;
 
case 'b':
case 'B':
result = match_word ("big_endian", BIG);
break;
 
case 'l':
case 'L':
result = match_word ("little_endian", LITTLE);
break;
 
case 'n':
case 'N':
result = match_word ("native", NATIVE);
break;
 
case 's':
case 'S':
result = match_word ("swap", SWAP);
break;
 
case '1': case '2': case '3': case '4': case '5':
case '6': case '7': case '8': case '9':
result = match_integer ();
break;
 
default:
result = ILLEGAL;
break;
}
return result;
}
 
/* Back up the last token by setting back the character pointer. */
 
static void
push_token (void)
{
p = lastpos;
}
 
/* This is called when a unit is identified. If do_count is nonzero,
increment the number of units by one. If do_count is zero,
put the unit into the table. */
 
static void
mark_single (int unit)
{
int i,j;
 
if (do_count)
{
unit_count++;
return;
}
if (search_unit (unit, &i))
{
elist[unit].conv = endian;
}
else
{
for (j=n_elist; j>=i; j--)
elist[j+1] = elist[j];
n_elist += 1;
elist[i].unit = unit;
elist[i].conv = endian;
}
}
 
/* This is called when a unit range is identified. If do_count is
nonzero, increase the number of units. If do_count is zero,
put the unit into the table. */
 
static void
mark_range (int unit1, int unit2)
{
int i;
if (do_count)
unit_count += abs (unit2 - unit1) + 1;
else
{
if (unit2 < unit1)
for (i=unit2; i<=unit1; i++)
mark_single (i);
else
for (i=unit1; i<=unit2; i++)
mark_single (i);
}
}
 
/* Parse the GFORTRAN_CONVERT_UNITS variable. This is called
twice, once to count the units and once to actually mark them in
the table. When counting, we don't check for double occurrences
of units. */
 
static int
do_parse (void)
{
int tok;
int unit1;
int continue_ulist;
char *start;
 
unit_count = 0;
 
start = p;
 
/* Parse the string. First, let's look for a default. */
tok = next_token ();
switch (tok)
{
case NATIVE:
endian = GFC_CONVERT_NATIVE;
break;
 
case SWAP:
endian = GFC_CONVERT_SWAP;
break;
 
case BIG:
endian = GFC_CONVERT_BIG;
break;
 
case LITTLE:
endian = GFC_CONVERT_LITTLE;
break;
 
case INTEGER:
/* A leading digit means that we are looking at an exception.
Reset the position to the beginning, and continue processing
at the exception list. */
p = start;
goto exceptions;
break;
 
case END:
goto end;
break;
 
default:
goto error;
break;
}
 
tok = next_token ();
switch (tok)
{
case ';':
def = endian;
break;
 
case ':':
/* This isn't a default after all. Reset the position to the
beginning, and continue processing at the exception list. */
p = start;
goto exceptions;
break;
 
case END:
def = endian;
goto end;
break;
 
default:
goto error;
break;
}
 
exceptions:
 
/* Loop over all exceptions. */
while(1)
{
tok = next_token ();
switch (tok)
{
case NATIVE:
if (next_token () != ':')
goto error;
endian = GFC_CONVERT_NATIVE;
break;
 
case SWAP:
if (next_token () != ':')
goto error;
endian = GFC_CONVERT_SWAP;
break;
 
case LITTLE:
if (next_token () != ':')
goto error;
endian = GFC_CONVERT_LITTLE;
break;
 
case BIG:
if (next_token () != ':')
goto error;
endian = GFC_CONVERT_BIG;
break;
 
case INTEGER:
push_token ();
break;
 
case END:
goto end;
break;
 
default:
goto error;
break;
}
/* We arrive here when we want to parse a list of
numbers. */
continue_ulist = 1;
do
{
tok = next_token ();
if (tok != INTEGER)
goto error;
 
unit1 = unit_num;
tok = next_token ();
/* The number can be followed by a - and another number,
which means that this is a unit range, a comma
or a semicolon. */
if (tok == '-')
{
if (next_token () != INTEGER)
goto error;
 
mark_range (unit1, unit_num);
tok = next_token ();
if (tok == END)
goto end;
else if (tok == ';')
continue_ulist = 0;
else if (tok != ',')
goto error;
}
else
{
mark_single (unit1);
switch (tok)
{
case ';':
continue_ulist = 0;
break;
 
case ',':
break;
 
case END:
goto end;
break;
 
default:
goto error;
}
}
} while (continue_ulist);
}
end:
return 0;
error:
def = GFC_CONVERT_NONE;
return -1;
}
 
void init_unformatted (variable * v)
{
char *val;
val = getenv (v->name);
def = GFC_CONVERT_NONE;
n_elist = 0;
 
if (val == NULL)
return;
do_count = 1;
p = val;
do_parse ();
if (do_count <= 0)
{
n_elist = 0;
elist = NULL;
}
else
{
elist = get_mem (unit_count * sizeof (exception_t));
do_count = 0;
p = val;
do_parse ();
}
}
 
/* Get the default conversion for for an unformatted unit. */
 
unit_convert
get_unformatted_convert (int unit)
{
int i;
 
if (elist == NULL)
return def;
else if (search_unit (unit, &i))
return elist[i].conv;
else
return def;
}
/main.c
0,0 → 1,257
/* Copyright (C) 2002-2003, 2005, 2007, 2009, 2011
Free Software Foundation, Inc.
Contributed by Andy Vaught and Paul Brook <paul@nowt.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, 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 <limits.h>
 
 
#ifdef HAVE_UNISTD_H
#include <unistd.h>
#endif
 
/* Stupid function to be sure the constructor is always linked in, even
in the case of static linking. See PR libfortran/22298 for details. */
void
stupid_function_name_for_static_linking (void)
{
return;
}
 
/* This will be 0 for little-endian
machines and 1 for big-endian machines. */
int big_endian = 0;
 
 
/* Figure out endianness for this machine. */
 
static void
determine_endianness (void)
{
union
{
GFC_LOGICAL_8 l8;
GFC_LOGICAL_4 l4[2];
} u;
 
u.l8 = 1;
if (u.l4[0])
big_endian = 0;
else if (u.l4[1])
big_endian = 1;
else
runtime_error ("Unable to determine machine endianness");
}
 
 
static int argc_save;
static char **argv_save;
 
static const char *exe_path;
static int please_free_exe_path_when_done;
 
/* Save the path under which the program was called, for use in the
backtrace routines. */
void
store_exe_path (const char * argv0)
{
#ifndef PATH_MAX
#define PATH_MAX 1024
#endif
 
#ifndef DIR_SEPARATOR
#define DIR_SEPARATOR '/'
#endif
 
char buf[PATH_MAX], *path;
const char *cwd;
 
/* This can only happen if store_exe_path is called multiple times. */
if (please_free_exe_path_when_done)
free ((char *) exe_path);
 
/* Reading the /proc/self/exe symlink is Linux-specific(?), but if
it works it gives the correct answer. */
#ifdef HAVE_READLINK
int len;
if ((len = readlink ("/proc/self/exe", buf, sizeof (buf) - 1)) != -1)
{
buf[len] = '\0';
exe_path = strdup (buf);
please_free_exe_path_when_done = 1;
return;
}
#endif
 
/* If the path is absolute or on a simulator where argv is not set. */
#ifdef __MINGW32__
if (argv0 == NULL
|| ('A' <= argv0[0] && argv0[0] <= 'Z' && argv0[1] == ':')
|| ('a' <= argv0[0] && argv0[0] <= 'z' && argv0[1] == ':')
|| (argv0[0] == '/' && argv0[1] == '/')
|| (argv0[0] == '\\' && argv0[1] == '\\'))
#else
if (argv0 == NULL || argv0[0] == DIR_SEPARATOR)
#endif
{
exe_path = argv0;
please_free_exe_path_when_done = 0;
return;
}
 
#ifdef HAVE_GETCWD
cwd = getcwd (buf, sizeof (buf));
#else
cwd = NULL;
#endif
 
if (!cwd)
{
exe_path = argv0;
please_free_exe_path_when_done = 0;
return;
}
 
/* exe_path will be cwd + "/" + argv[0] + "\0". This will not work
if the executable is not in the cwd, but at this point we're out
of better ideas. */
size_t pathlen = strlen (cwd) + 1 + strlen (argv0) + 1;
path = malloc (pathlen);
snprintf (path, pathlen, "%s%c%s", cwd, DIR_SEPARATOR, argv0);
exe_path = path;
please_free_exe_path_when_done = 1;
}
 
 
/* Return the full path of the executable. */
char *
full_exe_path (void)
{
return (char *) exe_path;
}
 
 
char *addr2line_path;
 
/* Find addr2line and store the path. */
 
void
find_addr2line (void)
{
#ifdef HAVE_ACCESS
#define A2L_LEN 10
char *path = getenv ("PATH");
if (!path)
return;
size_t n = strlen (path);
char ap[n + 1 + A2L_LEN];
size_t ai = 0;
for (size_t i = 0; i < n; i++)
{
if (path[i] != ':')
ap[ai++] = path[i];
else
{
ap[ai++] = '/';
memcpy (ap + ai, "addr2line", A2L_LEN);
if (access (ap, R_OK|X_OK) == 0)
{
addr2line_path = strdup (ap);
return;
}
else
ai = 0;
}
}
#endif
}
 
 
/* Set the saved values of the command line arguments. */
 
void
set_args (int argc, char **argv)
{
argc_save = argc;
argv_save = argv;
store_exe_path (argv[0]);
}
iexport(set_args);
 
 
/* Retrieve the saved values of the command line arguments. */
 
void
get_args (int *argc, char ***argv)
{
*argc = argc_save;
*argv = argv_save;
}
 
 
/* Initialize the runtime library. */
 
static void __attribute__((constructor))
init (void)
{
/* Figure out the machine endianness. */
determine_endianness ();
 
/* Must be first */
init_variables ();
 
init_units ();
set_fpu ();
init_compile_options ();
 
#ifdef DEBUG
/* Check for special command lines. */
 
if (argc > 1 && strcmp (argv[1], "--help") == 0)
show_variables ();
 
/* if (argc > 1 && strcmp(argv[1], "--resume") == 0) resume(); */
#endif
 
if (options.backtrace == 1)
find_addr2line ();
 
random_seed_i4 (NULL, NULL, NULL);
}
 
 
/* Cleanup the runtime library. */
 
static void __attribute__((destructor))
cleanup (void)
{
close_units ();
if (please_free_exe_path_when_done)
free ((char *) exe_path);
 
free (addr2line_path);
}
/stop.c
0,0 → 1,109
/* Implementation of the STOP statement.
Copyright 2002, 2005, 2007, 2009, 2010, 2011 Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.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>
#include <string.h>
#include <unistd.h>
 
/* A numeric STOP statement. */
 
extern void stop_numeric (GFC_INTEGER_4)
__attribute__ ((noreturn));
export_proto(stop_numeric);
 
void
stop_numeric (GFC_INTEGER_4 code)
{
if (code == -1)
code = 0;
else
st_printf ("STOP %d\n", (int)code);
 
exit (code);
}
 
 
/* A Fortran 2008 numeric STOP statement. */
 
extern void stop_numeric_f08 (GFC_INTEGER_4)
__attribute__ ((noreturn));
export_proto(stop_numeric_f08);
 
void
stop_numeric_f08 (GFC_INTEGER_4 code)
{
st_printf ("STOP %d\n", (int)code);
exit (code);
}
 
 
/* A character string or blank STOP statement. */
 
void
stop_string (const char *string, GFC_INTEGER_4 len)
{
if (string)
{
estr_write ("STOP ");
(void) write (STDERR_FILENO, string, len);
estr_write ("\n");
}
exit (0);
}
 
 
/* Per Fortran 2008, section 8.4: "Execution of a STOP statement initiates
normal termination of execution. Execution of an ERROR STOP statement
initiates error termination of execution." Thus, error_stop_string returns
a nonzero exit status code. */
 
extern void error_stop_string (const char *, GFC_INTEGER_4)
__attribute__ ((noreturn));
export_proto(error_stop_string);
 
void
error_stop_string (const char *string, GFC_INTEGER_4 len)
{
estr_write ("ERROR STOP ");
(void) write (STDERR_FILENO, string, len);
estr_write ("\n");
 
exit (1);
}
 
 
/* A numeric ERROR STOP statement. */
 
extern void error_stop_numeric (GFC_INTEGER_4)
__attribute__ ((noreturn));
export_proto(error_stop_numeric);
 
void
error_stop_numeric (GFC_INTEGER_4 code)
{
st_printf ("ERROR STOP %d\n", (int) code);
exit (code);
}
/error.c
0,0 → 1,614
/* Copyright (C) 2002, 2003, 2005, 2006, 2007, 2009, 2010, 2011
Free Software Foundation, Inc.
Contributed by Andy Vaught
 
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 <assert.h>
#include <string.h>
#include <errno.h>
#include <signal.h>
 
#ifdef HAVE_UNISTD_H
#include <unistd.h>
#endif
 
#include <stdlib.h>
 
#ifdef HAVE_SYS_TIME_H
#include <sys/time.h>
#endif
 
/* <sys/time.h> has to be included before <sys/resource.h> to work
around PR 30518; otherwise, MacOS 10.3.9 headers are just broken. */
#ifdef HAVE_SYS_RESOURCE_H
#include <sys/resource.h>
#endif
 
 
#ifdef __MINGW32__
#define HAVE_GETPID 1
#include <process.h>
#endif
 
 
/* Termination of a program: F2008 2.3.5 talks about "normal
termination" and "error termination". Normal termination occurs as
a result of e.g. executing the end program statement, and executing
the STOP statement. It includes the effect of the C exit()
function.
 
Error termination is initiated when the ERROR STOP statement is
executed, when ALLOCATE/DEALLOCATE fails without STAT= being
specified, when some of the co-array synchronization statements
fail without STAT= being specified, and some I/O errors if
ERR/IOSTAT/END/EOR is not present, and finally EXECUTE_COMMAND_LINE
failure without CMDSTAT=.
 
2.3.5 also explains how co-images synchronize during termination.
 
In libgfortran we have two ways of ending a program. exit(code) is
a normal exit; calling exit() also causes open units to be
closed. No backtrace or core dump is needed here. When something
goes wrong, we have sys_abort() which tries to print the backtrace
if -fbacktrace is enabled, and then dumps core; whether a core file
is generated is system dependent. When aborting, we don't flush and
close open units, as program memory might be corrupted and we'd
rather risk losing dirty data in the buffers rather than corrupting
files on disk.
 
*/
 
/* Error conditions. The tricky part here is printing a message when
* it is the I/O subsystem that is severely wounded. Our goal is to
* try and print something making the fewest assumptions possible,
* then try to clean up before actually exiting.
*
* The following exit conditions are defined:
* 0 Normal program exit.
* 1 Terminated because of operating system error.
* 2 Error in the runtime library
* 3 Internal error in runtime library
*
* Other error returns are reserved for the STOP statement with a numeric code.
*/
 
 
/* Write a null-terminated C string to standard error. This function
is async-signal-safe. */
 
ssize_t
estr_write (const char *str)
{
return write (STDERR_FILENO, str, strlen (str));
}
 
 
/* st_vprintf()-- vsnprintf-like function for error output. We use a
stack allocated buffer for formatting; since this function might be
called from within a signal handler, printing directly to stderr
with vfprintf is not safe since the stderr locking might lead to a
deadlock. */
 
#define ST_VPRINTF_SIZE 512
 
int
st_vprintf (const char *format, va_list ap)
{
int written;
char buffer[ST_VPRINTF_SIZE];
 
#ifdef HAVE_VSNPRINTF
written = vsnprintf(buffer, ST_VPRINTF_SIZE, format, ap);
#else
written = vsprintf(buffer, format, ap);
 
if (written >= ST_VPRINTF_SIZE - 1)
{
/* The error message was longer than our buffer. Ouch. Because
we may have messed up things badly, report the error and
quit. */
#define ERROR_MESSAGE "Internal error: buffer overrun in st_vprintf()\n"
write (STDERR_FILENO, buffer, ST_VPRINTF_SIZE - 1);
write (STDERR_FILENO, ERROR_MESSAGE, strlen(ERROR_MESSAGE));
sys_abort ();
#undef ERROR_MESSAGE
 
}
#endif
 
written = write (STDERR_FILENO, buffer, written);
return written;
}
 
 
int
st_printf (const char * format, ...)
{
int written;
va_list ap;
va_start (ap, format);
written = st_vprintf (format, ap);
va_end (ap);
return written;
}
 
 
/* sys_abort()-- Terminate the program showing backtrace and dumping
core. */
 
void
sys_abort (void)
{
/* If backtracing is enabled, print backtrace and disable signal
handler for ABRT. */
if (options.backtrace == 1
|| (options.backtrace == -1 && compile_options.backtrace == 1))
{
show_backtrace ();
signal (SIGABRT, SIG_DFL);
}
 
abort();
}
 
 
/* gfc_xtoa()-- Integer to hexadecimal conversion. */
 
const char *
gfc_xtoa (GFC_UINTEGER_LARGEST n, char *buffer, size_t len)
{
int digit;
char *p;
 
assert (len >= GFC_XTOA_BUF_SIZE);
 
if (n == 0)
return "0";
 
p = buffer + GFC_XTOA_BUF_SIZE - 1;
*p = '\0';
 
while (n != 0)
{
digit = n & 0xF;
if (digit > 9)
digit += 'A' - '0' - 10;
 
*--p = '0' + digit;
n >>= 4;
}
 
return p;
}
 
 
/* Hopefully thread-safe wrapper for a strerror_r() style function. */
 
char *
gf_strerror (int errnum,
char * buf __attribute__((unused)),
size_t buflen __attribute__((unused)))
{
#ifdef HAVE_STRERROR_R
return
__builtin_choose_expr (__builtin_classify_type (strerror_r (0, buf, 0))
== 5,
/* GNU strerror_r() */
strerror_r (errnum, buf, buflen),
/* POSIX strerror_r () */
(strerror_r (errnum, buf, buflen), buf));
#else
/* strerror () is not necessarily thread-safe, but should at least
be available everywhere. */
return strerror (errnum);
#endif
}
 
 
/* show_locus()-- Print a line number and filename describing where
* something went wrong */
 
void
show_locus (st_parameter_common *cmp)
{
char *filename;
 
if (!options.locus || cmp == NULL || cmp->filename == NULL)
return;
if (cmp->unit > 0)
{
filename = filename_from_unit (cmp->unit);
 
if (filename != NULL)
{
st_printf ("At line %d of file %s (unit = %d, file = '%s')\n",
(int) cmp->line, cmp->filename, (int) cmp->unit, filename);
free (filename);
}
else
{
st_printf ("At line %d of file %s (unit = %d)\n",
(int) cmp->line, cmp->filename, (int) cmp->unit);
}
return;
}
 
st_printf ("At line %d of file %s\n", (int) cmp->line, cmp->filename);
}
 
 
/* recursion_check()-- It's possible for additional errors to occur
* during fatal error processing. We detect this condition here and
* exit with code 4 immediately. */
 
#define MAGIC 0x20DE8101
 
static void
recursion_check (void)
{
static int magic = 0;
 
/* Don't even try to print something at this point */
if (magic == MAGIC)
sys_abort ();
 
magic = MAGIC;
}
 
 
#define STRERR_MAXSZ 256
 
/* os_error()-- Operating system error. We get a message from the
* operating system, show it and leave. Some operating system errors
* are caught and processed by the library. If not, we come here. */
 
void
os_error (const char *message)
{
char errmsg[STRERR_MAXSZ];
recursion_check ();
estr_write ("Operating system error: ");
estr_write (gf_strerror (errno, errmsg, STRERR_MAXSZ));
estr_write ("\n");
estr_write (message);
estr_write ("\n");
exit (1);
}
iexport(os_error);
 
 
/* void runtime_error()-- These are errors associated with an
* invalid fortran program. */
 
void
runtime_error (const char *message, ...)
{
va_list ap;
 
recursion_check ();
estr_write ("Fortran runtime error: ");
va_start (ap, message);
st_vprintf (message, ap);
va_end (ap);
estr_write ("\n");
exit (2);
}
iexport(runtime_error);
 
/* void runtime_error_at()-- These are errors associated with a
* run time error generated by the front end compiler. */
 
void
runtime_error_at (const char *where, const char *message, ...)
{
va_list ap;
 
recursion_check ();
estr_write (where);
estr_write ("\nFortran runtime error: ");
va_start (ap, message);
st_vprintf (message, ap);
va_end (ap);
estr_write ("\n");
exit (2);
}
iexport(runtime_error_at);
 
 
void
runtime_warning_at (const char *where, const char *message, ...)
{
va_list ap;
 
estr_write (where);
estr_write ("\nFortran runtime warning: ");
va_start (ap, message);
st_vprintf (message, ap);
va_end (ap);
estr_write ("\n");
}
iexport(runtime_warning_at);
 
 
/* void internal_error()-- These are this-can't-happen errors
* that indicate something deeply wrong. */
 
void
internal_error (st_parameter_common *cmp, const char *message)
{
recursion_check ();
show_locus (cmp);
estr_write ("Internal Error: ");
estr_write (message);
estr_write ("\n");
 
/* This function call is here to get the main.o object file included
when linking statically. This works because error.o is supposed to
be always linked in (and the function call is in internal_error
because hopefully it doesn't happen too often). */
stupid_function_name_for_static_linking();
 
exit (3);
}
 
 
/* translate_error()-- Given an integer error code, return a string
* describing the error. */
 
const char *
translate_error (int code)
{
const char *p;
 
switch (code)
{
case LIBERROR_EOR:
p = "End of record";
break;
 
case LIBERROR_END:
p = "End of file";
break;
 
case LIBERROR_OK:
p = "Successful return";
break;
 
case LIBERROR_OS:
p = "Operating system error";
break;
 
case LIBERROR_BAD_OPTION:
p = "Bad statement option";
break;
 
case LIBERROR_MISSING_OPTION:
p = "Missing statement option";
break;
 
case LIBERROR_OPTION_CONFLICT:
p = "Conflicting statement options";
break;
 
case LIBERROR_ALREADY_OPEN:
p = "File already opened in another unit";
break;
 
case LIBERROR_BAD_UNIT:
p = "Unattached unit";
break;
 
case LIBERROR_FORMAT:
p = "FORMAT error";
break;
 
case LIBERROR_BAD_ACTION:
p = "Incorrect ACTION specified";
break;
 
case LIBERROR_ENDFILE:
p = "Read past ENDFILE record";
break;
 
case LIBERROR_BAD_US:
p = "Corrupt unformatted sequential file";
break;
 
case LIBERROR_READ_VALUE:
p = "Bad value during read";
break;
 
case LIBERROR_READ_OVERFLOW:
p = "Numeric overflow on read";
break;
 
case LIBERROR_INTERNAL:
p = "Internal error in run-time library";
break;
 
case LIBERROR_INTERNAL_UNIT:
p = "Internal unit I/O error";
break;
 
case LIBERROR_DIRECT_EOR:
p = "Write exceeds length of DIRECT access record";
break;
 
case LIBERROR_SHORT_RECORD:
p = "I/O past end of record on unformatted file";
break;
 
case LIBERROR_CORRUPT_FILE:
p = "Unformatted file structure has been corrupted";
break;
 
default:
p = "Unknown error code";
break;
}
 
return p;
}
 
 
/* generate_error()-- Come here when an error happens. This
* subroutine is called if it is possible to continue on after the error.
* If an IOSTAT or IOMSG variable exists, we set it. If IOSTAT or
* ERR labels are present, we return, otherwise we terminate the program
* after printing a message. The error code is always required but the
* message parameter can be NULL, in which case a string describing
* the most recent operating system error is used. */
 
void
generate_error (st_parameter_common *cmp, int family, const char *message)
{
char errmsg[STRERR_MAXSZ];
 
/* If there was a previous error, don't mask it with another
error message, EOF or EOR condition. */
 
if ((cmp->flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_ERROR)
return;
 
/* Set the error status. */
if ((cmp->flags & IOPARM_HAS_IOSTAT))
*cmp->iostat = (family == LIBERROR_OS) ? errno : family;
 
if (message == NULL)
message =
(family == LIBERROR_OS) ? gf_strerror (errno, errmsg, STRERR_MAXSZ) :
translate_error (family);
 
if (cmp->flags & IOPARM_HAS_IOMSG)
cf_strcpy (cmp->iomsg, cmp->iomsg_len, message);
 
/* Report status back to the compiler. */
cmp->flags &= ~IOPARM_LIBRETURN_MASK;
switch (family)
{
case LIBERROR_EOR:
cmp->flags |= IOPARM_LIBRETURN_EOR;
if ((cmp->flags & IOPARM_EOR))
return;
break;
 
case LIBERROR_END:
cmp->flags |= IOPARM_LIBRETURN_END;
if ((cmp->flags & IOPARM_END))
return;
break;
 
default:
cmp->flags |= IOPARM_LIBRETURN_ERROR;
if ((cmp->flags & IOPARM_ERR))
return;
break;
}
 
/* Return if the user supplied an iostat variable. */
if ((cmp->flags & IOPARM_HAS_IOSTAT))
return;
 
/* Terminate the program */
 
recursion_check ();
show_locus (cmp);
estr_write ("Fortran runtime error: ");
estr_write (message);
estr_write ("\n");
exit (2);
}
iexport(generate_error);
 
 
/* generate_warning()-- Similar to generate_error but just give a warning. */
 
void
generate_warning (st_parameter_common *cmp, const char *message)
{
if (message == NULL)
message = " ";
 
show_locus (cmp);
estr_write ("Fortran runtime warning: ");
estr_write (message);
estr_write ("\n");
}
 
 
/* Whether, for a feature included in a given standard set (GFC_STD_*),
we should issue an error or a warning, or be quiet. */
 
notification
notification_std (int std)
{
int warning;
 
if (!compile_options.pedantic)
return NOTIFICATION_SILENT;
 
warning = compile_options.warn_std & std;
if ((compile_options.allow_std & std) != 0 && !warning)
return NOTIFICATION_SILENT;
 
return warning ? NOTIFICATION_WARNING : NOTIFICATION_ERROR;
}
 
 
/* Possibly issue a warning/error about use of a nonstandard (or deleted)
feature. An error/warning will be issued if the currently selected
standard does not contain the requested bits. */
 
try
notify_std (st_parameter_common *cmp, int std, const char * message)
{
int warning;
 
if (!compile_options.pedantic)
return SUCCESS;
 
warning = compile_options.warn_std & std;
if ((compile_options.allow_std & std) != 0 && !warning)
return SUCCESS;
 
if (!warning)
{
recursion_check ();
show_locus (cmp);
estr_write ("Fortran runtime error: ");
estr_write (message);
estr_write ("\n");
exit (2);
}
else
{
show_locus (cmp);
estr_write ("Fortran runtime warning: ");
estr_write (message);
estr_write ("\n");
}
return FAILURE;
}
/fpu.c
0,0 → 1,41
/* Set FPU mask.
Copyright 2005 Free Software Foundation, Inc.
Contributed by Francois-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"
 
/* We include the platform-dependent code. */
#include "fpu-target.h"
 
/* Function called by the front-end to tell us
when a FPE should be raised. */
extern void set_fpe (int);
export_proto(set_fpe);
 
void
set_fpe (int exceptions)
{
options.fpe = exceptions;
set_fpu ();
}
/bounds.c
0,0 → 1,272
/* Copyright (C) 2009
Free Software Foundation, Inc.
Contributed by Thomas Koenig
 
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 <assert.h>
 
/* Auxiliary functions for bounds checking, mostly to reduce library size. */
 
/* Bounds checking for the return values of the iforeach functions (such
as maxloc and minloc). The extent of ret_array must
must match the rank of array. */
 
void
bounds_iforeach_return (array_t *retarray, array_t *array, const char *name)
{
index_type rank;
index_type ret_rank;
index_type ret_extent;
 
ret_rank = GFC_DESCRIPTOR_RANK (retarray);
 
if (ret_rank != 1)
runtime_error ("Incorrect rank of return array in %s intrinsic:"
"is %ld, should be 1", name, (long int) ret_rank);
 
rank = GFC_DESCRIPTOR_RANK (array);
ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,0);
if (ret_extent != rank)
runtime_error ("Incorrect extent in return value of"
" %s intrinsic: is %ld, should be %ld",
name, (long int) ret_extent, (long int) rank);
 
}
 
/* Check the return of functions generated from ifunction.m4.
We check the array descriptor "a" against the extents precomputed
from ifunction.m4, and complain about the argument a_name in the
intrinsic function. */
 
void
bounds_ifunction_return (array_t * a, const index_type * extent,
const char * a_name, const char * intrinsic)
{
int empty;
int n;
int rank;
index_type a_size;
 
rank = GFC_DESCRIPTOR_RANK (a);
a_size = size0 (a);
 
empty = 0;
for (n = 0; n < rank; n++)
{
if (extent[n] == 0)
empty = 1;
}
if (empty)
{
if (a_size != 0)
runtime_error ("Incorrect size in %s of %s"
" intrinsic: should be zero-sized",
a_name, intrinsic);
}
else
{
if (a_size == 0)
runtime_error ("Incorrect size of %s in %s"
" intrinsic: should not be zero-sized",
a_name, intrinsic);
 
for (n = 0; n < rank; n++)
{
index_type a_extent;
a_extent = GFC_DESCRIPTOR_EXTENT(a, n);
if (a_extent != extent[n])
runtime_error("Incorrect extent in %s of %s"
" intrinsic in dimension %ld: is %ld,"
" should be %ld", a_name, intrinsic, (long int) n + 1,
(long int) a_extent, (long int) extent[n]);
 
}
}
}
 
/* Check that two arrays have equal extents, or are both zero-sized. Abort
with a runtime error if this is not the case. Complain that a has the
wrong size. */
 
void
bounds_equal_extents (array_t *a, array_t *b, const char *a_name,
const char *intrinsic)
{
index_type a_size, b_size, n;
 
assert (GFC_DESCRIPTOR_RANK(a) == GFC_DESCRIPTOR_RANK(b));
 
a_size = size0 (a);
b_size = size0 (b);
 
if (b_size == 0)
{
if (a_size != 0)
runtime_error ("Incorrect size of %s in %s"
" intrinsic: should be zero-sized",
a_name, intrinsic);
}
else
{
if (a_size == 0)
runtime_error ("Incorrect size of %s of %s"
" intrinsic: Should not be zero-sized",
a_name, intrinsic);
 
for (n = 0; n < GFC_DESCRIPTOR_RANK (b); n++)
{
index_type a_extent, b_extent;
a_extent = GFC_DESCRIPTOR_EXTENT(a, n);
b_extent = GFC_DESCRIPTOR_EXTENT(b, n);
if (a_extent != b_extent)
runtime_error("Incorrect extent in %s of %s"
" intrinsic in dimension %ld: is %ld,"
" should be %ld", a_name, intrinsic, (long int) n + 1,
(long int) a_extent, (long int) b_extent);
}
}
}
 
/* Check that the extents of a and b agree, except that a has a missing
dimension in argument which. Complain about a if anything is wrong. */
 
void
bounds_reduced_extents (array_t *a, array_t *b, int which, const char *a_name,
const char *intrinsic)
{
 
index_type i, n, a_size, b_size;
 
assert (GFC_DESCRIPTOR_RANK(a) == GFC_DESCRIPTOR_RANK(b) - 1);
 
a_size = size0 (a);
b_size = size0 (b);
 
if (b_size == 0)
{
if (a_size != 0)
runtime_error ("Incorrect size in %s of %s"
" intrinsic: should not be zero-sized",
a_name, intrinsic);
}
else
{
if (a_size == 0)
runtime_error ("Incorrect size of %s of %s"
" intrinsic: should be zero-sized",
a_name, intrinsic);
 
i = 0;
for (n = 0; n < GFC_DESCRIPTOR_RANK (b); n++)
{
index_type a_extent, b_extent;
 
if (n != which)
{
a_extent = GFC_DESCRIPTOR_EXTENT(a, i);
b_extent = GFC_DESCRIPTOR_EXTENT(b, n);
if (a_extent != b_extent)
runtime_error("Incorrect extent in %s of %s"
" intrinsic in dimension %ld: is %ld,"
" should be %ld", a_name, intrinsic, (long int) i + 1,
(long int) a_extent, (long int) b_extent);
i++;
}
}
}
}
 
/* count_0 - count all the true elements in an array. The front
end usually inlines this, we need this for bounds checking
for unpack. */
 
index_type count_0 (const gfc_array_l1 * array)
{
const GFC_LOGICAL_1 * restrict base;
index_type rank;
int kind;
int continue_loop;
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type sstride[GFC_MAX_DIMENSIONS];
index_type result;
index_type n;
 
rank = GFC_DESCRIPTOR_RANK (array);
kind = GFC_DESCRIPTOR_SIZE (array);
 
base = array->data;
 
if (kind == 1 || kind == 2 || kind == 4 || kind == 8
#ifdef HAVE_GFC_LOGICAL_16
|| kind == 16
#endif
)
{
if (base)
base = GFOR_POINTER_TO_L1 (base, kind);
}
else
internal_error (NULL, "Funny sized logical array in count_0");
 
for (n = 0; n < rank; n++)
{
sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,n);
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
count[n] = 0;
 
if (extent[n] <= 0)
return 0;
}
 
result = 0;
continue_loop = 1;
while (continue_loop)
{
if (*base)
result ++;
 
count[0]++;
base += sstride[0];
n = 0;
while (count[n] == extent[n])
{
count[n] = 0;
base -= sstride[n] * extent[n];
n++;
if (n == rank)
{
continue_loop = 0;
break;
}
else
{
count[n]++;
base += sstride[n];
}
}
}
return result;
}

powered by: WebSVN 2.1.0

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