libgfortran.h (gfc_char4_t): New type.
2008-05-14 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> * libgfortran.h (gfc_char4_t): New type. (GFC_SIZE_OF_CHAR_KIND): New macro. (compare_string): Adjust prototype. (compare_string_char4): New prototype. * gfortran.map (GFORTRAN_1.1): Add _gfortran_adjustl_char4, _gfortran_adjustr_char4, _gfortran_compare_string_char4, _gfortran_concat_string_char4, _gfortran_string_index_char4, _gfortran_string_len_trim_char4, _gfortran_string_minmax_char4, _gfortran_string_scan_char4, _gfortran_string_trim_char4 and _gfortran_string_verify_char4. * intrinsics/string_intrinsics_inc.c: New file from content of string_intrinsics.c with types replaced by macros. * intrinsics/string_intrinsics.c: Move content to string_intrinsics_inc.c. From-SVN: r135313
This commit is contained in:
Francois-Xavier Coudert
François-Xavier Coudert
parent
c5fcd67041
commit
4b267817ff
|
|
@ -1,3 +1,20 @@
|
|||
2008-05-14 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
|
||||
|
||||
* libgfortran.h (gfc_char4_t): New type.
|
||||
(GFC_SIZE_OF_CHAR_KIND): New macro.
|
||||
(compare_string): Adjust prototype.
|
||||
(compare_string_char4): New prototype.
|
||||
* gfortran.map (GFORTRAN_1.1): Add _gfortran_adjustl_char4,
|
||||
_gfortran_adjustr_char4, _gfortran_compare_string_char4,
|
||||
_gfortran_concat_string_char4, _gfortran_string_index_char4,
|
||||
_gfortran_string_len_trim_char4, _gfortran_string_minmax_char4,
|
||||
_gfortran_string_scan_char4, _gfortran_string_trim_char4 and
|
||||
_gfortran_string_verify_char4.
|
||||
* intrinsics/string_intrinsics_inc.c: New file from content of
|
||||
string_intrinsics.c with types replaced by macros.
|
||||
* intrinsics/string_intrinsics.c: Move content to
|
||||
string_intrinsics_inc.c.
|
||||
|
||||
2008-05-11 Jerry DeLisle <jvdelisle@gcc.gnu.org>
|
||||
|
||||
PR libfortran/36202
|
||||
|
|
|
|||
|
|
@ -1039,6 +1039,16 @@ GFORTRAN_1.1 {
|
|||
_gfortran_erfc_scaled_r16;
|
||||
_gfortran_selected_char_kind;
|
||||
_gfortran_st_wait;
|
||||
_gfortran_adjustl_char4;
|
||||
_gfortran_adjustr_char4;
|
||||
_gfortran_compare_string_char4;
|
||||
_gfortran_concat_string_char4;
|
||||
_gfortran_string_index_char4;
|
||||
_gfortran_string_len_trim_char4;
|
||||
_gfortran_string_minmax_char4;
|
||||
_gfortran_string_scan_char4;
|
||||
_gfortran_string_trim_char4;
|
||||
_gfortran_string_verify_char4;
|
||||
} GFORTRAN_1.0;
|
||||
|
||||
F2C_1.0 {
|
||||
|
|
|
|||
|
|
@ -1,8 +1,7 @@
|
|||
/* String intrinsics helper functions.
|
||||
Copyright 2002, 2005, 2007 Free Software Foundation, Inc.
|
||||
Contributed by Paul Brook <paul@nowt.org>
|
||||
Copyright 2008 Free Software Foundation, Inc.
|
||||
|
||||
This file is part of the GNU Fortran 95 runtime library (libgfortran).
|
||||
This file is part of the GNU Fortran runtime library (libgfortran).
|
||||
|
||||
Libgfortran is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU General Public
|
||||
|
|
@ -42,378 +41,45 @@ Boston, MA 02110-1301, USA. */
|
|||
#include <string.h>
|
||||
|
||||
|
||||
/* String functions. */
|
||||
/* Helper function to set parts of wide strings to a constant (usually
|
||||
spaces). */
|
||||
|
||||
extern void concat_string (GFC_INTEGER_4, char *,
|
||||
GFC_INTEGER_4, const char *,
|
||||
GFC_INTEGER_4, const char *);
|
||||
export_proto(concat_string);
|
||||
|
||||
extern GFC_INTEGER_4 string_len_trim (GFC_INTEGER_4, const char *);
|
||||
export_proto(string_len_trim);
|
||||
|
||||
extern void adjustl (char *, GFC_INTEGER_4, const char *);
|
||||
export_proto(adjustl);
|
||||
|
||||
extern void adjustr (char *, GFC_INTEGER_4, const char *);
|
||||
export_proto(adjustr);
|
||||
|
||||
extern GFC_INTEGER_4 string_index (GFC_INTEGER_4, const char *, GFC_INTEGER_4,
|
||||
const char *, GFC_LOGICAL_4);
|
||||
export_proto(string_index);
|
||||
|
||||
extern GFC_INTEGER_4 string_scan (GFC_INTEGER_4, const char *, GFC_INTEGER_4,
|
||||
const char *, GFC_LOGICAL_4);
|
||||
export_proto(string_scan);
|
||||
|
||||
extern GFC_INTEGER_4 string_verify (GFC_INTEGER_4, const char *, GFC_INTEGER_4,
|
||||
const char *, GFC_LOGICAL_4);
|
||||
export_proto(string_verify);
|
||||
|
||||
extern void string_trim (GFC_INTEGER_4 *, void **, GFC_INTEGER_4, const char *);
|
||||
export_proto(string_trim);
|
||||
|
||||
extern void string_minmax (GFC_INTEGER_4 *, void **, int, int, ...);
|
||||
export_proto(string_minmax);
|
||||
|
||||
|
||||
/* Use for functions which can return a zero-length string. */
|
||||
static char zero_length_string = '\0';
|
||||
|
||||
|
||||
/* Strings of unequal length are extended with pad characters. */
|
||||
|
||||
int
|
||||
compare_string (GFC_INTEGER_4 len1, const char * s1,
|
||||
GFC_INTEGER_4 len2, const char * s2)
|
||||
static gfc_char4_t *
|
||||
memset_char4 (gfc_char4_t *b, gfc_char4_t c, size_t len)
|
||||
{
|
||||
int res;
|
||||
const unsigned char *s;
|
||||
int len;
|
||||
size_t i;
|
||||
|
||||
res = memcmp (s1, s2, (len1 < len2) ? len1 : len2);
|
||||
if (res != 0)
|
||||
return res;
|
||||
for (i = 0; i < len; i++)
|
||||
b[i] = c;
|
||||
|
||||
if (len1 == len2)
|
||||
return 0;
|
||||
|
||||
if (len1 < len2)
|
||||
{
|
||||
len = len2 - len1;
|
||||
s = (unsigned char *) &s2[len1];
|
||||
res = -1;
|
||||
}
|
||||
else
|
||||
{
|
||||
len = len1 - len2;
|
||||
s = (unsigned char *) &s1[len2];
|
||||
res = 1;
|
||||
}
|
||||
|
||||
while (len--)
|
||||
{
|
||||
if (*s != ' ')
|
||||
{
|
||||
if (*s > ' ')
|
||||
return res;
|
||||
else
|
||||
return -res;
|
||||
}
|
||||
s++;
|
||||
}
|
||||
|
||||
return 0;
|
||||
}
|
||||
iexport(compare_string);
|
||||
|
||||
|
||||
/* The destination and source should not overlap. */
|
||||
|
||||
void
|
||||
concat_string (GFC_INTEGER_4 destlen, char * dest,
|
||||
GFC_INTEGER_4 len1, const char * s1,
|
||||
GFC_INTEGER_4 len2, const char * s2)
|
||||
{
|
||||
if (len1 >= destlen)
|
||||
{
|
||||
memcpy (dest, s1, destlen);
|
||||
return;
|
||||
}
|
||||
memcpy (dest, s1, len1);
|
||||
dest += len1;
|
||||
destlen -= len1;
|
||||
|
||||
if (len2 >= destlen)
|
||||
{
|
||||
memcpy (dest, s2, destlen);
|
||||
return;
|
||||
}
|
||||
|
||||
memcpy (dest, s2, len2);
|
||||
memset (&dest[len2], ' ', destlen - len2);
|
||||
return b;
|
||||
}
|
||||
|
||||
|
||||
/* Return string with all trailing blanks removed. */
|
||||
/* All other functions are defined using a few generic macros in
|
||||
string_intrinsics_inc.c, so we avoid code duplication between the
|
||||
various character type kinds. */
|
||||
|
||||
void
|
||||
string_trim (GFC_INTEGER_4 * len, void ** dest, GFC_INTEGER_4 slen,
|
||||
const char * src)
|
||||
{
|
||||
int i;
|
||||
#undef CHARTYPE
|
||||
#define CHARTYPE char
|
||||
#undef UCHARTYPE
|
||||
#define UCHARTYPE unsigned char
|
||||
#undef SUFFIX
|
||||
#define SUFFIX(x) x
|
||||
#undef MEMSET
|
||||
#define MEMSET memset
|
||||
|
||||
/* Determine length of result string. */
|
||||
for (i = slen - 1; i >= 0; i--)
|
||||
{
|
||||
if (src[i] != ' ')
|
||||
break;
|
||||
}
|
||||
*len = i + 1;
|
||||
|
||||
if (*len == 0)
|
||||
*dest = &zero_length_string;
|
||||
else
|
||||
{
|
||||
/* Allocate space for result string. */
|
||||
*dest = internal_malloc_size (*len);
|
||||
|
||||
/* Copy string if necessary. */
|
||||
memmove (*dest, src, *len);
|
||||
}
|
||||
}
|
||||
#include "string_intrinsics_inc.c"
|
||||
|
||||
|
||||
/* The length of a string not including trailing blanks. */
|
||||
#undef CHARTYPE
|
||||
#define CHARTYPE gfc_char4_t
|
||||
#undef UCHARTYPE
|
||||
#define UCHARTYPE gfc_char4_t
|
||||
#undef SUFFIX
|
||||
#define SUFFIX(x) x ## _char4
|
||||
#undef MEMSET
|
||||
#define MEMSET memset_char4
|
||||
|
||||
GFC_INTEGER_4
|
||||
string_len_trim (GFC_INTEGER_4 len, const char * s)
|
||||
{
|
||||
int i;
|
||||
#include "string_intrinsics_inc.c"
|
||||
|
||||
for (i = len - 1; i >= 0; i--)
|
||||
{
|
||||
if (s[i] != ' ')
|
||||
break;
|
||||
}
|
||||
return i + 1;
|
||||
}
|
||||
|
||||
|
||||
/* Find a substring within a string. */
|
||||
|
||||
GFC_INTEGER_4
|
||||
string_index (GFC_INTEGER_4 slen, const char * str, GFC_INTEGER_4 sslen,
|
||||
const char * sstr, GFC_LOGICAL_4 back)
|
||||
{
|
||||
int start;
|
||||
int last;
|
||||
int i;
|
||||
int delta;
|
||||
|
||||
if (sslen == 0)
|
||||
return 1;
|
||||
|
||||
if (sslen > slen)
|
||||
return 0;
|
||||
|
||||
if (!back)
|
||||
{
|
||||
last = slen + 1 - sslen;
|
||||
start = 0;
|
||||
delta = 1;
|
||||
}
|
||||
else
|
||||
{
|
||||
last = -1;
|
||||
start = slen - sslen;
|
||||
delta = -1;
|
||||
}
|
||||
i = 0;
|
||||
for (; start != last; start+= delta)
|
||||
{
|
||||
for (i = 0; i < sslen; i++)
|
||||
{
|
||||
if (str[start + i] != sstr[i])
|
||||
break;
|
||||
}
|
||||
if (i == sslen)
|
||||
return (start + 1);
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
|
||||
|
||||
/* Remove leading blanks from a string, padding at end. The src and dest
|
||||
should not overlap. */
|
||||
|
||||
void
|
||||
adjustl (char *dest, GFC_INTEGER_4 len, const char *src)
|
||||
{
|
||||
int i;
|
||||
|
||||
i = 0;
|
||||
while (i<len && src[i] == ' ')
|
||||
i++;
|
||||
|
||||
if (i < len)
|
||||
memcpy (dest, &src[i], len - i);
|
||||
if (i > 0)
|
||||
memset (&dest[len - i], ' ', i);
|
||||
}
|
||||
|
||||
|
||||
/* Remove trailing blanks from a string. */
|
||||
|
||||
void
|
||||
adjustr (char *dest, GFC_INTEGER_4 len, const char *src)
|
||||
{
|
||||
int i;
|
||||
|
||||
i = len;
|
||||
while (i > 0 && src[i - 1] == ' ')
|
||||
i--;
|
||||
|
||||
if (i < len)
|
||||
memset (dest, ' ', len - i);
|
||||
memcpy (dest + (len - i), src, i );
|
||||
}
|
||||
|
||||
|
||||
/* Scan a string for any one of the characters in a set of characters. */
|
||||
|
||||
GFC_INTEGER_4
|
||||
string_scan (GFC_INTEGER_4 slen, const char * str, GFC_INTEGER_4 setlen,
|
||||
const char * set, GFC_LOGICAL_4 back)
|
||||
{
|
||||
int i, j;
|
||||
|
||||
if (slen == 0 || setlen == 0)
|
||||
return 0;
|
||||
|
||||
if (back)
|
||||
{
|
||||
for (i = slen - 1; i >= 0; i--)
|
||||
{
|
||||
for (j = 0; j < setlen; j++)
|
||||
{
|
||||
if (str[i] == set[j])
|
||||
return (i + 1);
|
||||
}
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
for (i = 0; i < slen; i++)
|
||||
{
|
||||
for (j = 0; j < setlen; j++)
|
||||
{
|
||||
if (str[i] == set[j])
|
||||
return (i + 1);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
||||
|
||||
/* Verify that a set of characters contains all the characters in a
|
||||
string by identifying the position of the first character in a
|
||||
characters that does not appear in a given set of characters. */
|
||||
|
||||
GFC_INTEGER_4
|
||||
string_verify (GFC_INTEGER_4 slen, const char * str, GFC_INTEGER_4 setlen,
|
||||
const char * set, GFC_LOGICAL_4 back)
|
||||
{
|
||||
int start;
|
||||
int last;
|
||||
int i;
|
||||
int delta;
|
||||
|
||||
if (slen == 0)
|
||||
return 0;
|
||||
|
||||
if (back)
|
||||
{
|
||||
last = -1;
|
||||
start = slen - 1;
|
||||
delta = -1;
|
||||
}
|
||||
else
|
||||
{
|
||||
last = slen;
|
||||
start = 0;
|
||||
delta = 1;
|
||||
}
|
||||
for (; start != last; start += delta)
|
||||
{
|
||||
for (i = 0; i < setlen; i++)
|
||||
{
|
||||
if (str[start] == set[i])
|
||||
break;
|
||||
}
|
||||
if (i == setlen)
|
||||
return (start + 1);
|
||||
}
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
||||
|
||||
/* MIN and MAX intrinsics for strings. The front-end makes sure that
|
||||
nargs is at least 2. */
|
||||
|
||||
void
|
||||
string_minmax (GFC_INTEGER_4 *rlen, void **dest, int op, int nargs, ...)
|
||||
{
|
||||
va_list ap;
|
||||
int i;
|
||||
char * next, * res;
|
||||
GFC_INTEGER_4 nextlen, reslen;
|
||||
|
||||
va_start (ap, nargs);
|
||||
reslen = va_arg (ap, GFC_INTEGER_4);
|
||||
res = va_arg (ap, char *);
|
||||
*rlen = reslen;
|
||||
|
||||
if (res == NULL)
|
||||
runtime_error ("First argument of '%s' intrinsic should be present",
|
||||
op > 0 ? "MAX" : "MIN");
|
||||
|
||||
for (i = 1; i < nargs; i++)
|
||||
{
|
||||
nextlen = va_arg (ap, GFC_INTEGER_4);
|
||||
next = va_arg (ap, char *);
|
||||
|
||||
|
||||
if (next == NULL)
|
||||
{
|
||||
if (i == 1)
|
||||
runtime_error ("Second argument of '%s' intrinsic should be "
|
||||
"present", op > 0 ? "MAX" : "MIN");
|
||||
else
|
||||
continue;
|
||||
}
|
||||
|
||||
if (nextlen > *rlen)
|
||||
*rlen = nextlen;
|
||||
|
||||
if (op * compare_string (reslen, res, nextlen, next) < 0)
|
||||
{
|
||||
reslen = nextlen;
|
||||
res = next;
|
||||
}
|
||||
}
|
||||
va_end (ap);
|
||||
|
||||
if (*rlen == 0)
|
||||
*dest = &zero_length_string;
|
||||
else
|
||||
{
|
||||
char * tmp = internal_malloc_size (*rlen);
|
||||
memcpy (tmp, res, reslen);
|
||||
memset (&tmp[reslen], ' ', *rlen - reslen);
|
||||
*dest = tmp;
|
||||
}
|
||||
}
|
||||
|
|
|
|||
|
|
@ -0,0 +1,418 @@
|
|||
/* String intrinsics helper functions.
|
||||
Copyright 2002, 2005, 2007, 2008 Free Software Foundation, Inc.
|
||||
|
||||
This file is part of the GNU Fortran runtime library (libgfortran).
|
||||
|
||||
Libgfortran is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU General Public
|
||||
License as published by the Free Software Foundation; either
|
||||
version 2 of the License, or (at your option) any later version.
|
||||
|
||||
In addition to the permissions in the GNU General Public License, the
|
||||
Free Software Foundation gives you unlimited permission to link the
|
||||
compiled version of this file into combinations with other programs,
|
||||
and to distribute those combinations without any restriction coming
|
||||
from the use of this file. (The General Public License restrictions
|
||||
do apply in other respects; for example, they cover modification of
|
||||
the file, and distribution when not linked into a combine
|
||||
executable.)
|
||||
|
||||
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.
|
||||
|
||||
You should have received a copy of the GNU General Public
|
||||
License along with libgfortran; see the file COPYING. If not,
|
||||
write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
|
||||
Boston, MA 02110-1301, USA. */
|
||||
|
||||
|
||||
/* Rename the functions. */
|
||||
#define concat_string SUFFIX(concat_string)
|
||||
#define string_len_trim SUFFIX(string_len_trim)
|
||||
#define adjustl SUFFIX(adjustl)
|
||||
#define adjustr SUFFIX(adjustr)
|
||||
#define string_index SUFFIX(string_index)
|
||||
#define string_scan SUFFIX(string_scan)
|
||||
#define string_verify SUFFIX(string_verify)
|
||||
#define string_trim SUFFIX(string_trim)
|
||||
#define string_minmax SUFFIX(string_minmax)
|
||||
#define zero_length_string SUFFIX(zero_length_string)
|
||||
#define compare_string SUFFIX(compare_string)
|
||||
|
||||
|
||||
/* The prototypes. */
|
||||
|
||||
extern void concat_string (gfc_charlen_type, CHARTYPE *,
|
||||
gfc_charlen_type, const CHARTYPE *,
|
||||
gfc_charlen_type, const CHARTYPE *);
|
||||
export_proto(concat_string);
|
||||
|
||||
extern gfc_charlen_type string_len_trim (gfc_charlen_type, const CHARTYPE *);
|
||||
export_proto(string_len_trim);
|
||||
|
||||
extern void adjustl (CHARTYPE *, gfc_charlen_type, const CHARTYPE *);
|
||||
export_proto(adjustl);
|
||||
|
||||
extern void adjustr (CHARTYPE *, gfc_charlen_type, const CHARTYPE *);
|
||||
export_proto(adjustr);
|
||||
|
||||
extern gfc_charlen_type string_index (gfc_charlen_type, const CHARTYPE *,
|
||||
gfc_charlen_type, const CHARTYPE *,
|
||||
GFC_LOGICAL_4);
|
||||
export_proto(string_index);
|
||||
|
||||
extern gfc_charlen_type string_scan (gfc_charlen_type, const CHARTYPE *,
|
||||
gfc_charlen_type, const CHARTYPE *,
|
||||
GFC_LOGICAL_4);
|
||||
export_proto(string_scan);
|
||||
|
||||
extern gfc_charlen_type string_verify (gfc_charlen_type, const CHARTYPE *,
|
||||
gfc_charlen_type, const CHARTYPE *,
|
||||
GFC_LOGICAL_4);
|
||||
export_proto(string_verify);
|
||||
|
||||
extern void string_trim (gfc_charlen_type *, CHARTYPE **, gfc_charlen_type,
|
||||
const CHARTYPE *);
|
||||
export_proto(string_trim);
|
||||
|
||||
extern void string_minmax (gfc_charlen_type *, CHARTYPE **, int, int, ...);
|
||||
export_proto(string_minmax);
|
||||
|
||||
|
||||
/* Use for functions which can return a zero-length string. */
|
||||
static CHARTYPE zero_length_string = 0;
|
||||
|
||||
|
||||
/* Strings of unequal length are extended with pad characters. */
|
||||
|
||||
int
|
||||
compare_string (gfc_charlen_type len1, const CHARTYPE *s1,
|
||||
gfc_charlen_type len2, const CHARTYPE *s2)
|
||||
{
|
||||
const UCHARTYPE *s;
|
||||
gfc_charlen_type len;
|
||||
int res;
|
||||
|
||||
res = memcmp (s1, s2, ((len1 < len2) ? len1 : len2) * sizeof (CHARTYPE));
|
||||
if (res != 0)
|
||||
return res;
|
||||
|
||||
if (len1 == len2)
|
||||
return 0;
|
||||
|
||||
if (len1 < len2)
|
||||
{
|
||||
len = len2 - len1;
|
||||
s = (UCHARTYPE *) &s2[len1];
|
||||
res = -1;
|
||||
}
|
||||
else
|
||||
{
|
||||
len = len1 - len2;
|
||||
s = (UCHARTYPE *) &s1[len2];
|
||||
res = 1;
|
||||
}
|
||||
|
||||
while (len--)
|
||||
{
|
||||
if (*s != ' ')
|
||||
{
|
||||
if (*s > ' ')
|
||||
return res;
|
||||
else
|
||||
return -res;
|
||||
}
|
||||
s++;
|
||||
}
|
||||
|
||||
return 0;
|
||||
}
|
||||
iexport(compare_string);
|
||||
|
||||
|
||||
/* The destination and source should not overlap. */
|
||||
|
||||
void
|
||||
concat_string (gfc_charlen_type destlen, CHARTYPE * dest,
|
||||
gfc_charlen_type len1, const CHARTYPE * s1,
|
||||
gfc_charlen_type len2, const CHARTYPE * s2)
|
||||
{
|
||||
if (len1 >= destlen)
|
||||
{
|
||||
memcpy (dest, s1, destlen * sizeof (CHARTYPE));
|
||||
return;
|
||||
}
|
||||
memcpy (dest, s1, len1 * sizeof (CHARTYPE));
|
||||
dest += len1;
|
||||
destlen -= len1;
|
||||
|
||||
if (len2 >= destlen)
|
||||
{
|
||||
memcpy (dest, s2, destlen * sizeof (CHARTYPE));
|
||||
return;
|
||||
}
|
||||
|
||||
memcpy (dest, s2, len2 * sizeof (CHARTYPE));
|
||||
MEMSET (&dest[len2], ' ', destlen - len2);
|
||||
}
|
||||
|
||||
|
||||
/* Return string with all trailing blanks removed. */
|
||||
|
||||
void
|
||||
string_trim (gfc_charlen_type *len, CHARTYPE **dest, gfc_charlen_type slen,
|
||||
const CHARTYPE *src)
|
||||
{
|
||||
gfc_charlen_type i;
|
||||
|
||||
/* Determine length of result string. */
|
||||
for (i = slen - 1; i >= 0; i--)
|
||||
{
|
||||
if (src[i] != ' ')
|
||||
break;
|
||||
}
|
||||
*len = i + 1;
|
||||
|
||||
if (*len == 0)
|
||||
*dest = &zero_length_string;
|
||||
else
|
||||
{
|
||||
/* Allocate space for result string. */
|
||||
*dest = internal_malloc_size (*len * sizeof (CHARTYPE));
|
||||
|
||||
/* Copy string if necessary. */
|
||||
memcpy (*dest, src, *len * sizeof (CHARTYPE));
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
/* The length of a string not including trailing blanks. */
|
||||
|
||||
gfc_charlen_type
|
||||
string_len_trim (gfc_charlen_type len, const CHARTYPE *s)
|
||||
{
|
||||
gfc_charlen_type i;
|
||||
|
||||
for (i = len - 1; i >= 0; i--)
|
||||
{
|
||||
if (s[i] != ' ')
|
||||
break;
|
||||
}
|
||||
return i + 1;
|
||||
}
|
||||
|
||||
|
||||
/* Find a substring within a string. */
|
||||
|
||||
gfc_charlen_type
|
||||
string_index (gfc_charlen_type slen, const CHARTYPE *str,
|
||||
gfc_charlen_type sslen, const CHARTYPE *sstr,
|
||||
GFC_LOGICAL_4 back)
|
||||
{
|
||||
gfc_charlen_type start, last, delta, i;
|
||||
|
||||
if (sslen == 0)
|
||||
return 1;
|
||||
|
||||
if (sslen > slen)
|
||||
return 0;
|
||||
|
||||
if (!back)
|
||||
{
|
||||
last = slen + 1 - sslen;
|
||||
start = 0;
|
||||
delta = 1;
|
||||
}
|
||||
else
|
||||
{
|
||||
last = -1;
|
||||
start = slen - sslen;
|
||||
delta = -1;
|
||||
}
|
||||
|
||||
for (; start != last; start+= delta)
|
||||
{
|
||||
for (i = 0; i < sslen; i++)
|
||||
{
|
||||
if (str[start + i] != sstr[i])
|
||||
break;
|
||||
}
|
||||
if (i == sslen)
|
||||
return (start + 1);
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
|
||||
|
||||
/* Remove leading blanks from a string, padding at end. The src and dest
|
||||
should not overlap. */
|
||||
|
||||
void
|
||||
adjustl (CHARTYPE *dest, gfc_charlen_type len, const CHARTYPE *src)
|
||||
{
|
||||
gfc_charlen_type i;
|
||||
|
||||
i = 0;
|
||||
while (i < len && src[i] == ' ')
|
||||
i++;
|
||||
|
||||
if (i < len)
|
||||
memcpy (dest, &src[i], (len - i) * sizeof (CHARTYPE));
|
||||
if (i > 0)
|
||||
MEMSET (&dest[len - i], ' ', i);
|
||||
}
|
||||
|
||||
|
||||
/* Remove trailing blanks from a string. */
|
||||
|
||||
void
|
||||
adjustr (CHARTYPE *dest, gfc_charlen_type len, const CHARTYPE *src)
|
||||
{
|
||||
gfc_charlen_type i;
|
||||
|
||||
i = len;
|
||||
while (i > 0 && src[i - 1] == ' ')
|
||||
i--;
|
||||
|
||||
if (i < len)
|
||||
MEMSET (dest, ' ', len - i);
|
||||
memcpy (&dest[len - i], src, i * sizeof (CHARTYPE));
|
||||
}
|
||||
|
||||
|
||||
/* Scan a string for any one of the characters in a set of characters. */
|
||||
|
||||
gfc_charlen_type
|
||||
string_scan (gfc_charlen_type slen, const CHARTYPE *str,
|
||||
gfc_charlen_type setlen, const CHARTYPE *set, GFC_LOGICAL_4 back)
|
||||
{
|
||||
gfc_charlen_type i, j;
|
||||
|
||||
if (slen == 0 || setlen == 0)
|
||||
return 0;
|
||||
|
||||
if (back)
|
||||
{
|
||||
for (i = slen - 1; i >= 0; i--)
|
||||
{
|
||||
for (j = 0; j < setlen; j++)
|
||||
{
|
||||
if (str[i] == set[j])
|
||||
return (i + 1);
|
||||
}
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
for (i = 0; i < slen; i++)
|
||||
{
|
||||
for (j = 0; j < setlen; j++)
|
||||
{
|
||||
if (str[i] == set[j])
|
||||
return (i + 1);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
||||
|
||||
/* Verify that a set of characters contains all the characters in a
|
||||
string by identifying the position of the first character in a
|
||||
characters that does not appear in a given set of characters. */
|
||||
|
||||
gfc_charlen_type
|
||||
string_verify (gfc_charlen_type slen, const CHARTYPE *str,
|
||||
gfc_charlen_type setlen, const CHARTYPE *set,
|
||||
GFC_LOGICAL_4 back)
|
||||
{
|
||||
gfc_charlen_type start, last, delta, i;
|
||||
|
||||
if (slen == 0)
|
||||
return 0;
|
||||
|
||||
if (back)
|
||||
{
|
||||
last = -1;
|
||||
start = slen - 1;
|
||||
delta = -1;
|
||||
}
|
||||
else
|
||||
{
|
||||
last = slen;
|
||||
start = 0;
|
||||
delta = 1;
|
||||
}
|
||||
for (; start != last; start += delta)
|
||||
{
|
||||
for (i = 0; i < setlen; i++)
|
||||
{
|
||||
if (str[start] == set[i])
|
||||
break;
|
||||
}
|
||||
if (i == setlen)
|
||||
return (start + 1);
|
||||
}
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
||||
|
||||
/* MIN and MAX intrinsics for strings. The front-end makes sure that
|
||||
nargs is at least 2. */
|
||||
|
||||
void
|
||||
string_minmax (gfc_charlen_type *rlen, CHARTYPE **dest, int op, int nargs, ...)
|
||||
{
|
||||
va_list ap;
|
||||
int i;
|
||||
CHARTYPE *next, *res;
|
||||
gfc_charlen_type nextlen, reslen;
|
||||
|
||||
va_start (ap, nargs);
|
||||
reslen = va_arg (ap, gfc_charlen_type);
|
||||
res = va_arg (ap, CHARTYPE *);
|
||||
*rlen = reslen;
|
||||
|
||||
if (res == NULL)
|
||||
runtime_error ("First argument of '%s' intrinsic should be present",
|
||||
op > 0 ? "MAX" : "MIN");
|
||||
|
||||
for (i = 1; i < nargs; i++)
|
||||
{
|
||||
nextlen = va_arg (ap, gfc_charlen_type);
|
||||
next = va_arg (ap, CHARTYPE *);
|
||||
|
||||
if (next == NULL)
|
||||
{
|
||||
if (i == 1)
|
||||
runtime_error ("Second argument of '%s' intrinsic should be "
|
||||
"present", op > 0 ? "MAX" : "MIN");
|
||||
else
|
||||
continue;
|
||||
}
|
||||
|
||||
if (nextlen > *rlen)
|
||||
*rlen = nextlen;
|
||||
|
||||
if (op * compare_string (reslen, res, nextlen, next) < 0)
|
||||
{
|
||||
reslen = nextlen;
|
||||
res = next;
|
||||
}
|
||||
}
|
||||
va_end (ap);
|
||||
|
||||
if (*rlen == 0)
|
||||
*dest = &zero_length_string;
|
||||
else
|
||||
{
|
||||
CHARTYPE *tmp = internal_malloc_size (*rlen * sizeof (CHARTYPE));
|
||||
memcpy (tmp, res, reslen * sizeof (CHARTYPE));
|
||||
MEMSET (&tmp[reslen], ' ', *rlen - reslen);
|
||||
*dest = tmp;
|
||||
}
|
||||
}
|
||||
|
|
@ -259,9 +259,20 @@ typedef GFC_INTEGER_4 GFC_IO_INT;
|
|||
by the compiler. */
|
||||
/* The type used of array indices, amongst other things. */
|
||||
typedef ssize_t index_type;
|
||||
|
||||
/* The type used for the lengths of character variables. */
|
||||
typedef GFC_INTEGER_4 gfc_charlen_type;
|
||||
|
||||
/* Definitions of CHARACTER data types:
|
||||
- CHARACTER(KIND=1) corresponds to the C char type,
|
||||
- CHARACTER(KIND=4) corresponds to an unsigned 32-bit integer. */
|
||||
typedef GFC_UINTEGER_4 gfc_char4_t;
|
||||
|
||||
/* Byte size of character kinds. For the kinds currently supported, it's
|
||||
simply equal to the kind parameter itself. */
|
||||
#define GFC_SIZE_OF_CHAR_KIND(kind) (kind)
|
||||
|
||||
|
||||
/* This will be 0 on little-endian machines and one on big-endian machines. */
|
||||
extern int l8_to_l4_offset;
|
||||
internal_proto(l8_to_l4_offset);
|
||||
|
|
@ -1172,10 +1183,14 @@ internal_proto(spread_scalar_c16);
|
|||
|
||||
/* string_intrinsics.c */
|
||||
|
||||
extern int compare_string (GFC_INTEGER_4, const char *,
|
||||
GFC_INTEGER_4, const char *);
|
||||
extern int compare_string (gfc_charlen_type, const char *,
|
||||
gfc_charlen_type, const char *);
|
||||
iexport_proto(compare_string);
|
||||
|
||||
extern int compare_string_char4 (gfc_charlen_type, const gfc_char4_t *,
|
||||
gfc_charlen_type, const gfc_char4_t *);
|
||||
iexport_proto(compare_string_char4);
|
||||
|
||||
/* random.c */
|
||||
|
||||
extern void random_seed_i4 (GFC_INTEGER_4 * size, gfc_array_i4 * put,
|
||||
|
|
|
|||
Loading…
Reference in New Issue