This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
[patch, gfortran] Implement some more g77 intrinsics
- From: François-Xavier Coudert<Francois-Xavier dot Coudert at lcp dot u-psud dot fr>
- To: gcc-patches at gcc dot gnu dot org
- Cc: fortran at gcc dot gnu dot org
- Date: Tue, 01 Feb 2005 00:22:15 +0100
- Subject: [patch, gfortran] Implement some more g77 intrinsics
- Organization: Laboratoire de Chimie Physique
Since this is my first patch, I hope I did it right. Attached is the
diff and the new files to be included.
As I did not yet receive the paperwork for copyright assignment, I
hereby donate this code to the Free Software Fundation, and I hope it is
enough.
2005-01-31 François-Xavier Coudert <coudert@clipper.ens.fr>
Implement more g77 intrinsic functions and subroutines.
* chdir.c, gerror.c, getlog.c, hostnm.c, ierrno.c, kill.c,
link.c, perror.c, rename.c, sleep.c, symlnk.c, time.c: implement
intrinsics themselves.
* gcc/fortran/check.c, gcc/fortran/gfortran.h,
gcc/fortran/intrinsic.c, gcc/fortran/intrinsic.h,
gcc/fortran/iresolve.c, gcc/fortran/trans-intrinsic.c,
libgfortran/Makefile.am, libgfortran/configure.ac:
* gcc/fortran/invoke.texi: corrected typos.
/* Implementation of the CHDIR intrinsic.
Copyright (C) 2005 Free Software Foundation, Inc.
Contributed by François-Xavier Coudert <coudert@clipper.ens.fr>
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 General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
In addition to the permissions in the GNU General Public License, the
Free Software Foundation gives you unlimited permission to link the
compiled version of this file into combinations with other programs,
and to distribute those combinations without any restriction coming
from the use of this file. (The General Public License restrictions
do apply in other respects; for example, they cover modification of
the file, and distribution when not linked into a combine
executable.)
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 General Public License for more details.
You should have received a copy of the GNU General Public
License along with libgfortran; see the file COPYING. 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 <errno.h>
#include "../io/io.h"
#ifdef HAVE_UNISTD_H
#include <unistd.h>
#endif
/* SUBROUTINE CHDIR(DIR, STATUS)
CHARACTER(len=*), INTENT(IN) :: DIR
INTEGER, INTENT(OUT), OPTIONAL :: STATUS */
#ifdef HAVE_CHDIR
extern void chdir_i4_sub (char *, GFC_INTEGER_4 *, gfc_charlen_type);
iexport_proto(chdir_i4_sub);
void
chdir_i4_sub (char *dir, GFC_INTEGER_4 *status, gfc_charlen_type dir_len)
{
int val;
char *str;
/* Trim trailing spaces from paths. */
while (dir_len > 0 && dir[dir_len - 1] == ' ')
dir_len--;
/* Make a null terminated copy of the strings. */
str = gfc_alloca (dir_len + 1);
memcpy (str, dir, dir_len);
str[dir_len] = '\0';
val = chdir (str);
if (status != NULL)
*status = (val == 0) ? 0 : errno;
}
iexport(chdir_i4_sub);
extern void chdir_i8_sub (char *, GFC_INTEGER_8 *, gfc_charlen_type);
iexport_proto(chdir_i8_sub);
void
chdir_i8_sub (char *dir, GFC_INTEGER_8 *status, gfc_charlen_type dir_len)
{
int val;
char *str;
/* Trim trailing spaces from paths. */
while (dir_len > 0 && dir[dir_len - 1] == ' ')
dir_len--;
/* Make a null terminated copy of the strings. */
str = gfc_alloca (dir_len + 1);
memcpy (str, dir, dir_len);
str[dir_len] = '\0';
val = chdir (str);
if (status != NULL)
*status = (val == 0) ? 0 : errno;
}
iexport(chdir_i8_sub);
extern GFC_INTEGER_4 chdir_i4 (char *, gfc_charlen_type);
export_proto(chdir_i4);
GFC_INTEGER_4
chdir_i4 (char *dir, gfc_charlen_type dir_len)
{
GFC_INTEGER_4 val;
chdir_i4_sub (dir, &val, dir_len);
return val;
}
extern GFC_INTEGER_8 chdir_i8 (char *, gfc_charlen_type);
export_proto(chdir_i8);
GFC_INTEGER_8
chdir_i8 (char *dir, gfc_charlen_type dir_len)
{
GFC_INTEGER_8 val;
chdir_i8_sub (dir, &val, dir_len);
return val;
}
#endif
? libgfortran/intrinsics/chdir.c
? libgfortran/intrinsics/gerror.c
? libgfortran/intrinsics/getlog.c
? libgfortran/intrinsics/hostnm.c
? libgfortran/intrinsics/ierrno.c
? libgfortran/intrinsics/kill.c
? libgfortran/intrinsics/link.c
? libgfortran/intrinsics/perror.c
? libgfortran/intrinsics/rename.c
? libgfortran/intrinsics/sleep.c
? libgfortran/intrinsics/symlnk.c
? libgfortran/intrinsics/time.c
Index: gcc/fortran/check.c
===================================================================
RCS file: /cvsroot/gcc/gcc/gcc/fortran/check.c,v
retrieving revision 1.23
diff -r1.23 check.c
567a568,596
> gfc_check_chdir (gfc_expr * dir)
> {
> if (type_check (dir, 0, BT_CHARACTER) == FAILURE)
> return FAILURE;
>
> return SUCCESS;
> }
>
>
> try
> gfc_check_chdir_sub (gfc_expr * dir, gfc_expr * status)
> {
> if (type_check (dir, 0, BT_CHARACTER) == FAILURE)
> return FAILURE;
>
> if (status == NULL)
> return SUCCESS;
>
> if (type_check (status, 2, BT_INTEGER) == FAILURE)
> return FAILURE;
>
> if (scalar_check (status, 2) == FAILURE)
> return FAILURE;
>
> return SUCCESS;
> }
>
>
> try
992a1022,1053
> gfc_check_kill (gfc_expr * pid, gfc_expr * sig)
> {
> if (type_check (pid, 0, BT_INTEGER) == FAILURE)
> return FAILURE;
>
> if (type_check (sig, 1, BT_INTEGER) == FAILURE)
> return FAILURE;
>
> return SUCCESS;
> }
>
>
> try
> gfc_check_kill_sub (gfc_expr * pid, gfc_expr * sig, gfc_expr * status)
> {
> if (type_check (pid, 0, BT_INTEGER) == FAILURE)
> return FAILURE;
>
> if (type_check (sig, 1, BT_INTEGER) == FAILURE)
> return FAILURE;
>
> if (type_check (status, 2, BT_INTEGER) == FAILURE)
> return FAILURE;
>
> if (scalar_check (status, 2) == FAILURE)
> return FAILURE;
>
> return SUCCESS;
> }
>
>
> try
1023a1085,1154
> gfc_check_link (gfc_expr * path1, gfc_expr * path2)
> {
> if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
> return FAILURE;
>
> if (type_check (path2, 0, BT_CHARACTER) == FAILURE)
> return FAILURE;
>
> return SUCCESS;
> }
>
>
> try
> gfc_check_link_sub (gfc_expr * path1, gfc_expr * path2, gfc_expr * status)
> {
> if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
> return FAILURE;
>
> if (type_check (path2, 0, BT_CHARACTER) == FAILURE)
> return FAILURE;
>
> if (status == NULL)
> return SUCCESS;
>
> if (type_check (status, 2, BT_INTEGER) == FAILURE)
> return FAILURE;
>
> if (scalar_check (status, 2) == FAILURE)
> return FAILURE;
>
> return SUCCESS;
> }
>
>
> try
> gfc_check_symlnk (gfc_expr * path1, gfc_expr * path2)
> {
> if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
> return FAILURE;
>
> if (type_check (path2, 0, BT_CHARACTER) == FAILURE)
> return FAILURE;
>
> return SUCCESS;
> }
>
>
> try
> gfc_check_symlnk_sub (gfc_expr * path1, gfc_expr * path2, gfc_expr * status)
> {
> if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
> return FAILURE;
>
> if (type_check (path2, 0, BT_CHARACTER) == FAILURE)
> return FAILURE;
>
> if (status == NULL)
> return SUCCESS;
>
> if (type_check (status, 2, BT_INTEGER) == FAILURE)
> return FAILURE;
>
> if (scalar_check (status, 2) == FAILURE)
> return FAILURE;
>
> return SUCCESS;
> }
>
>
> try
1438a1570,1604
> gfc_check_rename (gfc_expr * path1, gfc_expr * path2)
> {
> if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
> return FAILURE;
>
> if (type_check (path2, 0, BT_CHARACTER) == FAILURE)
> return FAILURE;
>
> return SUCCESS;
> }
>
>
> try
> gfc_check_rename_sub (gfc_expr * path1, gfc_expr * path2, gfc_expr * status)
> {
> if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
> return FAILURE;
>
> if (type_check (path2, 0, BT_CHARACTER) == FAILURE)
> return FAILURE;
>
> if (status == NULL)
> return SUCCESS;
>
> if (type_check (status, 2, BT_INTEGER) == FAILURE)
> return FAILURE;
>
> if (scalar_check (status, 2) == FAILURE)
> return FAILURE;
>
> return SUCCESS;
> }
>
>
> try
1628a1795,1807
> gfc_check_sleep_sub (gfc_expr * seconds)
> {
> if (type_check (seconds, 2, BT_INTEGER) == FAILURE)
> return FAILURE;
>
> if (scalar_check (seconds, 2) == FAILURE)
> return FAILURE;
>
> return SUCCESS;
> }
>
>
> try
2204a2384,2393
> gfc_check_gerror (gfc_expr * msg)
> {
> if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
> return FAILURE;
>
> return SUCCESS;
> }
>
>
> try
2223a2413,2422
> gfc_check_getlog (gfc_expr * msg)
> {
> if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
> return FAILURE;
>
> return SUCCESS;
> }
>
>
> try
2255a2455,2493
> gfc_check_hostnm (gfc_expr * name)
> {
> if (type_check (name, 0, BT_CHARACTER) == FAILURE)
> return FAILURE;
>
> return SUCCESS;
> }
>
>
> try
> gfc_check_hostnm_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;
>
> if (type_check (status, 1, BT_INTEGER) == FAILURE)
> return FAILURE;
>
> return SUCCESS;
> }
>
>
> try
> gfc_check_perror (gfc_expr * string)
> {
> if (type_check (string, 0, BT_CHARACTER) == FAILURE)
> return FAILURE;
>
> return SUCCESS;
> }
>
>
> try
Index: gcc/fortran/gfortran.h
===================================================================
RCS file: /cvsroot/gcc/gcc/gcc/fortran/gfortran.h,v
retrieving revision 1.51
diff -r1.51 gfortran.h
294a295
> GFC_ISYM_CHDIR,
319a321
> GFC_ISYM_HOSTNM,
327a330
> GFC_ISYM_IERRNO,
333a337
> GFC_ISYM_KILL,
336a341
> GFC_ISYM_LINK,
361a367
> GFC_ISYM_RENAME,
380a387
> GFC_ISYM_SYMLNK,
383a391,392
> GFC_ISYM_TIME,
> GFC_ISYM_TIME8,
Index: gcc/fortran/intrinsic.c
===================================================================
RCS file: /cvsroot/gcc/gcc/gcc/fortran/intrinsic.c,v
retrieving revision 1.38
diff -r1.38 intrinsic.c
933c933
<
---
>
1092a1093,1098
> add_sym_1 ("chdir", 0, 1, BT_INTEGER, di, GFC_STD_GNU,
> gfc_check_chdir, NULL, gfc_resolve_chdir,
> a, BT_CHARACTER, dc, REQUIRED);
>
> make_generic ("chdir", GFC_ISYM_CHDIR, GFC_STD_GNU);
>
1323a1330,1335
> add_sym_1 ("hostnm", 0, 1, BT_INTEGER, di, GFC_STD_GNU,
> gfc_check_hostnm, NULL, gfc_resolve_hostnm,
> a, BT_CHARACTER, dc, REQUIRED);
>
> make_generic ("hostnm", GFC_ISYM_HOSTNM, GFC_STD_GNU);
>
1383a1396,1400
> add_sym_0 ("ierrno", 1, 0, BT_INTEGER, di, GFC_STD_GNU,
> NULL, NULL, gfc_resolve_ierrno);
>
> make_generic ("ierrno", GFC_ISYM_IERRNO, GFC_STD_GNU);
>
1430a1448,1453
> add_sym_2 ("kill", 1, 1, BT_INTEGER, di, GFC_STD_GNU,
> gfc_check_kill, NULL, gfc_resolve_kill,
> a, BT_INTEGER, di, REQUIRED, b, BT_INTEGER, di, REQUIRED);
>
> make_generic ("kill", GFC_ISYM_KILL, GFC_STD_GNU);
>
1452a1476,1477
> make_alias ("lnblnk", GFC_STD_GNU);
>
1478a1504,1509
> add_sym_2 ("link", 0, 1, BT_INTEGER, di, GFC_STD_GNU,
> gfc_check_link, NULL, gfc_resolve_link,
> a, BT_CHARACTER, dc, REQUIRED, b, BT_CHARACTER, dc, REQUIRED);
>
> make_generic ("link", GFC_ISYM_LINK, GFC_STD_GNU);
>
1744a1776,1781
> add_sym_2 ("rename", 0, 1, BT_INTEGER, di, GFC_STD_GNU,
> gfc_check_rename, NULL, gfc_resolve_rename,
> a, BT_CHARACTER, dc, REQUIRED, b, BT_CHARACTER, dc, REQUIRED);
>
> make_generic ("rename", GFC_ISYM_RENAME, GFC_STD_GNU);
>
1904a1942,1947
> add_sym_2 ("symlnk", 0, 1, BT_INTEGER, di, GFC_STD_GNU,
> gfc_check_symlnk, NULL, gfc_resolve_symlnk,
> a, BT_CHARACTER, dc, REQUIRED, b, BT_CHARACTER, dc, REQUIRED);
>
> make_generic ("symlnk", GFC_ISYM_SYMLNK, GFC_STD_GNU);
>
1930a1974,1983
> add_sym_0 ("time", 1, 0, BT_INTEGER, di, GFC_STD_GNU,
> NULL, NULL, gfc_resolve_time);
>
> make_generic ("time", GFC_ISYM_TIME, GFC_STD_GNU);
>
> add_sym_0 ("time8", 1, 0, BT_INTEGER, di, GFC_STD_GNU,
> NULL, NULL, gfc_resolve_time8);
>
> make_generic ("time8", GFC_ISYM_TIME8, GFC_STD_GNU);
>
2024a2078,2081
> add_sym_2s ("chdir", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
> gfc_check_chdir_sub, NULL, gfc_resolve_chdir_sub,
> name, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
>
2038a2096,2099
> add_sym_1s ("gerror", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
> gfc_check_gerror, NULL, gfc_resolve_gerror, c, BT_CHARACTER,
> dc, REQUIRED);
>
2050a2112,2115
> add_sym_1s ("getlog", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
> gfc_check_getlog, NULL, gfc_resolve_getlog, c, BT_CHARACTER,
> dc, REQUIRED);
>
2098a2164,2189
> add_sym_2s ("hostnm", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
> gfc_check_hostnm_sub, NULL, gfc_resolve_hostnm_sub,
> c, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
>
> add_sym_3s ("kill", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU, gfc_check_kill_sub,
> NULL, gfc_resolve_kill_sub, name, BT_INTEGER, di, REQUIRED,
> val, BT_INTEGER, di, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
>
> add_sym_3s ("link", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
> gfc_check_link_sub, NULL, gfc_resolve_link_sub,
> name, BT_CHARACTER, dc, REQUIRED, val, BT_CHARACTER,
> dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
>
> add_sym_1s ("perror", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
> gfc_check_perror, NULL, gfc_resolve_perror,
> c, BT_CHARACTER, dc, REQUIRED);
>
> add_sym_3s ("rename", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
> gfc_check_rename_sub, NULL, gfc_resolve_rename_sub,
> name, BT_CHARACTER, dc, REQUIRED, val, BT_CHARACTER,
> dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
>
> add_sym_1s ("sleep", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
> gfc_check_sleep_sub, NULL, gfc_resolve_sleep_sub,
> val, BT_CHARACTER, dc, REQUIRED);
>
2108a2200,2204
> add_sym_3s ("symlnk", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
> gfc_check_symlnk_sub, NULL, gfc_resolve_symlnk_sub,
> name, BT_CHARACTER, dc, REQUIRED, val, BT_CHARACTER,
> dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
>
Index: gcc/fortran/intrinsic.h
===================================================================
RCS file: /cvsroot/gcc/gcc/gcc/fortran/intrinsic.h,v
retrieving revision 1.21
diff -r1.21 intrinsic.h
40a41
> try gfc_check_chdir (gfc_expr *);
55a57
> try gfc_check_hostnm (gfc_expr *);
69a72
> try gfc_check_kill (gfc_expr *, gfc_expr *);
71a75
> try gfc_check_link (gfc_expr *, gfc_expr *);
90a95
> try gfc_check_rename (gfc_expr *, gfc_expr *);
104a110
> try gfc_check_symlnk (gfc_expr *, gfc_expr *);
116a123
> try gfc_check_chdir_sub (gfc_expr *, gfc_expr *);
122a130,131
> try gfc_check_gerror (gfc_expr *);
> try gfc_check_getlog (gfc_expr *);
128a138,144
> try gfc_check_hostnm_sub (gfc_expr *, gfc_expr *);
> try gfc_check_kill_sub (gfc_expr *, gfc_expr *, gfc_expr *);
> try gfc_check_perror (gfc_expr *);
> try gfc_check_rename_sub (gfc_expr *, gfc_expr *, gfc_expr *);
> try gfc_check_link_sub (gfc_expr *, gfc_expr *, gfc_expr *);
> try gfc_check_symlnk_sub (gfc_expr *, gfc_expr *, gfc_expr *);
> try gfc_check_sleep_sub (gfc_expr *);
255a272
> void gfc_resolve_chdir (gfc_expr *, gfc_expr *);
280a298
> void gfc_resolve_hostnm (gfc_expr *, gfc_expr *);
284a303
> void gfc_resolve_ierrno (gfc_expr *);
291a311
> void gfc_resolve_kill (gfc_expr *, gfc_expr *, gfc_expr *);
294a315
> void gfc_resolve_link (gfc_expr *, gfc_expr *, gfc_expr *);
313a335
> void gfc_resolve_rename (gfc_expr *, gfc_expr *, gfc_expr *);
331a354
> void gfc_resolve_symlnk (gfc_expr *, gfc_expr *, gfc_expr *);
334a358,359
> void gfc_resolve_time (gfc_expr *);
> void gfc_resolve_time8 (gfc_expr *);
345a371
> void gfc_resolve_chdir_sub (gfc_code *);
349a376
> void gfc_resolve_gerror (gfc_code *);
351a379
> void gfc_resolve_getlog (gfc_code *);
354a383,384
> void gfc_resolve_hostnm_sub (gfc_code *);
> void gfc_resolve_kill_sub (gfc_code *);
355a386
> void gfc_resolve_perror (gfc_code *);
356a388,391
> void gfc_resolve_rename_sub (gfc_code *);
> void gfc_resolve_link_sub (gfc_code *);
> void gfc_resolve_symlnk_sub (gfc_code *);
> void gfc_resolve_sleep_sub (gfc_code *);
Index: gcc/fortran/invoke.texi
===================================================================
RCS file: /cvsroot/gcc/gcc/gcc/fortran/invoke.texi,v
retrieving revision 1.7
diff -r1.7 invoke.texi
374,375c374,375
< An INTEGER SELECT construct has a CASE the can never be matched as it's
< lower value that is greater than its upper value.
---
> An INTEGER SELECT construct has a CASE that can never be matched as its
> lower value is greater than its upper value.
Index: gcc/fortran/iresolve.c
===================================================================
RCS file: /cvsroot/gcc/gcc/gcc/fortran/iresolve.c,v
retrieving revision 1.31
diff -r1.31 iresolve.c
255a256,280
> gfc_resolve_chdir (gfc_expr * f, gfc_expr * d ATTRIBUTE_UNUSED)
> {
> f->ts.type = BT_INTEGER;
> f->ts.kind = gfc_default_integer_kind;
> f->value.function.name = gfc_get_string (PREFIX("chdir_i%d"), f->ts.kind);
> }
>
>
> void
> gfc_resolve_chdir_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("chdir_i%d_sub"), kind);
> c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
> }
>
>
> void
535a561,568
> gfc_resolve_hostnm (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 ("hostnm"));
> }
>
> void
598a632,640
> gfc_resolve_ierrno (gfc_expr * f)
> {
> f->ts.type = BT_INTEGER;
> f->ts.kind = gfc_default_integer_kind;
> f->value.function.name = gfc_get_string (PREFIX("ierrno_i%d"), f->ts.kind);
> }
>
>
> void
672a715,724
> gfc_resolve_kill (gfc_expr * f, gfc_expr * p, gfc_expr * s)
> {
> f->ts.type = BT_INTEGER;
> f->ts.kind = gfc_default_integer_kind;
>
> f->value.function.name = gfc_get_string (PREFIX("kill_i%d"), f->ts.kind);
> }
>
>
> void
710a763,772
> gfc_resolve_link (gfc_expr * f, gfc_expr * p1 ATTRIBUTE_UNUSED,
> gfc_expr * p2 ATTRIBUTE_UNUSED)
> {
> f->ts.type = BT_INTEGER;
> f->ts.kind = gfc_default_integer_kind;
> f->value.function.name = gfc_get_string (PREFIX("link_i%d"), f->ts.kind);
> }
>
>
> void
1021a1084,1093
> gfc_resolve_rename (gfc_expr * f, gfc_expr * p1 ATTRIBUTE_UNUSED,
> gfc_expr * p2 ATTRIBUTE_UNUSED)
> {
> f->ts.type = BT_INTEGER;
> f->ts.kind = gfc_default_integer_kind;
> f->value.function.name = gfc_get_string (PREFIX("rename_i%d"), f->ts.kind);
> }
>
>
> void
1277a1350,1359
> void
> gfc_resolve_symlnk (gfc_expr * f, gfc_expr * p1 ATTRIBUTE_UNUSED,
> gfc_expr * p2 ATTRIBUTE_UNUSED)
> {
> f->ts.type = BT_INTEGER;
> f->ts.kind = gfc_default_integer_kind;
> f->value.function.name = gfc_get_string (PREFIX("symlnk_i%d"), f->ts.kind);
> }
>
>
1307a1390,1407
> gfc_resolve_time (gfc_expr * f)
> {
> f->ts.type = BT_INTEGER;
> f->ts.kind = 4;
> f->value.function.name = gfc_get_string (PREFIX("time_func"));
> }
>
>
> void
> gfc_resolve_time8 (gfc_expr * f)
> {
> f->ts.type = BT_INTEGER;
> f->ts.kind = 8;
> f->value.function.name = gfc_get_string (PREFIX("time8_func"));
> }
>
>
> void
1492a1593,1656
> void
> gfc_resolve_rename_sub (gfc_code * c)
> {
> const char *name;
> int kind;
>
> if (c->ext.actual->next->next->expr != NULL)
> kind = c->ext.actual->next->next->expr->ts.kind;
> else
> kind = gfc_default_integer_kind;
>
> name = gfc_get_string (PREFIX("rename_i%d_sub"), kind);
> c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
> }
>
>
> void
> gfc_resolve_kill_sub (gfc_code * c)
> {
> const char *name;
> int kind;
>
> if (c->ext.actual->next->next->expr != NULL)
> kind = c->ext.actual->next->next->expr->ts.kind;
> else
> kind = gfc_default_integer_kind;
>
> name = gfc_get_string (PREFIX("kill_i%d_sub"), kind);
> c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
> }
>
>
> void
> gfc_resolve_link_sub (gfc_code * c)
> {
> const char *name;
> int kind;
>
> if (c->ext.actual->next->next->expr != NULL)
> kind = c->ext.actual->next->next->expr->ts.kind;
> else
> kind = gfc_default_integer_kind;
>
> name = gfc_get_string (PREFIX("link_i%d_sub"), kind);
> c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
> }
>
>
> void
> gfc_resolve_symlnk_sub (gfc_code * c)
> {
> const char *name;
> int kind;
>
> if (c->ext.actual->next->next->expr != NULL)
> kind = c->ext.actual->next->next->expr->ts.kind;
> else
> kind = gfc_default_integer_kind;
>
> name = gfc_get_string (PREFIX("symlnk_i%d_sub"), kind);
> c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
> }
>
>
1516a1681,1696
> void
> gfc_resolve_sleep_sub (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("sleep_i%d_sub"), kind);
> c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
> }
>
>
1667a1848,1884
>
> void
> gfc_resolve_gerror (gfc_code * c)
> {
> c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("gerror"));
> }
>
>
> void
> gfc_resolve_getlog (gfc_code * c)
> {
> c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("getlog"));
> }
>
>
> void
> gfc_resolve_hostnm_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("hostnm_i%d_sub"), kind);
> c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
> }
>
>
> void
> gfc_resolve_perror (gfc_code * c)
> {
> c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("perror_sub"));
> }
>
Index: gcc/fortran/trans-intrinsic.c
===================================================================
RCS file: /cvsroot/gcc/gcc/gcc/fortran/trans-intrinsic.c,v
retrieving revision 1.43
diff -r1.43 trans-intrinsic.c
2982a2983
> case GFC_ISYM_CHDIR:
2990a2992,2994
> case GFC_ISYM_HOSTNM:
> case GFC_ISYM_KILL:
> case GFC_ISYM_IERRNO:
2991a2996
> case GFC_ISYM_LINK:
2993a2999
> case GFC_ISYM_RENAME:
2995a3002
> case GFC_ISYM_SYMLNK:
2996a3004,3005
> case GFC_ISYM_TIME:
> case GFC_ISYM_TIME8:
Index: libgfortran/Makefile.am
===================================================================
RCS file: /cvsroot/gcc/gcc/libgfortran/Makefile.am,v
retrieving revision 1.29
diff -r1.29 Makefile.am
46a47
> intrinsics/chdir.c \
57a59
> intrinsics/gerror.c \
58a61
> intrinsics/getlog.c \
59a63,65
> intrinsics/hostnm.c \
> intrinsics/kill.c \
> intrinsics/ierrno.c \
60a67
> intrinsics/link.c \
62a70
> intrinsics/perror.c \
63a72
> intrinsics/sleep.c \
68a78
> intrinsics/rename.c \
73a84
> intrinsics/symlnk.c \
74a86
> intrinsics/time.c \
Index: libgfortran/configure.ac
===================================================================
RCS file: /cvsroot/gcc/gcc/libgfortran/configure.ac,v
retrieving revision 1.20
diff -r1.20 configure.ac
149c149
< AC_HAVE_HEADERS(stdlib.h stdio.h string.h stddef.h math.h unistd.h)
---
> AC_HAVE_HEADERS(stdlib.h stdio.h string.h stddef.h math.h unistd.h signal.h)
162a163,164
> AC_CHECK_FUNCS(chdir strerror getlogin gethostname kill link symlink perror)
> AC_CHECK_FUNCS(sleep time)
/* Implementation of the GERROR g77 intrinsic.
Copyright (C) 2005 Free Software Foundation, Inc.
Contributed by François-Xavier Coudert <coudert@clipper.ens.fr>
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 General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
In addition to the permissions in the GNU General Public License, the
Free Software Foundation gives you unlimited permission to link the
compiled version of this file into combinations with other programs,
and to distribute those combinations without any restriction coming
from the use of this file. (The General Public License restrictions
do apply in other respects; for example, they cover modification of
the file, and distribution when not linked into a combine
executable.)
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 General Public License for more details.
You should have received a copy of the GNU General Public
License along with libgfortran; see the file COPYING. 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 <errno.h>
#ifdef HAVE_STRING_H
#include <string.h>
#endif
/* GERROR (MESSAGE), g77 intrinsic for retrieving the system error
message corresponding to the last system error (C errno).
CHARACTER(len=*), INTENT(OUT) :: MESSAGE */
#ifdef HAVE_STRERROR
void PREFIX(gerror) (char *, gfc_charlen_type);
export_proto_np(PREFIX(gerror));
void
PREFIX(gerror) (char * msg, gfc_charlen_type msg_len)
{
int p_len;
char *p;
memset (msg, ' ', msg_len); /* Blank the string. */
p = strerror (errno);
if (p == NULL)
return;
p_len = strlen (p);
if (msg_len < p_len)
memcpy (msg, p, msg_len);
else
memcpy (msg, p, p_len);
}
#endif
/* Implementation of the GETLOG g77 intrinsic.
Copyright (C) 2005 Free Software Foundation, Inc.
Contributed by François-Xavier Coudert <coudert@clipper.ens.fr>
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 General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
In addition to the permissions in the GNU General Public License, the
Free Software Foundation gives you unlimited permission to link the
compiled version of this file into combinations with other programs,
and to distribute those combinations without any restriction coming
from the use of this file. (The General Public License restrictions
do apply in other respects; for example, they cover modification of
the file, and distribution when not linked into a combine
executable.)
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 General Public License for more details.
You should have received a copy of the GNU General Public
License along with libgfortran; see the file COPYING. 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
/* GETLOG (LOGIN), g77 intrinsic for retrieving the login name for the
process.
CHARACTER(len=*), INTENT(OUT) :: LOGIN */
#ifdef HAVE_GETLOGIN
void PREFIX(getlog) (char *, gfc_charlen_type);
export_proto_np(PREFIX(getlog));
void
PREFIX(getlog) (char * login, gfc_charlen_type login_len)
{
int p_len;
char *p;
memset (login, ' ', login_len); /* Blank the string. */
p = getlogin ();
if (p == NULL)
return;
p_len = strlen (p);
if (login_len < p_len)
memcpy (login, p, login_len);
else
memcpy (login, p, p_len);
}
#endif
/* Implementation of the HOSTNM intrinsic.
Copyright (C) 2005 Free Software Foundation, Inc.
Contributed by François-Xavier Coudert <coudert@clipper.ens.fr>
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 General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
In addition to the permissions in the GNU General Public License, the
Free Software Foundation gives you unlimited permission to link the
compiled version of this file into combinations with other programs,
and to distribute those combinations without any restriction coming
from the use of this file. (The General Public License restrictions
do apply in other respects; for example, they cover modification of
the file, and distribution when not linked into a combine
executable.)
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 General Public License for more details.
You should have received a copy of the GNU General Public
License along with libgfortran; see the file COPYING. 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 <errno.h>
#include <string.h>
#ifdef HAVE_UNISTD_H
#include <unistd.h>
#endif
#include "../io/io.h"
/* SUBROUTINE HOSTNM(NAME, STATUS)
CHARACTER(len=*), INTENT(OUT) :: NAME
INTEGER, INTENT(OUT), OPTIONAL :: STATUS */
#ifdef HAVE_GETHOSTNAME
extern void hostnm_i4_sub (char *, GFC_INTEGER_4 *, gfc_charlen_type);
iexport_proto(hostnm_i4_sub);
void
hostnm_i4_sub (char *name, GFC_INTEGER_4 *status, gfc_charlen_type name_len)
{
int val, i;
char *p;
memset (name, ' ', name_len);
p = gfc_alloca (name_len + 1);
val = gethostname (p, name_len);
if (val == 0)
{
i = -1;
while (i < name_len && p[++i] != '\0')
name[i] = p[i];
}
if (status != NULL)
*status = (val == 0) ? 0 : errno;
}
iexport(hostnm_i4_sub);
extern void hostnm_i8_sub (char *, GFC_INTEGER_8 *, gfc_charlen_type);
iexport_proto(hostnm_i8_sub);
void
hostnm_i8_sub (char *name, GFC_INTEGER_8 *status, gfc_charlen_type name_len)
{
int val, i;
char *p;
memset (name, ' ', name_len);
p = gfc_alloca (name_len + 1);
val = gethostname (p, name_len);
if (val == 0)
{
i = -1;
while (i < name_len && p[++i] != '\0')
name[i] = p[i];
}
if (status != NULL)
*status = (val == 0) ? 0 : errno;
}
iexport(hostnm_i8_sub);
extern GFC_INTEGER_4 hostnm (char *, gfc_charlen_type);
export_proto(hostnm);
GFC_INTEGER_4
hostnm (char *name, gfc_charlen_type name_len)
{
GFC_INTEGER_4 val;
hostnm_i4_sub (name, &val, name_len);
return val;
}
#endif
/* Implementation of the IERRNO intrinsic.
Copyright (C) 2005 Free Software Foundation, Inc.
Contributed by François-Xavier Coudert <coudert@clipper.ens.fr>
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 General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
In addition to the permissions in the GNU General Public License, the
Free Software Foundation gives you unlimited permission to link the
compiled version of this file into combinations with other programs,
and to distribute those combinations without any restriction coming
from the use of this file. (The General Public License restrictions
do apply in other respects; for example, they cover modification of
the file, and distribution when not linked into a combine
executable.)
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 General Public License for more details.
You should have received a copy of the GNU General Public
License along with libgfortran; see the file COPYING. 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 <errno.h>
#include "../io/io.h"
/* INTEGER FUNCTION IERRNO() */
extern GFC_INTEGER_4 ierrno_i4 (void);
export_proto(ierrno_i4);
GFC_INTEGER_4
ierrno_i4 (void)
{
return (GFC_INTEGER_4) errno;
}
extern GFC_INTEGER_8 ierrno_i8 (void);
export_proto(ierrno_i8);
GFC_INTEGER_8
ierrno_i8 (void)
{
return (GFC_INTEGER_8) errno;
}
/* Implementation of the KILL g77 intrinsic.
Copyright (C) 2005 Free Software Foundation, Inc.
Contributed by François-Xavier Coudert <coudert@clipper.ens.fr>
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 General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
In addition to the permissions in the GNU General Public License, the
Free Software Foundation gives you unlimited permission to link the
compiled version of this file into combinations with other programs,
and to distribute those combinations without any restriction coming
from the use of this file. (The General Public License restrictions
do apply in other respects; for example, they cover modification of
the file, and distribution when not linked into a combine
executable.)
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 General Public License for more details.
You should have received a copy of the GNU General Public
License along with libgfortran; see the file COPYING. 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 <sys/types.h>
#endif
#ifdef HAVE_SIGNAL_H
#include <signal.h>
#endif
#include <errno.h>
#include "../io/io.h"
/* SUBROUTINE KILL(PID, SIGNAL, STATUS)
INTEGER, INTENT(IN) :: PID, SIGNAL
INTEGER(KIND=1), INTENT(OUT), OPTIONAL :: STATUS
INTEGER(KIND=1) FUNCTION KILL(PID, SIGNAL)
INTEGER, INTENT(IN) :: PID, SIGNAL */
#ifdef HAVE_KILL
extern void kill_i4_sub (GFC_INTEGER_4 *, GFC_INTEGER_4 *, GFC_INTEGER_4 *);
iexport_proto(kill_i4_sub);
void
kill_i4_sub (GFC_INTEGER_4 *pid, GFC_INTEGER_4 *signal,
GFC_INTEGER_4 *status)
{
int val;
val = kill (pid, signal);
if (status != NULL)
*status = (val == 0) ? 0 : errno;
}
iexport(kill_i4_sub);
extern void kill_i8_sub (GFC_INTEGER_8 *, GFC_INTEGER_8 *, GFC_INTEGER_8 *);
iexport_proto(kill_i8_sub);
void
kill_i8_sub (GFC_INTEGER_8 *pid, GFC_INTEGER_8 *signal,
GFC_INTEGER_8 *status)
{
int val;
val = kill (pid, signal);
if (status != NULL)
*status = (val == 0) ? 0 : errno;
}
iexport(kill_i8_sub);
extern GFC_INTEGER_4 kill_i4 (GFC_INTEGER_4 *, GFC_INTEGER_4 *);
export_proto(kill_i4);
GFC_INTEGER_4
kill_i4 (GFC_INTEGER_4 *pid, GFC_INTEGER_4 *signal)
{
GFC_INTEGER_4 val;
kill_i4_sub (pid, signal, &val);
return val;
}
extern GFC_INTEGER_8 kill_i8 (GFC_INTEGER_8 *, GFC_INTEGER_8 *);
export_proto(kill_i8);
GFC_INTEGER_8
kill_i8 (GFC_INTEGER_8 *pid, GFC_INTEGER_8 *signal)
{
GFC_INTEGER_8 val;
kill_i8_sub (pid, signal, &val);
return val;
}
#endif
/* Implementation of the LINK intrinsic.
Copyright (C) 2005 Free Software Foundation, Inc.
Contributed by François-Xavier Coudert <coudert@clipper.ens.fr>
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 General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
In addition to the permissions in the GNU General Public License, the
Free Software Foundation gives you unlimited permission to link the
compiled version of this file into combinations with other programs,
and to distribute those combinations without any restriction coming
from the use of this file. (The General Public License restrictions
do apply in other respects; for example, they cover modification of
the file, and distribution when not linked into a combine
executable.)
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 General Public License for more details.
You should have received a copy of the GNU General Public
License along with libgfortran; see the file COPYING. 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 <errno.h>
#include "../io/io.h"
#ifdef HAVE_UNISTD_H
#include <unistd.h>
#endif
/* SUBROUTINE LINK(PATH1, PATH2, STATUS)
CHARACTER(len=*), INTENT(IN) :: PATH1, PATH2
INTEGER, INTENT(OUT), OPTIONAL :: STATUS */
#ifdef HAVE_LINK
extern void link_i4_sub (char *, char *, GFC_INTEGER_4 *, gfc_charlen_type,
gfc_charlen_type);
iexport_proto(link_i4_sub);
void
link_i4_sub (char *path1, char *path2, GFC_INTEGER_4 *status,
gfc_charlen_type path1_len, gfc_charlen_type path2_len)
{
int val;
char *str1, *str2;
/* Trim trailing spaces from paths. */
while (path1_len > 0 && path1[path1_len - 1] == ' ')
path1_len--;
while (path2_len > 0 && path2[path2_len - 1] == ' ')
path2_len--;
/* Make a null terminated copy of the strings. */
str1 = gfc_alloca (path1_len + 1);
memcpy (str1, path1, path1_len);
str1[path1_len] = '\0';
str2 = gfc_alloca (path2_len + 1);
memcpy (str2, path2, path2_len);
str2[path2_len] = '\0';
val = link (str1, str2);
if (status != NULL)
*status = (val == 0) ? 0 : errno;
}
iexport(link_i4_sub);
extern void link_i8_sub (char *, char *, GFC_INTEGER_8 *, gfc_charlen_type,
gfc_charlen_type);
iexport_proto(link_i8_sub);
void
link_i8_sub (char *path1, char *path2, GFC_INTEGER_8 *status,
gfc_charlen_type path1_len, gfc_charlen_type path2_len)
{
int val;
char *str1, *str2;
/* Trim trailing spaces from paths. */
while (path1_len > 0 && path1[path1_len - 1] == ' ')
path1_len--;
while (path2_len > 0 && path2[path2_len - 1] == ' ')
path2_len--;
/* Make a null terminated copy of the strings. */
str1 = gfc_alloca (path1_len + 1);
memcpy (str1, path1, path1_len);
str1[path1_len] = '\0';
str2 = gfc_alloca (path2_len + 1);
memcpy (str2, path2, path2_len);
str2[path2_len] = '\0';
val = link (str1, str2);
if (status != NULL)
*status = (val == 0) ? 0 : errno;
}
iexport(link_i8_sub);
extern GFC_INTEGER_4 link_i4 (char *, char *, gfc_charlen_type,
gfc_charlen_type);
export_proto(link_i4);
GFC_INTEGER_4
link_i4 (char *path1, char *path2, gfc_charlen_type path1_len,
gfc_charlen_type path2_len)
{
GFC_INTEGER_4 val;
link_i4_sub (path1, path2, &val, path1_len, path2_len);
return val;
}
extern GFC_INTEGER_8 link_i8 (char *, char *, gfc_charlen_type,
gfc_charlen_type);
export_proto(link_i8);
GFC_INTEGER_8
link_i8 (char *path1, char *path2, gfc_charlen_type path1_len,
gfc_charlen_type path2_len)
{
GFC_INTEGER_8 val;
link_i8_sub (path1, path2, &val, path1_len, path2_len);
return val;
}
#endif
/* Implementation of the PERROR intrinsic.
Copyright (C) 2005 Free Software Foundation, Inc.
Contributed by François-Xavier Coudert <coudert@clipper.ens.fr>
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 General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
In addition to the permissions in the GNU General Public License, the
Free Software Foundation gives you unlimited permission to link the
compiled version of this file into combinations with other programs,
and to distribute those combinations without any restriction coming
from the use of this file. (The General Public License restrictions
do apply in other respects; for example, they cover modification of
the file, and distribution when not linked into a combine
executable.)
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 General Public License for more details.
You should have received a copy of the GNU General Public
License along with libgfortran; see the file COPYING. 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 <stdio.h>
#include <errno.h>
#include "../io/io.h"
/* SUBROUTINE PERROR(STRING)
CHARACTER(len=*), INTENT(IN) :: STRING */
#ifdef HAVE_PERROR
extern void perror_sub (char *, gfc_charlen_type);
iexport_proto(perror_sub);
void
perror_sub (char *string, gfc_charlen_type string_len)
{
char * str;
/* Trim trailing spaces from paths. */
while (string_len > 0 && string[string_len - 1] == ' ')
string_len--;
/* Make a null terminated copy of the strings. */
str = gfc_alloca (string_len + 1);
memcpy (str, string, string_len);
str[string_len] = '\0';
perror (str);
}
iexport(perror_sub);
#endif
/* Implementation of the RENAME intrinsic.
Copyright (C) 2005 Free Software Foundation, Inc.
Contributed by François-Xavier Coudert <coudert@clipper.ens.fr>
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 General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
In addition to the permissions in the GNU General Public License, the
Free Software Foundation gives you unlimited permission to link the
compiled version of this file into combinations with other programs,
and to distribute those combinations without any restriction coming
from the use of this file. (The General Public License restrictions
do apply in other respects; for example, they cover modification of
the file, and distribution when not linked into a combine
executable.)
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 General Public License for more details.
You should have received a copy of the GNU General Public
License along with libgfortran; see the file COPYING. 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 <errno.h>
#include "../io/io.h"
/* SUBROUTINE RENAME(PATH1, PATH2, STATUS)
CHARACTER(len=*), INTENT(IN) :: PATH1, PATH2
INTEGER, INTENT(OUT), OPTIONAL :: STATUS */
extern void rename_i4_sub (char *, char *, GFC_INTEGER_4 *, gfc_charlen_type,
gfc_charlen_type);
iexport_proto(rename_i4_sub);
void
rename_i4_sub (char *path1, char *path2, GFC_INTEGER_4 *status,
gfc_charlen_type path1_len, gfc_charlen_type path2_len)
{
int val;
char *str1, *str2;
/* Trim trailing spaces from paths. */
while (path1_len > 0 && path1[path1_len - 1] == ' ')
path1_len--;
while (path2_len > 0 && path2[path2_len - 1] == ' ')
path2_len--;
/* Make a null terminated copy of the strings. */
str1 = gfc_alloca (path1_len + 1);
memcpy (str1, path1, path1_len);
str1[path1_len] = '\0';
str2 = gfc_alloca (path2_len + 1);
memcpy (str2, path2, path2_len);
str2[path2_len] = '\0';
val = rename (str1, str2);
if (status != NULL)
*status = (val == 0) ? 0 : errno;
}
iexport(rename_i4_sub);
extern void rename_i8_sub (char *, char *, GFC_INTEGER_8 *, gfc_charlen_type,
gfc_charlen_type);
iexport_proto(rename_i8_sub);
void
rename_i8_sub (char *path1, char *path2, GFC_INTEGER_8 *status,
gfc_charlen_type path1_len, gfc_charlen_type path2_len)
{
int val;
char *str1, *str2;
/* Trim trailing spaces from paths. */
while (path1_len > 0 && path1[path1_len - 1] == ' ')
path1_len--;
while (path2_len > 0 && path2[path2_len - 1] == ' ')
path2_len--;
/* Make a null terminated copy of the strings. */
str1 = gfc_alloca (path1_len + 1);
memcpy (str1, path1, path1_len);
str1[path1_len] = '\0';
str2 = gfc_alloca (path2_len + 1);
memcpy (str2, path2, path2_len);
str2[path2_len] = '\0';
val = rename (str1, str2);
if (status != NULL)
*status = (val == 0) ? 0 : errno;
}
iexport(rename_i8_sub);
extern GFC_INTEGER_4 rename_i4 (char *, char *, gfc_charlen_type,
gfc_charlen_type);
export_proto(rename_i4);
GFC_INTEGER_4
rename_i4 (char *path1, char *path2, gfc_charlen_type path1_len,
gfc_charlen_type path2_len)
{
GFC_INTEGER_4 val;
rename_i4_sub (path1, path2, &val, path1_len, path2_len);
return val;
}
extern GFC_INTEGER_8 rename_i8 (char *, char *, gfc_charlen_type,
gfc_charlen_type);
export_proto(rename_i8);
GFC_INTEGER_8
rename_i8 (char *path1, char *path2, gfc_charlen_type path1_len,
gfc_charlen_type path2_len)
{
GFC_INTEGER_8 val;
rename_i8_sub (path1, path2, &val, path1_len, path2_len);
return val;
}
/* Implementation of the SLEEP intrinsic.
Copyright (C) 2005 Free Software Foundation, Inc.
Contributed by François-Xavier Coudert <coudert@clipper.ens.fr>
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 General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
In addition to the permissions in the GNU General Public License, the
Free Software Foundation gives you unlimited permission to link the
compiled version of this file into combinations with other programs,
and to distribute those combinations without any restriction coming
from the use of this file. (The General Public License restrictions
do apply in other respects; for example, they cover modification of
the file, and distribution when not linked into a combine
executable.)
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 General Public License for more details.
You should have received a copy of the GNU General Public
License along with libgfortran; see the file COPYING. 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 <errno.h>
#include "../io/io.h"
#ifdef HAVE_UNISTD_H
#include <unistd.h>
#endif
/* SUBROUTINE SLEEP(SECONDS)
INTEGER, INTENT(IN) :: SECONDS
A choice had to be made if SECONDS is negative. For g77, this is
equivalent to SLEEP(0). */
#ifdef HAVE_SLEEP
extern void sleep_i4_sub (GFC_INTEGER_4 *);
iexport_proto(sleep_i4_sub);
void
sleep_i4_sub (GFC_INTEGER_4 *seconds)
{
sleep (*seconds < 0 ? 0 : (unsigned int) *seconds);
}
iexport(sleep_i4_sub);
extern void sleep_i8_sub (GFC_INTEGER_8 *);
iexport_proto(sleep_i8_sub);
void
sleep_i8_sub (GFC_INTEGER_8 *seconds)
{
sleep (*seconds < 0 ? 0 : (unsigned int) *seconds);
}
iexport(sleep_i8_sub);
#endif
/* Implementation of the SYMLNK intrinsic.
Copyright (C) 2005 Free Software Foundation, Inc.
Contributed by François-Xavier Coudert <coudert@clipper.ens.fr>
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 General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
In addition to the permissions in the GNU General Public License, the
Free Software Foundation gives you unlimited permission to link the
compiled version of this file into combinations with other programs,
and to distribute those combinations without any restriction coming
from the use of this file. (The General Public License restrictions
do apply in other respects; for example, they cover modification of
the file, and distribution when not linked into a combine
executable.)
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 General Public License for more details.
You should have received a copy of the GNU General Public
License along with libgfortran; see the file COPYING. 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 <errno.h>
#include "../io/io.h"
#ifdef HAVE_UNISTD_H
#include <unistd.h>
#endif
/* SUBROUTINE SYMLNK(PATH1, PATH2, STATUS)
CHARACTER(len=*), INTENT(IN) :: PATH1, PATH2
INTEGER, INTENT(OUT), OPTIONAL :: STATUS */
#ifdef HAVE_SYMLINK
extern void symlnk_i4_sub (char *, char *, GFC_INTEGER_4 *, gfc_charlen_type,
gfc_charlen_type);
iexport_proto(symlnk_i4_sub);
void
symlnk_i4_sub (char *path1, char *path2, GFC_INTEGER_4 *status,
gfc_charlen_type path1_len, gfc_charlen_type path2_len)
{
int val;
char *str1, *str2;
/* Trim trailing spaces from paths. */
while (path1_len > 0 && path1[path1_len - 1] == ' ')
path1_len--;
while (path2_len > 0 && path2[path2_len - 1] == ' ')
path2_len--;
/* Make a null terminated copy of the strings. */
str1 = gfc_alloca (path1_len + 1);
memcpy (str1, path1, path1_len);
str1[path1_len] = '\0';
str2 = gfc_alloca (path2_len + 1);
memcpy (str2, path2, path2_len);
str2[path2_len] = '\0';
val = symlink (str1, str2);
if (status != NULL)
*status = (val == 0) ? 0 : errno;
}
iexport(symlnk_i4_sub);
extern void symlnk_i8_sub (char *, char *, GFC_INTEGER_8 *, gfc_charlen_type,
gfc_charlen_type);
iexport_proto(symlnk_i8_sub);
void
symlnk_i8_sub (char *path1, char *path2, GFC_INTEGER_8 *status,
gfc_charlen_type path1_len, gfc_charlen_type path2_len)
{
int val;
char *str1, *str2;
/* Trim trailing spaces from paths. */
while (path1_len > 0 && path1[path1_len - 1] == ' ')
path1_len--;
while (path2_len > 0 && path2[path2_len - 1] == ' ')
path2_len--;
/* Make a null terminated copy of the strings. */
str1 = gfc_alloca (path1_len + 1);
memcpy (str1, path1, path1_len);
str1[path1_len] = '\0';
str2 = gfc_alloca (path2_len + 1);
memcpy (str2, path2, path2_len);
str2[path2_len] = '\0';
val = symlink (str1, str2);
if (status != NULL)
*status = (val == 0) ? 0 : errno;
}
iexport(symlnk_i8_sub);
extern GFC_INTEGER_4 symlnk_i4 (char *, char *, gfc_charlen_type,
gfc_charlen_type);
export_proto(symlnk_i4);
GFC_INTEGER_4
symlnk_i4 (char *path1, char *path2, gfc_charlen_type path1_len,
gfc_charlen_type path2_len)
{
GFC_INTEGER_4 val;
symlnk_i4_sub (path1, path2, &val, path1_len, path2_len);
return val;
}
extern GFC_INTEGER_8 symlnk_i8 (char *, char *, gfc_charlen_type,
gfc_charlen_type);
export_proto(symlnk_i8);
GFC_INTEGER_8
symlnk_i8 (char *path1, char *path2, gfc_charlen_type path1_len,
gfc_charlen_type path2_len)
{
GFC_INTEGER_8 val;
symlnk_i8_sub (path1, path2, &val, path1_len, path2_len);
return val;
}
#endif
/* Implementation of the TIME and TIME8 g77 intrinsics.
Copyright (C) 2005 Free Software Foundation, Inc.
Contributed by François-Xavier Coudert <coudert@clipper.ens.fr>
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 General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
In addition to the permissions in the GNU General Public License, the
Free Software Foundation gives you unlimited permission to link the
compiled version of this file into combinations with other programs,
and to distribute those combinations without any restriction coming
from the use of this file. (The General Public License restrictions
do apply in other respects; for example, they cover modification of
the file, and distribution when not linked into a combine
executable.)
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 General Public License for more details.
You should have received a copy of the GNU General Public
License along with libgfortran; see the file COPYING. 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 TIME_WITH_SYS_TIME
# include <sys/time.h>
# include <time.h>
#else
# if HAVE_SYS_TIME_H
# include <sys/time.h>
# else
# ifdef HAVE_TIME_H
# include <time.h>
# endif
# endif
#endif
#include "../io/io.h"
/* INTEGER(KIND=1) FUNCTION TIME() */
#ifdef HAVE_TIME
extern GFC_INTEGER_4 time_func (void);
export_proto(time_func);
GFC_INTEGER_4
time_func (void)
{
return (GFC_INTEGER_4) time (NULL);
}
/* INTEGER(KIND=2) FUNCTION TIME8() */
extern GFC_INTEGER_8 time8_func (void);
export_proto(time8_func);
GFC_INTEGER_8
time8_func (void)
{
return (GFC_INTEGER_8) time (NULL);
}
#endif