+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
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;
GFC_ISYM_TRANSPOSE,
GFC_ISYM_TRIM,
GFC_ISYM_UBOUND,
+ GFC_ISYM_UMASK,
+ GFC_ISYM_UNLINK,
GFC_ISYM_UNPACK,
GFC_ISYM_VERIFY,
GFC_ISYM_CONVERSION
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,
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,
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);
+
}
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 *);
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 *);
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. */
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. */
}
+/* 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)
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)
{
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;
+2004-11-20 Steven G. Kargl <kargls@comcast.net>
+
+ * Makefile.am: Add intrinsics/{umask.c,unlink.c,exit.c}
+ * Makefile.in: Regenerated
+ * intrinsics/umask.c: New file
+ * intrinsics/unlink.c: ditto
+ * intrinsics/exit.c: ditto
+
2004-11-18 Victor Leikehman <lei@il.ibm.com>
* m4/matmul.m4: Loops reordered to improve cache behavior.
PR fortran/17143
* runtime/error.c (itoa): keep from overflowing during
- mod operation by using unsigned variable.
+ mod operation by using unsigned variable.
2004-08-24 Bud Davis <bdavis9659@comcast.net>
PR gfortran/14897
* io/transfer.c (formatted_transfer): position is unique
- for T and TL edit descriptors.
+ for T and TL edit descriptors.
(data_transfer_init): set record length to size of internal
- file.
+ file.
2004-06-09 Bud Davis <bdavis9659@comcast.net>
PR fortran/14906
* io/format.c (format_item): gracefully handle a ')'
- when it is the first character encountered in the string.
+ when it is the first character encountered in the string.
2004-04-11 Bud Davis <bdavis9659@comcast.net>
PR 13919
* io/io.h (global_t):
* io/list_read.c (next_char,list_formatted_read,ist_formatted_read):
- Move eof_jmp to a global structure.
+ Move eof_jmp to a global structure.
* io/transfer.c(finalize_transfer) : Set up eof_jump for callers.
2004-03-24 Bud Davis <bdavis9659@comcast.net>
2003-04-11 Xiaoqiang Zhang <zhangapache@yahoo.com>
- * io/write.c (extract_real): Ouput floating point value.
- (write_float): New Function.
- (write_e, write_f, write_en, write_es): Modified
- * io/transfer.c (formatted_transfer): Modified.
- * libgfor.h (default_rtoa): Declaration.
- (rtoa): Declaration.
- * runtime/error.c (default_rtoa): New Function.
- (rtoa): New Function.
+ * io/write.c (extract_real): Ouput floating point value.
+ (write_float): New Function.
+ (write_e, write_f, write_en, write_es): Modified
+ * io/transfer.c (formatted_transfer): Modified.
+ * libgfor.h (default_rtoa): Declaration.
+ (rtoa): Declaration.
+ * runtime/error.c (default_rtoa): New Function.
+ (rtoa): New Function.
2003-04-05 Paul Brook <paul@nowt.org>
intrinsics/eoshift0.c \
intrinsics/eoshift2.c \
intrinsics/etime.c \
+intrinsics/exit.c \
intrinsics/getcwd.c \
intrinsics/getXid.c \
intrinsics/ishftc.c \
intrinsics/selected_real_kind.f90 \
intrinsics/system_clock.c \
intrinsics/transpose_generic.c \
+intrinsics/umask.c \
+intrinsics/unlink.c \
intrinsics/unpack_generic.c \
runtime/in_pack_generic.c \
runtime/in_unpack_generic.c \
--- /dev/null
+/* Implementation of the EXIT intrinsic.
+ Copyright (C) 2004 Free Software Foundation, Inc.
+ Contributed by Steven G. Kargl <kargls@comcast.net>.
+
+This file is part of the GNU Fortran 95 runtime library (libgfortran).
+
+Libgfortran is free software; you can redistribute it and/or
+modify it under the terms of the GNU Lesser General Public
+License as published by the Free Software Foundation; either
+version 2.1 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 Lesser General Public License for more details.
+
+You should have received a copy of the GNU Lesser General Public
+License along with libgfor; see the file COPYING.LIB. If not,
+write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA. */
+
+
+#include "config.h"
+#include "libgfortran.h"
+
+#ifdef HAVE_STDLIB_H
+#include <stdlib.h>
+#endif
+
+/* SUBROUTINE EXIT(STATUS)
+ INTEGER, INTENT(IN), OPTIONAL :: STATUS */
+
+void
+prefix(exit_i4) (GFC_INTEGER_4 * status)
+{
+
+ if (status == NULL)
+ exit(0);
+ exit(*status);
+}
+
+void
+prefix(exit_i8) (GFC_INTEGER_8 * status)
+{
+
+ if (status == NULL)
+ exit(0);
+ exit((int) *status);
+}
--- /dev/null
+/* Implementation of the UMASK intrinsic.
+ Copyright (C) 2004 Free Software Foundation, Inc.
+ Contributed by Steven G. Kargl <kargls@comcast.net>.
+
+This file is part of the GNU Fortran 95 runtime library (libgfortran).
+
+Libgfortran is free software; you can redistribute it and/or
+modify it under the terms of the GNU Lesser General Public
+License as published by the Free Software Foundation; either
+version 2.1 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 Lesser General Public License for more details.
+
+You should have received a copy of the GNU Lesser General Public
+License along with libgfor; see the file COPYING.LIB. If not,
+write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA. */
+
+
+#include "config.h"
+#include "libgfortran.h"
+
+#ifdef HAVE_STDLIB_H
+#include <stdlib.h>
+#endif
+
+#ifdef HAVE_SYS_STAT_H
+#include <sys/stat.h>
+#endif
+
+/* SUBROUTINE UMASK(MASK, OLD)
+ INTEGER, INTENT(IN) :: MASK
+ INTEGER, INTENT(OUT), OPTIONAL :: OLD */
+
+void
+prefix(umask_i4_sub) (GFC_INTEGER_4 * mask, GFC_INTEGER_4 * old)
+{
+ mode_t val;
+
+ val = umask((mode_t) *mask);
+ if (old != NULL)
+ *old = (GFC_INTEGER_4) val;
+}
+
+void
+prefix(umask_i8_sub) (GFC_INTEGER_8 * mask, GFC_INTEGER_8 * old)
+{
+ mode_t val;
+
+ val = umask((mode_t) *mask);
+ if (old != NULL)
+ *old = (GFC_INTEGER_8) val;
+}
+
+/* INTEGER FUNCTION UMASK(MASK)
+ INTEGER, INTENT(IN) :: MASK */
+
+GFC_INTEGER_4
+prefix(umask) (GFC_INTEGER_4 * mask)
+{
+ GFC_INTEGER_4 old;
+ prefix(umask_i4_sub) (mask, &old);
+ return old;
+}
+
+GFC_INTEGER_8
+prefix(umask_i8) (GFC_INTEGER_8 * mask)
+{
+ GFC_INTEGER_8 old;
+ prefix(umask_i8_sub) (mask, &old);
+ return old;
+}
--- /dev/null
+/* Implementation of the UNLINK intrinsic.
+ Copyright (C) 2004 Free Software Foundation, Inc.
+ Contributed by Steven G. Kargl <kargls@comcast.net>.
+
+This file is part of the GNU Fortran 95 runtime library (libgfortran).
+
+Libgfortran is free software; you can redistribute it and/or
+modify it under the terms of the GNU Lesser General Public
+License as published by the Free Software Foundation; either
+version 2.1 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 Lesser General Public License for more details.
+
+You should have received a copy of the GNU Lesser General Public
+License along with libgfor; see the file COPYING.LIB. If not,
+write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA. */
+
+#include "config.h"
+#include "libgfortran.h"
+
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+#ifdef HAVE_STRING_H
+#include <string.h>
+#endif
+
+#include <errno.h>
+
+/* SUBROUTINE UNLINK(NAME, STATUS)
+ CHARACTER(LEN= ), INTENT(IN) :: NAME
+ INTEGER, INTENT(OUT), OPTIONAL :: STATUS) */
+
+void
+prefix(unlink_i4_sub) (char * name, GFC_INTEGER_4 * status,
+ gfc_charlen_type name_len)
+{
+
+ char *str, *s;
+ GFC_INTEGER_4 stat;
+
+ /* Trim trailing spaces from name. */
+ while (name_len > 0 && name[name_len - 1] == ' ')
+ name_len--;
+
+ /* Make a null terminated copy of the string. */
+ str = gfc_alloca (name_len + 1);
+ memcpy (str, name, name_len);
+ str[name_len] = '\0';
+
+ stat = unlink (str);
+
+ if (status != NULL)
+ *status = (stat == 0) ? stat : errno;
+}
+
+
+void
+prefix(unlink_i8_sub) (char * name, GFC_INTEGER_8 * status,
+ gfc_charlen_type name_len)
+{
+
+ GFC_INTEGER_4 status4;
+
+ prefix (unlink_i4_sub) (name, &status4, name_len);
+ if (status)
+ *status = status4;
+}
+
+
+/* INTEGER FUNCTION UNLINK(NAME)
+ CHARACTER(LEN= ), INTENT(IN) :: NAME */
+
+GFC_INTEGER_4
+prefix(unlink) (char * name, gfc_charlen_type name_len)
+{
+ GFC_INTEGER_4 status;
+ prefix(unlink_i4_sub) (name, &status, name_len);
+ return status;
+}
+
OSDN Git Service
