From 3b5c49c770792ea56ca6884adbcb8776c1e6e086 Mon Sep 17 00:00:00 2001 From: "Steven G. Kargl" Date: Thu, 2 Dec 2004 04:20:09 +0000 Subject: 2004-12-02 Steven G. Kargl Paul Brook libgfortran/ * intrinsics/flush.c: New file. * intrinsics/fnum.c: ditto * intrinsics/stat.c: ditto * io/io.h (unit_to_fd): Add prototype. * io/unix.c (unit_to_fd): New function. * configure.ac: Add test for members of struct stat. Check for sys/types.h and sys/stat.h * Makefile.am: Add intrinsics/{flush.c,fnum.c,stat.c} * configure.in: Regenerate. * config.h.in: Regenerate. * Makefile.in: Regenerate. fortran/ * check.c (gfc_check_flush, gfc_check_fnum): New functions. (gfc_check_fstat, gfc_check_fstat_sub): New functions. (gfc_check_stat, gfc_check_stat_sub): New functions. * gfortran.h (GFC_ISYM_FNUM,GFC_ISYM_FSTAT,GFC_ISYM_STAT): New symbols * intrinsic.c (add_functions,add_subroutines): Add flush, fnum, fstat, and stat to intrinsics symbol tables. * intrinsic.h (gfc_check_flush, gfc_resolve_stat_sub): Add prototypes. (gfc_resolve_fstat_sub, gfc_resolve_stat): Ditto. * iresolve.c (gfc_resolve_fnum, gfc_resolve_fstat): New functions. (gfc_resolve_stat, gfc_resolve_flush): New functions. (gfc_resolve_stat_sub,gfc_resolve_fstat_sub): New functions * trans-intrinsic.c (gfc_conv_intrinsic_function): Add new intrinsics. git-svn-id: https://gcc.gnu.org/svn/gcc/trunk@91611 138bc75d-0d04-0410-961f-82ee72b054a4 --- libgfortran/intrinsics/flush.c | 66 ++++++ libgfortran/intrinsics/fnum.c | 42 ++++ libgfortran/intrinsics/stat.c | 456 +++++++++++++++++++++++++++++++++++++++++ 3 files changed, 564 insertions(+) create mode 100644 libgfortran/intrinsics/flush.c create mode 100644 libgfortran/intrinsics/fnum.c create mode 100644 libgfortran/intrinsics/stat.c (limited to 'libgfortran') diff --git a/libgfortran/intrinsics/flush.c b/libgfortran/intrinsics/flush.c new file mode 100644 index 00000000000..4603d709f48 --- /dev/null +++ b/libgfortran/intrinsics/flush.c @@ -0,0 +1,66 @@ +/* Implementation of the FLUSH intrinsic. + Copyright (C) 2004 Free Software Foundation, Inc. + Contributed by Steven G. Kargl . + +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 +#endif + +#include "../io/io.h" + +/* SUBROUTINE FLUSH(UNIT) + INTEGER, INTENT(IN), OPTIONAL :: UNIT */ + +static void +recursive_flush (gfc_unit *us) +{ + /* There can be no open files. */ + if (us == NULL) + return; + + flush (us->s); + recursive_flush (us->left); + recursive_flush (us->right); +} + + +void +prefix(flush_i4) (GFC_INTEGER_4 * unit) +{ + + gfc_unit *us; + + /* flush all streams */ + if (unit == NULL) + { + us = g.unit_root; + recursive_flush(us); + } + else + { + us = find_unit(*unit); + if (us != NULL) + flush (us->s); + } +} diff --git a/libgfortran/intrinsics/fnum.c b/libgfortran/intrinsics/fnum.c new file mode 100644 index 00000000000..251cfb4e937 --- /dev/null +++ b/libgfortran/intrinsics/fnum.c @@ -0,0 +1,42 @@ +/* Implementation of the FNUM intrinsics. + Copyright (C) 2004 Free Software Foundation, Inc. + Contributed by Steven G. Kargl . + +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" + +#include "../io/io.h" + +/* FUNCTION FNUM(UNIT) + INTEGER FNUM + INTEGER, INTENT(IN), :: UNIT */ + +GFC_INTEGER_4 +prefix(fnum_i4) (GFC_INTEGER_4 * unit) +{ + return unit_to_fd (*unit); +} + + +GFC_INTEGER_8 +prefix(fnum_i8) (GFC_INTEGER_8 * unit) +{ + return unit_to_fd (*unit); +} diff --git a/libgfortran/intrinsics/stat.c b/libgfortran/intrinsics/stat.c new file mode 100644 index 00000000000..e597e44aa1c --- /dev/null +++ b/libgfortran/intrinsics/stat.c @@ -0,0 +1,456 @@ +/* Implementation of the STAT and FSTAT intrinsics. + Copyright (C) 2004 Free Software Foundation, Inc. + Contributed by Steven G. Kargl . + +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_SYS_TYPES_H +#include +#endif + +#ifdef HAVE_SYS_STAT_H +#include +#endif + +#ifdef HAVE_STDLIB_H +#include +#endif + +#ifdef HAVE_STRING_H +#include +#endif + +#include + +#include "../io/io.h" + +/* SUBROUTINE STAT(FILE, SARRAY, STATUS) + CHARACTER(len=*), INTENT(IN) :: FILE + INTEGER, INTENT(OUT), :: SARRAY(13) + INTEGER, INTENT(OUT), OPTIONAL :: STATUS + + FUNCTION STAT(FILE, SARRAY) + INTEGER STAT + CHARACTER(len=*), INTENT(IN) :: FILE + INTEGER, INTENT(OUT), :: SARRAY(13) */ + +void +prefix(stat_i4_sub) (char * name, gfc_array_i4 * sarray, + GFC_INTEGER_4 * status, gfc_charlen_type name_len) +{ + + int val; + char *str; + struct stat sb; + + index_type stride[GFC_MAX_DIMENSIONS - 1]; + + /* If the rank of the array is not 1, abort. */ + if (GFC_DESCRIPTOR_RANK (sarray) != 1) + runtime_error ("Array rank of SARRAY is not 1."); + + /* If the array is too small, abort. */ + if (sarray->dim[0].ubound + 1 - sarray->dim[0].lbound < 13) + runtime_error ("Array size of SARRAY is too small."); + + if (sarray->dim[0].stride == 0) + sarray->dim[0].stride = 1; + + /* 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'; + + val = stat(str, &sb); + + if (val == 0) + { + /* Device ID */ + sarray->data[0 * sarray->dim[0].stride] = sb.st_dev; + + /* Inode number */ + sarray->data[1 * sarray->dim[0].stride] = sb.st_ino; + + /* File mode */ + sarray->data[2 * sarray->dim[0].stride] = sb.st_mode; + + /* Number of (hard) links */ + sarray->data[3 * sarray->dim[0].stride] = sb.st_nlink; + + /* Owner's uid */ + sarray->data[4 * sarray->dim[0].stride] = sb.st_uid; + + /* Owner's gid */ + sarray->data[5 * sarray->dim[0].stride] = sb.st_gid; + + /* ID of device containing directory entry for file (0 if not available) */ +#if HAVE_STRUCT_STAT_ST_RDEV + sarray->data[6 * sarray->dim[0].stride] = sb.st_rdev; +#else + sarray->data[6 * sarray->dim[0].stride] = 0; +#endif + + /* File size (bytes) */ + sarray->data[7 * sarray->dim[0].stride] = sb.st_size; + + /* Last access time */ + sarray->data[8 * sarray->dim[0].stride] = sb.st_atime; + + /* Last modification time */ + sarray->data[9 * sarray->dim[0].stride] = sb.st_mtime; + + /* Last file status change time */ + sarray->data[10 * sarray->dim[0].stride] = sb.st_ctime; + + /* Preferred I/O block size (-1 if not available) */ +#if HAVE_STRUCT_STAT_ST_BLKSIZE + sarray->data[11 * sarray->dim[0].stride] = sb.st_blksize; +#else + sarray->data[11 * sarray->dim[0].stride] = -1; +#endif + + /* Number of blocks allocated (-1 if not available) */ +#if HAVE_STRUCT_STAT_ST_BLOCKS + sarray->data[12 * sarray->dim[0].stride] = sb.st_blocks; +#else + sarray->data[12 * sarray->dim[0].stride] = -1; +#endif + } + + if (status != NULL) + *status = (val == 0) ? 0 : errno; +} + +void +prefix(stat_i8_sub) (char * name, gfc_array_i8 * sarray, + GFC_INTEGER_8 * status, gfc_charlen_type name_len) +{ + + int val; + char *str; + struct stat sb; + + index_type stride[GFC_MAX_DIMENSIONS - 1]; + + /* If the rank of the array is not 1, abort. */ + if (GFC_DESCRIPTOR_RANK (sarray) != 1) + runtime_error ("Array rank of SARRAY is not 1."); + + /* If the array is too small, abort. */ + if (sarray->dim[0].ubound + 1 - sarray->dim[0].lbound < 13) + runtime_error ("Array size of SARRAY is too small."); + + if (sarray->dim[0].stride == 0) + sarray->dim[0].stride = 1; + + /* 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'; + + val = stat(str, &sb); + + if (val == 0) + { + /* Device ID */ + sarray->data[0] = sb.st_dev; + + /* Inode number */ + sarray->data[sarray->dim[0].stride] = sb.st_ino; + + /* File mode */ + sarray->data[2 * sarray->dim[0].stride] = sb.st_mode; + + /* Number of (hard) links */ + sarray->data[3 * sarray->dim[0].stride] = sb.st_nlink; + + /* Owner's uid */ + sarray->data[4 * sarray->dim[0].stride] = sb.st_uid; + + /* Owner's gid */ + sarray->data[5 * sarray->dim[0].stride] = sb.st_gid; + + /* ID of device containing directory entry for file (0 if not available) */ +#if HAVE_STRUCT_STAT_ST_RDEV + sarray->data[6 * sarray->dim[0].stride] = sb.st_rdev; +#else + sarray->data[6 * sarray->dim[0].stride] = 0; +#endif + + /* File size (bytes) */ + sarray->data[7 * sarray->dim[0].stride] = sb.st_size; + + /* Last access time */ + sarray->data[8 * sarray->dim[0].stride] = sb.st_atime; + + /* Last modification time */ + sarray->data[9 * sarray->dim[0].stride] = sb.st_mtime; + + /* Last file status change time */ + sarray->data[10 * sarray->dim[0].stride] = sb.st_ctime; + + /* Preferred I/O block size (-1 if not available) */ +#if HAVE_STRUCT_STAT_ST_BLKSIZE + sarray->data[11 * sarray->dim[0].stride] = sb.st_blksize; +#else + sarray->data[11 * sarray->dim[0].stride] = -1; +#endif + + /* Number of blocks allocated (-1 if not available) */ +#if HAVE_STRUCT_STAT_ST_BLOCKS + sarray->data[12 * sarray->dim[0].stride] = sb.st_blocks; +#else + sarray->data[12 * sarray->dim[0].stride] = -1; +#endif + } + + if (status != NULL) + *status = (val == 0) ? 0 : errno; +} + + +GFC_INTEGER_4 +prefix(stat_i4) (char * name, gfc_array_i4 * sarray, + gfc_charlen_type name_len) +{ + + GFC_INTEGER_4 val; + prefix(stat_i4_sub) (name, sarray, &val, name_len); + return val; +} + + +GFC_INTEGER_8 +prefix(stat_i8) (char * name, gfc_array_i8 * sarray, + gfc_charlen_type name_len) +{ + + GFC_INTEGER_8 val; + prefix(stat_i8_sub) (name, sarray, &val, name_len); + return val; +} + + +/* SUBROUTINE FSTAT(UNIT, SARRAY, STATUS) + INTEGER, INTENT(IN) :: UNIT + INTEGER, INTENT(OUT) :: SARRAY(13) + INTEGER, INTENT(OUT), OPTIONAL :: STATUS + + FUNCTION FSTAT(UNIT, SARRAY) + INTEGER FSTAT + INTEGER, INTENT(IN) :: UNIT + INTEGER, INTENT(OUT) :: SARRAY(13) */ + +void +prefix(fstat_i4_sub) (GFC_INTEGER_4 * unit, gfc_array_i4 * sarray, + GFC_INTEGER_4 * status) +{ + + int val; + struct stat sb; + + index_type stride[GFC_MAX_DIMENSIONS - 1]; + + /* If the rank of the array is not 1, abort. */ + if (GFC_DESCRIPTOR_RANK (sarray) != 1) + runtime_error ("Array rank of SARRAY is not 1."); + + /* If the array is too small, abort. */ + if (sarray->dim[0].ubound + 1 - sarray->dim[0].lbound < 13) + runtime_error ("Array size of SARRAY is too small."); + + if (sarray->dim[0].stride == 0) + sarray->dim[0].stride = 1; + + /* Convert Fortran unit number to C file descriptor. */ + val = unit_to_fd (*unit); + if (val >= 0) + val = fstat(val, &sb); + + if (val == 0) + { + /* Device ID */ + sarray->data[0 * sarray->dim[0].stride] = sb.st_dev; + + /* Inode number */ + sarray->data[1 * sarray->dim[0].stride] = sb.st_ino; + + /* File mode */ + sarray->data[2 * sarray->dim[0].stride] = sb.st_mode; + + /* Number of (hard) links */ + sarray->data[3 * sarray->dim[0].stride] = sb.st_nlink; + + /* Owner's uid */ + sarray->data[4 * sarray->dim[0].stride] = sb.st_uid; + + /* Owner's gid */ + sarray->data[5 * sarray->dim[0].stride] = sb.st_gid; + + /* ID of device containing directory entry for file (0 if not available) */ +#if HAVE_STRUCT_STAT_ST_RDEV + sarray->data[6 * sarray->dim[0].stride] = sb.st_rdev; +#else + sarray->data[6 * sarray->dim[0].stride] = 0; +#endif + + /* File size (bytes) */ + sarray->data[7 * sarray->dim[0].stride] = sb.st_size; + + /* Last access time */ + sarray->data[8 * sarray->dim[0].stride] = sb.st_atime; + + /* Last modification time */ + sarray->data[9 * sarray->dim[0].stride] = sb.st_mtime; + + /* Last file status change time */ + sarray->data[10 * sarray->dim[0].stride] = sb.st_ctime; + + /* Preferred I/O block size (-1 if not available) */ +#if HAVE_STRUCT_STAT_ST_BLKSIZE + sarray->data[11 * sarray->dim[0].stride] = sb.st_blksize; +#else + sarray->data[11 * sarray->dim[0].stride] = -1; +#endif + + /* Number of blocks allocated (-1 if not available) */ +#if HAVE_STRUCT_STAT_ST_BLOCKS + sarray->data[12 * sarray->dim[0].stride] = sb.st_blocks; +#else + sarray->data[12 * sarray->dim[0].stride] = -1; +#endif + } + + if (status != NULL) + *status = (val == 0) ? 0 : errno; +} + +void +prefix(fstat_i8_sub) (GFC_INTEGER_8 * unit, gfc_array_i8 * sarray, + GFC_INTEGER_8 * status) +{ + + int val; + struct stat sb; + + index_type stride[GFC_MAX_DIMENSIONS - 1]; + + /* If the rank of the array is not 1, abort. */ + if (GFC_DESCRIPTOR_RANK (sarray) != 1) + runtime_error ("Array rank of SARRAY is not 1."); + + /* If the array is too small, abort. */ + if (sarray->dim[0].ubound + 1 - sarray->dim[0].lbound < 13) + runtime_error ("Array size of SARRAY is too small."); + + if (sarray->dim[0].stride == 0) + sarray->dim[0].stride = 1; + + /* Convert Fortran unit number to C file descriptor. */ + val = unit_to_fd ((int) *unit); + if (val >= 0) + val = fstat(val, &sb); + + if (val == 0) + { + /* Device ID */ + sarray->data[0] = sb.st_dev; + + /* Inode number */ + sarray->data[sarray->dim[0].stride] = sb.st_ino; + + /* File mode */ + sarray->data[2 * sarray->dim[0].stride] = sb.st_mode; + + /* Number of (hard) links */ + sarray->data[3 * sarray->dim[0].stride] = sb.st_nlink; + + /* Owner's uid */ + sarray->data[4 * sarray->dim[0].stride] = sb.st_uid; + + /* Owner's gid */ + sarray->data[5 * sarray->dim[0].stride] = sb.st_gid; + + /* ID of device containing directory entry for file (0 if not available) */ +#if HAVE_STRUCT_STAT_ST_RDEV + sarray->data[6 * sarray->dim[0].stride] = sb.st_rdev; +#else + sarray->data[6 * sarray->dim[0].stride] = 0; +#endif + + /* File size (bytes) */ + sarray->data[7 * sarray->dim[0].stride] = sb.st_size; + + /* Last access time */ + sarray->data[8 * sarray->dim[0].stride] = sb.st_atime; + + /* Last modification time */ + sarray->data[9 * sarray->dim[0].stride] = sb.st_mtime; + + /* Last file status change time */ + sarray->data[10 * sarray->dim[0].stride] = sb.st_ctime; + + /* Preferred I/O block size (-1 if not available) */ +#if HAVE_STRUCT_STAT_ST_BLKSIZE + sarray->data[11 * sarray->dim[0].stride] = sb.st_blksize; +#else + sarray->data[11 * sarray->dim[0].stride] = -1; +#endif + + /* Number of blocks allocated (-1 if not available) */ +#if HAVE_STRUCT_STAT_ST_BLOCKS + sarray->data[12 * sarray->dim[0].stride] = sb.st_blocks; +#else + sarray->data[12 * sarray->dim[0].stride] = -1; +#endif + } + + if (status != NULL) + *status = (val == 0) ? 0 : errno; +} + + +GFC_INTEGER_4 +prefix(fstat_i4) (GFC_INTEGER_4 * unit, gfc_array_i4 * sarray) +{ + + GFC_INTEGER_4 val; + prefix(fstat_i4_sub) (unit, sarray, &val); + return val; +} + + +GFC_INTEGER_8 +prefix(fstat_i8) (GFC_INTEGER_8 * unit, gfc_array_i8 * sarray) +{ + + GFC_INTEGER_8 val; + prefix(fstat_i8_sub) (unit, sarray, &val); + return val; +} -- cgit v1.2.3