mirrors/gcc
1
0
Fork 0
mirror of https://gcc.gnu.org/git/gcc.git synced 2024-11-25 11:54:01 +08:00
Code Issues Actions Packages Projects Releases Wiki Activity

check.c (gfc_check_getcwd_sub): Fix seg fault.

Browse Source 
* 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

libgfortran/
	* 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

From-SVN: r90949
This commit is contained in:
Steven G. Kargl 2004-11-20 01:44:49 +00:00 committed by Steven Bosscher
parent 449ecb09b3
commit d8fe26b2cd
12 changed files with 460 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
gcc/fortran/ChangeLog
View File

@ -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

88
gcc/fortran/check.c
View File

@ -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;

2
gcc/fortran/gfortran.h
View File

@ -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

29
gcc/fortran/intrinsic.c
View File

@ -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);
}

18
gcc/fortran/intrinsic.h
View File

@ -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. */

75
gcc/fortran/iresolve.c
View File

@ -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)
{

2
gcc/fortran/trans-intrinsic.c
View File

@ -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;

34
libgfortran/ChangeLog
View File

@ -1,3 +1,11 @@
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.
@ -273,7 +281,7 @@
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>
@ -545,9 +553,9 @@
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>
@ -743,7 +751,7 @@
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>
@ -809,7 +817,7 @@
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>
@ -1233,14 +1241,14 @@
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>

3
libgfortran/Makefile.am
View File

@ -50,6 +50,7 @@ intrinsics/erf.c \
intrinsics/eoshift0.c \
intrinsics/eoshift2.c \
intrinsics/etime.c \
intrinsics/exit.c \
intrinsics/getcwd.c \
intrinsics/getXid.c \
intrinsics/ishftc.c \
@ -67,6 +68,8 @@ intrinsics/selected_int_kind.f90 \
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 \

49
libgfortran/intrinsics/exit.c Normal file
View File

@ -0,0 +1,49 @@
/* 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);
}

75
libgfortran/intrinsics/umask.c Normal file
View File

@ -0,0 +1,75 @@
/* 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;
}

85
libgfortran/intrinsics/unlink.c Normal file
View File

@ -0,0 +1,85 @@
/* 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;
}