#include "config.h"
#include "system.h"
#include "gfortran.h"
void *
gfc_getmem (size_t n)
{
void *p;
if (n == 0)
return NULL;
p = xmalloc (n);
if (p == NULL)
gfc_fatal_error ("Out of memory-- malloc() failed");
memset (p, 0, n);
return p;
}
#define temp free
#undef free
void
gfc_free (void *p)
{
if (p != NULL)
free (p);
}
#define free temp
#undef temp
int
gfc_terminal_width(void)
{
return 80;
}
void
gfc_clear_ts (gfc_typespec * ts)
{
ts->type = BT_UNKNOWN;
ts->kind = 0;
ts->derived = NULL;
ts->cl = NULL;
}
FILE *
gfc_open_file (const char *name)
{
struct stat statbuf;
if (!*name)
return stdin;
if (stat (name, &statbuf) < 0)
return NULL;
if (!S_ISREG (statbuf.st_mode))
return NULL;
return fopen (name, "r");
}
const char *
gfc_basic_typename (bt type)
{
const char *p;
switch (type)
{
case BT_INTEGER:
p = "INTEGER";
break;
case BT_REAL:
p = "REAL";
break;
case BT_COMPLEX:
p = "COMPLEX";
break;
case BT_LOGICAL:
p = "LOGICAL";
break;
case BT_CHARACTER:
p = "CHARACTER";
break;
case BT_HOLLERITH:
p = "HOLLERITH";
break;
case BT_DERIVED:
p = "DERIVED";
break;
case BT_PROCEDURE:
p = "PROCEDURE";
break;
case BT_UNKNOWN:
p = "UNKNOWN";
break;
default:
gfc_internal_error ("gfc_basic_typename(): Undefined type");
}
return p;
}
const char *
gfc_typename (gfc_typespec * ts)
{
static char buffer1[60], buffer2[60];
static int flag = 0;
char *buffer;
buffer = flag ? buffer1 : buffer2;
flag = !flag;
switch (ts->type)
{
case BT_INTEGER:
sprintf (buffer, "INTEGER(%d)", ts->kind);
break;
case BT_REAL:
sprintf (buffer, "REAL(%d)", ts->kind);
break;
case BT_COMPLEX:
sprintf (buffer, "COMPLEX(%d)", ts->kind);
break;
case BT_LOGICAL:
sprintf (buffer, "LOGICAL(%d)", ts->kind);
break;
case BT_CHARACTER:
sprintf (buffer, "CHARACTER(%d)", ts->kind);
break;
case BT_HOLLERITH:
sprintf (buffer, "HOLLERITH");
break;
case BT_DERIVED:
sprintf (buffer, "TYPE(%s)", ts->derived->name);
break;
case BT_PROCEDURE:
strcpy (buffer, "PROCEDURE");
break;
case BT_UNKNOWN:
strcpy (buffer, "UNKNOWN");
break;
default:
gfc_internal_error ("gfc_typespec(): Undefined type");
}
return buffer;
}
const char *
gfc_code2string (const mstring * m, int code)
{
while (m->string != NULL)
{
if (m->tag == code)
return m->string;
m++;
}
gfc_internal_error ("gfc_code2string(): Bad code");
}
int
gfc_string2code (const mstring * m, const char *string)
{
for (; m->string != NULL; m++)
if (strcmp (m->string, string) == 0)
return m->tag;
return m->tag;
}
const char *
gfc_intent_string (sym_intent i)
{
return gfc_code2string (intents, i);
}
void
gfc_init_1 (void)
{
gfc_error_init_1 ();
gfc_scanner_init_1 ();
gfc_arith_init_1 ();
gfc_intrinsic_init_1 ();
}
void
gfc_init_2 (void)
{
gfc_symbol_init_2 ();
gfc_module_init_2 ();
}
void
gfc_done_1 (void)
{
gfc_scanner_done_1 ();
gfc_intrinsic_done_1 ();
gfc_arith_done_1 ();
}
void
gfc_done_2 (void)
{
gfc_symbol_done_2 ();
gfc_module_done_2 ();
}