[thirdparty/gcc.git] / libgfortran / intrinsics / string_intrinsics_inc.c

/* String intrinsics helper functions.
   Copyright (C) 2002-2016 Free Software Foundation, Inc.

This file is part of the GNU Fortran runtime library (libgfortran).

Libgfortran is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.

Libgfortran is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

Under Section 7 of GPL version 3, you are granted additional
permissions described in the GCC Runtime Library Exception, version
3.1, as published by the Free Software Foundation.

You should have received a copy of the GNU General Public License and
a copy of the GCC Runtime Library Exception along with this program;
see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
<http://www.gnu.org/licenses/>.  */


/* Rename the functions.  */
#define concat_string SUFFIX(concat_string)
#define string_len_trim SUFFIX(string_len_trim)
#define adjustl SUFFIX(adjustl)
#define adjustr SUFFIX(adjustr)
#define string_index SUFFIX(string_index)
#define string_scan SUFFIX(string_scan)
#define string_verify SUFFIX(string_verify)
#define string_trim SUFFIX(string_trim)
#define string_minmax SUFFIX(string_minmax)
#define zero_length_string SUFFIX(zero_length_string)
#define compare_string SUFFIX(compare_string)


/* The prototypes.  */

extern void concat_string (gfc_charlen_type, CHARTYPE *,
			   gfc_charlen_type, const CHARTYPE *,
			   gfc_charlen_type, const CHARTYPE *);
export_proto(concat_string);

extern void adjustl (CHARTYPE *, gfc_charlen_type, const CHARTYPE *);
export_proto(adjustl);

extern void adjustr (CHARTYPE *, gfc_charlen_type, const CHARTYPE *);
export_proto(adjustr);

extern gfc_charlen_type string_index (gfc_charlen_type, const CHARTYPE *,
				      gfc_charlen_type, const CHARTYPE *,
				      GFC_LOGICAL_4);
export_proto(string_index);

extern gfc_charlen_type string_scan (gfc_charlen_type, const CHARTYPE *,
				     gfc_charlen_type, const CHARTYPE *,
				     GFC_LOGICAL_4);
export_proto(string_scan);

extern gfc_charlen_type string_verify (gfc_charlen_type, const CHARTYPE *,
				       gfc_charlen_type, const CHARTYPE *,
				       GFC_LOGICAL_4);
export_proto(string_verify);

extern void string_trim (gfc_charlen_type *, CHARTYPE **, gfc_charlen_type,
			 const CHARTYPE *);
export_proto(string_trim);

extern void string_minmax (gfc_charlen_type *, CHARTYPE **, int, int, ...);
export_proto(string_minmax);


/* Use for functions which can return a zero-length string.  */
static CHARTYPE zero_length_string = 0;


/* Strings of unequal length are extended with pad characters.  */

int
compare_string (gfc_charlen_type len1, const CHARTYPE *s1,
		gfc_charlen_type len2, const CHARTYPE *s2)
{
  const UCHARTYPE *s;
  gfc_charlen_type len;
  int res;

  res = MEMCMP (s1, s2, ((len1 < len2) ? len1 : len2));
  if (res != 0)
    return res;

  if (len1 == len2)
    return 0;

  if (len1 < len2)
    {
      len = len2 - len1;
      s = (UCHARTYPE *) &s2[len1];
      res = -1;
    }
  else
    {
      len = len1 - len2;
      s = (UCHARTYPE *) &s1[len2];
      res = 1;
    }

  while (len--)
    {
      if (*s != ' ')
        {
          if (*s > ' ')
            return res;
          else
            return -res;
        }
      s++;
    }

  return 0;
}
iexport(compare_string);


/* The destination and source should not overlap.  */

void
concat_string (gfc_charlen_type destlen, CHARTYPE * dest,
	       gfc_charlen_type len1, const CHARTYPE * s1,
	       gfc_charlen_type len2, const CHARTYPE * s2)
{
  if (len1 >= destlen)
    {
      memcpy (dest, s1, destlen * sizeof (CHARTYPE));
      return;
    }
  memcpy (dest, s1, len1 * sizeof (CHARTYPE));
  dest += len1;
  destlen -= len1;

  if (len2 >= destlen)
    {
      memcpy (dest, s2, destlen * sizeof (CHARTYPE));
      return;
    }

  memcpy (dest, s2, len2 * sizeof (CHARTYPE));
  MEMSET (&dest[len2], ' ', destlen - len2);
}


/* Return string with all trailing blanks removed.  */

