re PR libfortran/15280 (Fortran9x commandline not accessable)
PR fortran/15280 PR fortran/15665 * gfortran.h (enum gfc_generic_isym_id): Add GFC_ISYM_IARGC and GFC_ISYM_COMMAND_ARGUMENT_COUNT. * intrinsic.c (add_functions): Identify iargc. Add command_argument_count. (add_subroutines): Resolve getarg. Add get_command and get_command_argument. * intrinsic.h (gfc_resolve_getarg, gfc_resolve_get_command, gfc_resolve_get_command_argument): Add prototypes. * iresolve.c (gfc_resolve_getarg, gfc_resolve_get_command, gfc_resolve_get_command_argument): New functions. * trans-decl.c (gfor_fndecl_iargc): New variable. (gfc_build_intrinsic_function_decls): Set it. * trans-intrinsic.c (gfc_conv_intrinsic_iargc): New function. (gfc_conv_intrinsic_function): Use it. * trans.h (gfor_fndecl_iargc): Declare. libgfortran/ * libgfortran.h (gfc_strlen_type): Define. * intrinsics/args.c (getarg): Rename ... (getarg_i4): ... to this. (getarg_i8, get_command_argument_i4, get_command_argument_i8, get_command_i4, get_command_i8): New functions. Co-Authored-By: Paul Brook <paul@codesourcery.com> From-SVN: r84087
This commit is contained in:
Janne Blomqvist
Paul Brook
parent
dafa622b60
commit
b41b25345b
@ -1,3 +1,24 @@
|
||||
2004-07-04 Janne Blomqvist <jblomqvi@cc.hut.fi>
|
||||
Paul Brook <paul@codesourcery.com>
|
||||
|
||||
PR fortran/15280
|
||||
PR fortran/15665
|
||||
* gfortran.h (enum gfc_generic_isym_id): Add GFC_ISYM_IARGC and
|
||||
GFC_ISYM_COMMAND_ARGUMENT_COUNT.
|
||||
* intrinsic.c (add_functions): Identify iargc. Add
|
||||
command_argument_count.
|
||||
(add_subroutines): Resolve getarg. Add get_command and
|
||||
get_command_argument.
|
||||
* intrinsic.h (gfc_resolve_getarg, gfc_resolve_get_command,
|
||||
gfc_resolve_get_command_argument): Add prototypes.
|
||||
* iresolve.c (gfc_resolve_getarg, gfc_resolve_get_command,
|
||||
gfc_resolve_get_command_argument): New functions.
|
||||
* trans-decl.c (gfor_fndecl_iargc): New variable.
|
||||
(gfc_build_intrinsic_function_decls): Set it.
|
||||
* trans-intrinsic.c (gfc_conv_intrinsic_iargc): New function.
|
||||
(gfc_conv_intrinsic_function): Use it.
|
||||
* trans.h (gfor_fndecl_iargc): Declare.
|
||||
|
||||
2004-07-04 Matthias Klose <doko@debian.org>
|
||||
|
||||
* Make-lang.in: Generate and install gfortran man page.
|
||||
|
||||
@ -291,6 +291,7 @@ enum gfc_generic_isym_id
|
||||
GFC_ISYM_CEILING,
|
||||
GFC_ISYM_CHAR,
|
||||
GFC_ISYM_CMPLX,
|
||||
GFC_ISYM_COMMAND_ARGUMENT_COUNT,
|
||||
GFC_ISYM_CONJG,
|
||||
GFC_ISYM_COS,
|
||||
GFC_ISYM_COSH,
|
||||
@ -308,6 +309,7 @@ enum gfc_generic_isym_id
|
||||
GFC_ISYM_FRACTION,
|
||||
GFC_ISYM_IACHAR,
|
||||
GFC_ISYM_IAND,
|
||||
GFC_ISYM_IARGC,
|
||||
GFC_ISYM_IBCLR,
|
||||
GFC_ISYM_IBITS,
|
||||
GFC_ISYM_IBSET,
|
||||
|
||||
@ -1104,6 +1104,10 @@ add_functions (void)
|
||||
make_generic ("iand", GFC_ISYM_IAND);
|
||||
|
||||
add_sym_0 ("iargc", 1, 1, BT_INTEGER, di, NULL, NULL, NULL); /* Extension, takes no arguments */
|
||||
make_generic ("iargc", GFC_ISYM_IARGC);
|
||||
|
||||
add_sym_0 ("command_argument_count", 1, 1, BT_INTEGER, di, NULL, NULL, NULL);
|
||||
make_generic ("command_argument_count", GFC_ISYM_COMMAND_ARGUMENT_COUNT);
|
||||
|
||||
add_sym_2 ("ibclr", 1, 1, BT_INTEGER, di,
|
||||
gfc_check_ibclr, gfc_simplify_ibclr, gfc_resolve_ibclr,
|
||||
@ -1704,7 +1708,9 @@ add_subroutines (void)
|
||||
*h = "harvest", *dt = "date", *vl = "values", *pt = "put",
|
||||
*c = "count", *tm = "time", *tp = "topos", *gt = "get",
|
||||
*t = "to", *zn = "zone", *fp = "frompos", *cm = "count_max",
|
||||
*f = "from", *sz = "size", *ln = "len", *cr = "count_rate";
|
||||
*f = "from", *sz = "size", *ln = "len", *cr = "count_rate",
|
||||
*com = "command", *length = "length", *st = "status",
|
||||
*val = "value", *num = "number";
|
||||
|
||||
int di, dr, dc;
|
||||
|
||||
@ -1738,8 +1744,24 @@ add_subroutines (void)
|
||||
vl, BT_REAL, 4, 0, tm, BT_REAL, 4, 0);
|
||||
|
||||
add_sym_2 ("getarg", 0, 1, BT_UNKNOWN, 0,
|
||||
NULL, NULL, NULL,
|
||||
NULL, NULL, gfc_resolve_getarg,
|
||||
c, BT_INTEGER, di, 0, vl, BT_CHARACTER, dc, 0);
|
||||
|
||||
/* F2003 commandline routines. */
|
||||
|
||||
add_sym_3s ("get_command", 0, 1, BT_UNKNOWN, 0,
|
||||
NULL, NULL, gfc_resolve_get_command,
|
||||
com, BT_CHARACTER, dc, 1,
|
||||
length, BT_INTEGER, di, 1,
|
||||
st, BT_INTEGER, di, 1);
|
||||
|
||||
add_sym_4 ("get_command_argument", 0, 1, BT_UNKNOWN, 0,
|
||||
NULL, NULL, gfc_resolve_get_command_argument,
|
||||
num, BT_INTEGER, di, 0,
|
||||
val, BT_CHARACTER, dc, 1,
|
||||
length, BT_INTEGER, di, 1,
|
||||
st, BT_INTEGER, di, 1);
|
||||
|
||||
/* Extension */
|
||||
|
||||
add_sym_5 ("mvbits", 1, 1, BT_UNKNOWN, 0,
|
||||
|
||||
@ -315,6 +315,9 @@ void gfc_resolve_verify (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_cpu_time (gfc_code *);
|
||||
void gfc_resolve_system_clock(gfc_code *);
|
||||
void gfc_resolve_random_number (gfc_code *);
|
||||
void gfc_resolve_getarg (gfc_code *);
|
||||
void gfc_resolve_get_command (gfc_code *);
|
||||
void gfc_resolve_get_command_argument (gfc_code *);
|
||||
|
||||
|
||||
/* The mvbits() subroutine requires the most arguments: five. */
|
||||
|
||||
@ -1408,6 +1408,48 @@ gfc_resolve_srand (gfc_code * c)
|
||||
}
|
||||
|
||||
|
||||
/* Resolve the getarg intrinsic subroutine. */
|
||||
|
||||
void
|
||||
gfc_resolve_getarg (gfc_code * c)
|
||||
{
|
||||
const char *name;
|
||||
int kind;
|
||||
|
||||
kind = gfc_default_integer_kind ();
|
||||
name = gfc_get_string (PREFIX("getarg_i%d"), kind);
|
||||
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
|
||||
}
|
||||
|
||||
|
||||
/* Resolve the get_command intrinsic subroutine. */
|
||||
|
||||
void
|
||||
gfc_resolve_get_command (gfc_code * c)
|
||||
{
|
||||
const char *name;
|
||||
int kind;
|
||||
|
||||
kind = gfc_default_integer_kind ();
|
||||
name = gfc_get_string (PREFIX("get_command_i%d"), kind);
|
||||
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
|
||||
}
|
||||
|
||||
|
||||
/* Resolve the get_command_argument intrinsic subroutine. */
|
||||
|
||||
void
|
||||
gfc_resolve_get_command_argument (gfc_code * c)
|
||||
{
|
||||
const char *name;
|
||||
int kind;
|
||||
|
||||
kind = gfc_default_integer_kind ();
|
||||
name = gfc_get_string (PREFIX("get_command_argument_i%d"), kind);
|
||||
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
|
||||
}
|
||||
|
||||
|
||||
/* Determine if the arguments to SYSTEM_CLOCK are INTEGER(4) or INTEGER(8) */
|
||||
|
||||
void
|
||||
|
||||
@ -125,6 +125,7 @@ tree gfor_fndecl_adjustr;
|
||||
|
||||
tree gfor_fndecl_size0;
|
||||
tree gfor_fndecl_size1;
|
||||
tree gfor_fndecl_iargc;
|
||||
|
||||
/* Intrinsic functions implemented in FORTRAN. */
|
||||
tree gfor_fndecl_si_kind;
|
||||
@ -1518,6 +1519,11 @@ gfc_build_intrinsic_function_decls (void)
|
||||
gfc_array_index_type,
|
||||
2, pvoid_type_node,
|
||||
gfc_array_index_type);
|
||||
|
||||
gfor_fndecl_iargc =
|
||||
gfc_build_library_function_decl (get_identifier (PREFIX ("iargc")),
|
||||
gfc_int4_type_node,
|
||||
0);
|
||||
}
|
||||
|
||||
|
||||
|
||||
@ -2585,6 +2585,29 @@ gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
|
||||
}
|
||||
|
||||
|
||||
/* Generate code for the IARGC intrinsic. If args_only is true this is
|
||||
actually the COMMAND_ARGUMENT_COUNT intrinsic, so return IARGC - 1. */
|
||||
|
||||
static void
|
||||
gfc_conv_intrinsic_iargc (gfc_se * se, gfc_expr * expr, bool args_only)
|
||||
{
|
||||
tree tmp;
|
||||
tree fndecl;
|
||||
tree type;
|
||||
|
||||
/* Call the library function. This always returns an INTEGER(4). */
|
||||
fndecl = gfor_fndecl_iargc;
|
||||
tmp = gfc_build_function_call (fndecl, NULL_TREE);
|
||||
|
||||
/* Convert it to the required type. */
|
||||
type = gfc_typenode_for_spec (&expr->ts);
|
||||
tmp = fold_convert (type, tmp);
|
||||
|
||||
if (args_only)
|
||||
tmp = build (MINUS_EXPR, type, tmp, convert (type, integer_one_node));
|
||||
se->expr = tmp;
|
||||
}
|
||||
|
||||
/* Generate code for an intrinsic function. Some map directly to library
|
||||
calls, others get special handling. In some cases the name of the function
|
||||
used depends on the type specifiers. */
|
||||
@ -2739,6 +2762,10 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
|
||||
gfc_conv_intrinsic_cmplx (se, expr, name[5] == '1');
|
||||
break;
|
||||
|
||||
case GFC_ISYM_COMMAND_ARGUMENT_COUNT:
|
||||
gfc_conv_intrinsic_iargc (se, expr, TRUE);
|
||||
break;
|
||||
|
||||
case GFC_ISYM_CONJG:
|
||||
gfc_conv_intrinsic_conjg (se, expr);
|
||||
break;
|
||||
@ -2777,6 +2804,10 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
|
||||
gfc_conv_intrinsic_ichar (se, expr);
|
||||
break;
|
||||
|
||||
case GFC_ISYM_IARGC:
|
||||
gfc_conv_intrinsic_iargc (se, expr, FALSE);
|
||||
break;
|
||||
|
||||
case GFC_ISYM_IEOR:
|
||||
gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
|
||||
break;
|
||||
|
||||
@ -481,6 +481,7 @@ extern GTY(()) tree gfor_fndecl_adjustr;
|
||||
/* Other misc. runtime library functions. */
|
||||
extern GTY(()) tree gfor_fndecl_size0;
|
||||
extern GTY(()) tree gfor_fndecl_size1;
|
||||
extern GTY(()) tree gfor_fndecl_iargc;
|
||||
|
||||
/* Implemented in FORTRAN. */
|
||||
extern GTY(()) tree gfor_fndecl_si_kind;
|
||||
|
||||
@ -1,3 +1,14 @@
|
||||
2004-07-04 Janne Blomqvist <jblomqvi@cc.hut.fi>
|
||||
Paul Brook <paul@codesourcery.com>
|
||||
|
||||
PR fortran/15280
|
||||
PR fortran/15665
|
||||
* libgfortran.h (gfc_strlen_type): Define.
|
||||
* intrinsics/args.c (getarg): Rename ...
|
||||
(getarg_i4): ... to this.
|
||||
(getarg_i8, get_command_argument_i4, get_command_argument_i8,
|
||||
get_command_i4, get_command_i8): New functions.
|
||||
|
||||
2004-07-04 Matthias Klose <doko@debian.org>
|
||||
|
||||
* libtool-version: New.
|
||||
|
||||
@ -1,5 +1,7 @@
|
||||
/* Implementation of the IARG/ARGC intrinsic(s).
|
||||
/* Implementation of the GETARG and IARGC g77, and
|
||||
corresponding F2003, intrinsics.
|
||||
Copyright (C) 2004 Free Software Foundation, Inc.
|
||||
Contributed by Bud Davis and Janne Blomqvist.
|
||||
|
||||
This file is part of the GNU Fortran 95 runtime library (libgfortran).
|
||||
|
||||
@ -23,8 +25,11 @@ Boston, MA 02111-1307, USA. */
|
||||
#include <string.h>
|
||||
#include "libgfortran.h"
|
||||
|
||||
|
||||
/* Get a commandline argument. */
|
||||
|
||||
void
|
||||
prefix(getarg) (GFC_INTEGER_4 *pos, char *val, GFC_INTEGER_4 val_len)
|
||||
prefix(getarg_i4) (GFC_INTEGER_4 *pos, char *val, gfc_strlen_type val_len)
|
||||
{
|
||||
int argc;
|
||||
int arglen;
|
||||
@ -35,7 +40,7 @@ prefix(getarg) (GFC_INTEGER_4 *pos, char *val, GFC_INTEGER_4 val_len)
|
||||
if (val_len < 1 || !val )
|
||||
return; /* something is wrong , leave immediately */
|
||||
|
||||
memset( val, ' ', val_len);
|
||||
memset (val, ' ', val_len);
|
||||
|
||||
if ((*pos) + 1 <= argc && *pos >=0 )
|
||||
{
|
||||
@ -46,8 +51,23 @@ prefix(getarg) (GFC_INTEGER_4 *pos, char *val, GFC_INTEGER_4 val_len)
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
/* INTEGER*8 wrapper of getarg. */
|
||||
|
||||
void
|
||||
prefix(getarg_i8) (GFC_INTEGER_8 *pos, char *val, gfc_strlen_type val_len)
|
||||
{
|
||||
GFC_INTEGER_4 pos4;
|
||||
|
||||
pos4 = (GFC_INTEGER_4) *pos;
|
||||
prefix(getarg_i4) (&pos4, val, val_len);
|
||||
}
|
||||
|
||||
|
||||
/* Return the number of commandline arguments. */
|
||||
|
||||
GFC_INTEGER_4
|
||||
prefix(iargc) ()
|
||||
prefix(iargc) (void)
|
||||
{
|
||||
int argc;
|
||||
char **argv;
|
||||
@ -56,3 +76,175 @@ prefix(iargc) ()
|
||||
|
||||
return argc;
|
||||
}
|
||||
|
||||
|
||||
/* F2003 intrinsic functions and subroutines related to command line
|
||||
arguments.
|
||||
|
||||
- function command_argument_count() is converted to iargc by the compiler.
|
||||
|
||||
- subroutine get_command([command, length, status]).
|
||||
|
||||
- subroutine get_command_argument(number, [value, length, status]).
|
||||
*/
|
||||
|
||||
/* These two status codes are specified in the standard. */
|
||||
#define GFC_GC_SUCCESS 0
|
||||
#define GFC_GC_VALUE_TOO_SHORT -1
|
||||
|
||||
/* Processor-specific status failure code. */
|
||||
#define GFC_GC_FAILURE 42
|
||||
|
||||
|
||||
/* Get a single commandline argument. */
|
||||
|
||||
void
|
||||
prefix(get_command_argument_i4) (GFC_INTEGER_4 *number,
|
||||
char *value,
|
||||
GFC_INTEGER_4 *length,
|
||||
GFC_INTEGER_4 *status,
|
||||
gfc_strlen_type value_len)
|
||||
{
|
||||
int argc, arglen = 0, stat_flag = GFC_GC_SUCCESS;
|
||||
char **argv;
|
||||
|
||||
if (number == NULL )
|
||||
/* Should never happen. */
|
||||
runtime_error ("Missing argument to get_command_argument");
|
||||
|
||||
if (value == NULL && length == NULL && status == NULL)
|
||||
return; /* No need to do anything. */
|
||||
|
||||
get_args (&argc, &argv);
|
||||
|
||||
if (*number < 0 || *number >= argc)
|
||||
stat_flag = GFC_GC_FAILURE;
|
||||
else
|
||||
arglen = strlen(argv[*number]);
|
||||
|
||||
if (value != NULL)
|
||||
{
|
||||
if (value_len < 1)
|
||||
stat_flag = GFC_GC_FAILURE;
|
||||
else
|
||||
memset (value, ' ', value_len);
|
||||
}
|
||||
|
||||
if (value != NULL && stat_flag != GFC_GC_FAILURE)
|
||||
{
|
||||
if (arglen > value_len)
|
||||
{
|
||||
arglen = value_len;
|
||||
stat_flag = GFC_GC_VALUE_TOO_SHORT;
|
||||
}
|
||||
memcpy (value, argv[*number], arglen);
|
||||
}
|
||||
|
||||
if (length != NULL)
|
||||
*length = arglen;
|
||||
|
||||
if (status != NULL)
|
||||
*status = stat_flag;
|
||||
}
|
||||
|
||||
|
||||
/* INTEGER*8 wrapper for get_command_argument. */
|
||||
|
||||
void
|
||||
prefix(get_command_argument_i8) (GFC_INTEGER_8 *number,
|
||||
char *value,
|
||||
GFC_INTEGER_8 *length,
|
||||
GFC_INTEGER_8 *status,
|
||||
gfc_strlen_type value_len)
|
||||
{
|
||||
GFC_INTEGER_4 number4;
|
||||
GFC_INTEGER_4 length4;
|
||||
GFC_INTEGER_4 status4;
|
||||
|
||||
number4 = (GFC_INTEGER_4) *number;
|
||||
prefix (get_command_argument_i4) (&number4, value, &length4, &status4,
|
||||
value_len);
|
||||
if (length)
|
||||
*length = length4;
|
||||
if (status)
|
||||
*status = status4;
|
||||
}
|
||||
|
||||
|
||||
/* Return the whole commandline. */
|
||||
|
||||
void
|
||||
prefix(get_command_i4) (char *command,
|
||||
GFC_INTEGER_4 *length,
|
||||
GFC_INTEGER_4 *status,
|
||||
gfc_strlen_type command_len)
|
||||
{
|
||||
int i, argc, arglen, thisarg;
|
||||
int stat_flag = GFC_GC_SUCCESS;
|
||||
int tot_len = 0;
|
||||
char **argv;
|
||||
|
||||
if (command == NULL && length == NULL && status == NULL)
|
||||
return; /* No need to do anything. */
|
||||
|
||||
get_args (&argc, &argv);
|
||||
|
||||
if (command != NULL)
|
||||
{
|
||||
/* Initialize the string to blanks. */
|
||||
if (command_len < 1)
|
||||
stat_flag = GFC_GC_FAILURE;
|
||||
else
|
||||
memset (command, ' ', command_len);
|
||||
}
|
||||
|
||||
for (i = 0; i < argc ; i++)
|
||||
{
|
||||
arglen = strlen(argv[i]);
|
||||
|
||||
if (command != NULL && stat_flag == GFC_GC_SUCCESS)
|
||||
{
|
||||
thisarg = arglen;
|
||||
if (tot_len + thisarg > command_len)
|
||||
{
|
||||
thisarg = command_len - tot_len; /* Truncate. */
|
||||
stat_flag = GFC_GC_VALUE_TOO_SHORT;
|
||||
}
|
||||
/* Also a space before the next arg. */
|
||||
else if (i != argc - 1 && tot_len + arglen == command_len)
|
||||
stat_flag = GFC_GC_VALUE_TOO_SHORT;
|
||||
|
||||
memcpy (&command[tot_len], argv[i], thisarg);
|
||||
}
|
||||
|
||||
/* Add the legth of the argument. */
|
||||
tot_len += arglen;
|
||||
if (i != argc - 1)
|
||||
tot_len++;
|
||||
}
|
||||
|
||||
if (length != NULL)
|
||||
*length = tot_len;
|
||||
|
||||
if (status != NULL)
|
||||
*status = stat_flag;
|
||||
}
|
||||
|
||||
|
||||
/* INTEGER*8 wrapper for get_command. */
|
||||
|
||||
void
|
||||
prefix(get_command_i8) (char *command,
|
||||
GFC_INTEGER_8 *length,
|
||||
GFC_INTEGER_8 *status,
|
||||
gfc_strlen_type command_len)
|
||||
{
|
||||
GFC_INTEGER_4 length4;
|
||||
GFC_INTEGER_4 status4;
|
||||
|
||||
prefix (get_command_i4) (command, &length4, &status4, command_len);
|
||||
if (length)
|
||||
*length = length4;
|
||||
if (status)
|
||||
*status = status4;
|
||||
}
|
||||
|
||||
@ -88,6 +88,7 @@ typedef complex float GFC_COMPLEX_4;
|
||||
typedef complex double GFC_COMPLEX_8;
|
||||
|
||||
typedef size_t index_type;
|
||||
typedef GFC_INTEGER_4 gfc_strlen_type;
|
||||
|
||||
/* This will be 0 on little-endian machines and one on big-endian machines. */
|
||||
#define l8_to_l4_offset prefix(l8_to_l4_offset)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user