/* Miscellaneous stuff that doesn't fit anywhere else.
|
/* Miscellaneous stuff that doesn't fit anywhere else.
|
Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
|
Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
|
Free Software Foundation, Inc.
|
Free Software Foundation, Inc.
|
Contributed by Andy Vaught
|
Contributed by Andy Vaught
|
|
|
This file is part of GCC.
|
This file is part of GCC.
|
|
|
GCC is free software; you can redistribute it and/or modify it under
|
GCC 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
|
the terms of the GNU General Public License as published by the Free
|
Software Foundation; either version 3, or (at your option) any later
|
Software Foundation; either version 3, or (at your option) any later
|
version.
|
version.
|
|
|
GCC is distributed in the hope that it will be useful, but WITHOUT ANY
|
GCC is distributed in the hope that it will be useful, but WITHOUT ANY
|
WARRANTY; without even the implied warranty of MERCHANTABILITY or
|
WARRANTY; without even the implied warranty of MERCHANTABILITY or
|
FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
|
FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
|
for more details.
|
for more details.
|
|
|
You should have received a copy of the GNU General Public License
|
You should have received a copy of the GNU General Public License
|
along with GCC; see the file COPYING3. If not see
|
along with GCC; see the file COPYING3. If not see
|
<http://www.gnu.org/licenses/>. */
|
<http://www.gnu.org/licenses/>. */
|
|
|
#include "config.h"
|
#include "config.h"
|
#include "system.h"
|
#include "system.h"
|
#include "gfortran.h"
|
#include "gfortran.h"
|
|
|
/* Get a block of memory. Many callers assume that the memory we
|
/* Get a block of memory. Many callers assume that the memory we
|
return is zeroed. */
|
return is zeroed. */
|
|
|
void *
|
void *
|
gfc_getmem (size_t n)
|
gfc_getmem (size_t n)
|
{
|
{
|
void *p;
|
void *p;
|
|
|
if (n == 0)
|
if (n == 0)
|
return NULL;
|
return NULL;
|
|
|
p = xmalloc (n);
|
p = xmalloc (n);
|
if (p == NULL)
|
if (p == NULL)
|
gfc_fatal_error ("Out of memory-- malloc() failed");
|
gfc_fatal_error ("Out of memory-- malloc() failed");
|
memset (p, 0, n);
|
memset (p, 0, n);
|
return p;
|
return p;
|
}
|
}
|
|
|
|
|
void
|
void
|
gfc_free (void *p)
|
gfc_free (void *p)
|
{
|
{
|
/* The parentheses around free are needed in order to call not
|
/* The parentheses around free are needed in order to call not
|
the redefined free of gfortran.h. */
|
the redefined free of gfortran.h. */
|
if (p != NULL)
|
if (p != NULL)
|
(free) (p);
|
(free) (p);
|
}
|
}
|
|
|
|
|
/* Get terminal width. */
|
/* Get terminal width. */
|
|
|
int
|
int
|
gfc_terminal_width (void)
|
gfc_terminal_width (void)
|
{
|
{
|
return 80;
|
return 80;
|
}
|
}
|
|
|
|
|
/* Initialize a typespec to unknown. */
|
/* Initialize a typespec to unknown. */
|
|
|
void
|
void
|
gfc_clear_ts (gfc_typespec *ts)
|
gfc_clear_ts (gfc_typespec *ts)
|
{
|
{
|
ts->type = BT_UNKNOWN;
|
ts->type = BT_UNKNOWN;
|
ts->u.derived = NULL;
|
ts->u.derived = NULL;
|
ts->kind = 0;
|
ts->kind = 0;
|
ts->u.cl = NULL;
|
ts->u.cl = NULL;
|
ts->interface = NULL;
|
ts->interface = NULL;
|
/* flag that says if the type is C interoperable */
|
/* flag that says if the type is C interoperable */
|
ts->is_c_interop = 0;
|
ts->is_c_interop = 0;
|
/* says what f90 type the C kind interops with */
|
/* says what f90 type the C kind interops with */
|
ts->f90_type = BT_UNKNOWN;
|
ts->f90_type = BT_UNKNOWN;
|
/* flag that says whether it's from iso_c_binding or not */
|
/* flag that says whether it's from iso_c_binding or not */
|
ts->is_iso_c = 0;
|
ts->is_iso_c = 0;
|
}
|
}
|
|
|
|
|
/* Open a file for reading. */
|
/* Open a file for reading. */
|
|
|
FILE *
|
FILE *
|
gfc_open_file (const char *name)
|
gfc_open_file (const char *name)
|
{
|
{
|
struct stat statbuf;
|
struct stat statbuf;
|
|
|
if (!*name)
|
if (!*name)
|
return stdin;
|
return stdin;
|
|
|
if (stat (name, &statbuf) < 0)
|
if (stat (name, &statbuf) < 0)
|
return NULL;
|
return NULL;
|
|
|
if (!S_ISREG (statbuf.st_mode))
|
if (!S_ISREG (statbuf.st_mode))
|
return NULL;
|
return NULL;
|
|
|
return fopen (name, "r");
|
return fopen (name, "r");
|
}
|
}
|
|
|
|
|
/* Return a string for each type. */
|
/* Return a string for each type. */
|
|
|
const char *
|
const char *
|
gfc_basic_typename (bt type)
|
gfc_basic_typename (bt type)
|
{
|
{
|
const char *p;
|
const char *p;
|
|
|
switch (type)
|
switch (type)
|
{
|
{
|
case BT_INTEGER:
|
case BT_INTEGER:
|
p = "INTEGER";
|
p = "INTEGER";
|
break;
|
break;
|
case BT_REAL:
|
case BT_REAL:
|
p = "REAL";
|
p = "REAL";
|
break;
|
break;
|
case BT_COMPLEX:
|
case BT_COMPLEX:
|
p = "COMPLEX";
|
p = "COMPLEX";
|
break;
|
break;
|
case BT_LOGICAL:
|
case BT_LOGICAL:
|
p = "LOGICAL";
|
p = "LOGICAL";
|
break;
|
break;
|
case BT_CHARACTER:
|
case BT_CHARACTER:
|
p = "CHARACTER";
|
p = "CHARACTER";
|
break;
|
break;
|
case BT_HOLLERITH:
|
case BT_HOLLERITH:
|
p = "HOLLERITH";
|
p = "HOLLERITH";
|
break;
|
break;
|
case BT_DERIVED:
|
case BT_DERIVED:
|
p = "DERIVED";
|
p = "DERIVED";
|
break;
|
break;
|
case BT_CLASS:
|
case BT_CLASS:
|
p = "CLASS";
|
p = "CLASS";
|
break;
|
break;
|
case BT_PROCEDURE:
|
case BT_PROCEDURE:
|
p = "PROCEDURE";
|
p = "PROCEDURE";
|
break;
|
break;
|
case BT_VOID:
|
case BT_VOID:
|
p = "VOID";
|
p = "VOID";
|
break;
|
break;
|
case BT_UNKNOWN:
|
case BT_UNKNOWN:
|
p = "UNKNOWN";
|
p = "UNKNOWN";
|
break;
|
break;
|
default:
|
default:
|
gfc_internal_error ("gfc_basic_typename(): Undefined type");
|
gfc_internal_error ("gfc_basic_typename(): Undefined type");
|
}
|
}
|
|
|
return p;
|
return p;
|
}
|
}
|
|
|
|
|
/* Return a string describing the type and kind of a typespec. Because
|
/* Return a string describing the type and kind of a typespec. Because
|
we return alternating buffers, this subroutine can appear twice in
|
we return alternating buffers, this subroutine can appear twice in
|
the argument list of a single statement. */
|
the argument list of a single statement. */
|
|
|
const char *
|
const char *
|
gfc_typename (gfc_typespec *ts)
|
gfc_typename (gfc_typespec *ts)
|
{
|
{
|
static char buffer1[GFC_MAX_SYMBOL_LEN + 7]; /* 7 for "TYPE()" + '\0'. */
|
static char buffer1[GFC_MAX_SYMBOL_LEN + 7]; /* 7 for "TYPE()" + '\0'. */
|
static char buffer2[GFC_MAX_SYMBOL_LEN + 7];
|
static char buffer2[GFC_MAX_SYMBOL_LEN + 7];
|
static int flag = 0;
|
static int flag = 0;
|
char *buffer;
|
char *buffer;
|
|
|
buffer = flag ? buffer1 : buffer2;
|
buffer = flag ? buffer1 : buffer2;
|
flag = !flag;
|
flag = !flag;
|
|
|
switch (ts->type)
|
switch (ts->type)
|
{
|
{
|
case BT_INTEGER:
|
case BT_INTEGER:
|
sprintf (buffer, "INTEGER(%d)", ts->kind);
|
sprintf (buffer, "INTEGER(%d)", ts->kind);
|
break;
|
break;
|
case BT_REAL:
|
case BT_REAL:
|
sprintf (buffer, "REAL(%d)", ts->kind);
|
sprintf (buffer, "REAL(%d)", ts->kind);
|
break;
|
break;
|
case BT_COMPLEX:
|
case BT_COMPLEX:
|
sprintf (buffer, "COMPLEX(%d)", ts->kind);
|
sprintf (buffer, "COMPLEX(%d)", ts->kind);
|
break;
|
break;
|
case BT_LOGICAL:
|
case BT_LOGICAL:
|
sprintf (buffer, "LOGICAL(%d)", ts->kind);
|
sprintf (buffer, "LOGICAL(%d)", ts->kind);
|
break;
|
break;
|
case BT_CHARACTER:
|
case BT_CHARACTER:
|
sprintf (buffer, "CHARACTER(%d)", ts->kind);
|
sprintf (buffer, "CHARACTER(%d)", ts->kind);
|
break;
|
break;
|
case BT_HOLLERITH:
|
case BT_HOLLERITH:
|
sprintf (buffer, "HOLLERITH");
|
sprintf (buffer, "HOLLERITH");
|
break;
|
break;
|
case BT_DERIVED:
|
case BT_DERIVED:
|
sprintf (buffer, "TYPE(%s)", ts->u.derived->name);
|
sprintf (buffer, "TYPE(%s)", ts->u.derived->name);
|
break;
|
break;
|
case BT_CLASS:
|
case BT_CLASS:
|
sprintf (buffer, "CLASS(%s)",
|
sprintf (buffer, "CLASS(%s)",
|
ts->u.derived->components->ts.u.derived->name);
|
ts->u.derived->components->ts.u.derived->name);
|
break;
|
break;
|
case BT_PROCEDURE:
|
case BT_PROCEDURE:
|
strcpy (buffer, "PROCEDURE");
|
strcpy (buffer, "PROCEDURE");
|
break;
|
break;
|
case BT_UNKNOWN:
|
case BT_UNKNOWN:
|
strcpy (buffer, "UNKNOWN");
|
strcpy (buffer, "UNKNOWN");
|
break;
|
break;
|
default:
|
default:
|
gfc_internal_error ("gfc_typename(): Undefined type");
|
gfc_internal_error ("gfc_typename(): Undefined type");
|
}
|
}
|
|
|
return buffer;
|
return buffer;
|
}
|
}
|
|
|
|
|
/* Given an mstring array and a code, locate the code in the table,
|
/* Given an mstring array and a code, locate the code in the table,
|
returning a pointer to the string. */
|
returning a pointer to the string. */
|
|
|
const char *
|
const char *
|
gfc_code2string (const mstring *m, int code)
|
gfc_code2string (const mstring *m, int code)
|
{
|
{
|
while (m->string != NULL)
|
while (m->string != NULL)
|
{
|
{
|
if (m->tag == code)
|
if (m->tag == code)
|
return m->string;
|
return m->string;
|
m++;
|
m++;
|
}
|
}
|
|
|
gfc_internal_error ("gfc_code2string(): Bad code");
|
gfc_internal_error ("gfc_code2string(): Bad code");
|
/* Not reached */
|
/* Not reached */
|
}
|
}
|
|
|
|
|
/* Given an mstring array and a string, returns the value of the tag
|
/* Given an mstring array and a string, returns the value of the tag
|
field. Returns the final tag if no matches to the string are found. */
|
field. Returns the final tag if no matches to the string are found. */
|
|
|
int
|
int
|
gfc_string2code (const mstring *m, const char *string)
|
gfc_string2code (const mstring *m, const char *string)
|
{
|
{
|
for (; m->string != NULL; m++)
|
for (; m->string != NULL; m++)
|
if (strcmp (m->string, string) == 0)
|
if (strcmp (m->string, string) == 0)
|
return m->tag;
|
return m->tag;
|
|
|
return m->tag;
|
return m->tag;
|
}
|
}
|
|
|
|
|
/* Convert an intent code to a string. */
|
/* Convert an intent code to a string. */
|
/* TODO: move to gfortran.h as define. */
|
/* TODO: move to gfortran.h as define. */
|
|
|
const char *
|
const char *
|
gfc_intent_string (sym_intent i)
|
gfc_intent_string (sym_intent i)
|
{
|
{
|
return gfc_code2string (intents, i);
|
return gfc_code2string (intents, i);
|
}
|
}
|
|
|
|
|
/***************** Initialization functions ****************/
|
/***************** Initialization functions ****************/
|
|
|
/* Top level initialization. */
|
/* Top level initialization. */
|
|
|
void
|
void
|
gfc_init_1 (void)
|
gfc_init_1 (void)
|
{
|
{
|
gfc_error_init_1 ();
|
gfc_error_init_1 ();
|
gfc_scanner_init_1 ();
|
gfc_scanner_init_1 ();
|
gfc_arith_init_1 ();
|
gfc_arith_init_1 ();
|
gfc_intrinsic_init_1 ();
|
gfc_intrinsic_init_1 ();
|
}
|
}
|
|
|
|
|
/* Per program unit initialization. */
|
/* Per program unit initialization. */
|
|
|
void
|
void
|
gfc_init_2 (void)
|
gfc_init_2 (void)
|
{
|
{
|
gfc_symbol_init_2 ();
|
gfc_symbol_init_2 ();
|
gfc_module_init_2 ();
|
gfc_module_init_2 ();
|
}
|
}
|
|
|
|
|
/******************* Destructor functions ******************/
|
/******************* Destructor functions ******************/
|
|
|
/* Call all of the top level destructors. */
|
/* Call all of the top level destructors. */
|
|
|
void
|
void
|
gfc_done_1 (void)
|
gfc_done_1 (void)
|
{
|
{
|
gfc_scanner_done_1 ();
|
gfc_scanner_done_1 ();
|
gfc_intrinsic_done_1 ();
|
gfc_intrinsic_done_1 ();
|
gfc_arith_done_1 ();
|
gfc_arith_done_1 ();
|
}
|
}
|
|
|
|
|
/* Per program unit destructors. */
|
/* Per program unit destructors. */
|
|
|
void
|
void
|
gfc_done_2 (void)
|
gfc_done_2 (void)
|
{
|
{
|
gfc_symbol_done_2 ();
|
gfc_symbol_done_2 ();
|
gfc_module_done_2 ();
|
gfc_module_done_2 ();
|
}
|
}
|
|
|
|
|
/* Returns the index into the table of C interoperable kinds where the
|
/* Returns the index into the table of C interoperable kinds where the
|
kind with the given name (c_kind_name) was found. */
|
kind with the given name (c_kind_name) was found. */
|
|
|
int
|
int
|
get_c_kind(const char *c_kind_name, CInteropKind_t kinds_table[])
|
get_c_kind(const char *c_kind_name, CInteropKind_t kinds_table[])
|
{
|
{
|
int index = 0;
|
int index = 0;
|
|
|
for (index = 0; index < ISOCBINDING_LAST; index++)
|
for (index = 0; index < ISOCBINDING_LAST; index++)
|
if (strcmp (kinds_table[index].name, c_kind_name) == 0)
|
if (strcmp (kinds_table[index].name, c_kind_name) == 0)
|
return index;
|
return index;
|
|
|
return ISOCBINDING_INVALID;
|
return ISOCBINDING_INVALID;
|
}
|
}
|
|
|
