diff options
Diffstat (limited to 'gcc-4.4.3/libgfortran/m4')
42 files changed, 0 insertions, 5561 deletions
diff --git a/gcc-4.4.3/libgfortran/m4/all.m4 b/gcc-4.4.3/libgfortran/m4/all.m4 deleted file mode 100644 index 4dc4d1dc2..000000000 --- a/gcc-4.4.3/libgfortran/m4/all.m4 +++ /dev/null @@ -1,44 +0,0 @@ -`/* Implementation of the ALL intrinsic - 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. - -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(iparm.m4)dnl -include(ifunction_logical.m4)dnl - -`#if defined (HAVE_'rtype_name`)' - -ARRAY_FUNCTION(1, -` /* Return true only if all the elements are set. */ - result = 1;', -` if (! *src) - { - result = 0; - break; - }')` - -#endif' diff --git a/gcc-4.4.3/libgfortran/m4/any.m4 b/gcc-4.4.3/libgfortran/m4/any.m4 deleted file mode 100644 index e2a22705f..000000000 --- a/gcc-4.4.3/libgfortran/m4/any.m4 +++ /dev/null @@ -1,44 +0,0 @@ -`/* Implementation of the ANY intrinsic - 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. - -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(iparm.m4)dnl -include(ifunction_logical.m4)dnl - -`#if defined (HAVE_'rtype_name`)' - -ARRAY_FUNCTION(0, -` result = 0;', -` /* Return true if any of the elements are set. */ - if (*src) - { - result = 1; - break; - }')` - -#endif' diff --git a/gcc-4.4.3/libgfortran/m4/count.m4 b/gcc-4.4.3/libgfortran/m4/count.m4 deleted file mode 100644 index 5a669954c..000000000 --- a/gcc-4.4.3/libgfortran/m4/count.m4 +++ /dev/null @@ -1,40 +0,0 @@ -`/* Implementation of the COUNT intrinsic - 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. - -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(iparm.m4)dnl -include(ifunction_logical.m4)dnl - -`#if defined (HAVE_'rtype_name`)' - -ARRAY_FUNCTION(0, -` result = 0;', -` if (*src) - result++;')` - -#endif' diff --git a/gcc-4.4.3/libgfortran/m4/cshift0.m4 b/gcc-4.4.3/libgfortran/m4/cshift0.m4 deleted file mode 100644 index da385cbfb..000000000 --- a/gcc-4.4.3/libgfortran/m4/cshift0.m4 +++ /dev/null @@ -1,172 +0,0 @@ -`/* Helper function for cshift functions. - Copyright 2008, 2009 Free Software Foundation, Inc. - Contributed by Thomas Koenig <tkoenig@gcc.gnu.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>' - -include(iparm.m4)dnl - -`#if defined (HAVE_'rtype_name`) - -void -cshift0_'rtype_code` ('rtype` *ret, const 'rtype` *array, ssize_t shift, - int which) -{ - /* r.* indicates the return array. */ - index_type rstride[GFC_MAX_DIMENSIONS]; - index_type rstride0; - index_type roffset; - 'rtype_name` *rptr; - - /* s.* indicates the source array. */ - index_type sstride[GFC_MAX_DIMENSIONS]; - index_type sstride0; - index_type soffset; - const 'rtype_name` *sptr; - - index_type count[GFC_MAX_DIMENSIONS]; - index_type extent[GFC_MAX_DIMENSIONS]; - index_type dim; - index_type len; - index_type n; - - which = which - 1; - sstride[0] = 0; - rstride[0] = 0; - - extent[0] = 1; - count[0] = 0; - n = 0; - /* Initialized for avoiding compiler warnings. */ - roffset = 1; - soffset = 1; - len = 0; - - for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++) - { - if (dim == which) - { - roffset = ret->dim[dim].stride; - if (roffset == 0) - roffset = 1; - soffset = array->dim[dim].stride; - if (soffset == 0) - soffset = 1; - len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; - } - else - { - count[n] = 0; - extent[n] = array->dim[dim].ubound + 1 - array->dim[dim].lbound; - rstride[n] = ret->dim[dim].stride; - sstride[n] = array->dim[dim].stride; - n++; - } - } - if (sstride[0] == 0) - sstride[0] = 1; - if (rstride[0] == 0) - rstride[0] = 1; - - dim = GFC_DESCRIPTOR_RANK (array); - rstride0 = rstride[0]; - sstride0 = sstride[0]; - rptr = ret->data; - sptr = array->data; - - shift = len == 0 ? 0 : shift % (ssize_t)len; - if (shift < 0) - shift += len; - - while (rptr) - { - /* Do the shift for this dimension. */ - - /* If elements are contiguous, perform the operation - in two block moves. */ - if (soffset == 1 && roffset == 1) - { - size_t len1 = shift * sizeof ('rtype_name`); - size_t len2 = (len - shift) * sizeof ('rtype_name`); - memcpy (rptr, sptr + shift, len2); - memcpy (rptr + (len - shift), sptr, len1); - } - else - { - /* Otherwise, we will have to perform the copy one element at - a time. */ - 'rtype_name` *dest = rptr; - const 'rtype_name` *src = &sptr[shift * soffset]; - - for (n = 0; n < len - shift; n++) - { - *dest = *src; - dest += roffset; - src += soffset; - } - for (src = sptr, n = 0; n < shift; n++) - { - *dest = *src; - 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]; - } - } - } - - return; -} - -#endif' diff --git a/gcc-4.4.3/libgfortran/m4/cshift1.m4 b/gcc-4.4.3/libgfortran/m4/cshift1.m4 deleted file mode 100644 index 3c5ff5e66..000000000 --- a/gcc-4.4.3/libgfortran/m4/cshift1.m4 +++ /dev/null @@ -1,257 +0,0 @@ -`/* Implementation of the CSHIFT intrinsic - Copyright 2003, 2007, 2009 Free Software Foundation, Inc. - Contributed by Feng Wang <wf_cs@yahoo.com> - -This file is part of the GNU Fortran 95 runtime library (libgfortran). - -Libgfortran is free software; you can redistribute it and/or -modify it under the terms of the GNU General Public -License as published by the Free Software Foundation; either -version 3 of the License, or (at your option) any later version. - -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>' - -include(iparm.m4)dnl - -`#if defined (HAVE_'atype_name`) - -static void -cshift1 (gfc_array_char * const restrict ret, - const gfc_array_char * const restrict array, - const 'atype` * const restrict h, - const 'atype_name` * const restrict pwhich, - index_type size) -{ - /* r.* indicates the return array. */ - index_type rstride[GFC_MAX_DIMENSIONS]; - index_type rstride0; - index_type roffset; - char *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; - /* h.* indicates the shift array. */ - index_type hstride[GFC_MAX_DIMENSIONS]; - index_type hstride0; - const 'atype_name` *hptr; - - index_type count[GFC_MAX_DIMENSIONS]; - index_type extent[GFC_MAX_DIMENSIONS]; - index_type dim; - index_type len; - index_type n; - int which; - 'atype_name` sh; - index_type arraysize; - - if (pwhich) - which = *pwhich - 1; - else - which = 0; - - if (which < 0 || (which + 1) > 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->data = internal_malloc_size (size * arraysize); - ret->offset = 0; - ret->dtype = array->dtype; - for (i = 0; i < GFC_DESCRIPTOR_RANK (array); i++) - { - ret->dim[i].lbound = 0; - ret->dim[i].ubound = array->dim[i].ubound - array->dim[i].lbound; - - if (i == 0) - ret->dim[i].stride = 1; - else - ret->dim[i].stride = (ret->dim[i-1].ubound + 1) * ret->dim[i-1].stride; - } - } - - if (arraysize == 0) - return; - - extent[0] = 1; - count[0] = 0; - n = 0; - - /* Initialized for avoiding compiler warnings. */ - roffset = size; - soffset = size; - len = 0; - - for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++) - { - if (dim == which) - { - roffset = ret->dim[dim].stride * size; - if (roffset == 0) - roffset = size; - soffset = array->dim[dim].stride * size; - if (soffset == 0) - soffset = size; - len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; - } - else - { - count[n] = 0; - extent[n] = array->dim[dim].ubound + 1 - array->dim[dim].lbound; - rstride[n] = ret->dim[dim].stride * size; - sstride[n] = array->dim[dim].stride * size; - - hstride[n] = h->dim[n].stride; - n++; - } - } - if (sstride[0] == 0) - sstride[0] = size; - if (rstride[0] == 0) - rstride[0] = size; - if (hstride[0] == 0) - hstride[0] = 1; - - dim = GFC_DESCRIPTOR_RANK (array); - rstride0 = rstride[0]; - sstride0 = sstride[0]; - hstride0 = hstride[0]; - rptr = ret->data; - sptr = array->data; - hptr = h->data; - - while (rptr) - { - /* Do the shift for this dimension. */ - sh = *hptr; - sh = (div (sh, len)).rem; - if (sh < 0) - sh += len; - - src = &sptr[sh * soffset]; - dest = rptr; - - for (n = 0; n < len; n++) - { - memcpy (dest, src, size); - dest += roffset; - if (n == len - sh - 1) - src = sptr; - else - src += soffset; - } - - /* Advance to the next section. */ - rptr += rstride0; - sptr += sstride0; - hptr += hstride0; - 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]; - hptr -= hstride[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]; - hptr += hstride[n]; - } - } - } -} - -void cshift1_'atype_kind` (gfc_array_char * const restrict, - const gfc_array_char * const restrict, - const 'atype` * const restrict, - const 'atype_name` * const restrict); -export_proto(cshift1_'atype_kind`); - -void -cshift1_'atype_kind` (gfc_array_char * const restrict ret, - const gfc_array_char * const restrict array, - const 'atype` * const restrict h, - const 'atype_name` * const restrict pwhich) -{ - cshift1 (ret, array, h, pwhich, GFC_DESCRIPTOR_SIZE (array)); -} - - -void cshift1_'atype_kind`_char (gfc_array_char * const restrict ret, - GFC_INTEGER_4, - const gfc_array_char * const restrict array, - const 'atype` * const restrict h, - const 'atype_name` * const restrict pwhich, - GFC_INTEGER_4); -export_proto(cshift1_'atype_kind`_char); - -void -cshift1_'atype_kind`_char (gfc_array_char * const restrict ret, - GFC_INTEGER_4 ret_length __attribute__((unused)), - const gfc_array_char * const restrict array, - const 'atype` * const restrict h, - const 'atype_name` * const restrict pwhich, - GFC_INTEGER_4 array_length) -{ - cshift1 (ret, array, h, pwhich, array_length); -} - - -void cshift1_'atype_kind`_char4 (gfc_array_char * const restrict ret, - GFC_INTEGER_4, - const gfc_array_char * const restrict array, - const 'atype` * const restrict h, - const 'atype_name` * const restrict pwhich, - GFC_INTEGER_4); -export_proto(cshift1_'atype_kind`_char4); - -void -cshift1_'atype_kind`_char4 (gfc_array_char * const restrict ret, - GFC_INTEGER_4 ret_length __attribute__((unused)), - const gfc_array_char * const restrict array, - const 'atype` * const restrict h, - const 'atype_name` * const restrict pwhich, - GFC_INTEGER_4 array_length) -{ - cshift1 (ret, array, h, pwhich, array_length * sizeof (gfc_char4_t)); -} - -#endif' diff --git a/gcc-4.4.3/libgfortran/m4/eoshift1.m4 b/gcc-4.4.3/libgfortran/m4/eoshift1.m4 deleted file mode 100644 index 1ecf0a954..000000000 --- a/gcc-4.4.3/libgfortran/m4/eoshift1.m4 +++ /dev/null @@ -1,297 +0,0 @@ -`/* 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>' - -include(iparm.m4)dnl - -`#if defined (HAVE_'atype_name`) - -static void -eoshift1 (gfc_array_char * const restrict ret, - const gfc_array_char * const restrict array, - const 'atype` * const restrict h, - const char * const restrict pbound, - const 'atype_name` * const restrict pwhich, - 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 *rptr; - char * restrict dest; - /* s.* indicates the source array. */ - index_type sstride[GFC_MAX_DIMENSIONS]; - index_type sstride0; - index_type soffset; - const char *sptr; - const char *src; - /* h.* indicates the shift array. */ - index_type hstride[GFC_MAX_DIMENSIONS]; - index_type hstride0; - const 'atype_name` *hptr; - - index_type count[GFC_MAX_DIMENSIONS]; - index_type extent[GFC_MAX_DIMENSIONS]; - index_type dim; - index_type len; - index_type n; - int which; - 'atype_name` sh; - 'atype_name` delta; - - /* The compiler cannot figure out that these are set, initialize - them to avoid warnings. */ - len = 0; - soffset = 0; - roffset = 0; - - if (pwhich) - which = *pwhich - 1; - else - which = 0; - - extent[0] = 1; - count[0] = 0; - - if (ret->data == NULL) - { - int i; - - ret->data = internal_malloc_size (size * size0 ((array_t *)array)); - ret->offset = 0; - ret->dtype = array->dtype; - for (i = 0; i < GFC_DESCRIPTOR_RANK (array); i++) - { - ret->dim[i].lbound = 0; - ret->dim[i].ubound = array->dim[i].ubound - array->dim[i].lbound; - - if (i == 0) - ret->dim[i].stride = 1; - else - ret->dim[i].stride = (ret->dim[i-1].ubound + 1) * ret->dim[i-1].stride; - } - } - else - { - if (size0 ((array_t *) ret) == 0) - return; - } - - n = 0; - for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++) - { - if (dim == which) - { - roffset = ret->dim[dim].stride * size; - if (roffset == 0) - roffset = size; - soffset = array->dim[dim].stride * size; - if (soffset == 0) - soffset = size; - len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; - } - else - { - count[n] = 0; - extent[n] = array->dim[dim].ubound + 1 - array->dim[dim].lbound; - rstride[n] = ret->dim[dim].stride * size; - sstride[n] = array->dim[dim].stride * size; - - hstride[n] = h->dim[n].stride; - n++; - } - } - if (sstride[0] == 0) - sstride[0] = size; - if (rstride[0] == 0) - rstride[0] = size; - if (hstride[0] == 0) - hstride[0] = 1; - - dim = GFC_DESCRIPTOR_RANK (array); - rstride0 = rstride[0]; - sstride0 = sstride[0]; - hstride0 = hstride[0]; - rptr = ret->data; - sptr = array->data; - hptr = h->data; - - while (rptr) - { - /* Do the shift for this dimension. */ - sh = *hptr; - if (( sh >= 0 ? sh : -sh ) > len) - { - delta = len; - sh = len; - } - else - delta = (sh >= 0) ? sh: -sh; - - if (sh > 0) - { - src = &sptr[delta * soffset]; - dest = rptr; - } - else - { - src = sptr; - dest = &rptr[delta * roffset]; - } - for (n = 0; n < len - delta; n++) - { - memcpy (dest, src, size); - dest += roffset; - src += soffset; - } - if (sh < 0) - dest = rptr; - n = delta; - - 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; - hptr += hstride0; - 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]; - hptr -= hstride[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]; - hptr += hstride[n]; - } - } - } -} - -void eoshift1_'atype_kind` (gfc_array_char * const restrict, - const gfc_array_char * const restrict, - const 'atype` * const restrict, const char * const restrict, - const 'atype_name` * const restrict); -export_proto(eoshift1_'atype_kind`); - -void -eoshift1_'atype_kind` (gfc_array_char * const restrict ret, - const gfc_array_char * const restrict array, - const 'atype` * const restrict h, - const char * const restrict pbound, - const 'atype_name` * const restrict pwhich) -{ - eoshift1 (ret, array, h, pbound, pwhich, GFC_DESCRIPTOR_SIZE (array), - "\0", 1); -} - - -void eoshift1_'atype_kind`_char (gfc_array_char * const restrict, - GFC_INTEGER_4, - const gfc_array_char * const restrict, - const 'atype` * const restrict, - const char * const restrict, - const 'atype_name` * const restrict, - GFC_INTEGER_4, GFC_INTEGER_4); -export_proto(eoshift1_'atype_kind`_char); - -void -eoshift1_'atype_kind`_char (gfc_array_char * const restrict ret, - GFC_INTEGER_4 ret_length __attribute__((unused)), - const gfc_array_char * const restrict array, - const 'atype` * const restrict h, - const char * const restrict pbound, - const 'atype_name` * const restrict pwhich, - GFC_INTEGER_4 array_length, - GFC_INTEGER_4 bound_length __attribute__((unused))) -{ - eoshift1 (ret, array, h, pbound, pwhich, array_length, " ", 1); -} - - -void eoshift1_'atype_kind`_char4 (gfc_array_char * const restrict, - GFC_INTEGER_4, - const gfc_array_char * const restrict, - const 'atype` * const restrict, - const char * const restrict, - const 'atype_name` * const restrict, - GFC_INTEGER_4, GFC_INTEGER_4); -export_proto(eoshift1_'atype_kind`_char4); - -void -eoshift1_'atype_kind`_char4 (gfc_array_char * const restrict ret, - GFC_INTEGER_4 ret_length __attribute__((unused)), - const gfc_array_char * const restrict array, - const 'atype` * const restrict h, - const char * const restrict pbound, - const 'atype_name` * const restrict pwhich, - GFC_INTEGER_4 array_length, - GFC_INTEGER_4 bound_length __attribute__((unused))) -{ - static const gfc_char4_t space = (unsigned char) ''` ''`; - eoshift1 (ret, array, h, pbound, pwhich, array_length * sizeof (gfc_char4_t), - (const char *) &space, sizeof (gfc_char4_t)); -} - -#endif' diff --git a/gcc-4.4.3/libgfortran/m4/eoshift3.m4 b/gcc-4.4.3/libgfortran/m4/eoshift3.m4 deleted file mode 100644 index 902c3cdbf..000000000 --- a/gcc-4.4.3/libgfortran/m4/eoshift3.m4 +++ /dev/null @@ -1,316 +0,0 @@ -`/* 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>' - -include(iparm.m4)dnl - -`#if defined (HAVE_'atype_name`) - -static void -eoshift3 (gfc_array_char * const restrict ret, - const gfc_array_char * const restrict array, - const 'atype` * const restrict h, - const gfc_array_char * const restrict bound, - const 'atype_name` * const restrict pwhich, - 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 *rptr; - char * restrict dest; - /* s.* indicates the source array. */ - index_type sstride[GFC_MAX_DIMENSIONS]; - index_type sstride0; - index_type soffset; - const char *sptr; - const char *src; - /* h.* indicates the shift array. */ - index_type hstride[GFC_MAX_DIMENSIONS]; - index_type hstride0; - const 'atype_name` *hptr; - /* 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; - int which; - 'atype_name` sh; - 'atype_name` delta; - - /* The compiler cannot figure out that these are set, initialize - them to avoid warnings. */ - len = 0; - soffset = 0; - roffset = 0; - - if (pwhich) - which = *pwhich - 1; - else - which = 0; - - if (ret->data == NULL) - { - int i; - - ret->data = internal_malloc_size (size * size0 ((array_t *)array)); - ret->offset = 0; - ret->dtype = array->dtype; - for (i = 0; i < GFC_DESCRIPTOR_RANK (array); i++) - { - ret->dim[i].lbound = 0; - ret->dim[i].ubound = array->dim[i].ubound - array->dim[i].lbound; - - if (i == 0) - ret->dim[i].stride = 1; - else - ret->dim[i].stride = (ret->dim[i-1].ubound + 1) * ret->dim[i-1].stride; - } - } - else - { - if (size0 ((array_t *) ret) == 0) - return; - } - - - extent[0] = 1; - count[0] = 0; - n = 0; - for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++) - { - if (dim == which) - { - roffset = ret->dim[dim].stride * size; - if (roffset == 0) - roffset = size; - soffset = array->dim[dim].stride * size; - if (soffset == 0) - soffset = size; - len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; - } - else - { - count[n] = 0; - extent[n] = array->dim[dim].ubound + 1 - array->dim[dim].lbound; - rstride[n] = ret->dim[dim].stride * size; - sstride[n] = array->dim[dim].stride * size; - - hstride[n] = h->dim[n].stride; - if (bound) - bstride[n] = bound->dim[n].stride * size; - else - bstride[n] = 0; - n++; - } - } - if (sstride[0] == 0) - sstride[0] = size; - if (rstride[0] == 0) - rstride[0] = size; - if (hstride[0] == 0) - hstride[0] = 1; - if (bound && bstride[0] == 0) - bstride[0] = size; - - dim = GFC_DESCRIPTOR_RANK (array); - rstride0 = rstride[0]; - sstride0 = sstride[0]; - hstride0 = hstride[0]; - bstride0 = bstride[0]; - rptr = ret->data; - sptr = array->data; - hptr = h->data; - if (bound) - bptr = bound->data; - else - bptr = NULL; - - while (rptr) - { - /* Do the shift for this dimension. */ - sh = *hptr; - if (( sh >= 0 ? sh : -sh ) > len) - { - delta = len; - sh = len; - } - else - delta = (sh >= 0) ? sh: -sh; - - if (sh > 0) - { - src = &sptr[delta * soffset]; - dest = rptr; - } - else - { - src = sptr; - dest = &rptr[delta * roffset]; - } - for (n = 0; n < len - delta; n++) - { - memcpy (dest, src, size); - dest += roffset; - src += soffset; - } - if (sh < 0) - dest = rptr; - n = delta; - - 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; - hptr += hstride0; - 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]; - hptr -= hstride[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]; - hptr += hstride[n]; - bptr += bstride[n]; - } - } - } -} - -extern void eoshift3_'atype_kind` (gfc_array_char * const restrict, - const gfc_array_char * const restrict, - const 'atype` * const restrict, - const gfc_array_char * const restrict, - const 'atype_name` *); -export_proto(eoshift3_'atype_kind`); - -void -eoshift3_'atype_kind` (gfc_array_char * const restrict ret, - const gfc_array_char * const restrict array, - const 'atype` * const restrict h, - const gfc_array_char * const restrict bound, - const 'atype_name` * const restrict pwhich) -{ - eoshift3 (ret, array, h, bound, pwhich, GFC_DESCRIPTOR_SIZE (array), - "\0", 1); -} - - -extern void eoshift3_'atype_kind`_char (gfc_array_char * const restrict, - GFC_INTEGER_4, - const gfc_array_char * const restrict, - const 'atype` * const restrict, - const gfc_array_char * const restrict, - const 'atype_name` * const restrict, - GFC_INTEGER_4, GFC_INTEGER_4); -export_proto(eoshift3_'atype_kind`_char); - -void -eoshift3_'atype_kind`_char (gfc_array_char * const restrict ret, - GFC_INTEGER_4 ret_length __attribute__((unused)), - const gfc_array_char * const restrict array, - const 'atype` * const restrict h, - const gfc_array_char * const restrict bound, - const 'atype_name` * const restrict pwhich, - GFC_INTEGER_4 array_length, - GFC_INTEGER_4 bound_length __attribute__((unused))) -{ - eoshift3 (ret, array, h, bound, pwhich, array_length, " ", 1); -} - - -extern void eoshift3_'atype_kind`_char4 (gfc_array_char * const restrict, - GFC_INTEGER_4, - const gfc_array_char * const restrict, - const 'atype` * const restrict, - const gfc_array_char * const restrict, - const 'atype_name` * const restrict, - GFC_INTEGER_4, GFC_INTEGER_4); -export_proto(eoshift3_'atype_kind`_char4); - -void -eoshift3_'atype_kind`_char4 (gfc_array_char * const restrict ret, - GFC_INTEGER_4 ret_length __attribute__((unused)), - const gfc_array_char * const restrict array, - const 'atype` * const restrict h, - const gfc_array_char * const restrict bound, - const 'atype_name` * const restrict pwhich, - GFC_INTEGER_4 array_length, - GFC_INTEGER_4 bound_length __attribute__((unused))) -{ - static const gfc_char4_t space = (unsigned char) ''` ''`; - eoshift3 (ret, array, h, bound, pwhich, array_length * sizeof (gfc_char4_t), - (const char *) &space, sizeof (gfc_char4_t)); -} - -#endif' diff --git a/gcc-4.4.3/libgfortran/m4/exponent.m4 b/gcc-4.4.3/libgfortran/m4/exponent.m4 deleted file mode 100644 index bb9cda8a1..000000000 --- a/gcc-4.4.3/libgfortran/m4/exponent.m4 +++ /dev/null @@ -1,43 +0,0 @@ -`/* Implementation of the EXPONENT intrinsic - Copyright 2003, 2007, 2009 Free Software Foundation, Inc. - Contributed by Richard Henderson <rth@redhat.com>. - -This file is part of the GNU Fortran 95 runtime library (libgfortran). - -Libgfortran is free software; you can redistribute it and/or -modify it under the terms of the GNU General Public -License as published by the Free Software Foundation; either -version 3 of the License, or (at your option) any later version. - -Libgfortran is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -Under Section 7 of GPL version 3, you are granted additional -permissions described in the GCC Runtime Library Exception, version -3.1, as published by the Free Software Foundation. - -You should have received a copy of the GNU General Public License and -a copy of the GCC Runtime Library Exception along with this program; -see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -<http://www.gnu.org/licenses/>. */ - -#include "libgfortran.h"' - -include(`mtype.m4')dnl - -`#if defined (HAVE_'real_type`) && defined (HAVE_FREXP'Q`) - -extern GFC_INTEGER_4 exponent_r'kind` ('real_type` s); -export_proto(exponent_r'kind`); - -GFC_INTEGER_4 -exponent_r'kind` ('real_type` s) -{ - int ret; - frexp'q` (s, &ret); - return ret; -} - -#endif' diff --git a/gcc-4.4.3/libgfortran/m4/fraction.m4 b/gcc-4.4.3/libgfortran/m4/fraction.m4 deleted file mode 100644 index 2878127f5..000000000 --- a/gcc-4.4.3/libgfortran/m4/fraction.m4 +++ /dev/null @@ -1,42 +0,0 @@ -`/* Implementation of the FRACTION intrinsic - Copyright 2003, 2007, 2009 Free Software Foundation, Inc. - Contributed by Richard Henderson <rth@redhat.com>. - -This file is part of the GNU Fortran 95 runtime library (libgfortran). - -Libgfortran is free software; you can redistribute it and/or -modify it under the terms of the GNU General Public -License as published by the Free Software Foundation; either -version 3 of the License, or (at your option) any later version. - -Libgfortran is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -Under Section 7 of GPL version 3, you are granted additional -permissions described in the GCC Runtime Library Exception, version -3.1, as published by the Free Software Foundation. - -You should have received a copy of the GNU General Public License and -a copy of the GCC Runtime Library Exception along with this program; -see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -<http://www.gnu.org/licenses/>. */ - -#include "libgfortran.h"' - -include(`mtype.m4')dnl - -`#if defined (HAVE_'real_type`) && defined (HAVE_FREXP'Q`) - -extern 'real_type` fraction_r'kind` ('real_type` s); -export_proto(fraction_r'kind`); - -'real_type` -fraction_r'kind` ('real_type` s) -{ - int dummy_exp; - return frexp'q` (s, &dummy_exp); -} - -#endif' diff --git a/gcc-4.4.3/libgfortran/m4/head.m4 b/gcc-4.4.3/libgfortran/m4/head.m4 deleted file mode 100644 index 30cdea892..000000000 --- a/gcc-4.4.3/libgfortran/m4/head.m4 +++ /dev/null @@ -1,25 +0,0 @@ -`! 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). -! -!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/>. -! -!This file is machine generated.' diff --git a/gcc-4.4.3/libgfortran/m4/iforeach.m4 b/gcc-4.4.3/libgfortran/m4/iforeach.m4 deleted file mode 100644 index b620c653f..000000000 --- a/gcc-4.4.3/libgfortran/m4/iforeach.m4 +++ /dev/null @@ -1,334 +0,0 @@ -dnl Support macro file for intrinsic functions. -dnl Contains the generic sections of the array functions. -dnl This file is part of the GNU Fortran 95 Runtime Library (libgfortran) -dnl Distributed under the GNU GPL with exception. See COPYING for details. -define(START_FOREACH_FUNCTION, -` -extern void name`'rtype_qual`_'atype_code (rtype * const restrict retarray, - atype * const restrict array); -export_proto(name`'rtype_qual`_'atype_code); - -void -name`'rtype_qual`_'atype_code (rtype * const restrict retarray, - atype * const restrict array) -{ - index_type count[GFC_MAX_DIMENSIONS]; - index_type extent[GFC_MAX_DIMENSIONS]; - index_type sstride[GFC_MAX_DIMENSIONS]; - index_type dstride; - const atype_name *base; - rtype_name * restrict dest; - index_type rank; - index_type n; - - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); - - if (retarray->data == NULL) - { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; - retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (rtype_name) * rank); - } - else - { - if (unlikely (compile_options.bounds_check)) - { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in u_name intrinsic" - " should be 1, is %ld", (long int) ret_rank); - - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("Incorrect extent in return value of" - " u_name intrnisic: is %ld, should be %ld", - (long int) ret_extent, (long int) rank); - } - } - - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - { - sstride[n] = array->dim[n].stride; - extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; - count[n] = 0; - if (extent[n] <= 0) - { - /* Set the return value. */ - for (n = 0; n < rank; n++) - dest[n * dstride] = 0; - return; - } - } - - base = array->data; - - /* Initialize the return value. */ - for (n = 0; n < rank; n++) - dest[n * dstride] = 0; - { -')dnl -define(START_FOREACH_BLOCK, -` while (base) - { - { - /* Implementation start. */ -')dnl -define(FINISH_FOREACH_FUNCTION, -` /* Implementation end. */ - } - /* Advance to the next element. */ - count[0]++; - base += sstride[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. */ - base -= sstride[n] * extent[n]; - n++; - if (n == rank) - { - /* Break out of the loop. */ - base = NULL; - break; - } - else - { - count[n]++; - base += sstride[n]; - } - } - } - } -}')dnl -define(START_MASKED_FOREACH_FUNCTION, -` -extern void `m'name`'rtype_qual`_'atype_code (rtype * const restrict, - atype * const restrict, gfc_array_l1 * const restrict); -export_proto(`m'name`'rtype_qual`_'atype_code); - -void -`m'name`'rtype_qual`_'atype_code (rtype * const restrict retarray, - atype * const restrict array, - gfc_array_l1 * const restrict mask) -{ - index_type count[GFC_MAX_DIMENSIONS]; - index_type extent[GFC_MAX_DIMENSIONS]; - index_type sstride[GFC_MAX_DIMENSIONS]; - index_type mstride[GFC_MAX_DIMENSIONS]; - index_type dstride; - rtype_name *dest; - const atype_name *base; - GFC_LOGICAL_1 *mbase; - int rank; - index_type n; - int mask_kind; - - rank = GFC_DESCRIPTOR_RANK (array); - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); - - if (retarray->data == NULL) - { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; - retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (rtype_name) * rank); - } - else - { - if (unlikely (compile_options.bounds_check)) - { - int ret_rank, mask_rank; - index_type ret_extent; - int n; - index_type array_extent, mask_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in u_name intrinsic" - " should be 1, is %ld", (long int) ret_rank); - - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("Incorrect extent in return value of" - " u_name intrnisic: is %ld, should be %ld", - (long int) ret_extent, (long int) rank); - - mask_rank = GFC_DESCRIPTOR_RANK (mask); - if (rank != mask_rank) - runtime_error ("rank of MASK argument in u_name intrnisic" - "should be %ld, is %ld", (long int) rank, - (long int) mask_rank); - - for (n=0; n<rank; n++) - { - array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; - mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; - if (array_extent != mask_extent) - runtime_error ("Incorrect extent in MASK argument of" - " u_name intrinsic in dimension %ld:" - " is %ld, should be %ld", (long int) n + 1, - (long int) mask_extent, (long int) array_extent); - } - } - } - - mask_kind = GFC_DESCRIPTOR_SIZE (mask); - - mbase = mask->data; - - if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 -#ifdef HAVE_GFC_LOGICAL_16 - || mask_kind == 16 -#endif - ) - mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); - else - runtime_error ("Funny sized logical array"); - - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n < rank; n++) - { - sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride * mask_kind; - extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; - count[n] = 0; - if (extent[n] <= 0) - { - /* Set the return value. */ - for (n = 0; n < rank; n++) - dest[n * dstride] = 0; - return; - } - } - - base = array->data; - - /* Initialize the return value. */ - for (n = 0; n < rank; n++) - dest[n * dstride] = 0; - { -')dnl -define(START_MASKED_FOREACH_BLOCK, `START_FOREACH_BLOCK')dnl -define(FINISH_MASKED_FOREACH_FUNCTION, -` /* Implementation end. */ - } - /* Advance to the next element. */ - count[0]++; - base += sstride[0]; - mbase += mstride[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. */ - base -= sstride[n] * extent[n]; - mbase -= mstride[n] * extent[n]; - n++; - if (n == rank) - { - /* Break out of the loop. */ - base = NULL; - break; - } - else - { - count[n]++; - base += sstride[n]; - mbase += mstride[n]; - } - } - } - } -}')dnl -define(FOREACH_FUNCTION, -`START_FOREACH_FUNCTION -$1 -START_FOREACH_BLOCK -$2 -FINISH_FOREACH_FUNCTION')dnl -define(MASKED_FOREACH_FUNCTION, -`START_MASKED_FOREACH_FUNCTION -$1 -START_MASKED_FOREACH_BLOCK -$2 -FINISH_MASKED_FOREACH_FUNCTION')dnl -define(SCALAR_FOREACH_FUNCTION, -` -extern void `s'name`'rtype_qual`_'atype_code (rtype * const restrict, - atype * const restrict, GFC_LOGICAL_4 *); -export_proto(`s'name`'rtype_qual`_'atype_code); - -void -`s'name`'rtype_qual`_'atype_code (rtype * const restrict retarray, - atype * const restrict array, - GFC_LOGICAL_4 * mask) -{ - index_type rank; - index_type dstride; - index_type n; - rtype_name *dest; - - if (*mask) - { - name`'rtype_qual`_'atype_code (retarray, array); - return; - } - - rank = GFC_DESCRIPTOR_RANK (array); - - if (rank <= 0) - runtime_error ("Rank of array needs to be > 0"); - - if (retarray->data == NULL) - { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = rank-1; - retarray->dim[0].stride = 1; - retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; - retarray->offset = 0; - retarray->data = internal_malloc_size (sizeof (rtype_name) * rank); - } - else - { - if (unlikely (compile_options.bounds_check)) - { - int ret_rank; - index_type ret_extent; - - ret_rank = GFC_DESCRIPTOR_RANK (retarray); - if (ret_rank != 1) - runtime_error ("rank of return array in u_name intrinsic" - " should be 1, is %ld", (long int) ret_rank); - - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (ret_extent != rank) - runtime_error ("dimension of return array incorrect"); - } - } - - dstride = retarray->dim[0].stride; - dest = retarray->data; - for (n = 0; n<rank; n++) - dest[n * dstride] = $1 ; -}')dnl diff --git a/gcc-4.4.3/libgfortran/m4/ifunction.m4 b/gcc-4.4.3/libgfortran/m4/ifunction.m4 deleted file mode 100644 index e0c168e2e..000000000 --- a/gcc-4.4.3/libgfortran/m4/ifunction.m4 +++ /dev/null @@ -1,542 +0,0 @@ -dnl Support macro file for intrinsic functions. -dnl Contains the generic sections of the array functions. -dnl This file is part of the GNU Fortran 95 Runtime Library (libgfortran) -dnl Distributed under the GNU GPL with exception. See COPYING for details. -dnl -dnl Pass the implementation for a single section as the parameter to -dnl {MASK_}ARRAY_FUNCTION. -dnl The variables base, delta, and len describe the input section. -dnl For masked section the mask is described by mbase and mdelta. -dnl These should not be modified. The result should be stored in *dest. -dnl The names count, extent, sstride, dstride, base, dest, rank, dim -dnl retarray, array, pdim and mstride should not be used. -dnl The variable n is declared as index_type and may be used. -dnl Other variable declarations may be placed at the start of the code, -dnl The types of the array parameter and the return value are -dnl atype_name and rtype_name respectively. -dnl Execution should be allowed to continue to the end of the block. -dnl You should not return or break from the inner loop of the implementation. -dnl Care should also be taken to avoid using the names defined in iparm.m4 -define(START_ARRAY_FUNCTION, -` -extern void name`'rtype_qual`_'atype_code (rtype * const restrict, - atype * const restrict, const index_type * const restrict); -export_proto(name`'rtype_qual`_'atype_code); - -void -name`'rtype_qual`_'atype_code (rtype * const restrict retarray, - atype * const restrict array, - const index_type * const restrict pdim) -{ - index_type count[GFC_MAX_DIMENSIONS]; - index_type extent[GFC_MAX_DIMENSIONS]; - index_type sstride[GFC_MAX_DIMENSIONS]; - index_type dstride[GFC_MAX_DIMENSIONS]; - const atype_name * restrict base; - rtype_name * restrict dest; - index_type rank; - index_type n; - index_type len; - index_type delta; - index_type dim; - int continue_loop; - - /* Make dim zero based to avoid confusion. */ - dim = (*pdim) - 1; - rank = GFC_DESCRIPTOR_RANK (array) - 1; - - len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; - if (len < 0) - len = 0; - delta = array->dim[dim].stride; - - for (n = 0; n < dim; n++) - { - sstride[n] = array->dim[n].stride; - extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; - - if (extent[n] < 0) - extent[n] = 0; - } - for (n = dim; n < rank; n++) - { - sstride[n] = array->dim[n + 1].stride; - extent[n] = - array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; - - if (extent[n] < 0) - extent[n] = 0; - } - - if (retarray->data == NULL) - { - size_t alloc_size; - - for (n = 0; n < rank; n++) - { - retarray->dim[n].lbound = 0; - retarray->dim[n].ubound = extent[n]-1; - if (n == 0) - retarray->dim[n].stride = 1; - else - retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; - } - - retarray->offset = 0; - retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; - - alloc_size = sizeof (rtype_name) * retarray->dim[rank-1].stride - * extent[rank-1]; - - if (alloc_size == 0) - { - /* Make sure we have a zero-sized array. */ - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = -1; - return; - } - else - retarray->data = internal_malloc_size (alloc_size); - } - else - { - if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect in" - " u_name intrinsic: is %ld, should be %ld", - (long int) (GFC_DESCRIPTOR_RANK (retarray)), - (long int) rank); - - if (unlikely (compile_options.bounds_check)) - { - for (n=0; n < rank; n++) - { - index_type ret_extent; - - ret_extent = retarray->dim[n].ubound + 1 - - retarray->dim[n].lbound; - if (extent[n] != ret_extent) - runtime_error ("Incorrect extent in return value of" - " u_name intrinsic in dimension %ld:" - " is %ld, should be %ld", (long int) n + 1, - (long int) ret_extent, (long int) extent[n]); - } - } - } - - for (n = 0; n < rank; n++) - { - count[n] = 0; - dstride[n] = retarray->dim[n].stride; - if (extent[n] <= 0) - len = 0; - } - - base = array->data; - dest = retarray->data; - - continue_loop = 1; - while (continue_loop) - { - const atype_name * restrict src; - rtype_name result; - src = base; - { -')dnl -define(START_ARRAY_BLOCK, -` if (len <= 0) - *dest = '$1`; - else - { - for (n = 0; n < len; n++, src += delta) - { -')dnl -define(FINISH_ARRAY_FUNCTION, - ` } - *dest = result; - } - } - /* Advance to the next element. */ - count[0]++; - base += sstride[0]; - dest += dstride[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. */ - base -= sstride[n] * extent[n]; - dest -= dstride[n] * extent[n]; - n++; - if (n == rank) - { - /* Break out of the look. */ - continue_loop = 0; - break; - } - else - { - count[n]++; - base += sstride[n]; - dest += dstride[n]; - } - } - } -}')dnl -define(START_MASKED_ARRAY_FUNCTION, -` -extern void `m'name`'rtype_qual`_'atype_code (rtype * const restrict, - atype * const restrict, const index_type * const restrict, - gfc_array_l1 * const restrict); -export_proto(`m'name`'rtype_qual`_'atype_code); - -void -`m'name`'rtype_qual`_'atype_code (rtype * const restrict retarray, - atype * const restrict array, - const index_type * const restrict pdim, - gfc_array_l1 * const restrict mask) -{ - index_type count[GFC_MAX_DIMENSIONS]; - index_type extent[GFC_MAX_DIMENSIONS]; - index_type sstride[GFC_MAX_DIMENSIONS]; - index_type dstride[GFC_MAX_DIMENSIONS]; - index_type mstride[GFC_MAX_DIMENSIONS]; - rtype_name * restrict dest; - const atype_name * restrict base; - const GFC_LOGICAL_1 * restrict mbase; - int rank; - int dim; - index_type n; - index_type len; - index_type delta; - index_type mdelta; - int mask_kind; - - dim = (*pdim) - 1; - rank = GFC_DESCRIPTOR_RANK (array) - 1; - - len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; - if (len <= 0) - return; - - mbase = mask->data; - - 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 - ) - mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); - else - runtime_error ("Funny sized logical array"); - - delta = array->dim[dim].stride; - mdelta = mask->dim[dim].stride * mask_kind; - - for (n = 0; n < dim; n++) - { - sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride * mask_kind; - extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; - - if (extent[n] < 0) - extent[n] = 0; - - } - for (n = dim; n < rank; n++) - { - sstride[n] = array->dim[n + 1].stride; - mstride[n] = mask->dim[n + 1].stride * mask_kind; - extent[n] = - array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; - - if (extent[n] < 0) - extent[n] = 0; - } - - if (retarray->data == NULL) - { - size_t alloc_size; - - for (n = 0; n < rank; n++) - { - retarray->dim[n].lbound = 0; - retarray->dim[n].ubound = extent[n]-1; - if (n == 0) - retarray->dim[n].stride = 1; - else - retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; - } - - alloc_size = sizeof (rtype_name) * retarray->dim[rank-1].stride - * extent[rank-1]; - - retarray->offset = 0; - retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; - - if (alloc_size == 0) - { - /* Make sure we have a zero-sized array. */ - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = -1; - return; - } - else - retarray->data = internal_malloc_size (alloc_size); - - } - else - { - if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect in u_name intrinsic"); - - if (unlikely (compile_options.bounds_check)) - { - for (n=0; n < rank; n++) - { - index_type ret_extent; - - ret_extent = retarray->dim[n].ubound + 1 - - retarray->dim[n].lbound; - if (extent[n] != ret_extent) - runtime_error ("Incorrect extent in return value of" - " u_name intrinsic in dimension %ld:" - " is %ld, should be %ld", (long int) n + 1, - (long int) ret_extent, (long int) extent[n]); - } - for (n=0; n<= rank; n++) - { - index_type mask_extent, array_extent; - - array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; - mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; - if (array_extent != mask_extent) - runtime_error ("Incorrect extent in MASK argument of" - " u_name intrinsic in dimension %ld:" - " is %ld, should be %ld", (long int) n + 1, - (long int) mask_extent, (long int) array_extent); - } - } - } - - for (n = 0; n < rank; n++) - { - count[n] = 0; - dstride[n] = retarray->dim[n].stride; - if (extent[n] <= 0) - return; - } - - dest = retarray->data; - base = array->data; - - while (base) - { - const atype_name * restrict src; - const GFC_LOGICAL_1 * restrict msrc; - rtype_name result; - src = base; - msrc = mbase; - { -')dnl -define(START_MASKED_ARRAY_BLOCK, -` if (len <= 0) - *dest = '$1`; - else - { - for (n = 0; n < len; n++, src += delta, msrc += mdelta) - { -')dnl -define(FINISH_MASKED_ARRAY_FUNCTION, -` } - *dest = result; - } - } - /* Advance to the next element. */ - count[0]++; - base += sstride[0]; - mbase += mstride[0]; - dest += dstride[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. */ - base -= sstride[n] * extent[n]; - mbase -= mstride[n] * extent[n]; - dest -= dstride[n] * extent[n]; - n++; - if (n == rank) - { - /* Break out of the look. */ - base = NULL; - break; - } - else - { - count[n]++; - base += sstride[n]; - mbase += mstride[n]; - dest += dstride[n]; - } - } - } -}')dnl -define(SCALAR_ARRAY_FUNCTION, -` -extern void `s'name`'rtype_qual`_'atype_code (rtype * const restrict, - atype * const restrict, const index_type * const restrict, - GFC_LOGICAL_4 *); -export_proto(`s'name`'rtype_qual`_'atype_code); - -void -`s'name`'rtype_qual`_'atype_code (rtype * const restrict retarray, - atype * const restrict array, - const index_type * const restrict pdim, - GFC_LOGICAL_4 * mask) -{ - index_type count[GFC_MAX_DIMENSIONS]; - index_type extent[GFC_MAX_DIMENSIONS]; - index_type sstride[GFC_MAX_DIMENSIONS]; - index_type dstride[GFC_MAX_DIMENSIONS]; - rtype_name * restrict dest; - index_type rank; - index_type n; - index_type dim; - - - if (*mask) - { - name`'rtype_qual`_'atype_code (retarray, array, pdim); - return; - } - /* Make dim zero based to avoid confusion. */ - dim = (*pdim) - 1; - rank = GFC_DESCRIPTOR_RANK (array) - 1; - - for (n = 0; n < dim; n++) - { - sstride[n] = array->dim[n].stride; - extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; - - if (extent[n] <= 0) - extent[n] = 0; - } - - for (n = dim; n < rank; n++) - { - sstride[n] = array->dim[n + 1].stride; - extent[n] = - array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; - - if (extent[n] <= 0) - extent[n] = 0; - } - - if (retarray->data == NULL) - { - size_t alloc_size; - - for (n = 0; n < rank; n++) - { - retarray->dim[n].lbound = 0; - retarray->dim[n].ubound = extent[n]-1; - if (n == 0) - retarray->dim[n].stride = 1; - else - retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; - } - - retarray->offset = 0; - retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; - - alloc_size = sizeof (rtype_name) * retarray->dim[rank-1].stride - * extent[rank-1]; - - if (alloc_size == 0) - { - /* Make sure we have a zero-sized array. */ - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = -1; - return; - } - else - retarray->data = internal_malloc_size (alloc_size); - } - else - { - if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect in" - " u_name intrinsic: is %ld, should be %ld", - (long int) (GFC_DESCRIPTOR_RANK (retarray)), - (long int) rank); - - if (unlikely (compile_options.bounds_check)) - { - for (n=0; n < rank; n++) - { - index_type ret_extent; - - ret_extent = retarray->dim[n].ubound + 1 - - retarray->dim[n].lbound; - if (extent[n] != ret_extent) - runtime_error ("Incorrect extent in return value of" - " u_name intrinsic in dimension %ld:" - " is %ld, should be %ld", (long int) n + 1, - (long int) ret_extent, (long int) extent[n]); - } - } - } - - for (n = 0; n < rank; n++) - { - count[n] = 0; - dstride[n] = retarray->dim[n].stride; - } - - dest = retarray->data; - - while(1) - { - *dest = '$1`; - count[0]++; - dest += dstride[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. */ - dest -= dstride[n] * extent[n]; - n++; - if (n == rank) - return; - else - { - count[n]++; - dest += dstride[n]; - } - } - } -}')dnl -define(ARRAY_FUNCTION, -`START_ARRAY_FUNCTION -$2 -START_ARRAY_BLOCK($1) -$3 -FINISH_ARRAY_FUNCTION')dnl -define(MASKED_ARRAY_FUNCTION, -`START_MASKED_ARRAY_FUNCTION -$2 -START_MASKED_ARRAY_BLOCK($1) -$3 -FINISH_MASKED_ARRAY_FUNCTION')dnl diff --git a/gcc-4.4.3/libgfortran/m4/ifunction_logical.m4 b/gcc-4.4.3/libgfortran/m4/ifunction_logical.m4 deleted file mode 100644 index da6b4ae26..000000000 --- a/gcc-4.4.3/libgfortran/m4/ifunction_logical.m4 +++ /dev/null @@ -1,210 +0,0 @@ -dnl Support macro file for intrinsic functions. -dnl Contains the generic sections of the array functions. -dnl This file is part of the GNU Fortran 95 Runtime Library (libgfortran) -dnl Distributed under the GNU GPL with exception. See COPYING for details. -dnl -dnl Pass the implementation for a single section as the parameter to -dnl {MASK_}ARRAY_FUNCTION. -dnl The variables base, delta, and len describe the input section. -dnl For masked section the mask is described by mbase and mdelta. -dnl These should not be modified. The result should be stored in *dest. -dnl The names count, extent, sstride, dstride, base, dest, rank, dim -dnl retarray, array, pdim and mstride should not be used. -dnl The variable n is declared as index_type and may be used. -dnl Other variable declarations may be placed at the start of the code, -dnl The types of the array parameter and the return value are -dnl atype_name and rtype_name respectively. -dnl Execution should be allowed to continue to the end of the block. -dnl You should not return or break from the inner loop of the implementation. -dnl Care should also be taken to avoid using the names defined in iparm.m4 -define(START_ARRAY_FUNCTION, -` -extern void name`'rtype_qual`_'atype_code (rtype * const restrict, - gfc_array_l1 * const restrict, const index_type * const restrict); -export_proto(name`'rtype_qual`_'atype_code); - -void -name`'rtype_qual`_'atype_code (rtype * const restrict retarray, - gfc_array_l1 * const restrict array, - const index_type * const restrict pdim) -{ - index_type count[GFC_MAX_DIMENSIONS]; - index_type extent[GFC_MAX_DIMENSIONS]; - index_type sstride[GFC_MAX_DIMENSIONS]; - index_type dstride[GFC_MAX_DIMENSIONS]; - const GFC_LOGICAL_1 * restrict base; - rtype_name * restrict dest; - index_type rank; - index_type n; - index_type len; - index_type delta; - index_type dim; - int src_kind; - int continue_loop; - - /* Make dim zero based to avoid confusion. */ - dim = (*pdim) - 1; - rank = GFC_DESCRIPTOR_RANK (array) - 1; - - src_kind = GFC_DESCRIPTOR_SIZE (array); - - len = array->dim[dim].ubound + 1 - array->dim[dim].lbound; - if (len < 0) - len = 0; - - delta = array->dim[dim].stride * src_kind; - - for (n = 0; n < dim; n++) - { - sstride[n] = array->dim[n].stride * src_kind; - extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; - - if (extent[n] < 0) - extent[n] = 0; - } - for (n = dim; n < rank; n++) - { - sstride[n] = array->dim[n + 1].stride * src_kind; - extent[n] = - array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound; - - if (extent[n] < 0) - extent[n] = 0; - } - - if (retarray->data == NULL) - { - size_t alloc_size; - - for (n = 0; n < rank; n++) - { - retarray->dim[n].lbound = 0; - retarray->dim[n].ubound = extent[n]-1; - if (n == 0) - retarray->dim[n].stride = 1; - else - retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1]; - } - - retarray->offset = 0; - retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; - - alloc_size = sizeof (rtype_name) * retarray->dim[rank-1].stride - * extent[rank-1]; - - if (alloc_size == 0) - { - /* Make sure we have a zero-sized array. */ - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = -1; - return; - } - else - retarray->data = internal_malloc_size (alloc_size); - } - else - { - if (rank != GFC_DESCRIPTOR_RANK (retarray)) - runtime_error ("rank of return array incorrect in" - " u_name intrinsic: is %ld, should be %ld", - (long int) GFC_DESCRIPTOR_RANK (retarray), - (long int) rank); - - if (unlikely (compile_options.bounds_check)) - { - for (n=0; n < rank; n++) - { - index_type ret_extent; - - ret_extent = retarray->dim[n].ubound + 1 - - retarray->dim[n].lbound; - if (extent[n] != ret_extent) - runtime_error ("Incorrect extent in return value of" - " u_name intrinsic in dimension %d:" - " is %ld, should be %ld", (int) n + 1, - (long int) ret_extent, (long int) extent[n]); - } - } - } - - for (n = 0; n < rank; n++) - { - count[n] = 0; - dstride[n] = retarray->dim[n].stride; - if (extent[n] <= 0) - len = 0; - } - - base = array->data; - - if (src_kind == 1 || src_kind == 2 || src_kind == 4 || src_kind == 8 -#ifdef HAVE_GFC_LOGICAL_16 - || src_kind == 16 -#endif - ) - { - if (base) - base = GFOR_POINTER_TO_L1 (base, src_kind); - } - else - internal_error (NULL, "Funny sized logical array in u_name intrinsic"); - - dest = retarray->data; - - continue_loop = 1; - while (continue_loop) - { - const GFC_LOGICAL_1 * restrict src; - rtype_name result; - src = base; - { -')dnl -define(START_ARRAY_BLOCK, -` if (len <= 0) - *dest = '$1`; - else - { - for (n = 0; n < len; n++, src += delta) - { -')dnl -define(FINISH_ARRAY_FUNCTION, - ` } - *dest = result; - } - } - /* Advance to the next element. */ - count[0]++; - base += sstride[0]; - dest += dstride[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. */ - base -= sstride[n] * extent[n]; - dest -= dstride[n] * extent[n]; - n++; - if (n == rank) - { - /* Break out of the look. */ - continue_loop = 0; - break; - } - else - { - count[n]++; - base += sstride[n]; - dest += dstride[n]; - } - } - } -}')dnl -define(ARRAY_FUNCTION, -`START_ARRAY_FUNCTION -$2 -START_ARRAY_BLOCK($1) -$3 -FINISH_ARRAY_FUNCTION')dnl diff --git a/gcc-4.4.3/libgfortran/m4/in_pack.m4 b/gcc-4.4.3/libgfortran/m4/in_pack.m4 deleted file mode 100644 index b54ea04d7..000000000 --- a/gcc-4.4.3/libgfortran/m4/in_pack.m4 +++ /dev/null @@ -1,122 +0,0 @@ -`/* Helper function for repacking arrays. - Copyright 2003, 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. - -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(iparm.m4)dnl - -`#if defined (HAVE_'rtype_name`) - -/* Allocates a block of memory with internal_malloc if the array needs - repacking. */ -' -dnl The kind (ie size) is used to name the function for logicals, integers -dnl and reals. For complex, it's c4 or c8. -rtype_name` * -internal_pack_'rtype_ccode` ('rtype` * 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 'rtype_name` *src; - 'rtype_name` * restrict dest; - 'rtype_name` *destptr; - int n; - int packed; - - /* TODO: Investigate how we can figure out if this is a temporary - since the stride=0 thing has been removed from the frontend. */ - - dim = GFC_DESCRIPTOR_RANK (source); - ssize = 1; - packed = 1; - for (n = 0; n < dim; n++) - { - count[n] = 0; - stride[n] = source->dim[n].stride; - extent[n] = source->dim[n].ubound + 1 - source->dim[n].lbound; - 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 = ('rtype_name` *)internal_malloc_size (ssize * sizeof ('rtype_name`)); - dest = destptr; - src = source->data; - stride0 = stride[0]; - - - while (src) - { - /* Copy the data. */ - *(dest++) = *src; - /* Advance to the next element. */ - 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]; - n++; - if (n == dim) - { - src = NULL; - break; - } - else - { - count[n]++; - src += stride[n]; - } - } - } - return destptr; -} - -#endif -' diff --git a/gcc-4.4.3/libgfortran/m4/in_unpack.m4 b/gcc-4.4.3/libgfortran/m4/in_unpack.m4 deleted file mode 100644 index af7114501..000000000 --- a/gcc-4.4.3/libgfortran/m4/in_unpack.m4 +++ /dev/null @@ -1,110 +0,0 @@ -`/* Helper function for repacking arrays. - Copyright 2003, 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. - -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>' - -include(iparm.m4)dnl - -`#if defined (HAVE_'rtype_name`)' - -dnl Only the kind (ie size) is used to name the function for integers, -dnl reals and logicals. For complex, it's c4 and c8. -`void -internal_unpack_'rtype_ccode` ('rtype` * d, const 'rtype_name` * src) -{ - 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; - 'rtype_name` * restrict dest; - int n; - - dest = d->data; - if (src == dest || !src) - return; - - dim = GFC_DESCRIPTOR_RANK (d); - dsize = 1; - for (n = 0; n < dim; n++) - { - count[n] = 0; - stride[n] = d->dim[n].stride; - extent[n] = d->dim[n].ubound + 1 - d->dim[n].lbound; - if (extent[n] <= 0) - return; - - if (dsize == stride[n]) - dsize *= extent[n]; - else - dsize = 0; - } - - if (dsize != 0) - { - memcpy (dest, src, dsize * sizeof ('rtype_name`)); - return; - } - - stride0 = stride[0]; - - while (dest) - { - /* Copy the data. */ - *dest = *(src++); - /* 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]; - } - } - } -} - -#endif -' diff --git a/gcc-4.4.3/libgfortran/m4/iparm.m4 b/gcc-4.4.3/libgfortran/m4/iparm.m4 deleted file mode 100644 index 51ee40d04..000000000 --- a/gcc-4.4.3/libgfortran/m4/iparm.m4 +++ /dev/null @@ -1,35 +0,0 @@ -dnl Support macro file for intrinsic functions. -dnl Works out all the function types from the filename. -dnl This file is part of the GNU Fortran 95 Runtime Library (libgfortran) -dnl Distributed under the GNU GPL with exception. See COPYING for details. -dnl M4 macro file to get type names from filenames -define(get_typename2, `GFC_$1_$2')dnl -define(get_typename, `get_typename2(ifelse($1,i,INTEGER,ifelse($1,r,REAL,ifelse($1,l,LOGICAL,ifelse($1,c,COMPLEX,unknown)))),`$2')')dnl -define(get_arraytype, `gfc_array_$1$2')dnl -define(define_type, `dnl -ifelse(regexp($2,`^[0-9]'),-1,`dnl -define($1_letter, substr($2, 0, 1))dnl -define($1_kind, substr($2, 1))dnl -',`dnl -define($1_letter,i)dnl -define($1_kind,$2)dnl -')dnl -define($1_code,$1_letter`'$1_kind)dnl -define($1,get_arraytype($1_letter,$1_kind))dnl -define($1_name, get_typename($1_letter, $1_kind))')dnl -dnl -define_type(atype, regexp(file, `_\(.?[0-9]*\)\.c$', `\1'))dnl -define(rtype_tmp, regexp(file, `_\(.?[0-9]*\)_[^_]*\.c$', `\1'))dnl -ifelse(rtype_tmp,,`dnl -define_type(rtype, atype_code)dnl -define(rtype_qual,`')dnl -',`dnl -define_type(rtype, rtype_tmp)dnl -define(rtype_qual,`_'rtype_kind)dnl -')dnl -define(atype_max, atype_name`_HUGE')dnl -define(atype_min,ifelse(regexp(file, `_\(.\)[0-9]*\.c$', `\1'),`i',`(-'atype_max`-1)',`-'atype_max))dnl -define(name, regexp(regexp(file, `[^/]*$', `\&'), `^\([^_]*\)_', `\1'))dnl -define(`upcase', `translit(`$*', `a-z', `A-Z')')dnl -define(`u_name',`regexp(upcase(name),`\([A-Z]*\)',`\1')')dnl -define(rtype_ccode,ifelse(rtype_letter,`i',rtype_kind,rtype_code))dnl diff --git a/gcc-4.4.3/libgfortran/m4/matmul.m4 b/gcc-4.4.3/libgfortran/m4/matmul.m4 deleted file mode 100644 index 8ad1bd117..000000000 --- a/gcc-4.4.3/libgfortran/m4/matmul.m4 +++ /dev/null @@ -1,381 +0,0 @@ -`/* Implementation of the MATMUL intrinsic - Copyright 2002, 2005, 2006, 2007, 2009 Free Software Foundation, Inc. - Contributed by Paul Brook <paul@nowt.org> - -This file is part of the GNU Fortran 95 runtime library (libgfortran). - -Libgfortran is free software; you can redistribute it and/or -modify it under the terms of the GNU General Public -License as published by the Free Software Foundation; either -version 3 of the License, or (at your option) any later version. - -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>' - -include(iparm.m4)dnl - -`#if defined (HAVE_'rtype_name`) - -/* Prototype for the BLAS ?gemm subroutine, a pointer to which can be - passed to us by the front-end, in which case we''`ll call it for large - matrices. */ - -typedef void (*blas_call)(const char *, const char *, const int *, const int *, - const int *, const 'rtype_name` *, const 'rtype_name` *, - const int *, const 'rtype_name` *, const int *, - const 'rtype_name` *, 'rtype_name` *, const int *, - int, int); - -/* The order of loops is different in the case of plain matrix - multiplication C=MATMUL(A,B), and in the frequent special case where - the argument A is the temporary result of a TRANSPOSE intrinsic: - C=MATMUL(TRANSPOSE(A),B). Transposed temporaries are detected by - looking at their strides. - - The equivalent Fortran pseudo-code is: - - DIMENSION A(M,COUNT), B(COUNT,N), C(M,N) - IF (.NOT.IS_TRANSPOSED(A)) THEN - C = 0 - DO J=1,N - DO K=1,COUNT - DO I=1,M - C(I,J) = C(I,J)+A(I,K)*B(K,J) - ELSE - DO J=1,N - DO I=1,M - S = 0 - DO K=1,COUNT - S = S+A(I,K)*B(K,J) - C(I,J) = S - ENDIF -*/ - -/* If try_blas is set to a nonzero value, then the matmul function will - see if there is a way to perform the matrix multiplication by a call - to the BLAS gemm function. */ - -extern void matmul_'rtype_code` ('rtype` * const restrict retarray, - 'rtype` * const restrict a, 'rtype` * const restrict b, int try_blas, - int blas_limit, blas_call gemm); -export_proto(matmul_'rtype_code`); - -void -matmul_'rtype_code` ('rtype` * const restrict retarray, - 'rtype` * const restrict a, 'rtype` * const restrict b, int try_blas, - int blas_limit, blas_call gemm) -{ - const 'rtype_name` * restrict abase; - const 'rtype_name` * restrict bbase; - 'rtype_name` * restrict dest; - - index_type rxstride, rystride, axstride, aystride, bxstride, bystride; - index_type x, y, n, count, xcount, ycount; - - assert (GFC_DESCRIPTOR_RANK (a) == 2 - || GFC_DESCRIPTOR_RANK (b) == 2); - -/* C[xcount,ycount] = A[xcount, count] * B[count,ycount] - - Either A or B (but not both) can be rank 1: - - o One-dimensional argument A is implicitly treated as a row matrix - dimensioned [1,count], so xcount=1. - - o One-dimensional argument B is implicitly treated as a column matrix - dimensioned [count, 1], so ycount=1. - */ - - if (retarray->data == NULL) - { - if (GFC_DESCRIPTOR_RANK (a) == 1) - { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = b->dim[1].ubound - b->dim[1].lbound; - retarray->dim[0].stride = 1; - } - else if (GFC_DESCRIPTOR_RANK (b) == 1) - { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = a->dim[0].ubound - a->dim[0].lbound; - retarray->dim[0].stride = 1; - } - else - { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = a->dim[0].ubound - a->dim[0].lbound; - retarray->dim[0].stride = 1; - - retarray->dim[1].lbound = 0; - retarray->dim[1].ubound = b->dim[1].ubound - b->dim[1].lbound; - retarray->dim[1].stride = retarray->dim[0].ubound+1; - } - - retarray->data - = internal_malloc_size (sizeof ('rtype_name`) * size0 ((array_t *) retarray)); - retarray->offset = 0; - } - else if (unlikely (compile_options.bounds_check)) - { - index_type ret_extent, arg_extent; - - if (GFC_DESCRIPTOR_RANK (a) == 1) - { - arg_extent = b->dim[1].ubound + 1 - b->dim[1].lbound; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (arg_extent != ret_extent) - runtime_error ("Incorrect extent in return array in" - " MATMUL intrinsic: is %ld, should be %ld", - (long int) ret_extent, (long int) arg_extent); - } - else if (GFC_DESCRIPTOR_RANK (b) == 1) - { - arg_extent = a->dim[0].ubound + 1 - a->dim[0].lbound; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (arg_extent != ret_extent) - runtime_error ("Incorrect extent in return array in" - " MATMUL intrinsic: is %ld, should be %ld", - (long int) ret_extent, (long int) arg_extent); - } - else - { - arg_extent = a->dim[0].ubound + 1 - a->dim[0].lbound; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (arg_extent != ret_extent) - runtime_error ("Incorrect extent in return array in" - " MATMUL intrinsic for dimension 1:" - " is %ld, should be %ld", - (long int) ret_extent, (long int) arg_extent); - - arg_extent = b->dim[1].ubound + 1 - b->dim[1].lbound; - ret_extent = retarray->dim[1].ubound + 1 - retarray->dim[1].lbound; - if (arg_extent != ret_extent) - runtime_error ("Incorrect extent in return array in" - " MATMUL intrinsic for dimension 2:" - " is %ld, should be %ld", - (long int) ret_extent, (long int) arg_extent); - } - } -' -sinclude(`matmul_asm_'rtype_code`.m4')dnl -` - if (GFC_DESCRIPTOR_RANK (retarray) == 1) - { - /* One-dimensional result may be addressed in the code below - either as a row or a column matrix. We want both cases to - work. */ - rxstride = rystride = retarray->dim[0].stride; - } - else - { - rxstride = retarray->dim[0].stride; - rystride = retarray->dim[1].stride; - } - - - if (GFC_DESCRIPTOR_RANK (a) == 1) - { - /* Treat it as a a row matrix A[1,count]. */ - axstride = a->dim[0].stride; - aystride = 1; - - xcount = 1; - count = a->dim[0].ubound + 1 - a->dim[0].lbound; - } - else - { - axstride = a->dim[0].stride; - aystride = a->dim[1].stride; - - count = a->dim[1].ubound + 1 - a->dim[1].lbound; - xcount = a->dim[0].ubound + 1 - a->dim[0].lbound; - } - - if (count != b->dim[0].ubound + 1 - b->dim[0].lbound) - { - if (count > 0 || b->dim[0].ubound + 1 - b->dim[0].lbound > 0) - runtime_error ("dimension of array B incorrect in MATMUL intrinsic"); - } - - if (GFC_DESCRIPTOR_RANK (b) == 1) - { - /* Treat it as a column matrix B[count,1] */ - bxstride = b->dim[0].stride; - - /* bystride should never be used for 1-dimensional b. - in case it is we want it to cause a segfault, rather than - an incorrect result. */ - bystride = 0xDEADBEEF; - ycount = 1; - } - else - { - bxstride = b->dim[0].stride; - bystride = b->dim[1].stride; - ycount = b->dim[1].ubound + 1 - b->dim[1].lbound; - } - - abase = a->data; - bbase = b->data; - dest = retarray->data; - - - /* Now that everything is set up, we''`re performing the multiplication - itself. */ - -#define POW3(x) (((float) (x)) * ((float) (x)) * ((float) (x))) - - if (try_blas && rxstride == 1 && (axstride == 1 || aystride == 1) - && (bxstride == 1 || bystride == 1) - && (((float) xcount) * ((float) ycount) * ((float) count) - > POW3(blas_limit))) - { - const int m = xcount, n = ycount, k = count, ldc = rystride; - const 'rtype_name` one = 1, zero = 0; - const int lda = (axstride == 1) ? aystride : axstride, - ldb = (bxstride == 1) ? bystride : bxstride; - - if (lda > 0 && ldb > 0 && ldc > 0 && m > 1 && n > 1 && k > 1) - { - assert (gemm != NULL); - gemm (axstride == 1 ? "N" : "T", bxstride == 1 ? "N" : "T", &m, &n, &k, - &one, abase, &lda, bbase, &ldb, &zero, dest, &ldc, 1, 1); - return; - } - } - - if (rxstride == 1 && axstride == 1 && bxstride == 1) - { - const 'rtype_name` * restrict bbase_y; - 'rtype_name` * restrict dest_y; - const 'rtype_name` * restrict abase_n; - 'rtype_name` bbase_yn; - - if (rystride == xcount) - memset (dest, 0, (sizeof ('rtype_name`) * xcount * ycount)); - else - { - for (y = 0; y < ycount; y++) - for (x = 0; x < xcount; x++) - dest[x + y*rystride] = ('rtype_name`)0; - } - - for (y = 0; y < ycount; y++) - { - bbase_y = bbase + y*bystride; - dest_y = dest + y*rystride; - for (n = 0; n < count; n++) - { - abase_n = abase + n*aystride; - bbase_yn = bbase_y[n]; - for (x = 0; x < xcount; x++) - { - dest_y[x] += abase_n[x] * bbase_yn; - } - } - } - } - else if (rxstride == 1 && aystride == 1 && bxstride == 1) - { - if (GFC_DESCRIPTOR_RANK (a) != 1) - { - const 'rtype_name` *restrict abase_x; - const 'rtype_name` *restrict bbase_y; - 'rtype_name` *restrict dest_y; - 'rtype_name` s; - - for (y = 0; y < ycount; y++) - { - bbase_y = &bbase[y*bystride]; - dest_y = &dest[y*rystride]; - for (x = 0; x < xcount; x++) - { - abase_x = &abase[x*axstride]; - s = ('rtype_name`) 0; - for (n = 0; n < count; n++) - s += abase_x[n] * bbase_y[n]; - dest_y[x] = s; - } - } - } - else - { - const 'rtype_name` *restrict bbase_y; - 'rtype_name` s; - - for (y = 0; y < ycount; y++) - { - bbase_y = &bbase[y*bystride]; - s = ('rtype_name`) 0; - for (n = 0; n < count; n++) - s += abase[n*axstride] * bbase_y[n]; - dest[y*rystride] = s; - } - } - } - else if (axstride < aystride) - { - for (y = 0; y < ycount; y++) - for (x = 0; x < xcount; x++) - dest[x*rxstride + y*rystride] = ('rtype_name`)0; - - for (y = 0; y < ycount; y++) - for (n = 0; n < count; n++) - for (x = 0; x < xcount; x++) - /* dest[x,y] += a[x,n] * b[n,y] */ - dest[x*rxstride + y*rystride] += abase[x*axstride + n*aystride] * bbase[n*bxstride + y*bystride]; - } - else if (GFC_DESCRIPTOR_RANK (a) == 1) - { - const 'rtype_name` *restrict bbase_y; - 'rtype_name` s; - - for (y = 0; y < ycount; y++) - { - bbase_y = &bbase[y*bystride]; - s = ('rtype_name`) 0; - for (n = 0; n < count; n++) - s += abase[n*axstride] * bbase_y[n*bxstride]; - dest[y*rxstride] = s; - } - } - else - { - const 'rtype_name` *restrict abase_x; - const 'rtype_name` *restrict bbase_y; - 'rtype_name` *restrict dest_y; - 'rtype_name` s; - - for (y = 0; y < ycount; y++) - { - bbase_y = &bbase[y*bystride]; - dest_y = &dest[y*rystride]; - for (x = 0; x < xcount; x++) - { - abase_x = &abase[x*axstride]; - s = ('rtype_name`) 0; - for (n = 0; n < count; n++) - s += abase_x[n*aystride] * bbase_y[n*bxstride]; - dest_y[x*rxstride] = s; - } - } - } -} - -#endif' diff --git a/gcc-4.4.3/libgfortran/m4/matmull.m4 b/gcc-4.4.3/libgfortran/m4/matmull.m4 deleted file mode 100644 index d971d3da7..000000000 --- a/gcc-4.4.3/libgfortran/m4/matmull.m4 +++ /dev/null @@ -1,244 +0,0 @@ -`/* Implementation of the MATMUL intrinsic - Copyright 2002, 2005, 2006, 2007, 2009 Free Software Foundation, Inc. - Contributed by Paul Brook <paul@nowt.org> - -This file is part of the GNU Fortran 95 runtime library (libgfortran). - -Libgfortran is free software; you can redistribute it and/or -modify it under the terms of the GNU General Public -License as published by the Free Software Foundation; either -version 3 of the License, or (at your option) any later version. - -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(iparm.m4)dnl - -`#if defined (HAVE_'rtype_name`) - -/* Dimensions: retarray(x,y) a(x, count) b(count,y). - Either a or b can be rank 1. In this case x or y is 1. */ - -extern void matmul_'rtype_code` ('rtype` * const restrict, - gfc_array_l1 * const restrict, gfc_array_l1 * const restrict); -export_proto(matmul_'rtype_code`); - -void -matmul_'rtype_code` ('rtype` * const restrict retarray, - gfc_array_l1 * const restrict a, gfc_array_l1 * const restrict b) -{ - const GFC_LOGICAL_1 * restrict abase; - const GFC_LOGICAL_1 * restrict bbase; - 'rtype_name` * restrict dest; - index_type rxstride; - index_type rystride; - index_type xcount; - index_type ycount; - index_type xstride; - index_type ystride; - index_type x; - index_type y; - int a_kind; - int b_kind; - - const GFC_LOGICAL_1 * restrict pa; - const GFC_LOGICAL_1 * restrict pb; - index_type astride; - index_type bstride; - index_type count; - index_type n; - - assert (GFC_DESCRIPTOR_RANK (a) == 2 - || GFC_DESCRIPTOR_RANK (b) == 2); - - if (retarray->data == NULL) - { - if (GFC_DESCRIPTOR_RANK (a) == 1) - { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = b->dim[1].ubound - b->dim[1].lbound; - retarray->dim[0].stride = 1; - } - else if (GFC_DESCRIPTOR_RANK (b) == 1) - { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = a->dim[0].ubound - a->dim[0].lbound; - retarray->dim[0].stride = 1; - } - else - { - retarray->dim[0].lbound = 0; - retarray->dim[0].ubound = a->dim[0].ubound - a->dim[0].lbound; - retarray->dim[0].stride = 1; - - retarray->dim[1].lbound = 0; - retarray->dim[1].ubound = b->dim[1].ubound - b->dim[1].lbound; - retarray->dim[1].stride = retarray->dim[0].ubound+1; - } - - retarray->data - = internal_malloc_size (sizeof ('rtype_name`) * size0 ((array_t *) retarray)); - retarray->offset = 0; - } - else if (unlikely (compile_options.bounds_check)) - { - index_type ret_extent, arg_extent; - - if (GFC_DESCRIPTOR_RANK (a) == 1) - { - arg_extent = b->dim[1].ubound + 1 - b->dim[1].lbound; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (arg_extent != ret_extent) - runtime_error ("Incorrect extent in return array in" - " MATMUL intrinsic: is %ld, should be %ld", - (long int) ret_extent, (long int) arg_extent); - } - else if (GFC_DESCRIPTOR_RANK (b) == 1) - { - arg_extent = a->dim[0].ubound + 1 - a->dim[0].lbound; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (arg_extent != ret_extent) - runtime_error ("Incorrect extent in return array in" - " MATMUL intrinsic: is %ld, should be %ld", - (long int) ret_extent, (long int) arg_extent); - } - else - { - arg_extent = a->dim[0].ubound + 1 - a->dim[0].lbound; - ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; - if (arg_extent != ret_extent) - runtime_error ("Incorrect extent in return array in" - " MATMUL intrinsic for dimension 1:" - " is %ld, should be %ld", - (long int) ret_extent, (long int) arg_extent); - - arg_extent = b->dim[1].ubound + 1 - b->dim[1].lbound; - ret_extent = retarray->dim[1].ubound + 1 - retarray->dim[1].lbound; - if (arg_extent != ret_extent) - runtime_error ("Incorrect extent in return array in" - " MATMUL intrinsic for dimension 2:" - " is %ld, should be %ld", - (long int) ret_extent, (long int) arg_extent); - } - } - - abase = a->data; - a_kind = GFC_DESCRIPTOR_SIZE (a); - - if (a_kind == 1 || a_kind == 2 || a_kind == 4 || a_kind == 8 -#ifdef HAVE_GFC_LOGICAL_16 - || a_kind == 16 -#endif - ) - abase = GFOR_POINTER_TO_L1 (abase, a_kind); - else - internal_error (NULL, "Funny sized logical array"); - - bbase = b->data; - b_kind = GFC_DESCRIPTOR_SIZE (b); - - if (b_kind == 1 || b_kind == 2 || b_kind == 4 || b_kind == 8 -#ifdef HAVE_GFC_LOGICAL_16 - || b_kind == 16 -#endif - ) - bbase = GFOR_POINTER_TO_L1 (bbase, b_kind); - else - internal_error (NULL, "Funny sized logical array"); - - dest = retarray->data; -' -sinclude(`matmul_asm_'rtype_code`.m4')dnl -` - if (GFC_DESCRIPTOR_RANK (retarray) == 1) - { - rxstride = retarray->dim[0].stride; - rystride = rxstride; - } - else - { - rxstride = retarray->dim[0].stride; - rystride = retarray->dim[1].stride; - } - - /* If we have rank 1 parameters, zero the absent stride, and set the size to - one. */ - if (GFC_DESCRIPTOR_RANK (a) == 1) - { - astride = a->dim[0].stride * a_kind; - count = a->dim[0].ubound + 1 - a->dim[0].lbound; - xstride = 0; - rxstride = 0; - xcount = 1; - } - else - { - astride = a->dim[1].stride * a_kind; - count = a->dim[1].ubound + 1 - a->dim[1].lbound; - xstride = a->dim[0].stride * a_kind; - xcount = a->dim[0].ubound + 1 - a->dim[0].lbound; - } - if (GFC_DESCRIPTOR_RANK (b) == 1) - { - bstride = b->dim[0].stride * b_kind; - assert(count == b->dim[0].ubound + 1 - b->dim[0].lbound); - ystride = 0; - rystride = 0; - ycount = 1; - } - else - { - bstride = b->dim[0].stride * b_kind; - assert(count == b->dim[0].ubound + 1 - b->dim[0].lbound); - ystride = b->dim[1].stride * b_kind; - ycount = b->dim[1].ubound + 1 - b->dim[1].lbound; - } - - for (y = 0; y < ycount; y++) - { - for (x = 0; x < xcount; x++) - { - /* Do the summation for this element. For real and integer types - this is the same as DOT_PRODUCT. For complex types we use do - a*b, not conjg(a)*b. */ - pa = abase; - pb = bbase; - *dest = 0; - - for (n = 0; n < count; n++) - { - if (*pa && *pb) - { - *dest = 1; - break; - } - pa += astride; - pb += bstride; - } - - dest += rxstride; - abase += xstride; - } - abase -= xstride * xcount; - bbase += ystride; - dest += rystride - (rxstride * xcount); - } -} - -#endif -' diff --git a/gcc-4.4.3/libgfortran/m4/maxloc0.m4 b/gcc-4.4.3/libgfortran/m4/maxloc0.m4 deleted file mode 100644 index ce56ab44d..000000000 --- a/gcc-4.4.3/libgfortran/m4/maxloc0.m4 +++ /dev/null @@ -1,61 +0,0 @@ -`/* Implementation of the MAXLOC intrinsic - 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. - -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 <limits.h>' - -include(iparm.m4)dnl -include(iforeach.m4)dnl - -`#if defined (HAVE_'atype_name`) && defined (HAVE_'rtype_name`)' - -FOREACH_FUNCTION( -` atype_name maxval; - - maxval = atype_min;' -, -` if (*base > maxval || !dest[0]) - { - maxval = *base; - for (n = 0; n < rank; n++) - dest[n * dstride] = count[n] + 1; - }') - -MASKED_FOREACH_FUNCTION( -` atype_name maxval; - - maxval = atype_min;' -, -` if (*mbase && (*base > maxval || !dest[0])) - { - maxval = *base; - for (n = 0; n < rank; n++) - dest[n * dstride] = count[n] + 1; - }') - -SCALAR_FOREACH_FUNCTION(`0') -#endif diff --git a/gcc-4.4.3/libgfortran/m4/maxloc1.m4 b/gcc-4.4.3/libgfortran/m4/maxloc1.m4 deleted file mode 100644 index 2910384cc..000000000 --- a/gcc-4.4.3/libgfortran/m4/maxloc1.m4 +++ /dev/null @@ -1,58 +0,0 @@ -`/* Implementation of the MAXLOC intrinsic - 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. - -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 <limits.h>' - -include(iparm.m4)dnl -include(ifunction.m4)dnl - -`#if defined (HAVE_'atype_name`) && defined (HAVE_'rtype_name`)' - -ARRAY_FUNCTION(0, -` atype_name maxval; - maxval = atype_min; - result = 0;', -` if (*src > maxval || !result) - { - maxval = *src; - result = (rtype_name)n + 1; - }') - -MASKED_ARRAY_FUNCTION(0, -` atype_name maxval; - maxval = atype_min; - result = 0;', -` if (*msrc && (*src > maxval || !result)) - { - maxval = *src; - result = (rtype_name)n + 1; - }') - -SCALAR_ARRAY_FUNCTION(0) - -#endif diff --git a/gcc-4.4.3/libgfortran/m4/maxval.m4 b/gcc-4.4.3/libgfortran/m4/maxval.m4 deleted file mode 100644 index 1fd64a02b..000000000 --- a/gcc-4.4.3/libgfortran/m4/maxval.m4 +++ /dev/null @@ -1,47 +0,0 @@ -`/* Implementation of the MAXVAL intrinsic - 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. - -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(iparm.m4)dnl -include(ifunction.m4)dnl - -`#if defined (HAVE_'atype_name`) && defined (HAVE_'rtype_name`)' - -ARRAY_FUNCTION(atype_min, -` result = atype_min;', -` if (*src > result) - result = *src;') - -MASKED_ARRAY_FUNCTION(atype_min, -` result = atype_min;', -` if (*msrc && *src > result) - result = *src;') - -SCALAR_ARRAY_FUNCTION(atype_min) - -#endif diff --git a/gcc-4.4.3/libgfortran/m4/minloc0.m4 b/gcc-4.4.3/libgfortran/m4/minloc0.m4 deleted file mode 100644 index 45b6e9088..000000000 --- a/gcc-4.4.3/libgfortran/m4/minloc0.m4 +++ /dev/null @@ -1,61 +0,0 @@ -`/* Implementation of the MINLOC intrinsic - 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. - -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 <limits.h>' - -include(iparm.m4)dnl -include(iforeach.m4)dnl - -`#if defined (HAVE_'atype_name`) && defined (HAVE_'rtype_name`)' - -FOREACH_FUNCTION( -` atype_name minval; - - minval = atype_max;' -, -` if (*base < minval || !dest[0]) - { - minval = *base; - for (n = 0; n < rank; n++) - dest[n * dstride] = count[n] + 1; - }') - -MASKED_FOREACH_FUNCTION( -` atype_name minval; - - minval = atype_max;' -, -` if (*mbase && (*base < minval || !dest[0])) - { - minval = *base; - for (n = 0; n < rank; n++) - dest[n * dstride] = count[n] + 1; - }') - -SCALAR_FOREACH_FUNCTION(`0') -#endif diff --git a/gcc-4.4.3/libgfortran/m4/minloc1.m4 b/gcc-4.4.3/libgfortran/m4/minloc1.m4 deleted file mode 100644 index 905619a38..000000000 --- a/gcc-4.4.3/libgfortran/m4/minloc1.m4 +++ /dev/null @@ -1,58 +0,0 @@ -`/* Implementation of the MINLOC intrinsic - 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. - -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 <limits.h>' - -include(iparm.m4)dnl -include(ifunction.m4)dnl - -`#if defined (HAVE_'atype_name`) && defined (HAVE_'rtype_name`)' - -ARRAY_FUNCTION(0, -` atype_name minval; - minval = atype_max; - result = 0;', -` if (*src < minval || !result) - { - minval = *src; - result = (rtype_name)n + 1; - }') - -MASKED_ARRAY_FUNCTION(0, -` atype_name minval; - minval = atype_max; - result = 0;', -` if (*msrc && (*src < minval || !result)) - { - minval = *src; - result = (rtype_name)n + 1; - }') - -SCALAR_ARRAY_FUNCTION(0) - -#endif diff --git a/gcc-4.4.3/libgfortran/m4/minval.m4 b/gcc-4.4.3/libgfortran/m4/minval.m4 deleted file mode 100644 index 9b8be5bc0..000000000 --- a/gcc-4.4.3/libgfortran/m4/minval.m4 +++ /dev/null @@ -1,47 +0,0 @@ -`/* Implementation of the MINVAL intrinsic - 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. - -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(iparm.m4)dnl -include(ifunction.m4)dnl - -`#if defined (HAVE_'atype_name`) && defined (HAVE_'rtype_name`)' - -ARRAY_FUNCTION(atype_max, -` result = atype_max;', -` if (*src < result) - result = *src;') - -MASKED_ARRAY_FUNCTION(atype_max, -` result = atype_max;', -` if (*msrc && *src < result) - result = *src;') - -SCALAR_ARRAY_FUNCTION(atype_max) - -#endif diff --git a/gcc-4.4.3/libgfortran/m4/misc_specifics.m4 b/gcc-4.4.3/libgfortran/m4/misc_specifics.m4 deleted file mode 100644 index 3e40bf017..000000000 --- a/gcc-4.4.3/libgfortran/m4/misc_specifics.m4 +++ /dev/null @@ -1,64 +0,0 @@ -include(head.m4)dnl -dnl -dnl This file contains the specific functions that are not handled in the -dnl m4/specific.m4 file. - -#include "config.h" -#include "kinds.inc" - -dnl This is from GNU m4 examples file foreach.m4: -divert(-1) -# foreach(x, (item_1, item_2, ..., item_n), stmt) -define(`foreach', `pushdef(`$1', `')_foreach(`$1', `$2', -`$3')popdef(`$1')') -define(`_arg1', `$1') -define(`_foreach', - `ifelse(`$2', `()', , - `define(`$1', _arg1$2)$3`'_foreach(`$1', (shift$2), -`$3')')') -# traceon(`define', `foreach', `_foreach', `ifelse') -divert - -dnl NINT specifics -foreach(`ikind', `(4, 8, 16)', `foreach(`rkind', `(4, 8, 10, 16)', ` -`#if defined (HAVE_GFC_REAL_'rkind`) && defined (HAVE_GFC_INTEGER_'ikind`)' -elemental function _gfortran_specific__nint_`'ikind`_'rkind (parm) - real (kind=rkind) , intent (in) :: parm - integer (kind=ikind) :: _gfortran_specific__nint_`'ikind`_'rkind - _gfortran_specific__nint_`'ikind`_'rkind = nint (parm) -end function -#endif -')') - -dnl CHAR specifics -foreach(`ckind', `(1)', `foreach(`ikind', `(4, 8, 16)', ` -`#if defined (HAVE_GFC_INTEGER_'ikind`)' -elemental function _gfortran_specific__char_`'ckind`_i'ikind (parm) - integer (kind=ikind) , intent (in) :: parm - character (kind=ckind,len=1) :: _gfortran_specific__char_`'ckind`_i'ikind - _gfortran_specific__char_`'ckind`_i'ikind` = char (parm, kind='ckind`)' -end function -#endif -')') - -dnl LEN specifics -foreach(`ckind', `(1)', `foreach(`ikind', `(4, 8, 16)', ` -`#if defined (HAVE_GFC_INTEGER_'ikind`)' -elemental function _gfortran_specific__len_`'ckind`_i'ikind (parm) - character (kind=ckind,len=*) , intent (in) :: parm - integer (kind=ikind) :: _gfortran_specific__len_`'ckind`_i'ikind - _gfortran_specific__len_`'ckind`_i'ikind` = len (parm)' -end function -#endif -')') - -dnl INDEX specifics -foreach(`ckind', `(1)', `foreach(`ikind', `(4, 8, 16)', ` -`#if defined (HAVE_GFC_INTEGER_'ikind`)' -elemental function _gfortran_specific__index_`'ckind`_i'ikind (parm1, parm2) - character (kind=ckind,len=*) , intent (in) :: parm1, parm2 - integer (kind=ikind) :: _gfortran_specific__index_`'ckind`_i'ikind - _gfortran_specific__index_`'ckind`_i'ikind` = index (parm1, parm2)' -end function -#endif -')') diff --git a/gcc-4.4.3/libgfortran/m4/mtype.m4 b/gcc-4.4.3/libgfortran/m4/mtype.m4 deleted file mode 100644 index 8e7e889bf..000000000 --- a/gcc-4.4.3/libgfortran/m4/mtype.m4 +++ /dev/null @@ -1,6 +0,0 @@ -dnl Get type kind from filename. -define(kind,regexp(file, `_.\([0-9]+\).c$', `\1'))dnl -define(complex_type, `GFC_COMPLEX_'kind)dnl -define(real_type, `GFC_REAL_'kind)dnl -define(q,ifelse(kind,4,f,ifelse(kind,8,`',ifelse(kind,10,l,ifelse(kind,16,l,`_'kind)))))dnl -define(Q,translit(q,`a-z',`A-Z'))dnl diff --git a/gcc-4.4.3/libgfortran/m4/nearest.m4 b/gcc-4.4.3/libgfortran/m4/nearest.m4 deleted file mode 100644 index 98b417f3c..000000000 --- a/gcc-4.4.3/libgfortran/m4/nearest.m4 +++ /dev/null @@ -1,49 +0,0 @@ -`/* Implementation of the NEAREST intrinsic - Copyright 2003, 2007, 2009 Free Software Foundation, Inc. - Contributed by Richard Henderson <rth@redhat.com>. - -This file is part of the GNU Fortran 95 runtime library (libgfortran). - -Libgfortran is free software; you can redistribute it and/or -modify it under the terms of the GNU General Public -License as published by the Free Software Foundation; either -version 3 of the License, or (at your option) any later version. - -Libgfortran is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -Under Section 7 of GPL version 3, you are granted additional -permissions described in the GCC Runtime Library Exception, version -3.1, as published by the Free Software Foundation. - -You should have received a copy of the GNU General Public License and -a copy of the GCC Runtime Library Exception along with this program; -see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -<http://www.gnu.org/licenses/>. */ - -#include "libgfortran.h"' - -include(`mtype.m4')dnl - -`#if defined (HAVE_'real_type`) && defined (HAVE_COPYSIGN'Q`) && defined (HAVE_NEXTAFTER'Q`) - -extern 'real_type` nearest_r'kind` ('real_type` s, 'real_type` dir); -export_proto(nearest_r'kind`); - -'real_type` -nearest_r'kind` ('real_type` s, 'real_type` dir) -{ - dir = copysign'q` (__builtin_inf'q` (), dir); - if (FLT_EVAL_METHOD != 0) - { - /* ??? Work around glibc bug on x86. */ - volatile 'real_type` r = nextafter'q` (s, dir); - return r; - } - else - return nextafter'q` (s, dir); -} - -#endif' diff --git a/gcc-4.4.3/libgfortran/m4/pack.m4 b/gcc-4.4.3/libgfortran/m4/pack.m4 deleted file mode 100644 index 16b80731f..000000000 --- a/gcc-4.4.3/libgfortran/m4/pack.m4 +++ /dev/null @@ -1,316 +0,0 @@ -`/* Specific implementation of the PACK intrinsic - Copyright (C) 2002, 2004, 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc. - Contributed by Paul Brook <paul@nowt.org> - -This file is part of the GNU Fortran 95 runtime library (libgfortran). - -Libgfortran is free software; you can redistribute it and/or -modify it under the terms of the GNU General Public -License as published by the Free Software Foundation; either -version 3 of the License, or (at your option) any later version. - -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>' - -include(iparm.m4)dnl - -`#if defined (HAVE_'rtype_name`) - -/* 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. */ - -void -pack_'rtype_code` ('rtype` *ret, const 'rtype` *array, - const gfc_array_l1 *mask, const 'rtype` *vector) -{ - /* r.* indicates the return array. */ - index_type rstride0; - 'rtype_name` * restrict rptr; - /* s.* indicates the source array. */ - index_type sstride[GFC_MAX_DIMENSIONS]; - index_type sstride0; - const 'rtype_name` *sptr; - /* m.* indicates the mask array. */ - index_type mstride[GFC_MAX_DIMENSIONS]; - index_type mstride0; - const GFC_LOGICAL_1 *mptr; - - index_type count[GFC_MAX_DIMENSIONS]; - index_type extent[GFC_MAX_DIMENSIONS]; - int zero_sized; - index_type n; - index_type dim; - index_type nelem; - index_type total; - int mask_kind; - - dim = GFC_DESCRIPTOR_RANK (array); - - 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 - ) - { - /* Do not convert a NULL pointer as we use test for NULL below. */ - if (mptr) - mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind); - } - else - runtime_error ("Funny sized logical array"); - - zero_sized = 0; - for (n = 0; n < dim; n++) - { - count[n] = 0; - extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound; - if (extent[n] <= 0) - zero_sized = 1; - sstride[n] = array->dim[n].stride; - mstride[n] = mask->dim[n].stride * mask_kind; - } - if (sstride[0] == 0) - sstride[0] = 1; - if (mstride[0] == 0) - mstride[0] = mask_kind; - - if (zero_sized) - sptr = NULL; - else - sptr = array->data; - - if (ret->data == NULL || compile_options.bounds_check) - { - /* Count the elements, either for allocating memory or - for bounds checking. */ - - if (vector != NULL) - { - /* The return array will have as many - elements as there are in VECTOR. */ - total = vector->dim[0].ubound + 1 - vector->dim[0].lbound; - if (total < 0) - { - total = 0; - vector = NULL; - } - } - else - { - /* We have to count the true elements in MASK. */ - - /* TODO: We could speed up pack easily in the case of only - few .TRUE. entries in MASK, by keeping track of where we - would be in the source array during the initial traversal - of MASK, and caching the pointers to those elements. Then, - supposed the number of elements is small enough, we would - only have to traverse the list, and copy those elements - into the result array. In the case of datatypes which fit - in one of the integer types we could also cache the - value instead of a pointer to it. - This approach might be bad from the point of view of - cache behavior in the case where our cache is not big - enough to hold all elements that have to be copied. */ - - const GFC_LOGICAL_1 *m = mptr; - - total = 0; - if (zero_sized) - m = NULL; - - while (m) - { - /* Test this element. */ - if (*m) - total++; - - /* Advance to the next element. */ - m += mstride[0]; - count[0]++; - n = 0; - while (count[n] == extent[n]) - { - /* When we get to the end of a dimension, reset it - and increment the next dimension. */ - count[n] = 0; - /* We could precalculate this product, but this is a - less frequently used path so probably not worth - it. */ - m -= mstride[n] * extent[n]; - n++; - if (n >= dim) - { - /* Break out of the loop. */ - m = NULL; - break; - } - else - { - count[n]++; - m += mstride[n]; - } - } - } - } - - if (ret->data == NULL) - { - /* Setup the array descriptor. */ - ret->dim[0].lbound = 0; - ret->dim[0].ubound = total - 1; - ret->dim[0].stride = 1; - - ret->offset = 0; - if (total == 0) - { - /* In this case, nothing remains to be done. */ - ret->data = internal_malloc_size (1); - return; - } - else - ret->data = internal_malloc_size (sizeof ('rtype_name`) * total); - } - else - { - /* We come here because of range checking. */ - index_type ret_extent; - - ret_extent = ret->dim[0].ubound + 1 - ret->dim[0].lbound; - if (total != ret_extent) - runtime_error ("Incorrect extent in return value of PACK intrinsic;" - " is %ld, should be %ld", (long int) total, - (long int) ret_extent); - } - } - - rstride0 = ret->dim[0].stride; - if (rstride0 == 0) - rstride0 = 1; - sstride0 = sstride[0]; - mstride0 = mstride[0]; - rptr = ret->data; - - while (sptr && mptr) - { - /* Test this element. */ - if (*mptr) - { - /* Add it. */ - *rptr = *sptr; - rptr += rstride0; - } - /* Advance to the next element. */ - sptr += sstride0; - mptr += mstride0; - count[0]++; - n = 0; - while (count[n] == extent[n]) - { - /* When we get to the end of a dimension, reset it and increment - the next dimension. */ - count[n] = 0; - /* We could precalculate these products, but this is a less - frequently used path so probably not worth it. */ - sptr -= sstride[n] * extent[n]; - mptr -= mstride[n] * extent[n]; - n++; - if (n >= dim) - { - /* Break out of the loop. */ - sptr = NULL; - break; - } - else - { - count[n]++; - sptr += sstride[n]; - mptr += mstride[n]; - } - } - } - - /* Add any remaining elements from VECTOR. */ - if (vector) - { - n = vector->dim[0].ubound + 1 - vector->dim[0].lbound; - nelem = ((rptr - ret->data) / rstride0); - if (n > nelem) - { - sstride0 = vector->dim[0].stride; - if (sstride0 == 0) - sstride0 = 1; - - sptr = vector->data + sstride0 * nelem; - n -= nelem; - while (n--) - { - *rptr = *sptr; - rptr += rstride0; - sptr += sstride0; - } - } - } -} - -#endif -' diff --git a/gcc-4.4.3/libgfortran/m4/pow.m4 b/gcc-4.4.3/libgfortran/m4/pow.m4 deleted file mode 100644 index 3814f87fe..000000000 --- a/gcc-4.4.3/libgfortran/m4/pow.m4 +++ /dev/null @@ -1,83 +0,0 @@ -`/* Support routines for the intrinsic power (**) operator. - Copyright 2004, 2007, 2009 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 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(iparm.m4)dnl - -/* Use Binary Method to calculate the powi. This is not an optimal but - a simple and reasonable arithmetic. See section 4.6.3, "Evaluation of - Powers" of Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art - of Computer Programming", 3rd Edition, 1998. */ - -`#if defined (HAVE_'rtype_name`) && defined (HAVE_'atype_name`)' - -rtype_name `pow_'rtype_code`_'atype_code` ('rtype_name` a, 'atype_name` b); -export_proto(pow_'rtype_code`_'atype_code`); - -'rtype_name` -pow_'rtype_code`_'atype_code` ('rtype_name` a, 'atype_name` b) -{ - 'rtype_name` pow, x; - 'atype_name` n; - GFC_UINTEGER_'atype_kind` u; - - n = b; - x = a; - pow = 1; - if (n != 0) - { - if (n < 0) - { -'ifelse(rtype_letter,i,`dnl - if (x == 1) - return 1; - if (x == -1) - return (n & 1) ? -1 : 1; - return (x == 0) ? 1 / x : 0; -',` - u = -n; - x = pow / x; -')dnl -` } - else - { - u = n; - } - for (;;) - { - if (u & 1) - pow *= x; - u >>= 1; - if (u) - x *= x; - else - break; - } - } - return pow; -} - -#endif' diff --git a/gcc-4.4.3/libgfortran/m4/product.m4 b/gcc-4.4.3/libgfortran/m4/product.m4 deleted file mode 100644 index 669b106e0..000000000 --- a/gcc-4.4.3/libgfortran/m4/product.m4 +++ /dev/null @@ -1,46 +0,0 @@ -`/* Implementation of the PRODUCT intrinsic - 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. - -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(iparm.m4)dnl -include(ifunction.m4)dnl - -`#if defined (HAVE_'atype_name`) && defined (HAVE_'rtype_name`)' - -ARRAY_FUNCTION(1, -` result = 1;', -` result *= *src;') - -MASKED_ARRAY_FUNCTION(1, -` result = 1;', -` if (*msrc) - result *= *src;') - -SCALAR_ARRAY_FUNCTION(1) - -`#endif' diff --git a/gcc-4.4.3/libgfortran/m4/reshape.m4 b/gcc-4.4.3/libgfortran/m4/reshape.m4 deleted file mode 100644 index 5240e3866..000000000 --- a/gcc-4.4.3/libgfortran/m4/reshape.m4 +++ /dev/null @@ -1,356 +0,0 @@ -`/* Implementation of the RESHAPE - 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. - -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(iparm.m4)dnl - -`#if defined (HAVE_'rtype_name`) - -typedef GFC_ARRAY_DESCRIPTOR(1, 'index_type`) 'shape_type`;' - -dnl For integer routines, only the kind (ie size) is used to name the -dnl function. The same function will be used for integer and logical -dnl arrays of the same kind. - -`extern void reshape_'rtype_ccode` ('rtype` * const restrict, - 'rtype` * const restrict, - 'shape_type` * const restrict, - 'rtype` * const restrict, - 'shape_type` * const restrict); -export_proto(reshape_'rtype_ccode`); - -void -reshape_'rtype_ccode` ('rtype` * const restrict ret, - 'rtype` * const restrict source, - 'shape_type` * const restrict shape, - 'rtype` * const restrict pad, - 'shape_type` * const restrict order) -{ - /* 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; - 'rtype_name` *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 'rtype_name` *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 'rtype_name` *pptr; - - const 'rtype_name` *src; - int n; - int dim; - int sempty, pempty, shape_empty; - index_type shape_data[GFC_MAX_DIMENSIONS]; - - rdim = shape->dim[0].ubound - shape->dim[0].lbound + 1; - if (rdim != GFC_DESCRIPTOR_RANK(ret)) - runtime_error("rank of return array incorrect in RESHAPE intrinsic"); - - shape_empty = 0; - - for (n = 0; n < rdim; n++) - { - shape_data[n] = shape->data[n * shape->dim[0].stride]; - if (shape_data[n] <= 0) - { - shape_data[n] = 0; - shape_empty = 1; - } - } - - if (ret->data == NULL) - { - rs = 1; - for (n = 0; n < rdim; n++) - { - ret->dim[n].lbound = 0; - rex = shape_data[n]; - ret->dim[n].ubound = rex - 1; - ret->dim[n].stride = rs; - rs *= rex; - } - ret->offset = 0; - ret->data = internal_malloc_size ( rs * sizeof ('rtype_name`)); - ret->dtype = (source->dtype & ~GFC_DTYPE_RANK_MASK) | rdim; - } - - if (shape_empty) - return; - - if (pad) - { - pdim = GFC_DESCRIPTOR_RANK (pad); - psize = 1; - pempty = 0; - for (n = 0; n < pdim; n++) - { - pcount[n] = 0; - pstride[n] = pad->dim[n].stride; - pextent[n] = pad->dim[n].ubound + 1 - pad->dim[n].lbound; - if (pextent[n] <= 0) - { - pempty = 1; - pextent[n] = 0; - } - - if (psize == pstride[n]) - psize *= pextent[n]; - else - psize = 0; - } - pptr = pad->data; - } - else - { - pdim = 0; - psize = 1; - pempty = 1; - pptr = NULL; - } - - if (unlikely (compile_options.bounds_check)) - { - index_type ret_extent, source_extent; - - rs = 1; - for (n = 0; n < rdim; n++) - { - rs *= shape_data[n]; - ret_extent = ret->dim[n].ubound + 1 - ret->dim[n].lbound; - if (ret_extent != shape_data[n]) - runtime_error("Incorrect extent in return value of RESHAPE" - " intrinsic in dimension %ld: is %ld," - " should be %ld", (long int) n+1, - (long int) ret_extent, (long int) shape_data[n]); - } - - source_extent = 1; - sdim = GFC_DESCRIPTOR_RANK (source); - for (n = 0; n < sdim; n++) - { - index_type se; - se = source->dim[n].ubound + 1 - source->dim[0].lbound; - source_extent *= se > 0 ? se : 0; - } - - if (rs > source_extent && (!pad || pempty)) - runtime_error("Incorrect size in SOURCE argument to RESHAPE" - " intrinsic: is %ld, should be %ld", - (long int) source_extent, (long int) rs); - - if (order) - { - int seen[GFC_MAX_DIMENSIONS]; - index_type v; - - for (n = 0; n < rdim; n++) - seen[n] = 0; - - for (n = 0; n < rdim; n++) - { - v = order->data[n * order->dim[0].stride] - 1; - - if (v < 0 || v >= rdim) - runtime_error("Value %ld out of range in ORDER argument" - " to RESHAPE intrinsic", (long int) v + 1); - - if (seen[v] != 0) - runtime_error("Duplicate value %ld in ORDER argument to" - " RESHAPE intrinsic", (long int) v + 1); - - seen[v] = 1; - } - } - } - - rsize = 1; - for (n = 0; n < rdim; n++) - { - if (order) - dim = order->data[n * order->dim[0].stride] - 1; - else - dim = n; - - rcount[n] = 0; - rstride[n] = ret->dim[dim].stride; - rextent[n] = ret->dim[dim].ubound + 1 - ret->dim[dim].lbound; - if (rextent[n] < 0) - rextent[n] = 0; - - if (rextent[n] != shape_data[dim]) - runtime_error ("shape and target do not conform"); - - if (rsize == rstride[n]) - rsize *= rextent[n]; - else - rsize = 0; - if (rextent[n] <= 0) - return; - } - - sdim = GFC_DESCRIPTOR_RANK (source); - ssize = 1; - sempty = 0; - for (n = 0; n < sdim; n++) - { - scount[n] = 0; - sstride[n] = source->dim[n].stride; - sextent[n] = source->dim[n].ubound + 1 - source->dim[n].lbound; - if (sextent[n] <= 0) - { - sempty = 1; - sextent[n] = 0; - } - - if (ssize == sstride[n]) - ssize *= sextent[n]; - else - ssize = 0; - } - - if (rsize != 0 && ssize != 0 && psize != 0) - { - rsize *= sizeof ('rtype_name`); - ssize *= sizeof ('rtype_name`); - psize *= sizeof ('rtype_name`); - reshape_packed ((char *)ret->data, rsize, (char *)source->data, - ssize, pad ? (char *)pad->data : NULL, psize); - return; - } - rptr = ret->data; - src = sptr = source->data; - rstride0 = rstride[0]; - sstride0 = sstride[0]; - - 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]; - } - } - - while (rptr) - { - /* Select between the source and pad arrays. */ - *rptr = *src; - /* 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]; - n++; - if (n == rdim) - { - /* Break out of the loop. */ - rptr = NULL; - break; - } - else - { - rcount[n]++; - rptr += rstride[n]; - } - } - /* 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]; - 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]; - } - } - /* We now start again from the beginning of the pad array. */ - src = pptr; - break; - } - else - { - scount[n]++; - src += sstride[n]; - } - } - } -} - -#endif' diff --git a/gcc-4.4.3/libgfortran/m4/rrspacing.m4 b/gcc-4.4.3/libgfortran/m4/rrspacing.m4 deleted file mode 100644 index f66bb3b75..000000000 --- a/gcc-4.4.3/libgfortran/m4/rrspacing.m4 +++ /dev/null @@ -1,52 +0,0 @@ -`/* Implementation of the RRSPACING intrinsic - Copyright 2006, 2007, 2009 Free Software Foundation, Inc. - Contributed by Steven G. Kargl <kargl@gcc.gnu.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(`mtype.m4')dnl - -`#if defined (HAVE_'real_type`) && defined (HAVE_FABS'Q`) && defined (HAVE_FREXP'Q`) - -extern 'real_type` rrspacing_r'kind` ('real_type` s, int p); -export_proto(rrspacing_r'kind`); - -'real_type` -rrspacing_r'kind` ('real_type` s, int p) -{ - int e; - 'real_type` x; - x = fabs'q` (s); - if (x == 0.) - return 0.; - frexp'q` (s, &e); -#if defined (HAVE_LDEXP'Q`) - return ldexp'q` (x, p - e); -#else - return scalbn'q` (x, p - e); -#endif - -} - -#endif' diff --git a/gcc-4.4.3/libgfortran/m4/set_exponent.m4 b/gcc-4.4.3/libgfortran/m4/set_exponent.m4 deleted file mode 100644 index 84200fd33..000000000 --- a/gcc-4.4.3/libgfortran/m4/set_exponent.m4 +++ /dev/null @@ -1,42 +0,0 @@ -`/* Implementation of the SET_EXPONENT intrinsic - Copyright 2003, 2007, 2009 Free Software Foundation, Inc. - Contributed by Richard Henderson <rth@redhat.com>. - -This file is part of the GNU Fortran 95 runtime library (libgfortran). - -Libgfortran is free software; you can redistribute it and/or -modify it under the terms of the GNU General Public -License as published by the Free Software Foundation; either -version 3 of the License, or (at your option) any later version. - -Libgfortran is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -Under Section 7 of GPL version 3, you are granted additional -permissions described in the GCC Runtime Library Exception, version -3.1, as published by the Free Software Foundation. - -You should have received a copy of the GNU General Public License and -a copy of the GCC Runtime Library Exception along with this program; -see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -<http://www.gnu.org/licenses/>. */ - -#include "libgfortran.h"' - -include(`mtype.m4')dnl - -`#if defined (HAVE_'real_type`) && defined (HAVE_SCALBN'Q`) && defined (HAVE_FREXP'Q`) - -extern 'real_type` set_exponent_r'kind` ('real_type` s, GFC_INTEGER_4 i); -export_proto(set_exponent_r'kind`); - -'real_type` -set_exponent_r'kind` ('real_type` s, GFC_INTEGER_4 i) -{ - int dummy_exp; - return scalbn'q` (frexp'q` (s, &dummy_exp), i); -} - -#endif' diff --git a/gcc-4.4.3/libgfortran/m4/shape.m4 b/gcc-4.4.3/libgfortran/m4/shape.m4 deleted file mode 100644 index b189f804e..000000000 --- a/gcc-4.4.3/libgfortran/m4/shape.m4 +++ /dev/null @@ -1,58 +0,0 @@ -`/* Implementation of the SHAPE 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. - -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(iparm.m4)dnl - -`#if defined (HAVE_'rtype_name`) - -extern void shape_'rtype_kind` ('rtype` * const restrict ret, - const 'rtype` * const restrict array); -export_proto(shape_'rtype_kind`); - -void -shape_'rtype_kind` ('rtype` * const restrict ret, - const 'rtype` * const restrict array) -{ - int n; - index_type stride; - index_type extent; - - stride = ret->dim[0].stride; - - if (ret->dim[0].ubound < ret->dim[0].lbound) - return; - - for (n = 0; n < GFC_DESCRIPTOR_RANK (array); n++) - { - extent = array->dim[n].ubound + 1 - array->dim[n].lbound; - ret->data[n * stride] = extent > 0 ? extent : 0 ; - } -} - -#endif' diff --git a/gcc-4.4.3/libgfortran/m4/spacing.m4 b/gcc-4.4.3/libgfortran/m4/spacing.m4 deleted file mode 100644 index 62fa739c7..000000000 --- a/gcc-4.4.3/libgfortran/m4/spacing.m4 +++ /dev/null @@ -1,51 +0,0 @@ -`/* Implementation of the SPACING intrinsic - Copyright 2006, 2007, 2009 Free Software Foundation, Inc. - Contributed by Steven G. Kargl <kargl@gcc.gnu.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(`mtype.m4')dnl - -`#if defined (HAVE_'real_type`) && defined (HAVE_FREXP'Q`) - -extern 'real_type` spacing_r'kind` ('real_type` s, int p, int emin, 'real_type` tiny); -export_proto(spacing_r'kind`); - -'real_type` -spacing_r'kind` ('real_type` s, int p, int emin, 'real_type` tiny) -{ - int e; - if (s == 0.) - return tiny; - frexp'q` (s, &e); - e = e - p; - e = e > emin ? e : emin; -#if defined (HAVE_LDEXP'Q`) - return ldexp'q` (1., e); -#else - return scalbn'q` (1., e); -#endif -} - -#endif' diff --git a/gcc-4.4.3/libgfortran/m4/specific.m4 b/gcc-4.4.3/libgfortran/m4/specific.m4 deleted file mode 100644 index ebc89839a..000000000 --- a/gcc-4.4.3/libgfortran/m4/specific.m4 +++ /dev/null @@ -1,43 +0,0 @@ -include(head.m4) -define(atype_code,regexp(file,`_\([ircl][0-9]+\).[fF]90',`\1'))dnl -define(atype_letter,substr(atype_code, 0, 1))dnl -define(atype_kind,substr(atype_code, 1))dnl -define(get_typename2, `$1 (kind=$2)')dnl -define(get_typename, `get_typename2(ifelse($1,i,integer,ifelse($1,r,real,ifelse($1,l,logical,ifelse($1,c,complex,unknown)))),`$2')')dnl -define(atype_name, get_typename(atype_letter,atype_kind))dnl -define(name, regexp(regexp(file, `[^/]*$', `\&'), `^_\([^_]*\)_', `\1'))dnl -define(rtype_name,get_typename(ifelse(name,abs,ifelse(atype_letter,c,r,atype_letter),ifelse(name,aimag,ifelse(atype_letter,c,r,atype_letter),atype_letter)),atype_kind))dnl -define(function_name,ifelse(name,conjg,`_gfortran_specific__conjg_'atype_kind,`_gfortran_specific__'name`_'atype_code))dnl - -define(type,ifelse(atype_letter,l,LOGICAL,ifelse(atype_letter,i,INTEGER,ifelse(atype_letter,r,REAL,ifelse(atype_letter,c,COMPLEX,UNKNOW)))))dnl -define(Q,ifelse(atype_kind,4,F,ifelse(atype_kind,8,`',ifelse(atype_kind,10,L,ifelse(atype_kind,16,L,`_'atype_kind)))))dnl - -dnl A few specifics require a function other than their name, or -dnl nothing. The list is currently: -dnl - integer and logical specifics require no libm function -dnl - AINT requires the trunc() family functions -dnl - ANINT requires round() -dnl - AIMAG, CONJG, DIM, SIGN require no libm function -define(needed,ifelse(atype_letter,i,`none',ifelse(atype_letter,l,`none',ifelse(name,aint,trunc,ifelse(name,anint,round,ifelse(name,aimag,none,ifelse(name,conjg,none,ifelse(name,dim,none,ifelse(name,sign,none,ifelse(name,abs,fabs,name))))))))))dnl -define(prefix,ifelse(atype_letter,c,C,`'))dnl - -dnl Special case for fabs, for which the corresponding complex function -dnl is not cfabs but cabs. -define(NEEDED,translit(ifelse(prefix`'needed,`Cfabs',`abs',needed),`a-z',`A-Z'))dnl - -#include "config.h" -#include "kinds.inc" -#include "c99_protos.inc" - -`#if defined (HAVE_GFC_'type`_'atype_kind`)' -ifelse(NEEDED,NONE,`',`#ifdef HAVE_'prefix`'NEEDED`'Q) - -elemental function function_name (parm) - atype_name, intent (in) :: parm - rtype_name :: function_name - - function_name = name (parm) -end function - -ifelse(NEEDED,NONE,`',`#endif') -#endif diff --git a/gcc-4.4.3/libgfortran/m4/specific2.m4 b/gcc-4.4.3/libgfortran/m4/specific2.m4 deleted file mode 100644 index d05e8db14..000000000 --- a/gcc-4.4.3/libgfortran/m4/specific2.m4 +++ /dev/null @@ -1,30 +0,0 @@ -include(head.m4) -define(atype_code,regexp(file,`_\([ircl][0-9]+\).[fF]90',`\1'))dnl -define(atype_letter,substr(atype_code, 0, 1))dnl -define(atype_kind,substr(atype_code, 1))dnl -define(get_typename2, `$1 (kind=$2)')dnl -define(get_typename, `get_typename2(ifelse($1,i,integer,ifelse($1,r,real,ifelse($1,l,logical,ifelse($1,c,complex,unknown)))),`$2')')dnl -define(atype_name, get_typename(atype_letter,atype_kind))dnl -define(name, regexp(regexp(file, `[^/]*$', `\&'), `^_\([^_]*\)_', `\1'))dnl -define(function_name,`_gfortran_specific__'name`_'atype_code)dnl - -define(Q,ifelse(atype_kind,4,F,ifelse(atype_kind,8,`',ifelse(atype_kind,10,L,ifelse(atype_kind,16,L,`_'atype_kind)))))dnl - -#include "config.h" -#include "kinds.inc" -#include "c99_protos.inc" - -`#if defined (HAVE_GFC_'ifelse(atype_letter,l,LOGICAL,ifelse(atype_letter,i,INTEGER,ifelse(atype_letter,r,REAL,ifelse(atype_letter,c,COMPLEX,UNKNOW))))`_'atype_kind`)' - -ifelse(name,atan2,`#ifdef HAVE_ATAN2'Q,) - -elemental function function_name (p1, p2) - atype_name, intent (in) :: p1, p2 - atype_name :: function_name - - function_name = name (p1, p2) -end function - -ifelse(name,atan2,`#endif',) - -#endif diff --git a/gcc-4.4.3/libgfortran/m4/spread.m4 b/gcc-4.4.3/libgfortran/m4/spread.m4 deleted file mode 100644 index 84ea00c33..000000000 --- a/gcc-4.4.3/libgfortran/m4/spread.m4 +++ /dev/null @@ -1,274 +0,0 @@ -`/* Special implementation of the SPREAD intrinsic - Copyright 2008, 2009 Free Software Foundation, Inc. - Contributed by Thomas Koenig <tkoenig@gcc.gnu.org>, based on - spread_generic.c written 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>' - -include(iparm.m4)dnl - -`#if defined (HAVE_'rtype_name`) - -void -spread_'rtype_code` ('rtype` *ret, const 'rtype` *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; - 'rtype_name` *rptr; - 'rtype_name` * restrict dest; - /* s.* indicates the source array. */ - index_type sstride[GFC_MAX_DIMENSIONS]; - index_type sstride0; - index_type srank; - const 'rtype_name` *sptr; - - index_type count[GFC_MAX_DIMENSIONS]; - index_type extent[GFC_MAX_DIMENSIONS]; - index_type n; - index_type dim; - index_type ncopies; - - srank = GFC_DESCRIPTOR_RANK(source); - - rrank = srank + 1; - if (rrank > GFC_MAX_DIMENSIONS) - runtime_error ("return rank too large in spread()"); - - if (along > rrank) - runtime_error ("dim outside of rank in spread()"); - - ncopies = pncopies; - - if (ret->data == NULL) - { - /* The front end has signalled that we need to populate the - return array descriptor. */ - ret->dtype = (source->dtype & ~GFC_DTYPE_RANK_MASK) | rrank; - dim = 0; - rs = 1; - for (n = 0; n < rrank; n++) - { - ret->dim[n].stride = rs; - ret->dim[n].lbound = 0; - if (n == along - 1) - { - ret->dim[n].ubound = ncopies - 1; - rdelta = rs; - rs *= ncopies; - } - else - { - count[dim] = 0; - extent[dim] = source->dim[dim].ubound + 1 - - source->dim[dim].lbound; - sstride[dim] = source->dim[dim].stride; - rstride[dim] = rs; - - ret->dim[n].ubound = extent[dim]-1; - rs *= extent[dim]; - dim++; - } - } - ret->offset = 0; - if (rs > 0) - ret->data = internal_malloc_size (rs * sizeof('rtype_name`)); - else - { - ret->data = internal_malloc_size (1); - return; - } - } - else - { - int zero_sized; - - zero_sized = 0; - - dim = 0; - if (GFC_DESCRIPTOR_RANK(ret) != rrank) - runtime_error ("rank mismatch in spread()"); - - if (unlikely (compile_options.bounds_check)) - { - for (n = 0; n < rrank; n++) - { - index_type ret_extent; - - ret_extent = ret->dim[n].ubound + 1 - ret->dim[n].lbound; - if (n == along - 1) - { - rdelta = ret->dim[n].stride; - - if (ret_extent != ncopies) - runtime_error("Incorrect extent in return value of SPREAD" - " intrinsic in dimension %ld: is %ld," - " should be %ld", (long int) n+1, - (long int) ret_extent, (long int) ncopies); - } - else - { - count[dim] = 0; - extent[dim] = source->dim[dim].ubound + 1 - - source->dim[dim].lbound; - if (ret_extent != extent[dim]) - runtime_error("Incorrect extent in return value of SPREAD" - " intrinsic in dimension %ld: is %ld," - " should be %ld", (long int) n+1, - (long int) ret_extent, - (long int) extent[dim]); - - if (extent[dim] <= 0) - zero_sized = 1; - sstride[dim] = source->dim[dim].stride; - rstride[dim] = ret->dim[n].stride; - dim++; - } - } - } - else - { - for (n = 0; n < rrank; n++) - { - if (n == along - 1) - { - rdelta = ret->dim[n].stride; - } - else - { - count[dim] = 0; - extent[dim] = source->dim[dim].ubound + 1 - - source->dim[dim].lbound; - if (extent[dim] <= 0) - zero_sized = 1; - sstride[dim] = source->dim[dim].stride; - rstride[dim] = ret->dim[n].stride; - dim++; - } - } - } - - if (zero_sized) - return; - - if (sstride[0] == 0) - sstride[0] = 1; - } - 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++) - { - *dest = *sptr; - 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. */ - -void -spread_scalar_'rtype_code` ('rtype` *ret, const 'rtype_name` *source, - const index_type along, const index_type pncopies) -{ - int n; - int ncopies = pncopies; - 'rtype_name` * restrict dest; - index_type stride; - - 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 * sizeof ('rtype_name`)); - ret->offset = 0; - ret->dim[0].stride = 1; - ret->dim[0].lbound = 0; - ret->dim[0].ubound = ncopies - 1; - } - else - { - if (ncopies - 1 > (ret->dim[0].ubound - ret->dim[0].lbound) - / ret->dim[0].stride) - runtime_error ("dim too large in spread()"); - } - - dest = ret->data; - stride = ret->dim[0].stride; - - for (n = 0; n < ncopies; n++) - { - *dest = *source; - dest += stride; - } -} - -#endif -' diff --git a/gcc-4.4.3/libgfortran/m4/sum.m4 b/gcc-4.4.3/libgfortran/m4/sum.m4 deleted file mode 100644 index b502c6e7d..000000000 --- a/gcc-4.4.3/libgfortran/m4/sum.m4 +++ /dev/null @@ -1,46 +0,0 @@ -`/* Implementation of the SUM intrinsic - 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. - -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(iparm.m4)dnl -include(ifunction.m4)dnl - -`#if defined (HAVE_'atype_name`) && defined (HAVE_'rtype_name`)' - -ARRAY_FUNCTION(0, -` result = 0;', -` result += *src;') - -MASKED_ARRAY_FUNCTION(0, -` result = 0;', -` if (*msrc) - result += *src;') - -SCALAR_ARRAY_FUNCTION(0) - -#endif diff --git a/gcc-4.4.3/libgfortran/m4/transpose.m4 b/gcc-4.4.3/libgfortran/m4/transpose.m4 deleted file mode 100644 index 8c50767fc..000000000 --- a/gcc-4.4.3/libgfortran/m4/transpose.m4 +++ /dev/null @@ -1,117 +0,0 @@ -`/* Implementation of the TRANSPOSE intrinsic - Copyright 2003, 2005, 2006, 2007, 2009 Free Software Foundation, Inc. - Contributed by Tobias Schlüter - -This file is part of the GNU Fortran 95 runtime library (libgfortran). - -Libgfortran is free software; you can redistribute it and/or -modify it under the terms of the GNU General Public -License as published by the Free Software Foundation; either -version 3 of the License, or (at your option) any later version. - -Libgfortran is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -Under Section 7 of GPL version 3, you are granted additional -permissions described in the GCC Runtime Library Exception, version -3.1, as published by the Free Software Foundation. - -You should have received a copy of the GNU General Public License and -a copy of the GCC Runtime Library Exception along with this program; -see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -<http://www.gnu.org/licenses/>. */ - -#include "libgfortran.h" -#include <assert.h>' - -include(iparm.m4)dnl - -`#if defined (HAVE_'rtype_name`) - -extern void transpose_'rtype_code` ('rtype` * const restrict ret, - 'rtype` * const restrict source); -export_proto(transpose_'rtype_code`); - -void -transpose_'rtype_code` ('rtype` * const restrict ret, - 'rtype` * const restrict source) -{ - /* r.* indicates the return array. */ - index_type rxstride, rystride; - 'rtype_name` * restrict rptr; - /* s.* indicates the source array. */ - index_type sxstride, systride; - const 'rtype_name` *sptr; - - index_type xcount, ycount; - index_type x, y; - - assert (GFC_DESCRIPTOR_RANK (source) == 2); - - if (ret->data == NULL) - { - assert (GFC_DESCRIPTOR_RANK (ret) == 2); - assert (ret->dtype == source->dtype); - - ret->dim[0].lbound = 0; - ret->dim[0].ubound = source->dim[1].ubound - source->dim[1].lbound; - ret->dim[0].stride = 1; - - ret->dim[1].lbound = 0; - ret->dim[1].ubound = source->dim[0].ubound - source->dim[0].lbound; - ret->dim[1].stride = ret->dim[0].ubound+1; - - ret->data = internal_malloc_size (sizeof ('rtype_name`) * size0 ((array_t *) ret)); - ret->offset = 0; - } else if (unlikely (compile_options.bounds_check)) - { - index_type ret_extent, src_extent; - - ret_extent = ret->dim[0].ubound + 1 - ret->dim[0].lbound; - src_extent = source->dim[1].ubound + 1 - source->dim[1].lbound; - - if (src_extent != ret_extent) - runtime_error ("Incorrect extent in return value of TRANSPOSE" - " intrinsic in dimension 1: is %ld," - " should be %ld", (long int) src_extent, - (long int) ret_extent); - - ret_extent = ret->dim[1].ubound + 1 - ret->dim[1].lbound; - src_extent = source->dim[0].ubound + 1 - source->dim[0].lbound; - - if (src_extent != ret_extent) - runtime_error ("Incorrect extent in return value of TRANSPOSE" - " intrinsic in dimension 2: is %ld," - " should be %ld", (long int) src_extent, - (long int) ret_extent); - - } - - sxstride = source->dim[0].stride; - systride = source->dim[1].stride; - xcount = source->dim[0].ubound + 1 - source->dim[0].lbound; - ycount = source->dim[1].ubound + 1 - source->dim[1].lbound; - - rxstride = ret->dim[0].stride; - rystride = ret->dim[1].stride; - - rptr = ret->data; - sptr = source->data; - - for (y=0; y < ycount; y++) - { - for (x=0; x < xcount; x++) - { - *rptr = *sptr; - - sptr += sxstride; - rptr += rystride; - } - sptr += systride - (sxstride * xcount); - rptr += rxstride - (rystride * xcount); - } -} - -#endif' diff --git a/gcc-4.4.3/libgfortran/m4/types.m4 b/gcc-4.4.3/libgfortran/m4/types.m4 deleted file mode 100644 index cb808290c..000000000 --- a/gcc-4.4.3/libgfortran/m4/types.m4 +++ /dev/null @@ -1,4 +0,0 @@ -define(get_typename2, `GFC_$1_$2')dnl -define(get_typename, `get_typename2(ifelse($1,i,INTEGER,ifelse($1,r,REAL,ifelse($1,l,LOGICAL,ifelse($1,c,COMPLEX,unknown)))),`$2')')dnl -define(get_arraytype, `gfc_array_$1$2')dnl -define(name, regexp(regexp(file, `[^/]*$', `\&'), `^\([^_]*\)_', `\1'))dnl diff --git a/gcc-4.4.3/libgfortran/m4/unpack.m4 b/gcc-4.4.3/libgfortran/m4/unpack.m4 deleted file mode 100644 index a26128c78..000000000 --- a/gcc-4.4.3/libgfortran/m4/unpack.m4 +++ /dev/null @@ -1,334 +0,0 @@ -`/* Specific implementation of the UNPACK intrinsic - Copyright 2008, 2009 Free Software Foundation, Inc. - Contributed by Thomas Koenig <tkoenig@gcc.gnu.org>, based on - unpack_generic.c 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>' - -include(iparm.m4)dnl - -`#if defined (HAVE_'rtype_name`) - -void -unpack0_'rtype_code` ('rtype` *ret, const 'rtype` *vector, - const gfc_array_l1 *mask, const 'rtype_name` *fptr) -{ - /* r.* indicates the return array. */ - index_type rstride[GFC_MAX_DIMENSIONS]; - index_type rstride0; - index_type rs; - 'rtype_name` * restrict rptr; - /* v.* indicates the vector array. */ - index_type vstride0; - 'rtype_name` *vptr; - /* Value for field, this is constant. */ - const 'rtype_name` fval = *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 - ) - { - /* Do not convert a NULL pointer as we use test for NULL below. */ - if (mptr) - mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind); - } - else - runtime_error ("Funny sized logical array"); - - if (ret->data == NULL) - { - /* The front end has signalled that we need to populate the - return array descriptor. */ - dim = GFC_DESCRIPTOR_RANK (mask); - rs = 1; - for (n = 0; n < dim; n++) - { - count[n] = 0; - ret->dim[n].stride = rs; - ret->dim[n].lbound = 0; - ret->dim[n].ubound = mask->dim[n].ubound - mask->dim[n].lbound; - extent[n] = ret->dim[n].ubound + 1; - empty = empty || extent[n] <= 0; - rstride[n] = ret->dim[n].stride; - mstride[n] = mask->dim[n].stride * mask_kind; - rs *= extent[n]; - } - ret->offset = 0; - ret->data = internal_malloc_size (rs * sizeof ('rtype_name`)); - } - else - { - dim = GFC_DESCRIPTOR_RANK (ret); - for (n = 0; n < dim; n++) - { - count[n] = 0; - extent[n] = ret->dim[n].ubound + 1 - ret->dim[n].lbound; - empty = empty || extent[n] <= 0; - rstride[n] = ret->dim[n].stride; - mstride[n] = mask->dim[n].stride * mask_kind; - } - if (rstride[0] == 0) - rstride[0] = 1; - } - - if (empty) - return; - - if (mstride[0] == 0) - mstride[0] = 1; - - vstride0 = vector->dim[0].stride; - if (vstride0 == 0) - vstride0 = 1; - rstride0 = rstride[0]; - mstride0 = mstride[0]; - rptr = ret->data; - vptr = vector->data; - - while (rptr) - { - if (*mptr) - { - /* From vector. */ - *rptr = *vptr; - vptr += vstride0; - } - else - { - /* From field. */ - *rptr = fval; - } - /* Advance to the next element. */ - rptr += rstride0; - 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]; - mptr -= mstride[n] * extent[n]; - n++; - if (n >= dim) - { - /* Break out of the loop. */ - rptr = NULL; - break; - } - else - { - count[n]++; - rptr += rstride[n]; - mptr += mstride[n]; - } - } - } -} - -void -unpack1_'rtype_code` ('rtype` *ret, const 'rtype` *vector, - const gfc_array_l1 *mask, const 'rtype` *field) -{ - /* r.* indicates the return array. */ - index_type rstride[GFC_MAX_DIMENSIONS]; - index_type rstride0; - index_type rs; - 'rtype_name` * restrict rptr; - /* v.* indicates the vector array. */ - index_type vstride0; - 'rtype_name` *vptr; - /* f.* indicates the field array. */ - index_type fstride[GFC_MAX_DIMENSIONS]; - index_type fstride0; - const 'rtype_name` *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 - ) - { - /* Do not convert a NULL pointer as we use test for NULL below. */ - if (mptr) - mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind); - } - else - runtime_error ("Funny sized logical array"); - - if (ret->data == NULL) - { - /* The front end has signalled that we need to populate the - return array descriptor. */ - dim = GFC_DESCRIPTOR_RANK (mask); - rs = 1; - for (n = 0; n < dim; n++) - { - count[n] = 0; - ret->dim[n].stride = rs; - ret->dim[n].lbound = 0; - ret->dim[n].ubound = mask->dim[n].ubound - mask->dim[n].lbound; - extent[n] = ret->dim[n].ubound + 1; - empty = empty || extent[n] <= 0; - rstride[n] = ret->dim[n].stride; - fstride[n] = field->dim[n].stride; - mstride[n] = mask->dim[n].stride * mask_kind; - rs *= extent[n]; - } - ret->offset = 0; - ret->data = internal_malloc_size (rs * sizeof ('rtype_name`)); - } - else - { - dim = GFC_DESCRIPTOR_RANK (ret); - for (n = 0; n < dim; n++) - { - count[n] = 0; - extent[n] = ret->dim[n].ubound + 1 - ret->dim[n].lbound; - empty = empty || extent[n] <= 0; - rstride[n] = ret->dim[n].stride; - fstride[n] = field->dim[n].stride; - mstride[n] = mask->dim[n].stride * mask_kind; - } - if (rstride[0] == 0) - rstride[0] = 1; - } - - if (empty) - return; - - if (fstride[0] == 0) - fstride[0] = 1; - if (mstride[0] == 0) - mstride[0] = 1; - - vstride0 = vector->dim[0].stride; - if (vstride0 == 0) - vstride0 = 1; - rstride0 = rstride[0]; - fstride0 = fstride[0]; - mstride0 = mstride[0]; - rptr = ret->data; - fptr = field->data; - vptr = vector->data; - - while (rptr) - { - if (*mptr) - { - /* From vector. */ - *rptr = *vptr; - vptr += vstride0; - } - else - { - /* From field. */ - *rptr = *fptr; - } - /* 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]; - } - } - } -} - -#endif -' |