aboutsummaryrefslogtreecommitdiff
path: root/gcc
diff options
context:
space:
mode:
Diffstat (limited to 'gcc')
-rw-r--r--gcc/fortran/ChangeLog17
-rw-r--r--gcc/fortran/check.c88
-rw-r--r--gcc/fortran/gfortran.h2
-rw-r--r--gcc/fortran/intrinsic.c29
-rw-r--r--gcc/fortran/intrinsic.h18
-rw-r--r--gcc/fortran/iresolve.c75
-rw-r--r--gcc/fortran/trans-intrinsic.c2
7 files changed, 227 insertions, 4 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 86ddef6..1ee3207 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,20 @@
+2004-11-20 Steven G. Kargl <kargls@comcast.net>
+
+ * check.c (gfc_check_getcwd_sub): Fix seg fault.
+
+ * check.c (gfc_check_exit,gfc_check_umask,gfc_check_umask_sub,
+ gfc_check_unlink,gfc_check_unlink_sub): New functions
+ * gfortran.h (GFC_ISYM_UMASK,GFC_ISYM_UNLINK): New symbols
+ * intrinsic.c (add_functions,add_subroutines): Add umask, unlink,
+ exit to intrinsics symbol tables.
+ * intrinsic.h (gfc_check_umask,gfc_check_unlink,gfc_check_exit,
+ gfc_check_umask_sub,gfc_check_unlink_sub,gfc_resolve_umask,
+ gfc_resolve_unlink,gfc_resolve_exit,gfc_resolve_umask_sub,
+ gfc_resolve_unlink_sub): Add and sort prototypes.
+ * iresolve.c (gfc_resolve_umask,gfc_resolve_unlink,gfc_resolve_exit,
+ gfc_resolve_umask_sub,gfc_resolve_unlink_sub): New functions
+ * trans-intrinsic.c (gfc_conv_intrinsic_function): Use symbols
+
2004-11-16 Paul Brook <paul@codesourcery.com>
PR fortran/13010
diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index b8ed5e9..3920864 100644
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -2108,6 +2108,94 @@ gfc_check_getcwd_sub (gfc_expr * cwd, gfc_expr * status)
if (type_check (cwd, 0, BT_CHARACTER) == FAILURE)
return FAILURE;
+ if (status == NULL)
+ return SUCCESS;
+
+ if (scalar_check (status, 1) == FAILURE)
+ return FAILURE;
+
+ if (type_check (status, 1, BT_INTEGER) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+
+try
+gfc_check_exit (gfc_expr * status)
+{
+
+ if (status == NULL)
+ return SUCCESS;
+
+ if (type_check (status, 0, BT_INTEGER) == FAILURE)
+ return FAILURE;
+
+ if (scalar_check (status, 0) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+
+try
+gfc_check_umask (gfc_expr * mask)
+{
+
+ if (type_check (mask, 0, BT_INTEGER) == FAILURE)
+ return FAILURE;
+
+ if (scalar_check (mask, 0) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+
+try
+gfc_check_umask_sub (gfc_expr * mask, gfc_expr * old)
+{
+
+ if (type_check (mask, 0, BT_INTEGER) == FAILURE)
+ return FAILURE;
+
+ if (scalar_check (mask, 0) == FAILURE)
+ return FAILURE;
+
+ if (old == NULL)
+ return SUCCESS;
+
+ if (scalar_check (old, 1) == FAILURE)
+ return FAILURE;
+
+ if (type_check (old, 1, BT_INTEGER) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+
+try
+gfc_check_unlink (gfc_expr * name)
+{
+
+ if (type_check (name, 0, BT_CHARACTER) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+
+try
+gfc_check_unlink_sub (gfc_expr * name, gfc_expr * status)
+{
+
+ if (type_check (name, 0, BT_CHARACTER) == FAILURE)
+ return FAILURE;
+
+ if (status == NULL)
+ return SUCCESS;
+
if (scalar_check (status, 1) == FAILURE)
return FAILURE;
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 1e42eb6..838e6d9 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -387,6 +387,8 @@ enum gfc_generic_isym_id
GFC_ISYM_TRANSPOSE,
GFC_ISYM_TRIM,
GFC_ISYM_UBOUND,
+ GFC_ISYM_UMASK,
+ GFC_ISYM_UNLINK,
GFC_ISYM_UNPACK,
GFC_ISYM_VERIFY,
GFC_ISYM_CONVERSION
diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c
index 462d076..9fe36ef 100644
--- a/gcc/fortran/intrinsic.c
+++ b/gcc/fortran/intrinsic.c
@@ -1856,6 +1856,20 @@ add_functions (void)
make_generic ("ubound", GFC_ISYM_UBOUND, GFC_STD_F95);
+ /* g77 compatibility for UMASK. */
+ add_sym_1 ("umask", 0, 1, BT_INTEGER, di, GFC_STD_GNU,
+ gfc_check_umask, NULL, gfc_resolve_umask,
+ a, BT_INTEGER, di, 0);
+
+ make_generic ("umask", GFC_ISYM_UMASK, GFC_STD_GNU);
+
+ /* g77 compatibility for UNLINK. */
+ add_sym_1 ("unlink", 0, 1, BT_INTEGER, di, GFC_STD_GNU,
+ gfc_check_unlink, NULL, gfc_resolve_unlink,
+ a, BT_CHARACTER, dc, 0);
+
+ make_generic ("unlink", GFC_ISYM_UNLINK, GFC_STD_GNU);
+
add_sym_3 ("unpack", 0, 1, BT_REAL, dr, GFC_STD_F95,
gfc_check_unpack, NULL, gfc_resolve_unpack,
v, BT_REAL, dr, 0, msk, BT_LOGICAL, dl, 0,
@@ -1984,6 +1998,10 @@ add_subroutines (void)
gfc_check_srand, NULL, gfc_resolve_srand,
c, BT_INTEGER, 4, 0);
+ add_sym_1s ("exit", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
+ gfc_check_exit, NULL, gfc_resolve_exit,
+ c, BT_INTEGER, di, 1);
+
add_sym_2s ("system", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
NULL, NULL, gfc_resolve_system_sub,
c, BT_CHARACTER, dc, 0,
@@ -1993,6 +2011,17 @@ add_subroutines (void)
gfc_check_system_clock, NULL, gfc_resolve_system_clock,
c, BT_INTEGER, di, 1, cr, BT_INTEGER, di, 1,
cm, BT_INTEGER, di, 1);
+
+ add_sym_2s ("umask", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
+ gfc_check_umask_sub, NULL, gfc_resolve_umask_sub,
+ val, BT_INTEGER, di, 0,
+ num, BT_INTEGER, di, 1);
+
+ add_sym_2s ("unlink", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
+ gfc_check_unlink_sub, NULL, gfc_resolve_unlink_sub,
+ c, BT_CHARACTER, dc, 0,
+ st, BT_INTEGER, di, 1);
+
}
diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h
index c9e1dc1..36d3b63 100644
--- a/gcc/fortran/intrinsic.h
+++ b/gcc/fortran/intrinsic.h
@@ -100,6 +100,8 @@ try gfc_check_transfer (gfc_expr *, gfc_expr *, gfc_expr *);
try gfc_check_transpose (gfc_expr *);
try gfc_check_trim (gfc_expr *);
try gfc_check_ubound (gfc_expr *, gfc_expr *);
+try gfc_check_umask (gfc_expr *);
+try gfc_check_unlink (gfc_expr *);
try gfc_check_unpack (gfc_expr *, gfc_expr *, gfc_expr *);
try gfc_check_verify (gfc_expr *, gfc_expr *, gfc_expr *);
try gfc_check_x (gfc_expr *);
@@ -109,6 +111,7 @@ try gfc_check_x (gfc_expr *);
try gfc_check_cpu_time (gfc_expr *);
try gfc_check_system_clock (gfc_expr *, gfc_expr *, gfc_expr *);
try gfc_check_date_and_time (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
+try gfc_check_exit (gfc_expr *);
try gfc_check_mvbits (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *,
gfc_expr *);
try gfc_check_random_number (gfc_expr *);
@@ -116,6 +119,8 @@ try gfc_check_random_seed (gfc_expr *, gfc_expr *, gfc_expr *);
try gfc_check_etime_sub (gfc_expr *, gfc_expr *);
try gfc_check_getcwd_sub (gfc_expr *, gfc_expr *);
try gfc_check_system_sub (gfc_expr *, gfc_expr *);
+try gfc_check_umask_sub (gfc_expr *, gfc_expr *);
+try gfc_check_unlink_sub (gfc_expr *, gfc_expr *);
/* Simplification functions. */
@@ -319,21 +324,26 @@ void gfc_resolve_transfer (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_transpose (gfc_expr *, gfc_expr *);
void gfc_resolve_trim (gfc_expr *, gfc_expr *);
void gfc_resolve_ubound (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_umask (gfc_expr *, gfc_expr *);
+void gfc_resolve_unlink (gfc_expr *, gfc_expr *);
void gfc_resolve_unpack (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_verify (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
/* Intrinsic subroutine resolution. */
void gfc_resolve_cpu_time (gfc_code *);
-void gfc_resolve_system_sub (gfc_code *);
-void gfc_resolve_system_clock (gfc_code *);
-void gfc_resolve_mvbits (gfc_code *);
-void gfc_resolve_random_number (gfc_code *);
+void gfc_resolve_exit (gfc_code *);
void gfc_resolve_getarg (gfc_code *);
void gfc_resolve_getcwd_sub (gfc_code *);
void gfc_resolve_get_command (gfc_code *);
void gfc_resolve_get_command_argument (gfc_code *);
void gfc_resolve_get_environment_variable (gfc_code *);
+void gfc_resolve_mvbits (gfc_code *);
+void gfc_resolve_random_number (gfc_code *);
+void gfc_resolve_system_clock (gfc_code *);
+void gfc_resolve_system_sub (gfc_code *);
+void gfc_resolve_umask_sub (gfc_code *);
+void gfc_resolve_unlink_sub (gfc_code *);
/* The mvbits() subroutine requires the most arguments: five. */
diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c
index d6bbe26..0379d70 100644
--- a/gcc/fortran/iresolve.c
+++ b/gcc/fortran/iresolve.c
@@ -1433,6 +1433,29 @@ gfc_resolve_ubound (gfc_expr * f, gfc_expr * array,
}
+/* Resolve the g77 compatibility function UMASK. */
+
+void
+gfc_resolve_umask (gfc_expr * f, gfc_expr * n)
+{
+
+ f->ts.type = BT_INTEGER;
+ f->ts.kind = n->ts.kind;
+ f->value.function.name = gfc_get_string (PREFIX("umask_i%d"), n->ts.kind);
+}
+
+
+/* Resolve the g77 compatibility function UNLINK. */
+
+void
+gfc_resolve_unlink (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED)
+{
+
+ f->ts.type = BT_INTEGER;
+ f->ts.kind = 4;
+ f->value.function.name = gfc_get_string (PREFIX("unlink"));
+}
+
void
gfc_resolve_unpack (gfc_expr * f, gfc_expr * vector, gfc_expr * mask,
gfc_expr * field ATTRIBUTE_UNUSED)
@@ -1639,6 +1662,58 @@ gfc_resolve_system_clock (gfc_code * c)
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
+/* Resolve the EXIT intrinsic subroutine. */
+
+void
+gfc_resolve_exit (gfc_code * c)
+{
+ const char *name;
+ int kind;
+
+ if (c->ext.actual->expr != NULL)
+ kind = c->ext.actual->expr->ts.kind;
+ else
+ kind = gfc_default_integer_kind;
+
+ name = gfc_get_string (PREFIX("exit_i%d"), kind);
+ c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+}
+
+/* Resolve the UMASK intrinsic subroutine. */
+
+void
+gfc_resolve_umask_sub (gfc_code * c)
+{
+ const char *name;
+ int kind;
+
+ if (c->ext.actual->next->expr != NULL)
+ kind = c->ext.actual->next->expr->ts.kind;
+ else
+ kind = gfc_default_integer_kind;
+
+ name = gfc_get_string (PREFIX("umask_i%d_sub"), kind);
+ c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+}
+
+/* Resolve the UNLINK intrinsic subroutine. */
+
+void
+gfc_resolve_unlink_sub (gfc_code * c)
+{
+ const char *name;
+ int kind;
+
+ if (c->ext.actual->next->expr != NULL)
+ kind = c->ext.actual->next->expr->ts.kind;
+ else
+ kind = gfc_default_integer_kind;
+
+ name = gfc_get_string (PREFIX("unlink_i%d_sub"), kind);
+ c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+}
+
+
void
gfc_iresolve_init_1 (void)
{
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index 927fcfc..f5b3b34 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -2974,6 +2974,8 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
case GFC_ISYM_GETPID:
case GFC_ISYM_GETUID:
case GFC_ISYM_SYSTEM:
+ case GFC_ISYM_UMASK:
+ case GFC_ISYM_UNLINK:
gfc_conv_intrinsic_funcall (se, expr);
break;
generated by cgit v1.1 at 2025-05-30 17:02:38 +0000