void
string_trim (gfc_charlen_type *len, CHARTYPE **dest, gfc_charlen_type slen,
	     const CHARTYPE *src)
{
  *len = string_len_trim (slen, src);

  if (*len == 0)
    *dest = &zero_length_string;
  else
    {
      /* Allocate space for result string.  */
      *dest = xmallocarray (*len, sizeof (CHARTYPE));

      /* Copy string if necessary.  */
      memcpy (*dest, src, *len * sizeof (CHARTYPE));
    }
}


/* The length of a string not including trailing blanks.  */

gfc_charlen_type
string_len_trim (gfc_charlen_type len, const CHARTYPE *s)
{
  const gfc_charlen_type long_len = (gfc_charlen_type) sizeof (unsigned long);
  gfc_charlen_type i;

  i = len - 1;

  /* If we've got the standard (KIND=1) character type, we scan the string in
     long word chunks to speed it up (until a long word is hit that does not
     consist of ' 's).  */
  if (sizeof (CHARTYPE) == 1 && i >= long_len)
    {
      int starting;
      unsigned long blank_longword;

      /* Handle the first characters until we're aligned on a long word
	 boundary.  Actually, s + i + 1 must be properly aligned, because
	 s + i will be the last byte of a long word read.  */
      starting = ((unsigned long)
#ifdef __INTPTR_TYPE__
		  (__INTPTR_TYPE__)
#endif
		  (s + i + 1)) % long_len;
      i -= starting;
      for (; starting > 0; --starting)
	if (s[i + starting] != ' ')
	  return i + starting + 1;

      /* Handle the others in a batch until first non-blank long word is
	 found.  Here again, s + i is the last byte of the current chunk,
	 to it starts at s + i - sizeof (long) + 1.  */

#if __SIZEOF_LONG__ == 4
      blank_longword = 0x20202020L;
#elif __SIZEOF_LONG__ == 8
      blank_longword = 0x2020202020202020L;
#else
      #error Invalid size of long!
#endif

      while (i >= long_len)
	{
	  i -= long_len;
	  if (*((unsigned long*) (s + i + 1)) != blank_longword)
	    {
	      i += long_len;
	      break;
	    }
	}

      /* Now continue for the last characters with naive approach below.  */
      assert (i >= 0);
    }

  /* Simply look for the first non-blank character.  */
  while (i >= 0 && s[i] == ' ')
    --i;
  return i + 1;
}


/* Find a substring within a string.  */

gfc_charlen_type
string_index (gfc_charlen_type slen, const CHARTYPE *str,
	      gfc_charlen_type sslen, const CHARTYPE *sstr,
	      GFC_LOGICAL_4 back)
{
  gfc_charlen_type start, last, delta, i;

  if (sslen == 0)
    return back ? (slen + 1) : 1;

  if (sslen > slen)
    return 0;

  if (!back)
    {
      last = slen + 1 - sslen;
      start = 0;
      delta = 1;
    }
  else
    {
      last = -1;
      start = slen - sslen;
      delta = -1;
    }

  for (; start != last; start+= delta)
    {
      for (i = 0; i < sslen; i++)
        {
          if (str[start + i] != sstr[i])
            break;
        }
      if (i == sslen)
        return (start + 1);
    }
  return 0;
}


/* Remove leading blanks from a string, padding at end.  The src and dest
   should not overlap.  */

void
adjustl (CHARTYPE *dest, gfc_charlen_type len, const CHARTYPE *src)
{
  gfc_charlen_type i;

  i = 0;
  while (i < len && src[i] == ' ')
    i++;

  if (i < len)
    memcpy (dest, &src[i], (len - i) * sizeof (CHARTYPE));
  if (i > 0)
    MEMSET (&dest[len - i], ' ', i);
}


/* Remove trailing blanks from a string.  */

void
adjustr (CHARTYPE *dest, gfc_charlen_type len, const CHARTYPE *src)
{
  gfc_charlen_type i;

  i = len;
  while (i > 0 && src[i - 1] == ' ')
    i--;

  if (i < len)
    MEMSET (dest, ' ', len - i);
  memcpy (&dest[len - i], src, i * sizeof (CHARTYPE));
}


/* Scan a string for any one of the characters in a set of characters.  */

