https://gcc.gnu.org/bugzilla/show_bug.cgi?id=30372
--- Comment #13 from kargl at gcc dot gnu.org ---
This patch makes the UMASK subroutine a generic subprogram. This is
accomplished by converting its arguments to INTEGER(4), call
_gfortran_umask_i4_sub, and converting the OLD argument back to an appropriate
integer kind. Don't know if it works with -fdefault-real-8, but who cares.
That option should be removed from gfortran.
Index: gcc/fortran/check.c
===================================================================
--- gcc/fortran/check.c (revision 280157)
+++ gcc/fortran/check.c (working copy)
@@ -7236,6 +7236,14 @@ gfc_check_umask_sub (gfc_expr *mask, gfc_expr *old)
if (!type_check (old, 1, BT_INTEGER))
return false;
+ if (old->expr_type != EXPR_VARIABLE
+ || (old->symtree && old->symtree->n.sym
+ && old->symtree->n.sym->attr.intent == INTENT_IN))
+ {
+ gfc_error ("OLD at %L shall be an INTENT(OUT) variable", &old->where);
+ return false;
+ }
+
return true;
}
Index: gcc/fortran/intrinsic.texi
===================================================================
--- gcc/fortran/intrinsic.texi (revision 280157)
+++ gcc/fortran/intrinsic.texi (working copy)
@@ -14795,9 +14795,10 @@ corresponding to the lower cobound of the array along
@table @asis
@item @emph{Description}:
-Sets the file creation mask to @var{MASK}. If called as a function, it
-returns the old value. If called as a subroutine and argument @var{OLD}
-if it is supplied, it is set to the old value. See @code{umask(2)}.
+Sets the file creation mask to @var{MASK}.
+If called as a function, it returns the old value.
+If called as a subroutine, and @var{OLD} is present,
+it sets @var{OLD} to the previous value.
@item @emph{Standard}:
GNU extension
Index: gcc/fortran/trans-decl.c
===================================================================
--- gcc/fortran/trans-decl.c (revision 280157)
+++ gcc/fortran/trans-decl.c (working copy)
@@ -212,12 +212,13 @@ tree gfor_fndecl_convert_char4_to_char1;
/* Other misc. runtime library functions. */
-tree gfor_fndecl_size0;
-tree gfor_fndecl_size1;
tree gfor_fndecl_iargc;
+tree gfor_fndecl_is_contiguous0;
tree gfor_fndecl_kill;
tree gfor_fndecl_kill_sub;
-tree gfor_fndecl_is_contiguous0;
+tree gfor_fndecl_size0;
+tree gfor_fndecl_size1;
+tree gfor_fndecl_umask_sub;
/* Intrinsic functions implemented in Fortran. */
@@ -3635,6 +3636,10 @@ gfc_build_intrinsic_function_decls (void)
gfor_fndecl_iargc = gfc_build_library_function_decl (
get_identifier (PREFIX ("iargc")), gfc_int4_type_node, 0);
TREE_NOTHROW (gfor_fndecl_iargc) = 1;
+
+ gfor_fndecl_umask_sub = gfc_build_library_function_decl (
+ get_identifier (PREFIX ("umask_i4_sub")), void_type_node,
+ 2, gfc_pint4_type_node, gfc_pint4_type_node);
gfor_fndecl_kill_sub = gfc_build_library_function_decl (
get_identifier (PREFIX ("kill_sub")), void_type_node,
Index: gcc/fortran/trans-intrinsic.c
===================================================================
--- gcc/fortran/trans-intrinsic.c (revision 280157)
+++ gcc/fortran/trans-intrinsic.c (working copy)
@@ -9138,7 +9138,51 @@ conv_intrinsic_kill_sub (gfc_code *code)
}
+/* Translate a call to the UMASK subroutine. */
+static tree
+conv_intrinsic_umask_sub (gfc_code *code)
+{
+ stmtblock_t block;
+ gfc_se se, se_old;
+ tree int4_type_node = gfc_get_int_type (4);
+ tree mask;
+ tree oldp = NULL_TREE;
+ tree tmp;
+
+ /* Make the function call. */
+ gfc_init_block (&block);
+ gfc_init_se (&se, NULL);
+
+ /* Convert mask to an INTEGER(4) entity. */
+ gfc_conv_expr (&se, code->ext.actual->expr);
+ gfc_add_block_to_block (&block, &se.pre);
+ mask = fold_convert (int4_type_node, gfc_evaluate_now (se.expr, &block));
+ gfc_add_block_to_block (&block, &se.post);
+
+ /* Deal with an optional OLD. */
+ if (code->ext.actual->next->expr)
+ {
+ gfc_init_se (&se_old, NULL);
+ gfc_conv_expr (&se_old, code->ext.actual->next->expr);
+ oldp = gfc_create_var (int4_type_node, "_oldp");
+ }
+
+ tmp = build_call_expr_loc (input_location, gfor_fndecl_umask_sub, 2,
+ gfc_build_addr_expr (NULL_TREE, mask),
+ oldp ? gfc_build_addr_expr (NULL_TREE, oldp)
+ : null_pointer_node);
+
+ gfc_add_expr_to_block (&block, tmp);
+
+ if (oldp && oldp != se_old.expr)
+ gfc_add_modify (&block, se_old.expr,
+ fold_convert (TREE_TYPE (se_old.expr), oldp));
+
+ return gfc_finish_block (&block);
+}
+
+
/* The loc intrinsic returns the address of its argument as
gfc_index_integer_kind integer. */
@@ -11899,6 +11943,10 @@ gfc_conv_intrinsic_subroutine (gfc_code *code)
case GFC_ISYM_KILL:
res = conv_intrinsic_kill_sub (code);
+ break;
+
+ case GFC_ISYM_UMASK:
+ res = conv_intrinsic_umask_sub (code);
break;
case GFC_ISYM_SYSTEM_CLOCK:
Index: gcc/fortran/trans.h
===================================================================
--- gcc/fortran/trans.h (revision 280157)
+++ gcc/fortran/trans.h (working copy)
@@ -939,12 +939,13 @@ extern GTY(()) tree gfor_fndecl_convert_char1_to_char4
extern GTY(()) tree gfor_fndecl_convert_char4_to_char1;
/* Other misc. runtime library functions. */
-extern GTY(()) tree gfor_fndecl_size0;
-extern GTY(()) tree gfor_fndecl_size1;
extern GTY(()) tree gfor_fndecl_iargc;
+extern GTY(()) tree gfor_fndecl_is_contiguous0;
extern GTY(()) tree gfor_fndecl_kill;
extern GTY(()) tree gfor_fndecl_kill_sub;
-extern GTY(()) tree gfor_fndecl_is_contiguous0;
+extern GTY(()) tree gfor_fndecl_size0;
+extern GTY(()) tree gfor_fndecl_size1;
+extern GTY(()) tree gfor_fndecl_umask_sub;
/* Implemented in Fortran. */
extern GTY(()) tree gfor_fndecl_sc_kind;
