diff options
author | Diego Novillo <dnovillo@gcc.gnu.org> | 2004-05-13 02:41:07 -0400 |
---|---|---|
committer | Diego Novillo <dnovillo@gcc.gnu.org> | 2004-05-13 02:41:07 -0400 |
commit | 6de9cd9a886ea695aa892c3c7c07818a7b7e9e6f (patch) | |
tree | a2568888a519c077427b133de9ece5879a8484a5 /libgfortran/runtime | |
parent | ac1a20aec53364d77f3bdff94a2a0a06840e0fe9 (diff) | |
download | gcc-6de9cd9a886ea695aa892c3c7c07818a7b7e9e6f.zip gcc-6de9cd9a886ea695aa892c3c7c07818a7b7e9e6f.tar.gz gcc-6de9cd9a886ea695aa892c3c7c07818a7b7e9e6f.tar.bz2 |
Merge tree-ssa-20020619-branch into mainline.
From-SVN: r81764
Diffstat (limited to 'libgfortran/runtime')
-rw-r--r-- | libgfortran/runtime/environ.c | 678 | ||||
-rw-r--r-- | libgfortran/runtime/error.c | 538 | ||||
-rw-r--r-- | libgfortran/runtime/in_pack_generic.c | 123 | ||||
-rw-r--r-- | libgfortran/runtime/in_unpack_generic.c | 120 | ||||
-rw-r--r-- | libgfortran/runtime/main.c | 113 | ||||
-rw-r--r-- | libgfortran/runtime/memory.c | 312 | ||||
-rw-r--r-- | libgfortran/runtime/pause.c | 71 | ||||
-rw-r--r-- | libgfortran/runtime/select.c | 125 | ||||
-rw-r--r-- | libgfortran/runtime/stop.c | 56 | ||||
-rw-r--r-- | libgfortran/runtime/string.c | 120 |
10 files changed, 2256 insertions, 0 deletions
diff --git a/libgfortran/runtime/environ.c b/libgfortran/runtime/environ.c new file mode 100644 index 0000000..7141961 --- /dev/null +++ b/libgfortran/runtime/environ.c @@ -0,0 +1,678 @@ +/* Copyright (C) 2002-2003 Free Software Foundation, Inc. + Contributed by Andy Vaught + +This file is part of the GNU Fortran 95 runtime library (libgfor). + +Libgfor 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. + +Libgfor 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 libgfor; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +#include "config.h" +#include <string.h> +#include <stdlib.h> +#include <ctype.h> + +#include "libgfortran.h" +#include "../io/io.h" + + +/* Environment scanner. Examine the environment for controlling minor + * aspects of the program's execution. Our philosophy here that the + * environment should not prevent the program from running, so an + * environment variable with a messed-up value will be interpreted in + * the default way. + * + * Most of the environment is checked early in the startup sequence, + * but other variables are checked during execution of the user's + * program. */ + +options_t options; + +extern char **environ; + +typedef struct variable +{ + const char *name; + int value, *var; + void (*init) (struct variable *); + void (*show) (struct variable *); + const char *desc; + int bad; +} +variable; + + +/* print_spaces()-- Print a particular number of spaces */ + +static void +print_spaces (int n) +{ + char buffer[80]; + int i; + + if (n <= 0) + return; + + for (i = 0; i < n; i++) + buffer[i] = ' '; + + buffer[i] = '\0'; + + st_printf (buffer); +} + + +/* var_source()-- Return a string that describes where the value of a + * variable comes from */ + +static const char * +var_source (variable * v) +{ + + if (getenv (v->name) == NULL) + return "Default"; + + if (v->bad) + return "Bad "; + + return "Set "; +} + + +/* init_integer()-- Initialize an integer environment variable */ + +static void +init_integer (variable * v) +{ + char *p, *q; + + p = getenv (v->name); + if (p == NULL) + goto set_default; + + for (q = p; *q; q++) + if (!isdigit (*q)) + { + v->bad = 1; + goto set_default; + } + + *v->var = atoi (p); + return; + +set_default: + *v->var = v->value; + return; +} + + +/* show_integer()-- Show an integer environment variable */ + +static void +show_integer (variable * v) +{ + + st_printf ("%s %d\n", var_source (v), *v->var); +} + + +/* init_boolean()-- Initialize a boolean environment variable. We + * only look at the first letter of the variable. */ + +static void +init_boolean (variable * v) +{ + char *p; + + p = getenv (v->name); + if (p == NULL) + goto set_default; + + if (*p == '1' || *p == 'Y' || *p == 'y') + { + *v->var = 1; + return; + } + + if (*p == '0' || *p == 'N' || *p == 'n') + { + *v->var = 0; + return; + } + + v->bad = 1; + +set_default: + *v->var = v->value; + return; +} + + +/* show_boolean()-- Show a boolean environment variable */ + +static void +show_boolean (variable * v) +{ + + st_printf ("%s %s\n", var_source (v), *v->var ? "Yes" : "No"); +} + + +/* init_mem()-- Initialize environment variables that have to do with + * how memory from an ALLOCATE statement is filled. A single flag + * enables filling and a second variable gives the value that is used + * to initialize the memory. */ + +static void +init_mem (variable * v) +{ + int offset, n; + char *p; + + p = getenv (v->name); + + options.allocate_init_flag = 0; /* The default */ + + if (p == NULL) + return; + + if (strcasecmp (p, "NONE") == 0) + return; + + /* IEEE-754 Quiet Not-a-Number that will work for single and double + * precision. Look for the 'f95' mantissa in debug dumps. */ + + if (strcasecmp (p, "NaN") == 0) + { + options.allocate_init_flag = 1; + options.allocate_init_value = 0xfff80f95; + return; + } + + /* Interpret the string as a hexadecimal constant */ + + n = 0; + while (*p) + { + if (!isxdigit (*p)) + { + v->bad = 1; + return; + } + + offset = '0'; + if (islower (*p)) + offset = 'a'; + if (isupper (*p)) + offset = 'A'; + + n = (n << 4) | (*p++ - offset); + } + + options.allocate_init_flag = 1; + options.allocate_init_value = n; +} + + +static void +show_mem (variable * v) +{ + char *p; + + p = getenv (v->name); + + st_printf ("%s ", var_source (v)); + + if (options.allocate_init_flag) + st_printf ("0x%x", options.allocate_init_value); + + st_printf ("\n"); +} + + +static void +init_sep (variable * v) +{ + int seen_comma; + char *p; + + p = getenv (v->name); + if (p == NULL) + goto set_default; + + v->bad = 1; + options.separator = p; + options.separator_len = strlen (p); + + /* Make sure the separator is valid */ + + if (options.separator_len == 0) + goto set_default; + seen_comma = 0; + + while (*p) + { + if (*p == ',') + { + if (seen_comma) + goto set_default; + seen_comma = 1; + p++; + continue; + } + + if (*p++ != ' ') + goto set_default; + } + + v->bad = 0; + return; + +set_default: + options.separator = " "; + options.separator_len = 1; +} + + +static void +show_sep (variable * v) +{ + + st_printf ("%s \"%s\"\n", var_source (v), options.separator); +} + + +static void +init_string (variable * v) +{ +} + +static void +show_string (variable * v) +{ + const char *p; + + p = getenv (v->name); + if (p == NULL) + p = ""; + + st_printf ("%s \"%s\"\n", var_source (v), p); +} + + +/* Structure for associating names and values. */ + +typedef struct +{ + const char *name; + int value; +} +choice; + + +enum +{ FP_ROUND_NEAREST, FP_ROUND_UP, FP_ROUND_DOWN, FP_ROUND_ZERO }; + +static choice rounding[] = { + {"NEAREST", FP_ROUND_NEAREST}, + {"UP", FP_ROUND_UP}, + {"DOWN", FP_ROUND_DOWN}, + {"ZERO", FP_ROUND_ZERO}, + {NULL} +}, precision[] = +{ + { + "24", 1} + , + { + "53", 2} + , + { + "64", 0} + , + { + NULL} +} + +, signal_choices[] = +{ + { + "IGNORE", 1} + , + { + "ABORT", 0} + , + { + NULL} +}; + + +static void +init_choice (variable * v, choice * c) +{ + char *p; + + p = getenv (v->name); + if (p == NULL) + goto set_default; + + for (; c->name; c++) + if (strcasecmp (c->name, p) == 0) + break; + + if (c->name == NULL) + { + v->bad = 1; + goto set_default; + } + + *v->var = c->value; + return; + +set_default: + *v->var = v->value; +} + + +static void +show_choice (variable * v, choice * c) +{ + + st_printf ("%s ", var_source (v)); + + for (; c->name; c++) + if (c->value == *v->var) + break; + + if (c->name) + st_printf ("%s\n", c->name); + else + st_printf ("(Unknown)\n"); + +} + + +static void +init_round (variable * v) +{ + init_choice (v, rounding); +} +static void +show_round (variable * v) +{ + show_choice (v, rounding); +} + +static void +init_precision (variable * v) +{ + init_choice (v, precision); +} +static void +show_precision (variable * v) +{ + show_choice (v, precision); +} + +static void +init_signal (variable * v) +{ + init_choice (v, signal_choices); +} +static void +show_signal (variable * v) +{ + show_choice (v, signal_choices); +} + + +static variable variable_table[] = { + {"GFORTRAN_STDIN_UNIT", 5, &options.stdin_unit, init_integer, show_integer, + "Unit number that will be preconnected to standard input\n" + "(No preconnection if negative)"}, + + {"GFORTRAN_STDOUT_UNIT", 6, &options.stdout_unit, init_integer, + show_integer, + "Unit number that will be preconnected to standard output\n" + "(No preconnection if negative)"}, + + {"GFORTRAN_USE_STDERR", 1, &options.use_stderr, init_boolean, + show_boolean, + "Sends library output to standard error instead of standard output."}, + + {"GFORTRAN_TMPDIR", 0, NULL, init_string, show_string, + "Directory for scratch files. Overrides the TMP environment variable\n" + "If TMP is not set " DEFAULT_TEMPDIR " is used."}, + + {"GFORTRAN_UNBUFFERED_ALL", 0, &options.all_unbuffered, init_boolean, + show_boolean, + "If TRUE, all output is unbuffered. This will slow down large writes " + "but can be\nuseful for forcing data to be displayed immediately."}, + + {"GFORTRAN_SHOW_LOCUS", 1, &options.locus, init_boolean, show_boolean, + "If TRUE, print filename and line number where runtime errors happen."}, + +/* GFORTRAN_NAME_xx (where xx is a unit number) gives the names of files + * preconnected to those units. */ + +/* GFORTRAN_UNBUFFERED_xx (where xx is a unit number) gives a boolean that is used + * to turn off buffering for that unit. */ + + {"GFORTRAN_OPTIONAL_PLUS", 0, &options.optional_plus, init_boolean, show_boolean, + "Print optional plus signs in numbers where permitted. Default FALSE."}, + + {"GFORTRAN_DEFAULT_RECL", DEFAULT_RECL, &options.default_recl, + init_integer, show_integer, + "Default maximum record length for sequential files. Most useful for\n" + "adjusting line length of preconnected units. Default " + stringize (DEFAULT_RECL)}, + + {"GFORTRAN_LIST_SEPARATOR", 0, NULL, init_sep, show_sep, + "Separatator to use when writing list output. May contain any number of " + "spaces\nand at most one comma. Default is a single space."}, + + /* Memory related controls */ + + {"GFORTRAN_MEM_INIT", 0, NULL, init_mem, show_mem, + "How to initialize allocated memory. Default value is NONE for no " + "initialization\n(faster), NAN for a Not-a-Number with the mantissa " + "0x40f95 or a custom\nhexadecimal value"}, + + {"GFORTRAN_MEM_CHECK", 0, &options.mem_check, init_boolean, show_boolean, + "Whether memory still allocated will be reported when the program ends."}, + + /* Signal handling (Unix). */ + + {"GFORTRAN_SIGHUP", 0, &options.sighup, init_signal, show_signal, + "Whether the program will IGNORE or ABORT on SIGHUP."}, + + {"GFORTRAN_SIGINT", 0, &options.sigint, init_signal, show_signal, + "Whether the program will IGNORE or ABORT on SIGINT."}, + + /* Floating point control */ + + {"GFORTRAN_FPU_ROUND", 0, &options.fpu_round, init_round, show_round, + "Set floating point rounding. Values are NEAREST, UP, DOWN, ZERO."}, + + {"GFORTRAN_FPU_PRECISION", 0, &options.fpu_precision, init_precision, + show_precision, + "Precision of intermediate results. Values are 24, 53 and 64."}, + + {"GFORTRAN_FPU_INVALID", 1, &options.fpu_invalid, init_boolean, + show_boolean, + "Raise a floating point exception on invalid FP operation."}, + + {"GFORTRAN_FPU_DENORMAL", 1, &options.fpu_denormal, init_boolean, + show_boolean, + "Raise a floating point exception when denormal numbers are encountered."}, + + {"GFORTRAN_FPU_ZERO", 0, &options.fpu_zerodiv, init_boolean, show_boolean, + "Raise a floating point exception when dividing by zero."}, + + {"GFORTRAN_FPU_OVERFLOW", 0, &options.fpu_overflow, init_boolean, + show_boolean, + "Raise a floating point exception on overflow."}, + + {"GFORTRAN_FPU_UNDERFLOW", 0, &options.fpu_underflow, init_boolean, + show_boolean, + "Raise a floating point exception on underflow."}, + + {"GFORTRAN_FPU_PRECISION", 0, &options.fpu_precision_loss, init_boolean, + show_boolean, + "Raise a floating point exception on precision loss."}, + + {NULL} +}; + + +/* init_variables()-- Initialize most runtime variables from + * environment variables. */ + +void +init_variables (void) +{ + variable *v; + + for (v = variable_table; v->name; v++) + v->init (v); +} + + +/* check_buffered()-- Given an unit number n, determine if an override + * for the stream exists. Returns zero for unbuffered, one for + * buffered or two for not set. */ + +int +check_buffered (int n) +{ + char name[40]; + variable v; + int rv; + + if (options.all_unbuffered) + return 0; + + strcpy (name, "GFORTRAN_UNBUFFERED_"); + strcat (name, itoa (n)); + + v.name = name; + v.value = 2; + v.var = &rv; + + init_boolean (&v); + + return rv; +} + + +/* pattern_scan()-- Given an environment string, check that the name + * has the same name as the pattern followed by an integer. On a + * match, a pointer to the value is returned and the integer pointed + * to by n is updated. Returns NULL on no match. */ + +static char * +pattern_scan (char *env, const char *pattern, int *n) +{ + char *p; + size_t len; + + len = strlen (pattern); + if (strncasecmp (env, pattern, len) != 0) + return NULL; + p = env + len; + + if (!isdigit (*p)) + return NULL; + + while (isdigit (*p)) + p++; + + if (*p != '=') + return NULL; + + *p = '\0'; + *n = atoi (env + len); + *p++ = '='; + + return p; +} + + +void +show_variables (void) +{ + char *p, **e; + variable *v; + int n; +/* TODO: print version number. */ + st_printf ("GNU Fortran 95 runtime library version " + "UNKNOWN" "\n\n"); + + st_printf ("Environment variables:\n"); + st_printf ("----------------------\n"); + + for (v = variable_table; v->name; v++) + { + n = st_printf ("%s", v->name); + print_spaces (25 - n); + + if (v->show == show_integer) + st_printf ("Integer "); + else if (v->show == show_boolean) + st_printf ("Boolean "); + else + st_printf ("String "); + + v->show (v); + st_printf ("%s\n\n", v->desc); + } + + st_printf ("\nDefault unit names (GFORTRAN_NAME_x):\n"); + + for (e = environ; *e; e++) + { + p = pattern_scan (*e, "GFORTRAN_NAME_", &n); + if (p == NULL) + continue; + st_printf ("GFORTRAN_NAME_%d %s\n", n, p); + } + + st_printf ("\nUnit buffering overrides (GFORTRAN_UNBUFFERED_x):\n"); + for (e = environ; *e; e++) + { + p = pattern_scan (*e, "GFORTRAN_UNBUFFERED_", &n); + if (p == NULL) + continue; + + st_printf ("GFORTRAN_UNBUFFERED_%d = %s\n", n, p); + } + + /* System error codes */ + + st_printf ("\nRuntime error codes:"); + st_printf ("\n--------------------\n"); + + for (n = ERROR_FIRST + 1; n < ERROR_LAST; n++) + if (n < 0 || n > 9) + st_printf ("%d %s\n", n, translate_error (n)); + else + st_printf (" %d %s\n", n, translate_error (n)); + + st_printf ("\nCommand line arguments:\n"); + st_printf (" --help Print this list\n"); + + /* st_printf(" --resume <dropfile> Resume program execution from dropfile\n"); */ + + sys_exit (0); +} diff --git a/libgfortran/runtime/error.c b/libgfortran/runtime/error.c new file mode 100644 index 0000000..8cd980d --- /dev/null +++ b/libgfortran/runtime/error.c @@ -0,0 +1,538 @@ +/* Copyright (C) 2002-2003 Free Software Foundation, Inc. + Contributed by Andy Vaught + +This file is part of the GNU Fortran 95 runtime library (libgfor). + +Libgfor 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. + +Libgfor 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 libgfor; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + + +#include "config.h" +#include <stdio.h> +#include <stdarg.h> +#include <string.h> +#include <float.h> + +#include "libgfortran.h" +#include "../io/io.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 + * try and print something making the fewest assumptions possible, + * then try to clean up before actually exiting. + * + * The following exit conditions are defined: + * 0 Normal program exit. + * 1 Terminated because of operating system error. + * 2 Error in the runtime library + * 3 Internal error in runtime library + * 4 Error during error processing (very bad) + * + * Other error returns are reserved for the STOP statement with a numeric code. + */ + +/* locus variables. These are optionally set by a caller before a + * library subroutine is called. They are always cleared on exit so + * that files that report loci and those that do not can be linked + * together without reporting an erroneous position. */ + +char *filename; +unsigned line; + +static char buffer[32]; /* buffer for integer/ascii conversions */ + +/* rtoa()-- Real to ascii conversion for base 10 and below. + * Returns a pointer to a static buffer. */ + +char * +rtoa (double f, int length, int oprec) +{ + double n = f; + double fval, minval; + int negative, prec; + unsigned k; + char formats[16]; + + prec = 0; + negative = 0; + if (n < 0.0) + { + negative = 1; + n = -n; + } + + if (length >= 8) + minval = FLT_MIN; + else + minval = DBL_MIN; + + + if (n <= minval) + { + buffer[0] = '0'; + buffer[1] = '.'; + for (k = 2; k < 28 ; k++) + buffer[k] = '0'; + buffer[k+1] = '\0'; + return buffer; + } + fval = n; + while (fval > 1.0) + { + fval = fval / 10.0; + prec ++; + } + + prec = sizeof (buffer) - 2 - prec; + if (prec > 20) + prec = 20; + prec = prec > oprec ? oprec : prec ; + + if (negative) + sprintf (formats, "-%%.%df", prec); + else + sprintf (formats, "%%.%df", prec); + + sprintf (buffer, formats, n); + return buffer; +} + + +/* Returns a pointer to a static buffer. */ + +char * +itoa (int64_t n) +{ + int negative; + char *p; + + if (n == 0) + { + buffer[0] = '0'; + buffer[1] = '\0'; + return buffer; + } + + negative = 0; + if (n < 0) + { + negative = 1; + n = -n; + } + + p = buffer + sizeof (buffer) - 1; + *p-- = '\0'; + + while (n != 0) + { + *p-- = '0' + (n % 10); + n /= 10; + } + + if (negative) + *p-- = '-'; + return ++p; +} + + +/* xtoa()-- Integer to hexadecimal conversion. Returns a pointer to a + * static buffer. */ + +char * +xtoa (uint64_t n) +{ + int digit; + char *p; + + if (n == 0) + { + buffer[0] = '0'; + buffer[1] = '\0'; + return buffer; + } + + p = buffer + sizeof (buffer) - 1; + *p-- = '\0'; + + while (n != 0) + { + digit = n & 0xF; + if (digit > 9) + digit += 'A' - '0' - 10; + + *p-- = '0' + digit; + n >>= 4; + } + + return ++p; +} + + +/* 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, *q; + stream *s; + + 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 = itoa (va_arg (arg, int)); + count = strlen (q); + + p = salloc_w (s, &count); + memmove (p, q, count); + sfree (s); + break; + + case 'x': + q = xtoa (va_arg (arg, unsigned)); + 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 +st_sprintf (char *buffer, const char *format, ...) +{ + va_list arg; + char c, *p; + int count; + + va_start (arg, format); + + for (;;) + { + c = *format++; + if (c != '%') + { + *buffer++ = c; + if (c == '\0') + break; + continue; + } + + c = *format++; + switch (c) + { + case 'c': + *buffer++ = (char) va_arg (arg, int); + break; + + case 'd': + p = itoa (va_arg (arg, int)); + count = strlen (p); + + memcpy (buffer, p, count); + buffer += count; + break; + + case 's': + p = va_arg (arg, char *); + count = strlen (p); + + memcpy (buffer, p, count); + buffer += count; + break; + + default: + *buffer++ = c; + } + } + + va_end (arg); +} + + +/* show_locus()-- Print a line number and filename describing where + * something went wrong */ + +void +show_locus (void) +{ + + if (!options.locus || filename == NULL) + return; + + st_printf ("At line %d of file %s\n", line, 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 +recursion_check (void) +{ + static int magic = 0; + + if (magic == MAGIC) + sys_exit (4); /* Don't even try to print something at this point */ + + magic = MAGIC; +} + + +/* os_error()-- Operating system error. We get a message from the + * operating system, show it and leave. Some operating system errors + * are caught and processed by the library. If not, we come here. */ + +void +os_error (const char *message) +{ + + recursion_check (); + + show_locus (); + st_printf ("Operating system error: %s\n%s\n", get_oserror (), message); + + sys_exit (1); +} + + +/* void runtime_error()-- These are errors associated with an + * invalid fortran program. */ + +void +runtime_error (const char *message) +{ + + recursion_check (); + + show_locus (); + st_printf ("Fortran runtime error: %s\n", message); + + sys_exit (2); +} + + +/* void internal_error()-- These are this-can't-happen errors + * that indicate something deeply wrong. */ + +void +internal_error (const char *message) +{ + + recursion_check (); + + show_locus (); + st_printf ("Internal Error: %s\n", message); + sys_exit (3); +} + + +/* translate_error()-- Given an integer error code, return a string + * describing the error. */ + +const char * +translate_error (int code) +{ + const char *p; + + switch (code) + { + case ERROR_EOR: + p = "End of record"; + break; + + case ERROR_END: + p = "End of file"; + break; + + case ERROR_OK: + p = "Successful return"; + break; + + case ERROR_OS: + p = "Operating system error"; + break; + + case ERROR_BAD_OPTION: + p = "Bad statement option"; + break; + + case ERROR_MISSING_OPTION: + p = "Missing statement option"; + break; + + case ERROR_OPTION_CONFLICT: + p = "Conflicting statement options"; + break; + + case ERROR_ALREADY_OPEN: + p = "File already opened in another unit"; + break; + + case ERROR_BAD_UNIT: + p = "Unattached unit"; + break; + + case ERROR_FORMAT: + p = "FORMAT error"; + break; + + case ERROR_BAD_ACTION: + p = "Incorrect ACTION specified"; + break; + + case ERROR_ENDFILE: + p = "Read past ENDFILE record"; + break; + + case ERROR_BAD_US: + p = "Corrupt unformatted sequential file"; + break; + + case ERROR_READ_VALUE: + p = "Bad value during read"; + break; + + case ERROR_READ_OVERFLOW: + p = "Numeric overflow on read"; + break; + + default: + p = "Unknown error code"; + break; + } + + return p; +} + + +/* 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 variable exists, we set it. If the IOSTAT or + * ERR label is present, we return, otherwise we terminate the program + * after print 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 (int family, const char *message) +{ + + if (ioparm.iostat != NULL) + { + *ioparm.iostat = family; + return; + } + + switch (family) + { + case ERROR_EOR: + ioparm.library_return = LIBRARY_EOR; + if (ioparm.eor != 0) + return; + break; + + case ERROR_END: + ioparm.library_return = LIBRARY_END; + if (ioparm.end != 0) + return; + break; + + default: + ioparm.library_return = LIBRARY_ERROR; + break; + } + + if (ioparm.err != 0) + return; + + /* Terminate the program */ + + if (message == NULL) + message = + (family == ERROR_OS) ? get_oserror () : translate_error (family); + + runtime_error (message); +} diff --git a/libgfortran/runtime/in_pack_generic.c b/libgfortran/runtime/in_pack_generic.c new file mode 100644 index 0000000..8af4f3f --- /dev/null +++ b/libgfortran/runtime/in_pack_generic.c @@ -0,0 +1,123 @@ +/* Generic helper function for repacking arrays. + Copyright 2003 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfor). + +Libgfor is free software; you can redistribute it and/or +modify it under the terms of the GNU Lesser General Public +License as published by the Free Software Foundation; either +version 2.1 of the License, or (at your option) any later version. + +Ligbfor is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU Lesser General Public License for more details. + +You should have received a copy of the GNU Lesser General Public +License along with libgfor; see the file COPYING.LIB. If not, +write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include <string.h> +#include "libgfortran.h" + +void * +internal_pack (gfc_array_char * source) +{ + index_type count[GFC_MAX_DIMENSIONS - 1]; + index_type extent[GFC_MAX_DIMENSIONS - 1]; + index_type stride[GFC_MAX_DIMENSIONS - 1]; + index_type stride0; + index_type dim; + index_type ssize; + const char *src; + char *dest; + void *destptr; + int n; + int packed; + index_type size; + + if (source->dim[0].stride == 0) + { + source->dim[0].stride = 1; + return source->data; + } + + size = GFC_DESCRIPTOR_SIZE (source); + switch (size) + { + case 4: + return internal_pack_4 ((gfc_array_i4 *)source); + + case 8: + return internal_pack_8 ((gfc_array_i8 *)source); + } + + dim = GFC_DESCRIPTOR_RANK (source); + ssize = 1; + packed = 1; + for (n = 0; n < dim; n++) + { + count[n] = 0; + stride[n] = source->dim[n].stride; + extent[n] = source->dim[n].ubound + 1 - source->dim[n].lbound; + if (extent[n] <= 0) + { + /* Do nothing. */ + packed = 1; + break; + } + + if (ssize != stride[n]) + packed = 0; + + ssize *= extent[n]; + } + + if (packed) + return source->data; + + /* Allocate storage for the destination. */ + destptr = internal_malloc_size (ssize * size); + dest = (char *)destptr; + src = source->data; + stride0 = stride[0] * size; + + while (src) + { + /* Copy the data. */ + memcpy(dest, src, size); + /* Advance to the next element. */ + dest += size; + src += stride0; + count[0]++; + /* Advance to the next source element. */ + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + src -= stride[n] * extent[n] * size; + n++; + if (n == dim) + { + src = NULL; + break; + } + else + { + count[n]++; + src += stride[n] * size; + } + } + } + return destptr; +} + diff --git a/libgfortran/runtime/in_unpack_generic.c b/libgfortran/runtime/in_unpack_generic.c new file mode 100644 index 0000000..82a6771 --- /dev/null +++ b/libgfortran/runtime/in_unpack_generic.c @@ -0,0 +1,120 @@ +/* Generic helper function for repacking arrays. + Copyright 2003 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfor). + +Libgfor is free software; you can redistribute it and/or +modify it under the terms of the GNU Lesser General Public +License as published by the Free Software Foundation; either +version 2.1 of the License, or (at your option) any later version. + +Ligbfor is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU Lesser General Public License for more details. + +You should have received a copy of the GNU Lesser General Public +License along with libgfor; see the file COPYING.LIB. If not, +write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +#include "config.h" +#include <stdlib.h> +#include <assert.h> +#include <string.h> +#include "libgfortran.h" + +void +internal_unpack (gfc_array_char * d, const void * s) +{ + index_type count[GFC_MAX_DIMENSIONS - 1]; + index_type extent[GFC_MAX_DIMENSIONS - 1]; + index_type stride[GFC_MAX_DIMENSIONS - 1]; + index_type stride0; + index_type dim; + index_type dsize; + char *dest; + const char *src; + int n; + int size; + + dest = d->data; + /* This check may be redundant, but do it anyway. */ + if (s == dest || !s) + return; + + size = GFC_DESCRIPTOR_SIZE (d); + switch (size) + { + case 4: + internal_unpack_4 ((gfc_array_i4 *)d, (const GFC_INTEGER_4 *)s); + return; + + case 8: + internal_unpack_8 ((gfc_array_i8 *)d, (const GFC_INTEGER_8 *)s); + return; + } + + if (d->dim[0].stride == 0) + d->dim[0].stride = 1; + + dim = GFC_DESCRIPTOR_RANK (d); + dsize = 1; + for (n = 0; n < dim; n++) + { + count[n] = 0; + stride[n] = d->dim[n].stride; + extent[n] = d->dim[n].ubound + 1 - d->dim[n].lbound; + if (extent[n] <= 0) + abort (); + + if (dsize == stride[n]) + dsize *= extent[n]; + else + dsize = 0; + } + + src = s; + + if (dsize != 0) + { + memcpy (dest, src, dsize * size); + return; + } + + stride0 = stride[0] * size; + + while (dest) + { + /* Copy the data. */ + memcpy (dest, src, size); + /* Advance to the next element. */ + src += size; + dest += stride0; + count[0]++; + /* Advance to the next source element. */ + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so proabably not worth it. */ + dest -= stride[n] * extent[n] * size; + n++; + if (n == dim) + { + dest = NULL; + break; + } + else + { + count[n]++; + dest += stride[n] * size; + } + } + } +} + diff --git a/libgfortran/runtime/main.c b/libgfortran/runtime/main.c new file mode 100644 index 0000000..60c032b --- /dev/null +++ b/libgfortran/runtime/main.c @@ -0,0 +1,113 @@ +/* Copyright (C) 2002-2003 Free Software Foundation, Inc. + Contributed by Andy Vaught and Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfor). + +Libgfor 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. + +Libgfor 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 libgfor; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +#include <stdio.h> +#include <stdlib.h> +#include <string.h> +#include <math.h> +#include <stddef.h> + +#include "libgfortran.h" + +/* This is the offset (in bytes) required to cast from logical(8)* to + logical(4)*. and still get the same result. Will be 0 for little-endian + machines and 4 for big-endian machines. */ +int l8_to_l4_offset; + + +/* Figure out endianness for this machine. */ + +#define detetmine_endianness prefix(determine_endianness) +static void +determine_endianness (void) +{ + union + { + GFC_LOGICAL_8 l8; + GFC_LOGICAL_4 l4[2]; + } u; + + u.l8 = 1; + if (u.l4[0]) + l8_to_l4_offset = 0; + else if (u.l4[1]) + l8_to_l4_offset = 1; + else + runtime_error ("Unable to determine machine endianness"); +} + + +static int argc_save; +static char **argv_save; + +/* Set the saved values of the command line arguments. */ + +void +set_args (int argc, char **argv) +{ + argc_save = argc; + argv_save = argv; +} + +/* Retrieve the saved values of the command line arguments. */ + +void +get_args (int *argc, char ***argv) +{ + + *argc = argc_save; + *argv = argv_save; +} + + +/* Initialize the runtime library. */ + +static void __attribute__((constructor)) +init (void) +{ + /* Figure out the machine endianness. */ + determine_endianness (); + + /* Must be first */ + init_variables (); + + init_units (); + +#ifdef DEBUG + /* Check for special command lines. */ + + if (argc > 1 && strcmp (argv[1], "--help") == 0) + show_variables (); + +/* if (argc > 1 && strcmp(argv[1], "--resume") == 0) resume(); */ +#endif + + memory_init (); +} + + +/* Cleanup the runtime library. */ + +static void __attribute__((destructor)) +cleanup () +{ + close_units (); +} + diff --git a/libgfortran/runtime/memory.c b/libgfortran/runtime/memory.c new file mode 100644 index 0000000..ca5eb15 --- /dev/null +++ b/libgfortran/runtime/memory.c @@ -0,0 +1,312 @@ +/* Memory mamagement routines. + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfor). + +Libgfor is free software; you can redistribute it and/or +modify it under the terms of the GNU Lesser General Public +License as published by the Free Software Foundation; either +version 2.1 of the License, or (at your option) any later version. + +Libgfor is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU Lesser General Public License for more details. + +You should have received a copy of the GNU Lesser General Public +License along with libgfor; see the file COPYING.LIB. If not, +write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +#include "config.h" +#include <stdlib.h> +#include "libgfortran.h" + +/* If GFC_CLEAR_MEMORY is defined, the memory allocation routines will + return memory that is guaranteed to be set to zero. This can have + a severe efficiency penalty, so it should never be set if good + performance is desired, but it can help when you're debugging code. */ +#define GFC_CLEAR_MEMORY + +/* If GFC_CHECK_MEMORY is defined, we do some sanity checks at runtime. + This causes small overhead, but again, it also helps debugging. */ +#define GFC_CHECK_MEMORY + +/* We use a double linked list of these structures to keep track of + the memory we allocate internally. We could also use this for user + allocated memory (ALLOCATE/DEALLOCATE). This should be stored in a + seperate list. */ +#define malloc_t prefix(malloc_t) +typedef struct malloc_t +{ + int magic; + int marker; + struct malloc_t *prev, *next; + + /* The start of the block. */ + void *data; +} +malloc_t; + +/* We try to make sure we don't get memory corruption by checking for + a magic number. */ +#define GFC_MALLOC_MAGIC 0x4d353941 /* "G95M" */ + +#define HEADER_SIZE offsetof (malloc_t, data) +#define DATA_POINTER(pheader) (&((pheader)->data)) +#define DATA_HEADER(pdata) ((malloc_t *)((char *) (pdata) - HEADER_SIZE)) + +/* The root of the circular double linked list for compiler generated + malloc calls. */ +static malloc_t mem_root; + + +void +memory_init (void) +{ + + /* The root should never be used directly, so don't set the magic. */ + mem_root.magic = 0; + mem_root.next = &mem_root; + mem_root.prev = &mem_root; + mem_root.marker = 0; +} + + +/* Doesn't actually do any cleaning up, just throws an error if something + has got out of sync somewhere. */ + +void +runtime_cleanup (void) +{ + /* Make sure all memory we've allocated is freed on exit. */ + if (mem_root.next != &mem_root) + runtime_error ("Unfreed memory on program termination"); +} + + + +void * +get_mem (size_t n) +{ + void *p; + +#ifdef GFC_CLEAR_MEMORY + p = (void *) calloc (n, 1); +#else +#define temp malloc +#undef malloc + p = (void *) malloc (n); +#define malloc temp +#undef temp +#endif + if (p == NULL) + os_error ("Memory allocation failed"); + + return p; +} + + +void +free_mem (void *p) +{ + + free (p); +} + + +/* Allocates a block of memory with a size of N bytes. N does not + include the size of the header. */ + +static malloc_t * +malloc_with_header (size_t n) +{ + malloc_t *newmem; + + n = n + HEADER_SIZE; + + newmem = (malloc_t *) get_mem (n); + + if (newmem) + { + newmem->magic = GFC_MALLOC_MAGIC; + newmem->marker = 0; + } + + return newmem; +} + + +/* Allocate memory for internal (compiler generated) use. */ + +void * +internal_malloc_size (size_t size) +{ + malloc_t *newmem; + + newmem = malloc_with_header (size); + + if (!newmem) + os_error ("Out of memory."); + + /* Add to end of list. */ + newmem->next = &mem_root; + newmem->prev = mem_root.prev; + mem_root.prev->next = newmem; + mem_root.prev = newmem; + + return DATA_POINTER (newmem); +} + + +void * +internal_malloc (GFC_INTEGER_4 size) +{ +#ifdef GFC_CHECK_MEMORY + /* Under normal circumstances, this is _never_ going to happen! */ + if (size <= 0) + runtime_error ("Attempt to allocate a non-positive amount of memory."); + +#endif + return internal_malloc_size ((size_t) size); +} + + +void * +internal_malloc64 (GFC_INTEGER_8 size) +{ +#ifdef GFC_CHECK_MEMORY + /* Under normal circumstances, this is _never_ going to happen! */ + if (size <= 0) + runtime_error ("Attempt to allocate a non-positive amount of memory."); +#endif + return internal_malloc_size ((size_t) size); +} + + +/* Free internally allocated memory. Pointer is NULLified. Also used to + free user allocated memory. */ +/* TODO: keep a list of previously allocated blocks and reuse them. */ + +void +internal_free (void *mem) +{ + malloc_t *m; + + if (!mem) + runtime_error ("Internal: Possible double free of temporary."); + + m = DATA_HEADER (mem); + + if (m->magic != GFC_MALLOC_MAGIC) + runtime_error ("Internal: No magic memblock marker. " + "Possible memory corruption"); + + /* Move markers up the chain, so they don't get lost. */ + m->prev->marker += m->marker; + /* Remove from list. */ + m->prev->next = m->next; + m->next->prev = m->prev; + + free (m); +} + + +/* User-allocate, one call for each member of the alloc-list of an + ALLOCATE statement. */ + +static void +allocate_size (void **mem, size_t size, GFC_INTEGER_4 * stat) +{ + malloc_t *newmem; + + if (!mem) + runtime_error ("Internal: NULL mem pointer in ALLOCATE."); + + newmem = malloc_with_header (size); + if (!newmem) + { + if (stat) + { + *stat = 1; + return; + } + else + runtime_error ("ALLOCATE: Out of memory."); + } + + /* We don't keep a list of these at the moment, so just link to itself. */ + newmem->next = newmem; + newmem->prev = newmem; + + (*mem) = DATA_POINTER (newmem); + + if (stat) + *stat = 0; +} + + +void +allocate (void **mem, GFC_INTEGER_4 size, GFC_INTEGER_4 * stat) +{ + + if (size < 0) + { + runtime_error ("Attempt to allocate negative amount of memory. " + "Possible integer overflow"); + abort (); + } + + allocate_size (mem, (size_t) size, stat); +} + + +void +allocate64 (void **mem, GFC_INTEGER_8 size, GFC_INTEGER_4 * stat) +{ + + if (size < 0) + { + runtime_error + ("ALLOCATE64: Attempt to allocate negative amount of memory. " + "Possible integer overflow"); + abort (); + } + + allocate_size (mem, (size_t) size, stat); +} + + +/* User-deallocate; pointer is NULLified. */ + +void +deallocate (void **mem, GFC_INTEGER_4 * stat) +{ + + if (!mem) + runtime_error ("Internal: NULL mem pointer in ALLOCATE."); + + if (!*mem) + { + if (stat) + { + *stat = 1; + return; + } + else + { + runtime_error + ("Internal: Attempt to DEALLOCATE unallocated memory."); + abort (); + } + } + + /* Just use the internal routine. */ + internal_free (*mem); + *mem = NULL; + + if (stat) + *stat = 0; +} + diff --git a/libgfortran/runtime/pause.c b/libgfortran/runtime/pause.c new file mode 100644 index 0000000..9b8447f --- /dev/null +++ b/libgfortran/runtime/pause.c @@ -0,0 +1,71 @@ +/* Implementation of the STOP statement. + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfor). + +Libgfor is free software; you can redistribute it and/or +modify it under the terms of the GNU Lesser General Public +License as published by the Free Software Foundation; either +version 2.1 of the License, or (at your option) any later version. + +Libgfor is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU Lesser General Public License for more details. + +You should have received a copy of the GNU Lesser General Public +License along with libgfor; see the file COPYING.LIB. If not, +write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +#include "config.h" +#include <string.h> +#include <stdio.h> + +#include "libgfortran.h" + +#define pause_numeric prefix(pause_numeric) +#define pause_string prefix(pause_string) + +static void +do_pause (void) +{ + char buff[4]; + st_printf ("To resume execution, type go. " + "Other input will terminate the job.\n"); + + fgets(buff, 4, stdin); + if (strncmp(buff, "go\n", 3) != 0) + stop_numeric (-1); + st_printf ("RESUMED\n"); +} + +/* A numeric or blank STOP statement. */ +void +pause_numeric (GFC_INTEGER_4 code) +{ + show_locus (); + + if (code == -1) + st_printf ("PAUSE\n"); + else + st_printf ("PAUSE %d\n", (int)code); + + do_pause (); +} + + +void +pause_string (char *string, GFC_INTEGER_4 len) +{ + show_locus (); + + st_printf ("PAUSE "); + while (len--) + st_printf ("%c", *(string++)); + st_printf ("\n"); + + do_pause (); +} + diff --git a/libgfortran/runtime/select.c b/libgfortran/runtime/select.c new file mode 100644 index 0000000..5ee873a --- /dev/null +++ b/libgfortran/runtime/select.c @@ -0,0 +1,125 @@ +/* Implement the SELECT statement for character variables. + Contributed by Andy Vaught + +This file is part of the GNU Fortran 95 runtime library (libgfor). + +Libgfor 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. + +Libgfor 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 libgfor; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +#include "libgfortran.h" + +typedef struct +{ + char *low; + int low_len; + char *high; + int high_len; + void *address; +} +select_struct; + + +#define select_string prefix(select_string) + + +/* select_string()-- Given a selector string and a table of + * select_struct structures, return the address to jump to. */ + +void *select_string (select_struct *table, int table_len, void *default_jump, + const char *selector, int selector_len) +{ + select_struct *t; + int i, low, high, mid; + + if (table_len == 0) + return default_jump; + + /* Record the default address if present */ + + if (table->low == NULL && table->high == NULL) + { + default_jump = table->address; + + table++; + table_len--; + if (table_len == 0) + return default_jump; + } + + /* Try the high and low bounds if present. */ + + if (table->low == NULL) + { + if (compare_string (table->high_len, table->high, + selector_len, selector) >= 0) + return table->address; + + table++; + table_len--; + if (table_len == 0) + return default_jump; + } + + t = table + table_len - 1; + + if (t->high == NULL) + { + if (compare_string (t->low_len, t->low, + selector_len, selector) <= 0) + return t->address; + + table_len--; + if (table_len == 0) + return default_jump; + } + + /* At this point, the only table entries are bounded entries. Find + the right entry with a binary chop. */ + + low = -1; + high = table_len; + + while (low + 1 < high) + { + mid = (low + high) / 2; + + t = table + mid; + i = compare_string (t->low_len, t->low, selector_len, selector); + + if (i == 0) + return t->address; + + if (i < 0) + low = mid; + else + high = mid; + } + + /* The string now lies between the low indeces of the now-adjacent + high and low entries. Because it is less than the low entry of + 'high', it can't be that one. If low is still -1, then no + entries match. Otherwise, we have to check the high entry of + 'low'. */ + + if (low == -1) + return default_jump; + + t = table + low; + if (compare_string (selector_len, selector, + t->high_len, t->high) <= 0) + return t->address; + + return default_jump; +} diff --git a/libgfortran/runtime/stop.c b/libgfortran/runtime/stop.c new file mode 100644 index 0000000..bc901bb --- /dev/null +++ b/libgfortran/runtime/stop.c @@ -0,0 +1,56 @@ +/* Implementation of the STOP statement. + Copyright 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of the GNU Fortran 95 runtime library (libgfor). + +Libgfor is free software; you can redistribute it and/or +modify it under the terms of the GNU Lesser General Public +License as published by the Free Software Foundation; either +version 2.1 of the License, or (at your option) any later version. + +Libgfor is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU Lesser General Public License for more details. + +You should have received a copy of the GNU Lesser General Public +License along with libgfor; see the file COPYING.LIB. If not, +write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +#include "config.h" +#include <string.h> + +#include "libgfortran.h" + +#define stop_string prefix(stop_string) + +/* A numeric or blank STOP statement. */ +void +stop_numeric (GFC_INTEGER_4 code) +{ + show_locus (); + + if (code == -1) + st_printf ("STOP\n"); + else + st_printf ("STOP %d\n", (int)code); + + sys_exit (code); +} + + +void +stop_string (const char *string, GFC_INTEGER_4 len) +{ + show_locus (); + + st_printf ("STOP "); + while (len--) + st_printf ("%c", *(string++)); + st_printf ("\n"); + + sys_exit (0); +} + diff --git a/libgfortran/runtime/string.c b/libgfortran/runtime/string.c new file mode 100644 index 0000000..bcd6092 --- /dev/null +++ b/libgfortran/runtime/string.c @@ -0,0 +1,120 @@ +/* Copyright (C) 2002-2003 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 95 runtime library (libgfor). + +Libgfor 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. + +Libgfor 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 libgfor; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +#include "config.h" +#include <string.h> + +#include "libgfortran.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 i; + + if (strncasecmp (s1, s2, s1_len) != 0) + return 0; + + /* The rest of s1 needs to be blanks for equality. */ + + for (i = strlen (s2); i < s1_len; i++) + if (s1[i] != ' ') + return 0; + + return 1; +} + + +/* Given a fortran string, return its length exclusive of the trailing + spaces. */ +int +fstrlen (const char *string, int len) +{ + + for (len--; len >= 0; len--) + if (string[len] != ' ') + break; + + return len + 1; +} + + + +void +fstrcpy (char *dest, int destlen, const char *src, int srclen) +{ + + if (srclen >= destlen) + { + /* This will truncate if too long. */ + memcpy (dest, src, destlen); + } + else + { + memcpy (dest, src, srclen); + /* Pad with spaces. */ + memset (&dest[srclen], ' ', destlen - srclen); + } +} + + +void +cf_strcpy (char *dest, int dest_len, const char *src) +{ + int src_len; + + src_len = strlen (src); + + if (src_len >= dest_len) + { + /* This will truncate if too long. */ + memcpy (dest, src, dest_len); + } + else + { + memcpy (dest, src, src_len); + /* Pad with spaces. */ + 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 (const char *s1, int s1_len, st_option * opts, + const char *error_message) +{ + + for (; opts->name; opts++) + if (compare0 (s1, s1_len, opts->name)) + return opts->value; + + generate_error (ERROR_BAD_OPTION, error_message); + + return -1; +} + |