gfc_charlen_type
string_scan (gfc_charlen_type slen, const CHARTYPE *str,
	     gfc_charlen_type setlen, const CHARTYPE *set, GFC_LOGICAL_4 back)
{
  gfc_charlen_type i, j;

  if (slen == 0 || setlen == 0)
    return 0;

  if (back)
    {
      for (i = slen - 1; i >= 0; i--)
	{
	  for (j = 0; j < setlen; j++)
	    {
	      if (str[i] == set[j])
		return (i + 1);
	    }
	}
    }
  else
    {
      for (i = 0; i < slen; i++)
	{
	  for (j = 0; j < setlen; j++)
	    {
	      if (str[i] == set[j])
		return (i + 1);
	    }
	}
    }

  return 0;
}


/* Verify that a set of characters contains all the characters in a
   string by identifying the position of the first character in a
   characters that does not appear in a given set of characters.  */

gfc_charlen_type
string_verify (gfc_charlen_type slen, const CHARTYPE *str,
	       gfc_charlen_type setlen, const CHARTYPE *set,
	       GFC_LOGICAL_4 back)
{
  gfc_charlen_type start, last, delta, i;

  if (slen == 0)
    return 0;

  if (back)
    {
      last = -1;
      start = slen - 1;
      delta = -1;
    }
  else
    {
      last = slen;
      start = 0;
      delta = 1;
    }
  for (; start != last; start += delta)
    {
      for (i = 0; i < setlen; i++)
        {
          if (str[start] == set[i])
            break;
        }
      if (i == setlen)
        return (start + 1);
    }

  return 0;
}


/* MIN and MAX intrinsics for strings.  The front-end makes sure that
   nargs is at least 2.  */

void
string_minmax (gfc_charlen_type *rlen, CHARTYPE **dest, int op, int nargs, ...)
{
  va_list ap;
  int i;
  CHARTYPE *next, *res;
  gfc_charlen_type nextlen, reslen;

  va_start (ap, nargs);
  reslen = va_arg (ap, gfc_charlen_type);
  res = va_arg (ap, CHARTYPE *);
  *rlen = reslen;

  if (res == NULL)
    runtime_error ("First argument of '%s' intrinsic should be present",
		   op > 0 ? "MAX" : "MIN");

  for (i = 1; i < nargs; i++)
    {
      nextlen = va_arg (ap, gfc_charlen_type);
      next = va_arg (ap, CHARTYPE *);

      if (next == NULL)
	{
	  if (i == 1)
	    runtime_error ("Second argument of '%s' intrinsic should be "
			   "present", op > 0 ? "MAX" : "MIN");
	  else
	    continue;
	}

      if (nextlen > *rlen)
	*rlen = nextlen;

      if (op * compare_string (reslen, res, nextlen, next) < 0)
	{
	  reslen = nextlen;
	  res = next;
	}
    }
  va_end (ap);

  if (*rlen == 0)
    *dest = &zero_length_string;
  else
    {
      CHARTYPE *tmp = xmallocarray (*rlen, sizeof (CHARTYPE));
      memcpy (tmp, res, reslen * sizeof (CHARTYPE));
      MEMSET (&tmp[reslen], ' ', *rlen - reslen);
      *dest = tmp;
    }
}
Commit	Line	Data
4b267817	1	/* String intrinsics helper functions.
818ab71a	2	Copyright (C) 2002-2016 Free Software Foundation, Inc.
4b267817 FXC	3
	4	This file is part of the GNU Fortran runtime library (libgfortran).
	5
	6	Libgfortran is free software; you can redistribute it and/or
	7	modify it under the terms of the GNU General Public
	8	License as published by the Free Software Foundation; either
748086b7	9	version 3 of the License, or (at your option) any later version.
4b267817 FXC	10
	11	Libgfortran is distributed in the hope that it will be useful,
	12	but WITHOUT ANY WARRANTY; without even the implied warranty of
	13	MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	14	GNU General Public License for more details.
	15
748086b7 JJ	16	Under Section 7 of GPL version 3, you are granted additional
	17	permissions described in the GCC Runtime Library Exception, version
	18	3.1, as published by the Free Software Foundation.
	19
	20	You should have received a copy of the GNU General Public License and
	21	a copy of the GCC Runtime Library Exception along with this program;
	22	see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
	23	<http://www.gnu.org/licenses/>. */
