This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
[gfortran,patch] RFC: libgfortran cleanup
- From: FX Coudert <fxcoudert at gmail dot com>
- To: gfortran <fortran at gcc dot gnu dot org>, patch <gcc-patches at gcc dot gnu dot org>
- Date: Sat, 24 Jun 2006 19:11:50 +0200
- Subject: [gfortran,patch] RFC: libgfortran cleanup
Hi all,
The attached patch is a proposed cleanup for libgfortran:
-- stuff that is purely I/O related is contained inside the io/ folder
-- functions from the io/ folder that need to be called from
functions in intrinsic/ or runtime/ is declared in libgfortran.h,
everything else is kept in io/io.h
-- stuff unix.h is incorporated back inside unix.c, since it's not
really called from anywhere else
-- Makefile.am is modified to add basic dependencies: everything
depends on libgfortran.h, while everything inside io/ depends on io/io.h
There has been discussion on IRC whether now is a right time to do all
this shuffling and cleaning up. I think that since it's (almost) only
moving entire functions, it is fairly low-risk. So, I'm not asking here
for a single review of that patch but for the opinion of our library
developpers (FYI, Paul Brook and Steven B. are opposed to doing that now).
FX
2006-06-24 Francois-Xavier Coudert <coudert@clipper.ens.fr>
* runtime/environ.c: Don't include "io/io.h".
* runtime/string.c (compare0, find_option): Remove.
* runtime/error.c: Don't include "io/io.h" and "io/unix.h".
(st_printf, show_locus, generate_error): Remove.
(internal_error): Remove cmp argument.
* intrinsics/flush.c: Don't include "io/io.h". Call flush_unit
instead of doing the job here.
* intrinsics/fget.c: Don't include "io/io.h". Call unit_fgetc
and unit_fputc.
* intrinsics/ftell.c: Don't include "io/io.h". Call ftell_unit.
* intrinsics/tty.c: Don't include "io/io.h". Call unit_isatty.
* libgfortran.h (DEFAULT_TEMPDIR, DEFAULT_RECL, unit_convert,
try, notification_std,notify_std,get_unformatted_convert): Move here.
(st_printf,generate_error,show_locus,find_option): Remove.
(internal_error): Update proto.
(unit_to_fd,flush_all_units,flush_unit,ftell_unit,unit_isatty,
unit_ttyname,unit_fgetc,unit_fputc,st_printf,generate_error):
New functions from io/ directory.
* io/io.h (DEFAULT_TEMPDIR,try,unit_convert,DEFAULT_RECL,
flush_all_units,stream_isatty,stream_ttyname,unit_to_fd,
notify_std,notification_std,get_unformatted_convert): Remove.
(init_error_stream,find_option,internal_io_error): Add new protos.
* io/file_pos.c (ftell_unit): New function.
* io/util.c: New file.
* io/unit.c (insert): Replace internal_error by internal_io_error.
(unit_fgetc,unit_fputc): New functions.
* io/unix.c: Include the content of old unix.h.
(unit_to_fd): Replace internal_error by internal_io_error.
(init_error_stream): Allocate memory for the stream.
(flush_unit): New function.
(stream_isatty): Remove.
(unit_isatty): New function.
(stream_ttyname): Remove.
(unit_ttyname): New function.
* io/unix.h: Delete.
* Makefile.am: Add dependency on libgfortran.h and io/io.h.
Add new io/util.c file.
* intrinsics/system_clock.c: Remove first argument of
internal_error.
* io/open.c (new_unit, st_open): Replace internal_error by
internal_io_error.
* io/list_read.c (list_formatted_read_scalar,nml_read_obj):
Replace internal_error by internal_io_error.
* io/read.c (set_integer,max_value,convert_real,read_f):
Replace internal_error by internal_io_error.
* io/inquire.c (inquire_via_unit): Replace internal_error by
internal_io_error.
* io/transfer.c (type_name,formatted_transfer_scalar,transfer_array,
transfer_array,data_transfer_init): Replace internal_error
by internal_io_error.
* io/write.c (extract_int,extract_uint,extract_real,
output_float,write_real,list_formatted_write_scalar,
nml_write_obj): Replace internal_error by internal_io_error.
Index: runtime/environ.c
===================================================================
--- runtime/environ.c (revision 114961)
+++ runtime/environ.c (working copy)
@@ -34,7 +34,6 @@
#include <ctype.h>
#include "libgfortran.h"
-#include "../io/io.h"
/* Environment scanner. Examine the environment for controlling minor
Index: runtime/string.c
===================================================================
--- runtime/string.c (revision 114961)
+++ runtime/string.c (working copy)
@@ -31,23 +31,7 @@
#include <string.h>
#include "libgfortran.h"
-#include "../io/io.h"
-/* Compare a C-style string with a fortran style string in a case-insensitive
- manner. Used for decoding string options to various statements. Returns
- zero if not equal, nonzero if equal. */
-
-static int
-compare0 (const char *s1, int s1_len, const char *s2)
-{
- int len;
-
- /* Strip trailing blanks from the Fortran string. */
- len = fstrlen (s1, s1_len);
- return strncasecmp (s1, s2, len) == 0;
-}
-
-
/* Given a fortran string, return its length exclusive of the trailing
spaces. */
int
@@ -97,21 +81,3 @@
memset (&dest[src_len], ' ', dest_len - src_len);
}
}
-
-
-/* Given a fortran string and an array of st_option structures, search through
- the array to find a match. If the option is not found, we generate an error
- if no default is provided. */
-
-int
-find_option (st_parameter_common *cmp, const char *s1, int s1_len,
- const st_option * opts, const char *error_message)
-{
- for (; opts->name; opts++)
- if (compare0 (s1, s1_len, opts->name))
- return opts->value;
-
- generate_error (cmp, ERROR_BAD_OPTION, error_message);
-
- return -1;
-}
Index: runtime/error.c
===================================================================
--- runtime/error.c (revision 114961)
+++ runtime/error.c (working copy)
@@ -36,8 +36,6 @@
#include <float.h>
#include "libgfortran.h"
-#include "../io/io.h"
-#include "../io/unix.h"
/* Error conditions. The tricky part here is printing a message when
* it is the I/O subsystem that is severely wounded. Our goal is to
@@ -121,104 +119,6 @@
}
-/* st_printf()-- simple printf() function for streams that handles the
- * formats %d, %s and %c. This function handles printing of error
- * messages that originate within the library itself, not from a user
- * program. */
-
-int
-st_printf (const char *format, ...)
-{
- int count, total;
- va_list arg;
- char *p;
- const char *q;
- stream *s;
- char itoa_buf[GFC_ITOA_BUF_SIZE];
- unix_stream err_stream;
-
- total = 0;
- s = init_error_stream (&err_stream);
- va_start (arg, format);
-
- for (;;)
- {
- count = 0;
-
- while (format[count] != '%' && format[count] != '\0')
- count++;
-
- if (count != 0)
- {
- p = salloc_w (s, &count);
- memmove (p, format, count);
- sfree (s);
- }
-
- total += count;
- format += count;
- if (*format++ == '\0')
- break;
-
- switch (*format)
- {
- case 'c':
- count = 1;
-
- p = salloc_w (s, &count);
- *p = (char) va_arg (arg, int);
-
- sfree (s);
- break;
-
- case 'd':
- q = gfc_itoa (va_arg (arg, int), itoa_buf, sizeof (itoa_buf));
- count = strlen (q);
-
- p = salloc_w (s, &count);
- memmove (p, q, count);
- sfree (s);
- break;
-
- case 'x':
- q = xtoa (va_arg (arg, unsigned), itoa_buf, sizeof (itoa_buf));
- count = strlen (q);
-
- p = salloc_w (s, &count);
- memmove (p, q, count);
- sfree (s);
- break;
-
- case 's':
- q = va_arg (arg, char *);
- count = strlen (q);
-
- p = salloc_w (s, &count);
- memmove (p, q, count);
- sfree (s);
- break;
-
- case '\0':
- return total;
-
- default:
- count = 2;
- p = salloc_w (s, &count);
- p[0] = format[-1];
- p[1] = format[0];
- sfree (s);
- break;
- }
-
- total += count;
- format++;
- }
-
- va_end (arg);
- return total;
-}
-
-
/* st_sprintf()-- Simple sprintf() for formatting memory buffers. */
void
@@ -275,19 +175,6 @@
}
-/* show_locus()-- Print a line number and filename describing where
- * something went wrong */
-
-void
-show_locus (st_parameter_common *cmp)
-{
- if (!options.locus || cmp == NULL || cmp->filename == NULL)
- return;
-
- st_printf ("At line %d of file %s\n", cmp->line, cmp->filename);
-}
-
-
/* recursion_check()-- It's possible for additional errors to occur
* during fatal error processing. We detect this condition here and
* exit with code 4 immediately. */
@@ -337,10 +224,9 @@
* that indicate something deeply wrong. */
void
-internal_error (st_parameter_common *cmp, const char *message)
+internal_error (const char *message)
{
recursion_check ();
- show_locus (cmp);
st_printf ("Internal Error: %s\n", message);
/* This function call is here to get the main.o object file included
@@ -444,64 +330,6 @@
}
-/* generate_error()-- Come here when an error happens. This
- * subroutine is called if it is possible to continue on after the error.
- * If an IOSTAT or IOMSG variable exists, we set it. If IOSTAT or
- * ERR labels are present, we return, otherwise we terminate the program
- * after printing a message. The error code is always required but the
- * message parameter can be NULL, in which case a string describing
- * the most recent operating system error is used. */
-
-void
-generate_error (st_parameter_common *cmp, int family, const char *message)
-{
- /* Set the error status. */
- if ((cmp->flags & IOPARM_HAS_IOSTAT))
- *cmp->iostat = family;
-
- if (message == NULL)
- message =
- (family == ERROR_OS) ? get_oserror () : translate_error (family);
-
- if (cmp->flags & IOPARM_HAS_IOMSG)
- cf_strcpy (cmp->iomsg, cmp->iomsg_len, message);
-
- /* Report status back to the compiler. */
- cmp->flags &= ~IOPARM_LIBRETURN_MASK;
- switch (family)
- {
- case ERROR_EOR:
- cmp->flags |= IOPARM_LIBRETURN_EOR;
- if ((cmp->flags & IOPARM_EOR))
- return;
- break;
-
- case ERROR_END:
- cmp->flags |= IOPARM_LIBRETURN_END;
- if ((cmp->flags & IOPARM_END))
- return;
- break;
-
- default:
- cmp->flags |= IOPARM_LIBRETURN_ERROR;
- if ((cmp->flags & IOPARM_ERR))
- return;
- break;
- }
-
- /* Return if the user supplied an iostat variable. */
- if ((cmp->flags & IOPARM_HAS_IOSTAT))
- return;
-
- /* Terminate the program */
-
- recursion_check ();
- show_locus (cmp);
- st_printf ("Fortran runtime error: %s\n", message);
- sys_exit (2);
-}
-
-
/* Whether, for a feature included in a given standard set (GFC_STD_*),
we should issue an error or a warning, or be quiet. */
Index: intrinsics/flush.c
===================================================================
--- intrinsics/flush.c (revision 114961)
+++ intrinsics/flush.c (working copy)
@@ -36,8 +36,6 @@
#include <stdlib.h>
#endif
-#include "../io/io.h"
-
/* SUBROUTINE FLUSH(UNIT)
INTEGER, INTENT(IN), OPTIONAL :: UNIT */
@@ -47,20 +45,10 @@
void
flush_i4 (GFC_INTEGER_4 *unit)
{
- gfc_unit *us;
-
- /* flush all streams */
if (unit == NULL)
flush_all_units ();
else
- {
- us = find_unit (*unit);
- if (us != NULL)
- {
- flush (us->s);
- unlock_unit (us);
- }
- }
+ flush_unit (*unit);
}
@@ -70,18 +58,8 @@
void
flush_i8 (GFC_INTEGER_8 *unit)
{
- gfc_unit *us;
-
- /* flush all streams */
if (unit == NULL)
flush_all_units ();
else
- {
- us = find_unit (*unit);
- if (us != NULL)
- {
- flush (us->s);
- unlock_unit (us);
- }
- }
+ flush_unit ((int) *unit);
}
Index: intrinsics/fget.c
===================================================================
--- intrinsics/fget.c (revision 114961)
+++ intrinsics/fget.c (working copy)
@@ -33,8 +33,6 @@
#include <string.h>
-#include "../io/io.h"
-
static const int five = 5;
static const int six = 6;
@@ -44,25 +42,8 @@
int
PREFIX(fgetc) (const int * unit, char * c, gfc_charlen_type c_len)
{
- int ret;
- size_t s;
- gfc_unit * u = find_unit (*unit);
-
- if (u == NULL)
- return -1;
-
- s = 1;
memset (c, ' ', c_len);
- ret = sread (u->s, c, &s);
- unlock_unit (u);
-
- if (ret != 0)
- return ret;
-
- if (s != 1)
- return -1;
- else
- return 0;
+ return unit_fgetc (*unit, c);
}
@@ -118,17 +99,7 @@
PREFIX(fputc) (const int * unit, char * c,
gfc_charlen_type c_len __attribute__((unused)))
{
- size_t s;
- int ret;
- gfc_unit * u = find_unit (*unit);
-
- if (u == NULL)
- return -1;
-
- s = 1;
- ret = swrite (u->s, c, &s);
- unlock_unit (u);
- return ret;
+ return unit_fputc (*unit, c);
}
Index: intrinsics/ftell.c
===================================================================
--- intrinsics/ftell.c (revision 114961)
+++ intrinsics/ftell.c (working copy)
@@ -33,21 +33,13 @@
#include <string.h>
-#include "../io/io.h"
-
extern size_t PREFIX(ftell) (int *);
export_proto_np(PREFIX(ftell));
size_t
PREFIX(ftell) (int * unit)
{
- gfc_unit * u = find_unit (*unit);
- size_t ret;
- if (u == NULL)
- return ((size_t) -1);
- ret = (size_t) stream_offset (u->s);
- unlock_unit (u);
- return ret;
+ return ftell_unit (*unit);
}
#define FTELL_SUB(kind) \
@@ -56,14 +48,12 @@
void \
ftell_i ## kind ## _sub (int * unit, GFC_INTEGER_ ## kind * offset) \
{ \
- gfc_unit * u = find_unit (*unit); \
- if (u == NULL) \
- *offset = -1; \
+ size_t o; \
+ o = ftell_unit (*unit); \
+ if (o == (size_t) -1) \
+ *offset = (GFC_INTEGER_ ## kind) -1; \
else \
- { \
- *offset = stream_offset (u->s); \
- unlock_unit (u); \
- } \
+ *offset = (GFC_INTEGER_ ## kind) o; \
}
FTELL_SUB(1)
Index: intrinsics/tty.c
===================================================================
--- intrinsics/tty.c (revision 114961)
+++ intrinsics/tty.c (working copy)
@@ -30,7 +30,6 @@
#include "config.h"
#include "libgfortran.h"
-#include "../io/io.h"
#include <string.h>
@@ -43,16 +42,7 @@
GFC_LOGICAL_4
isatty_l4 (int *unit)
{
- gfc_unit *u;
- GFC_LOGICAL_4 ret = 0;
-
- u = find_unit (*unit);
- if (u != NULL)
- {
- ret = (GFC_LOGICAL_4) stream_isatty (u->s);
- unlock_unit (u);
- }
- return ret;
+ return ((GFC_LOGICAL_4) unit_isatty (*unit));
}
@@ -62,16 +52,7 @@
GFC_LOGICAL_8
isatty_l8 (int *unit)
{
- gfc_unit *u;
- GFC_LOGICAL_8 ret = 0;
-
- u = find_unit (*unit);
- if (u != NULL)
- {
- ret = (GFC_LOGICAL_8) stream_isatty (u->s);
- unlock_unit (u);
- }
- return ret;
+ return ((GFC_LOGICAL_8) unit_isatty (*unit));
}
@@ -85,22 +66,16 @@
void
ttynam_sub (int *unit, char * name, gfc_charlen_type name_len)
{
- gfc_unit *u;
char * n;
int i;
memset (name, ' ', name_len);
- u = find_unit (*unit);
- if (u != NULL)
+ n = unit_ttyname (*unit);
+ if (n != NULL)
{
- n = stream_ttyname (u->s);
- if (n != NULL)
- {
- i = 0;
- while (*n && i < name_len)
- name[i++] = *(n++);
- }
- unlock_unit (u);
+ i = 0;
+ while (*n && i < name_len)
+ name[i++] = *(n++);
}
}
@@ -111,22 +86,12 @@
void
ttynam (char ** name, gfc_charlen_type * name_len, int unit)
{
- gfc_unit *u;
-
- u = find_unit (unit);
- if (u != NULL)
+ *name = unit_ttyname (unit);
+ if (*name != NULL)
{
- *name = stream_ttyname (u->s);
- if (*name != NULL)
- {
- *name_len = strlen (*name);
- *name = strdup (*name);
- unlock_unit (u);
- return;
- }
- unlock_unit (u);
+ *name_len = strlen (*name);
+ *name = strdup (*name);
}
-
- *name_len = 0;
- *name = NULL;
+ else
+ *name_len = 0;
}
Index: libgfortran.h
===================================================================
--- libgfortran.h (revision 114961)
+++ libgfortran.h (working copy)
@@ -62,6 +62,7 @@
#define NULL (void *) 0
#endif
+
#ifndef __GNUC__
#define __attribute__(x)
#endif
@@ -429,6 +430,27 @@
#define gfc_alloca(x) __builtin_alloca(x)
+
+/* Some definitions of the I/O system that need to be known in the rest
+ of the library. */
+
+#define DEFAULT_TEMPDIR "/tmp"
+
+/* The default value of record length for preconnected units is defined
+ here. This value can be overriden by an environment variable.
+ Default value is 1 Gb. */
+
+#define DEFAULT_RECL 1073741824
+
+typedef enum
+{ CONVERT_NONE=-1, CONVERT_NATIVE, CONVERT_SWAP, CONVERT_BIG, CONVERT_LITTLE }
+unit_convert;
+
+typedef enum
+{ SUCCESS = 1, FAILURE }
+try;
+
+
/* main.c */
extern void stupid_function_name_for_static_linking (void);
@@ -462,14 +484,10 @@
extern void os_error (const char *) __attribute__ ((noreturn));
internal_proto(os_error);
-extern void show_locus (struct st_parameter_common *);
-internal_proto(show_locus);
-
extern void runtime_error (const char *) __attribute__ ((noreturn));
iexport_proto(runtime_error);
-extern void internal_error (struct st_parameter_common *, const char *)
- __attribute__ ((noreturn));
+extern void internal_error (const char *) __attribute__ ((noreturn));
internal_proto(internal_error);
extern const char *get_oserror (void);
@@ -478,10 +496,6 @@
extern void sys_exit (int) __attribute__ ((noreturn));
internal_proto(sys_exit);
-extern int st_printf (const char *, ...)
- __attribute__ ((format (printf, 1, 2)));
-internal_proto(st_printf);
-
extern void st_sprintf (char *, const char *, ...)
__attribute__ ((format (printf, 2, 3)));
internal_proto(st_sprintf);
@@ -489,9 +503,12 @@
extern const char *translate_error (int);
internal_proto(translate_error);
-extern void generate_error (struct st_parameter_common *, int, const char *);
-internal_proto(generate_error);
+extern try notify_std (int, const char *);
+internal_proto(notify_std);
+extern notification notification_std(int);
+internal_proto(notification_std);
+
/* fpu.c */
extern void set_fpu (void);
@@ -522,12 +539,11 @@
extern void show_variables (void);
internal_proto(show_variables);
+unit_convert get_unformatted_convert (int);
+internal_proto(get_unformatted_convert);
+
/* string.c */
-extern int find_option (struct st_parameter_common *, const char *, int,
- const st_option *, const char *);
-internal_proto(find_option);
-
extern int fstrlen (const char *, int);
internal_proto(fstrlen);
@@ -537,7 +553,7 @@
extern void cf_strcpy (char *, int, const char *);
internal_proto(cf_strcpy);
-/* io.c */
+/* All files in io/ directory. */
extern void init_units (void);
internal_proto(init_units);
@@ -545,6 +561,37 @@
extern void close_units (void);
internal_proto(close_units);
+extern int unit_to_fd (const int);
+internal_proto(unit_to_fd);
+
+extern void flush_all_units (void);
+internal_proto(flush_all_units);
+
+extern void flush_unit (const int);
+internal_proto(flush_unit);
+
+extern size_t ftell_unit (const int);
+internal_proto(ftell_unit);
+
+extern int unit_isatty (const int);
+internal_proto(unit_isatty);
+
+extern char * unit_ttyname (const int);
+internal_proto(unit_ttyname);
+
+extern int unit_fgetc (const int, char *);
+internal_proto(unit_fgetc);
+
+extern int unit_fputc (const int, char *);
+internal_proto(unit_fputc);
+
+extern int st_printf (const char *, ...)
+ __attribute__ ((format (printf, 1, 2)));
+internal_proto(st_printf);
+
+extern void generate_error (struct st_parameter_common *, int, const char *);
+internal_proto(generate_error);
+
/* stop.c */
extern void stop_numeric (GFC_INTEGER_4);
Index: io/file_pos.c
===================================================================
--- io/file_pos.c (revision 114961)
+++ io/file_pos.c (working copy)
@@ -343,3 +343,19 @@
library_end ();
}
+
+
+/* This is the function called by the FTELL intrinsic, via
+ libgfortran/intrinsics/ftell.c. */
+size_t
+ftell_unit (const int unit)
+{
+ size_t ret;
+ gfc_unit * u = find_unit (unit);
+
+ if (u == NULL)
+ return ((size_t) -1);
+ ret = (size_t) stream_offset (u->s);
+ unlock_unit (u);
+ return ret;
+}
Index: io/io.h
===================================================================
--- io/io.h (revision 114961)
+++ io/io.h (working copy)
@@ -35,8 +35,6 @@
#include <gthr.h>
-#define DEFAULT_TEMPDIR "/tmp"
-
/* Basic types used in data transfers. */
typedef enum
@@ -46,10 +44,6 @@
bt;
-typedef enum
-{ SUCCESS = 1, FAILURE }
-try;
-
struct st_parameter_dt;
typedef struct stream
@@ -209,10 +203,6 @@
{READING, WRITING}
unit_mode;
-typedef enum
-{ CONVERT_NONE=-1, CONVERT_NATIVE, CONVERT_SWAP, CONVERT_BIG, CONVERT_LITTLE }
-unit_convert;
-
#define CHARACTER1(name) \
char * name; \
gfc_charlen_type name ## _len
@@ -473,13 +463,6 @@
unit_flags;
-/* The default value of record length for preconnected units is defined
- here. This value can be overriden by an environment variable.
- Default value is 1 Gb. */
-
-#define DEFAULT_RECL 1073741824
-
-
typedef struct gfc_unit
{
int unit_number;
@@ -616,9 +599,6 @@
extern gfc_unit *find_file (const char *file, gfc_charlen_type file_len);
internal_proto(find_file);
-extern void flush_all_units (void);
-internal_proto(flush_all_units);
-
extern int stream_at_bof (stream *);
internal_proto(stream_at_bof);
@@ -673,21 +653,15 @@
extern try flush (stream *);
internal_proto(flush);
-extern int stream_isatty (stream *);
-internal_proto(stream_isatty);
-
-extern char * stream_ttyname (stream *);
-internal_proto(stream_ttyname);
-
extern gfc_offset stream_offset (stream *s);
internal_proto(stream_offset);
-extern int unit_to_fd (int);
-internal_proto(unit_to_fd);
-
extern int unpack_filename (char *, const char *, int);
internal_proto(unpack_filename);
+extern stream *init_error_stream (void);
+internal_proto(init_error_stream);
+
/* unit.c */
/* Maximum file offset, computed at library initialization time. */
@@ -867,13 +841,6 @@
size_t);
internal_proto(list_formatted_write);
-/* error.c */
-extern try notify_std (int, const char *);
-internal_proto(notify_std);
-
-extern notification notification_std(int);
-internal_proto(notification_std);
-
/* size_from_kind.c */
extern size_t size_from_real_kind (int);
internal_proto(size_from_real_kind);
@@ -919,7 +886,14 @@
#endif
-/* ../runtime/environ.c This is here because we return unit_convert. */
-unit_convert get_unformatted_convert (int);
-internal_proto(get_unformatted_convert);
+/* util.c */
+
+extern int find_option (struct st_parameter_common *, const char *, int,
+ const st_option *, const char *);
+internal_proto(find_option);
+
+extern void internal_io_error (struct st_parameter_common *, const char *)
+ __attribute__ ((noreturn));
+internal_proto(internal_io_error);
+
Index: io/util.c
===================================================================
--- io/util.c (revision 0)
+++ io/util.c (revision 0)
@@ -0,0 +1,276 @@
+/* Copyright (C) 2006 Free Software Foundation, Inc.
+
+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, 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, 51 Franklin Street, Fifth Floor,
+Boston, MA 02110-1301, USA. */
+
+#include "config.h"
+#include <string.h>
+#include <assert.h>
+#include <stdio.h>
+#include <stdarg.h>
+#include <float.h>
+
+#include "libgfortran.h"
+#include "io.h"
+
+/* Compare a C-style string with a fortran style string in a case-insensitive
+ manner. Used for decoding string options to various statements. Returns
+ zero if not equal, nonzero if equal. */
+
+static int
+compare0 (const char *s1, int s1_len, const char *s2)
+{
+ int len;
+
+ /* Strip trailing blanks from the Fortran string. */
+ len = fstrlen (s1, s1_len);
+ return strncasecmp (s1, s2, len) == 0;
+}
+
+/* Given a fortran string and an array of st_option structures, search through
+ the array to find a match. If the option is not found, we generate an error
+ if no default is provided. */
+
+int
+find_option (st_parameter_common *cmp, const char *s1, int s1_len,
+ const st_option * opts, const char *error_message)
+{
+ for (; opts->name; opts++)
+ if (compare0 (s1, s1_len, opts->name))
+ return opts->value;
+
+ generate_error (cmp, ERROR_BAD_OPTION, error_message);
+
+ return -1;
+}
+
+
+/* st_printf()-- simple printf() function for streams that handles the
+ * formats %d, %s and %c. This function handles printing of error
+ * messages that originate within the library itself, not from a user
+ * program. */
+
+int
+st_printf (const char *format, ...)
+{
+ int count, total;
+ va_list arg;
+ char *p;
+ const char *q;
+ stream *s;
+ char itoa_buf[GFC_ITOA_BUF_SIZE];
+
+ total = 0;
+ s = init_error_stream ();
+ va_start (arg, format);
+
+ for (;;)
+ {
+ count = 0;
+
+ while (format[count] != '%' && format[count] != '\0')
+ count++;
+
+ if (count != 0)
+ {
+ p = salloc_w (s, &count);
+ memmove (p, format, count);
+ sfree (s);
+ }
+
+ total += count;
+ format += count;
+ if (*format++ == '\0')
+ break;
+
+ switch (*format)
+ {
+ case 'c':
+ count = 1;
+
+ p = salloc_w (s, &count);
+ *p = (char) va_arg (arg, int);
+
+ sfree (s);
+ break;
+
+ case 'd':
+ q = gfc_itoa (va_arg (arg, int), itoa_buf, sizeof (itoa_buf));
+ count = strlen (q);
+
+ p = salloc_w (s, &count);
+ memmove (p, q, count);
+ sfree (s);
+ break;
+
+ case 'x':
+ q = xtoa (va_arg (arg, unsigned), itoa_buf, sizeof (itoa_buf));
+ count = strlen (q);
+
+ p = salloc_w (s, &count);
+ memmove (p, q, count);
+ sfree (s);
+ break;
+
+ case 's':
+ q = va_arg (arg, char *);
+ count = strlen (q);
+
+ p = salloc_w (s, &count);
+ memmove (p, q, count);
+ sfree (s);
+ break;
+
+ case '\0':
+ return total;
+
+ default:
+ count = 2;
+ p = salloc_w (s, &count);
+ p[0] = format[-1];
+ p[1] = format[0];
+ sfree (s);
+ break;
+ }
+
+ total += count;
+ format++;
+ }
+
+ va_end (arg);
+ return total;
+}
+
+
+/* show_locus()-- Print a line number and filename describing where
+ * something went wrong */
+
+static void
+show_locus (st_parameter_common *cmp)
+{
+ if (!options.locus || cmp == NULL || cmp->filename == NULL)
+ return;
+
+ st_printf ("At line %d of file %s\n", cmp->line, cmp->filename);
+}
+
+
+/* recursion_check()-- It's possible for additional errors to occur
+ * during fatal error processing. We detect this condition here and
+ * exit with code 4 immediately. */
+
+#define MAGIC 0x20DE8101
+
+static void
+io_recursion_check (void)
+{
+ static int magic = 0;
+
+ /* Don't even try to print something at this point */
+ if (magic == MAGIC)
+ sys_exit (4);
+
+ magic = MAGIC;
+}
+
+
+/* generate_error()-- Come here when an error happens. This
+ * subroutine is called if it is possible to continue on after the error.
+ * If an IOSTAT or IOMSG variable exists, we set it. If IOSTAT or
+ * ERR labels are present, we return, otherwise we terminate the program
+ * after printing a message. The error code is always required but the
+ * message parameter can be NULL, in which case a string describing
+ * the most recent operating system error is used. */
+
+void
+generate_error (st_parameter_common *cmp, int family, const char *message)
+{
+ /* Set the error status. */
+ if ((cmp->flags & IOPARM_HAS_IOSTAT))
+ *cmp->iostat = family;
+
+ if (message == NULL)
+ message =
+ (family == ERROR_OS) ? get_oserror () : translate_error (family);
+
+ if (cmp->flags & IOPARM_HAS_IOMSG)
+ cf_strcpy (cmp->iomsg, cmp->iomsg_len, message);
+
+ /* Report status back to the compiler. */
+ cmp->flags &= ~IOPARM_LIBRETURN_MASK;
+ switch (family)
+ {
+ case ERROR_EOR:
+ cmp->flags |= IOPARM_LIBRETURN_EOR;
+ if ((cmp->flags & IOPARM_EOR))
+ return;
+ break;
+
+ case ERROR_END:
+ cmp->flags |= IOPARM_LIBRETURN_END;
+ if ((cmp->flags & IOPARM_END))
+ return;
+ break;
+
+ default:
+ cmp->flags |= IOPARM_LIBRETURN_ERROR;
+ if ((cmp->flags & IOPARM_ERR))
+ return;
+ break;
+ }
+
+ /* Return if the user supplied an iostat variable. */
+ if ((cmp->flags & IOPARM_HAS_IOSTAT))
+ return;
+
+ /* Terminate the program */
+
+ io_recursion_check ();
+ show_locus (cmp);
+ st_printf ("Fortran runtime error: %s\n", message);
+ sys_exit (2);
+}
+
+
+/* void internal_io_error()-- These are this-can't-happen errors
+ * that indicate something deeply wrong. */
+
+void
+internal_io_error (st_parameter_common *cmp, const char *message)
+{
+ io_recursion_check ();
+ show_locus (cmp);
+ st_printf ("Internal Error: %s\n", message);
+
+ /* This function call is here to get the main.o object file included
+ when linking statically. This works because error.o is supposed to
+ be always linked in (and the function call is in internal_io_error
+ because hopefully it doesn't happen too often). */
+ stupid_function_name_for_static_linking();
+
+ sys_exit (3);
+}
+
Index: io/unit.c
===================================================================
--- io/unit.c (revision 114961)
+++ io/unit.c (working copy)
@@ -171,7 +171,7 @@
}
if (c == 0)
- internal_error (NULL, "insert(): Duplicate key found!");
+ internal_io_error (NULL, "insert(): Duplicate key found!");
return t;
}
@@ -643,3 +643,43 @@
close_unit_1 (unit_root, 1);
__gthread_mutex_unlock (&unit_lock);
}
+
+
+int
+unit_fgetc (const int unit, char * c)
+{
+ int ret;
+ size_t s;
+ gfc_unit * u = find_unit (unit);
+
+ if (u == NULL)
+ return -1;
+
+ s = 1;
+ ret = sread (u->s, c, &s);
+ unlock_unit (u);
+
+ if (ret != 0)
+ return ret;
+
+ if (s != 1)
+ return -1;
+ else
+ return 0;
+}
+
+int
+unit_fputc (const int unit, char * c)
+{
+ int ret;
+ size_t s;
+ gfc_unit * u = find_unit (unit);
+
+ if (u == NULL)
+ return -1;
+
+ s = 1;
+ ret = swrite (u->s, c, &s);
+ unlock_unit (u);
+ return ret;
+}
Index: io/unix.c
===================================================================
--- io/unix.c (revision 114961)
+++ io/unix.c (working copy)
@@ -45,8 +45,36 @@
#include "libgfortran.h"
#include "io.h"
-#include "unix.h"
+#define BUFFER_SIZE 8192
+
+typedef struct
+{
+ stream st;
+
+ int fd;
+ gfc_offset buffer_offset; /* File offset of the start of the buffer */
+ gfc_offset physical_offset; /* Current physical file offset */
+ gfc_offset logical_offset; /* Current logical file offset */
+ gfc_offset dirty_offset; /* Start of modified bytes in buffer */
+ gfc_offset file_length; /* Length of the file, -1 if not seekable. */
+
+ char *buffer;
+ int len; /* Physical length of the current buffer */
+ int active; /* Length of valid bytes in the buffer */
+
+ int prot;
+ int ndirty; /* Dirty bytes starting at dirty_offset */
+
+ int special_file; /* =1 if the fd refers to a special file */
+
+ unsigned unbuffered:1;
+
+ char small_buffer[BUFFER_SIZE];
+
+}
+unix_stream;
+
#ifndef SSIZE_MAX
#define SSIZE_MAX SHRT_MAX
#endif
@@ -1021,7 +1049,7 @@
/* Given the Fortran unit number, convert it to a C file descriptor. */
int
-unit_to_fd (int unit)
+unit_to_fd (const int unit)
{
gfc_unit *us;
int fd;
@@ -1150,7 +1178,7 @@
break;
default:
- internal_error (&opp->common, "regular_file(): Bad action");
+ internal_io_error (&opp->common, "regular_file(): Bad action");
}
switch (flags->status)
@@ -1173,7 +1201,7 @@
break;
default:
- internal_error (&opp->common, "regular_file(): Bad status");
+ internal_io_error (&opp->common, "regular_file(): Bad status");
}
/* rwflag |= O_LARGEFILE; */
@@ -1266,7 +1294,7 @@
break;
default:
- internal_error (&opp->common, "open_external(): Bad action");
+ internal_io_error (&opp->common, "open_external(): Bad action");
}
return fd_to_stream (fd, prot);
@@ -1308,8 +1336,11 @@
* corrupted. */
stream *
-init_error_stream (unix_stream *error)
+init_error_stream (void)
{
+ unix_stream *error;
+
+ error = malloc (sizeof (*error));
memset (error, '\0', sizeof (*error));
error->fd = options.use_stderr ? STDERR_FILENO : STDOUT_FILENO;
@@ -1508,7 +1539,19 @@
while (1);
}
+void
+flush_unit (const int unit)
+{
+ gfc_unit *us;
+ us = find_unit (unit);
+ if (us != NULL)
+ {
+ flush (us->s);
+ unlock_unit (us);
+ }
+}
+
/* stream_at_bof()-- Returns nonzero if the stream is at the beginning
* of the file. */
@@ -1749,16 +1792,38 @@
}
int
-stream_isatty (stream *s)
+unit_isatty (const int unit)
{
- return isatty (((unix_stream *) s)->fd);
+ int ret;
+ gfc_unit *u = find_unit (unit);
+
+ if (u != NULL)
+ {
+ ret = isatty (((unix_stream *) u->s)->fd);
+ unlock_unit (u);
+ }
+ else
+ ret = 0;
+
+ return ret;
}
char *
-stream_ttyname (stream *s)
+unit_ttyname (const int unit)
{
#ifdef HAVE_TTYNAME
- return ttyname (((unix_stream *) s)->fd);
+ char * n;
+ gfc_unit *u = find_unit (unit);
+
+ if (u != NULL)
+ {
+ n = ttyname (((unix_stream *) u->s)->fd);
+ unlock_unit (u);
+ }
+ else
+ n = NULL;
+
+ return n;
#else
return NULL;
#endif
Index: Makefile.am
===================================================================
--- Makefile.am (revision 114961)
+++ Makefile.am (working copy)
@@ -33,11 +33,20 @@
io/transfer.c \
io/unit.c \
io/unix.c \
+io/util.c \
io/write.c
+gfor_io_obj = $(notdir $(gfor_io_src:.c=.lo))
+
gfor_io_headers= \
io/io.h
+$(gfor_io_obj): $(gfor_io_headers)
+
+gfor_global_headers= \
+libgfortran.h \
+c99_protos.h
+
gfor_helper_src= \
intrinsics/associated.c \
intrinsics/abort.c \
@@ -109,9 +118,7 @@
runtime/pause.c \
runtime/stop.c \
runtime/string.c \
-runtime/select.c \
-gfortypes.h \
-libgfortran.h
+runtime/select.c
i_all_c= \
generated/all_l4.c \
@@ -593,8 +600,11 @@
BUILT_SOURCES=$(gfor_built_src) $(gfor_built_specific_src) \
$(gfor_built_specific2_src)
libgfortran_la_SOURCES = $(gfor_src) $(gfor_built_src) $(gfor_io_src) \
- $(gfor_helper_src) $(gfor_io_headers) $(gfor_specific_src)
+ $(gfor_helper_src) $(gfor_specific_src)
+# Everything depends on the global headers
+$(patsubst %.c,%.lo,$(notdir $(libgfortran_la_SOURCES))): $(gfor_global_headers)
+
I_M4_DEPS=m4/iparm.m4
I_M4_DEPS0=$(I_M4_DEPS) m4/iforeach.m4
I_M4_DEPS1=$(I_M4_DEPS) m4/ifunction.m4
Index: intrinsics/system_clock.c
===================================================================
--- intrinsics/system_clock.c (revision 114961)
+++ intrinsics/system_clock.c (working copy)
@@ -69,7 +69,7 @@
struct timezone tzp;
if (sizeof (tp1.tv_sec) < sizeof (GFC_INTEGER_4))
- internal_error (NULL, "tv_sec too small");
+ internal_error ("tv_sec too small");
if (gettimeofday(&tp1, &tzp) == 0)
{
@@ -96,7 +96,7 @@
GFC_UINTEGER_4 ucnt;
if (sizeof (time_t) < sizeof (GFC_INTEGER_4))
- internal_error (NULL, "time_t too small");
+ internal_error ("time_t too small");
ucnt = time (NULL);
if (ucnt > GFC_INTEGER_4_HUGE)
@@ -132,7 +132,7 @@
struct timezone tzp;
if (sizeof (tp1.tv_sec) < sizeof (GFC_INTEGER_4))
- internal_error (NULL, "tv_sec too small");
+ internal_error ("tv_sec too small");
if (gettimeofday(&tp1, &tzp) == 0)
{
@@ -171,7 +171,7 @@
}
#elif defined(HAVE_TIME_H)
if (sizeof (time_t) < sizeof (GFC_INTEGER_4))
- internal_error (NULL, "time_t too small");
+ internal_error ("time_t too small");
else if (sizeof (time_t) == sizeof (GFC_INTEGER_4))
{
GFC_UINTEGER_4 ucnt = time (NULL);
Index: io/open.c
===================================================================
--- io/open.c (revision 114961)
+++ io/open.c (working copy)
@@ -338,7 +338,7 @@
break;
default:
- internal_error (&opp->common, "new_unit(): Bad status");
+ internal_io_error (&opp->common, "new_unit(): Bad status");
}
/* Make sure the file isn't already open someplace else.
@@ -376,7 +376,7 @@
u->file = get_mem (opp->file_len);
if (u->unit_number != opp->common.unit)
- internal_error (&opp->common, "Unit number changed");
+ internal_io_error (&opp->common, "Unit number changed");
u->s = s;
u->flags = *flags;
u->read_bad = 0;
@@ -592,7 +592,7 @@
break;
default:
- internal_error (&opp->common, "Illegal value for CONVERT");
+ internal_io_error (&opp->common, "Illegal value for CONVERT");
break;
}
Index: io/list_read.c
===================================================================
--- io/list_read.c (revision 114961)
+++ io/list_read.c (working copy)
@@ -1542,7 +1542,7 @@
read_complex (dtp, kind, size);
break;
default:
- internal_error (&dtp->common, "Bad type for list read");
+ internal_io_error (&dtp->common, "Bad type for list read");
}
if (dtp->u.p.saved_type != BT_CHARACTER && dtp->u.p.saved_type != BT_NULL)
@@ -2161,7 +2161,7 @@
default:
st_sprintf (nml_err_msg, "Bad type for namelist object %s",
nl->var_name);
- internal_error (&dtp->common, nml_err_msg);
+ internal_io_error (&dtp->common, nml_err_msg);
goto nml_err_ret;
}
}
Index: io/read.c
===================================================================
--- io/read.c (revision 114961)
+++ io/read.c (working copy)
@@ -80,7 +80,7 @@
}
break;
default:
- internal_error (NULL, "Bad integer kind");
+ internal_io_error (NULL, "Bad integer kind");
}
}
@@ -119,7 +119,7 @@
value = signed_flag ? 0x7f : 0xff;
break;
default:
- internal_error (NULL, "Bad integer kind");
+ internal_io_error (NULL, "Bad integer kind");
}
return value;
@@ -172,7 +172,7 @@
break;
#endif
default:
- internal_error (&dtp->common, "Unsupported real kind during IO");
+ internal_io_error (&dtp->common, "Unsupported real kind during IO");
}
if (errno != 0 && errno != EINVAL)
@@ -688,7 +688,7 @@
#endif
default:
- internal_error (&dtp->common, "Unsupported real kind during IO");
+ internal_io_error (&dtp->common, "Unsupported real kind during IO");
}
return;
Index: io/inquire.c
===================================================================
--- io/inquire.c (revision 114961)
+++ io/inquire.c (working copy)
@@ -76,7 +76,7 @@
p = "DIRECT";
break;
default:
- internal_error (&iqp->common, "inquire_via_unit(): Bad access");
+ internal_io_error (&iqp->common, "inquire_via_unit(): Bad access");
}
cf_strcpy (iqp->access, iqp->access_len, p);
@@ -120,7 +120,7 @@
p = "UNFORMATTED";
break;
default:
- internal_error (&iqp->common, "inquire_via_unit(): Bad form");
+ internal_io_error (&iqp->common, "inquire_via_unit(): Bad form");
}
cf_strcpy (iqp->form, iqp->form_len, p);
@@ -162,7 +162,7 @@
p = "ZERO";
break;
default:
- internal_error (&iqp->common, "inquire_via_unit(): Bad blank");
+ internal_io_error (&iqp->common, "inquire_via_unit(): Bad blank");
}
cf_strcpy (iqp->blank, iqp->blank_len, p);
@@ -211,7 +211,7 @@
p = "READWRITE";
break;
default:
- internal_error (&iqp->common, "inquire_via_unit(): Bad action");
+ internal_io_error (&iqp->common, "inquire_via_unit(): Bad action");
}
cf_strcpy (iqp->action, iqp->action_len, p);
@@ -258,7 +258,7 @@
p = "APOSTROPHE";
break;
default:
- internal_error (&iqp->common, "inquire_via_unit(): Bad delim");
+ internal_io_error (&iqp->common, "inquire_via_unit(): Bad delim");
}
cf_strcpy (iqp->delim, iqp->delim_len, p);
@@ -278,7 +278,7 @@
p = "YES";
break;
default:
- internal_error (&iqp->common, "inquire_via_unit(): Bad pad");
+ internal_io_error (&iqp->common, "inquire_via_unit(): Bad pad");
}
cf_strcpy (iqp->pad, iqp->pad_len, p);
@@ -301,7 +301,7 @@
break;
default:
- internal_error (&iqp->common, "inquire_via_unit(): Bad convert");
+ internal_io_error (&iqp->common, "inquire_via_unit(): Bad convert");
}
cf_strcpy (iqp->convert, iqp->convert_len, p);
Index: io/transfer.c
===================================================================
--- io/transfer.c (revision 114961)
+++ io/transfer.c (working copy)
@@ -572,7 +572,7 @@
p = "COMPLEX";
break;
default:
- internal_error (NULL, "type_name(): Bad type");
+ internal_io_error (NULL, "type_name(): Bad type");
}
return p;
@@ -893,7 +893,7 @@
break;
default:
bad_type:
- internal_error (&dtp->common,
+ internal_io_error (&dtp->common,
"formatted_transfer(): Bad type");
}
@@ -1057,7 +1057,7 @@
break;
default:
- internal_error (&dtp->common, "Bad format node");
+ internal_io_error (&dtp->common, "Bad format node");
}
/* Free a buffer that we had to allocate during a sequential
@@ -1218,11 +1218,11 @@
kind = charlen;
break;
case GFC_DTYPE_DERIVED:
- internal_error (&dtp->common,
+ internal_io_error (&dtp->common,
"Derived type I/O should have been handled via the frontend.");
break;
default:
- internal_error (&dtp->common, "transfer_array(): Bad type");
+ internal_io_error (&dtp->common, "transfer_array(): Bad type");
}
if (desc->dim[0].stride == 0)
@@ -1493,7 +1493,7 @@
break;
default:
- internal_error (&opp.common, "Illegal value for CONVERT");
+ internal_io_error (&opp.common, "Illegal value for CONVERT");
break;
}
Index: io/write.c
===================================================================
--- io/write.c (revision 114961)
+++ io/write.c (working copy)
@@ -115,7 +115,7 @@
break;
#endif
default:
- internal_error (NULL, "bad integer kind");
+ internal_io_error (NULL, "bad integer kind");
}
return i;
@@ -169,7 +169,7 @@
break;
#endif
default:
- internal_error (NULL, "bad integer kind");
+ internal_io_error (NULL, "bad integer kind");
}
return i;
@@ -214,7 +214,7 @@
break;
#endif
default:
- internal_error (NULL, "bad real kind");
+ internal_io_error (NULL, "bad real kind");
}
return i;
}
@@ -417,7 +417,7 @@
/* We should always know the field width and precision. */
if (d < 0)
- internal_error (&dtp->common, "Unspecified precision");
+ internal_io_error (&dtp->common, "Unspecified precision");
/* Use sprintf to print the number in the format +D.DDDDe+ddd
For an N digit exponent, this gives us (MIN_FIELD_WIDTH-5)-N digits
@@ -481,7 +481,7 @@
/* Check the resulting string has punctuation in the correct places. */
if (d != 0 && (buffer[2] != '.' || buffer[ndigits + 2] != 'e'))
- internal_error (&dtp->common, "printf is broken");
+ internal_io_error (&dtp->common, "printf is broken");
/* Read the exponent back in. */
e = atoi (&buffer[ndigits + 3]) + 1;
@@ -577,7 +577,7 @@
default:
/* Should never happen. */
- internal_error (&dtp->common, "Unexpected format token");
+ internal_io_error (&dtp->common, "Unexpected format token");
}
/* Round the value. */
@@ -1394,7 +1394,7 @@
f.u.real.e = 4;
break;
default:
- internal_error (&dtp->common, "bad real kind");
+ internal_io_error (&dtp->common, "bad real kind");
break;
}
write_float (dtp, &f, source , length);
@@ -1473,7 +1473,7 @@
write_complex (dtp, p, kind, size);
break;
default:
- internal_error (&dtp->common, "list_formatted_write(): Bad type");
+ internal_io_error (&dtp->common, "list_formatted_write(): Bad type");
}
dtp->u.p.char_flag = (type == BT_CHARACTER);
@@ -1731,7 +1731,7 @@
goto obj_loop;
default:
- internal_error (&dtp->common, "Bad type for namelist write");
+ internal_io_error (&dtp->common, "Bad type for namelist write");
}
/* Reset the leading blank suppression, write a comma and, if 5