4b267817 FXC	24
	25
	26	/* Rename the functions. */
	27	#define concat_string SUFFIX(concat_string)
	28	#define string_len_trim SUFFIX(string_len_trim)
	29	#define adjustl SUFFIX(adjustl)
	30	#define adjustr SUFFIX(adjustr)
	31	#define string_index SUFFIX(string_index)
	32	#define string_scan SUFFIX(string_scan)
	33	#define string_verify SUFFIX(string_verify)
	34	#define string_trim SUFFIX(string_trim)
	35	#define string_minmax SUFFIX(string_minmax)
	36	#define zero_length_string SUFFIX(zero_length_string)
	37	#define compare_string SUFFIX(compare_string)
	38
	39
	40	/* The prototypes. */
	41
	42	extern void concat_string (gfc_charlen_type, CHARTYPE *,
	43	gfc_charlen_type, const CHARTYPE *,
	44	gfc_charlen_type, const CHARTYPE *);
	45	export_proto(concat_string);
	46
4b267817 FXC	47	extern void adjustl (CHARTYPE , gfc_charlen_type, const CHARTYPE );
	48	export_proto(adjustl);
	49
	50	extern void adjustr (CHARTYPE , gfc_charlen_type, const CHARTYPE );
	51	export_proto(adjustr);
	52
	53	extern gfc_charlen_type string_index (gfc_charlen_type, const CHARTYPE *,
	54	gfc_charlen_type, const CHARTYPE *,
	55	GFC_LOGICAL_4);
	56	export_proto(string_index);
	57
	58	extern gfc_charlen_type string_scan (gfc_charlen_type, const CHARTYPE *,
	59	gfc_charlen_type, const CHARTYPE *,
	60	GFC_LOGICAL_4);
	61	export_proto(string_scan);
	62
	63	extern gfc_charlen_type string_verify (gfc_charlen_type, const CHARTYPE *,
	64	gfc_charlen_type, const CHARTYPE *,
	65	GFC_LOGICAL_4);
	66	export_proto(string_verify);
	67
	68	extern void string_trim (gfc_charlen_type , CHARTYPE *, gfc_charlen_type,
	69	const CHARTYPE *);
	70	export_proto(string_trim);
	71
	72	extern void string_minmax (gfc_charlen_type , CHARTYPE *, int, int, ...);
	73	export_proto(string_minmax);
	74
	75
	76	/* Use for functions which can return a zero-length string. */
	77	static CHARTYPE zero_length_string = 0;
	78
	79
	80	/* Strings of unequal length are extended with pad characters. */
	81
	82	int
	83	compare_string (gfc_charlen_type len1, const CHARTYPE *s1,
	84	gfc_charlen_type len2, const CHARTYPE *s2)
	85	{
	86	const UCHARTYPE *s;
	87	gfc_charlen_type len;
	88	int res;
	89
e7898e54	90	res = MEMCMP (s1, s2, ((len1 < len2) ? len1 : len2));
4b267817 FXC	91	if (res != 0)
	92	return res;
	93
	94	if (len1 == len2)
	95	return 0;
	96
	97	if (len1 < len2)
	98	{
	99	len = len2 - len1;
	100	s = (UCHARTYPE *) &s2[len1];
	101	res = -1;
	102	}
	103	else
	104	{
	105	len = len1 - len2;
	106	s = (UCHARTYPE *) &s1[len2];
	107	res = 1;
	108	}
	109
	110	while (len--)
	111	{
	112	if (*s != ' ')
	113	{
	114	if (*s > ' ')
	115	return res;
	116	else
	117	return -res;
	118	}
	119	s++;
	120	}
	121
	122	return 0;
	123	}
	124	iexport(compare_string);
	125
	126
	127	/* The destination and source should not overlap. */
	128
	129	void
	130	concat_string (gfc_charlen_type destlen, CHARTYPE * dest,
	131	gfc_charlen_type len1, const CHARTYPE * s1,
	132	gfc_charlen_type len2, const CHARTYPE * s2)
	133	{
	134	if (len1 >= destlen)
	135	{
	136	memcpy (dest, s1, destlen * sizeof (CHARTYPE));
	137	return;
	138	}
	139	memcpy (dest, s1, len1 * sizeof (CHARTYPE));
	140	dest += len1;
	141	destlen -= len1;
	142
	143	if (len2 >= destlen)
	144	{
	145	memcpy (dest, s2, destlen * sizeof (CHARTYPE));
	146	return;
	147	}
	148
	149	memcpy (dest, s2, len2 * sizeof (CHARTYPE));
	150	MEMSET (&dest[len2], ' ', destlen - len2);
	151	}
	152
	153
	154	/* Return string with all trailing blanks removed. */
155
156	void
157	string_trim (gfc_charlen_type len, CHARTYPE *dest, gfc_charlen_type slen,
158	const CHARTYPE *src)
159	{
bc6600ab	160	*len = string_len_trim (slen, src);
4b267817 FXC	161
	162	if (*len == 0)
	163	*dest = &zero_length_string;
	164	else
	165	{
	166	/* Allocate space for result string. */
92e6f3a4	167	dest = xmallocarray (len, sizeof (CHARTYPE));
4b267817 FXC	168
	169	/* Copy string if necessary. */
	170	memcpy (dest, src, len * sizeof (CHARTYPE));
	171	}
	172	}
	173
	174
	175	/* The length of a string not including trailing blanks. */
	176
	177	gfc_charlen_type
	178	string_len_trim (gfc_charlen_type len, const CHARTYPE *s)
	179	{
bc6600ab	180	const gfc_charlen_type long_len = (gfc_charlen_type) sizeof (unsigned long);
4b267817 FXC	181	gfc_charlen_type i;
4b267817 FXC	182
bc6600ab DK	183	i = len - 1;
	184
	185	/* If we've got the standard (KIND=1) character type, we scan the string in
	186	long word chunks to speed it up (until a long word is hit that does not
	187	consist of ' 's). */
	188	if (sizeof (CHARTYPE) == 1 && i >= long_len)
4b267817	189	{
bc6600ab DK	190	int starting;
	191	unsigned long blank_longword;
	192
	193	/* Handle the first characters until we're aligned on a long word
	194	boundary. Actually, s + i + 1 must be properly aligned, because
	195	s + i will be the last byte of a long word read. */
9d345853 KT	196	starting = ((unsigned long)
	197	#ifdef __INTPTR_TYPE__
	198	(__INTPTR_TYPE__)
	199	#endif
	200	(s + i + 1)) % long_len;
bc6600ab DK	201	i -= starting;
	202	for (; starting > 0; --starting)
	203	if (s[i + starting] != ' ')
	204	return i + starting + 1;
	205
	206	/* Handle the others in a batch until first non-blank long word is
	207	found. Here again, s + i is the last byte of the current chunk,
	208	to it starts at s + i - sizeof (long) + 1. */
	209
	210	#if __SIZEOF_LONG__ == 4
	211	blank_longword = 0x20202020L;
	212	#elif __SIZEOF_LONG__ == 8
	213	blank_longword = 0x2020202020202020L;
	214	#else
	215	#error Invalid size of long!
	216	#endif
	217
	218	while (i >= long_len)
	219	{
	220	i -= long_len;
	221	if (((unsigned long) (s + i + 1)) != blank_longword)
	222	{
	223	i += long_len;
	224	break;
	225	}
	226	}
	227
	228	/* Now continue for the last characters with naive approach below. */
	229	assert (i >= 0);
4b267817	230	}
bc6600ab DK	231
	232	/* Simply look for the first non-blank character. */
	233	while (i >= 0 && s[i] == ' ')
	234	--i;
4b267817 FXC	235	return i + 1;
	236	}
	237
	238
	239	/* Find a substring within a string. */
	240
	241	gfc_charlen_type
	242	string_index (gfc_charlen_type slen, const CHARTYPE *str,
	243	gfc_charlen_type sslen, const CHARTYPE *sstr,
	244	GFC_LOGICAL_4 back)
	245	{
	246	gfc_charlen_type start, last, delta, i;
	247
	248	if (sslen == 0)
691da334	249	return back ? (slen + 1) : 1;
4b267817 FXC	250
	251	if (sslen > slen)
	252	return 0;
	253
	254	if (!back)
	255	{
	256	last = slen + 1 - sslen;
	257	start = 0;
	258	delta = 1;
	259	}
	260	else
	261	{
	262	last = -1;
	263	start = slen - sslen;
	264	delta = -1;
	265	}
	266
	267	for (; start != last; start+= delta)
	268	{
	269	for (i = 0; i < sslen; i++)
	270	{
	271	if (str[start + i] != sstr[i])
	272	break;
	273	}
	274	if (i == sslen)
	275	return (start + 1);
	276	}
	277	return 0;
	278	}
	279
	280
	281	/* Remove leading blanks from a string, padding at end. The src and dest
	282	should not overlap. */
	283
	284	void
	285	adjustl (CHARTYPE dest, gfc_charlen_type len, const CHARTYPE src)
	286	{
	287	gfc_charlen_type i;
	288
	289	i = 0;
	290	while (i < len && src[i] == ' ')
	291	i++;
	292
	293	if (i < len)
	294	memcpy (dest, &src[i], (len - i) * sizeof (CHARTYPE));
	295	if (i > 0)
	296	MEMSET (&dest[len - i], ' ', i);
	297	}
	298
	299
	300	/* Remove trailing blanks from a string. */
	301
	302	void
	303	adjustr (CHARTYPE dest, gfc_charlen_type len, const CHARTYPE src)
	304	{
	305	gfc_charlen_type i;
	306
	307	i = len;
	308	while (i > 0 && src[i - 1] == ' ')
	309	i--;
	310
	311	if (i < len)
	312	MEMSET (dest, ' ', len - i);
	313	memcpy (&dest[len - i], src, i * sizeof (CHARTYPE));
314	}
315
316
317	/* Scan a string for any one of the characters in a set of characters. */
318
319	gfc_charlen_type
320	string_scan (gfc_charlen_type slen, const CHARTYPE *str,
321	gfc_charlen_type setlen, const CHARTYPE *set, GFC_LOGICAL_4 back)
322	{
323	gfc_charlen_type i, j;
324
325	if (slen == 0 \|\| setlen == 0)
326	return 0;
327
328	if (back)
329	{
330	for (i = slen - 1; i >= 0; i--)
331	{
332	for (j = 0; j < setlen; j++)
333	{
334	if (str[i] == set[j])
335	return (i + 1);
336	}
337	}
338	}
339	else
340	{
341	for (i = 0; i < slen; i++)
342	{
343	for (j = 0; j < setlen; j++)
344	{
345	if (str[i] == set[j])
346	return (i + 1);
347	}
348	}
349	}
350
351	return 0;
352	}
353
354
355	/* Verify that a set of characters contains all the characters in a
356	string by identifying the position of the first character in a
357	characters that does not appear in a given set of characters. */
358
359	gfc_charlen_type
360	string_verify (gfc_charlen_type slen, const CHARTYPE *str,
361	gfc_charlen_type setlen, const CHARTYPE *set,
362	GFC_LOGICAL_4 back)
363	{
364	gfc_charlen_type start, last, delta, i;
365
366	if (slen == 0)
367	return 0;
368
369	if (back)
370	{
371	last = -1;
372	start = slen - 1;
373	delta = -1;
374	}
375	else
376	{
377	last = slen;
378	start = 0;
379	delta = 1;
380	}
381	for (; start != last; start += delta)
382	{
383	for (i = 0; i < setlen; i++)
384	{
385	if (str[start] == set[i])
386	break;
387	}
388	if (i == setlen)
389	return (start + 1);
390	}
391
392	return 0;
393	}
394
395
396	/* MIN and MAX intrinsics for strings. The front-end makes sure that
397	nargs is at least 2. */
398
399	void
400	string_minmax (gfc_charlen_type rlen, CHARTYPE *dest, int op, int nargs, ...)
401	{
402	va_list ap;
403	int i;
404	CHARTYPE next, res;
405	gfc_charlen_type nextlen, reslen;
406
407	va_start (ap, nargs);
408	reslen = va_arg (ap, gfc_charlen_type);
409	res = va_arg (ap, CHARTYPE *);
410	*rlen = reslen;
411
412	if (res == NULL)
413	runtime_error ("First argument of '%s' intrinsic should be present",
414	op > 0 ? "MAX" : "MIN");
415
416	for (i = 1; i < nargs; i++)
417	{
418	nextlen = va_arg (ap, gfc_charlen_type);
419	next = va_arg (ap, CHARTYPE *);
420
421	if (next == NULL)
422	{
423	if (i == 1)
424	runtime_error ("Second argument of '%s' intrinsic should be "
425	"present", op > 0 ? "MAX" : "MIN");
426	else
427	continue;
428	}
429
430	if (nextlen > *rlen)
431	*rlen = nextlen;
432
433	if (op * compare_string (reslen, res, nextlen, next) < 0)
434	{
435	reslen = nextlen;
436	res = next;
437	}
438	}
439	va_end (ap);
440
441	if (*rlen == 0)
442	*dest = &zero_length_string;
443	else
444	{
92e6f3a4	445	CHARTYPE tmp = xmallocarray (rlen, sizeof (CHARTYPE));
4b267817 FXC	446	memcpy (tmp, res, reslen * sizeof (CHARTYPE));
	447	MEMSET (&tmp[reslen], ' ', *rlen - reslen);
	448	*dest = tmp;
	449	}
	450	}