#include "config.h"
#include <stdlib.h>
#include "libgfortran.h"
#define GFC_CHECK_MEMORY
void *
get_mem (size_t n)
{
void *p;
#ifdef GFC_CLEAR_MEMORY
p = (void *) calloc (1, n);
#else
p = (void *) malloc (n);
#endif
if (p == NULL)
os_error ("Memory allocation failed");
return p;
}
void
free_mem (void *p)
{
free (p);
}
void *
internal_malloc_size (size_t size)
{
if (size == 0)
return NULL;
return get_mem (size);
}
extern void *internal_malloc (GFC_INTEGER_4);
export_proto(internal_malloc);
void *
internal_malloc (GFC_INTEGER_4 size)
{
#ifdef GFC_CHECK_MEMORY
if (size < 0)
runtime_error ("Attempt to allocate a negative amount of memory.");
#endif
return internal_malloc_size ((size_t) size);
}
extern void *internal_malloc64 (GFC_INTEGER_8);
export_proto(internal_malloc64);
void *
internal_malloc64 (GFC_INTEGER_8 size)
{
#ifdef GFC_CHECK_MEMORY
if (size < 0)
runtime_error ("Attempt to allocate a negative amount of memory.");
#endif
return internal_malloc_size ((size_t) size);
}
void
internal_free (void *mem)
{
if (mem != NULL)
free (mem);
}
iexport(internal_free);
static void *
internal_realloc_size (void *mem, size_t size)
{
if (size == 0)
{
if (mem)
free (mem);
return NULL;
}
if (mem == 0)
return get_mem (size);
mem = realloc (mem, size);
if (!mem)
os_error ("Out of memory.");
return mem;
}
extern void *internal_realloc (void *, GFC_INTEGER_4);
export_proto(internal_realloc);
void *
internal_realloc (void *mem, GFC_INTEGER_4 size)
{
#ifdef GFC_CHECK_MEMORY
if (size < 0)
runtime_error ("Attempt to allocate a negative amount of memory.");
#endif
return internal_realloc_size (mem, (size_t) size);
}
extern void *internal_realloc64 (void *, GFC_INTEGER_8);
export_proto(internal_realloc64);
void *
internal_realloc64 (void *mem, GFC_INTEGER_8 size)
{
#ifdef GFC_CHECK_MEMORY
if (size < 0)
runtime_error ("Attempt to allocate a negative amount of memory.");
#endif
return internal_realloc_size (mem, (size_t) size);
}
static void *
allocate_size (size_t size, GFC_INTEGER_4 * stat)
{
void *newmem;
newmem = malloc (size ? size : 1);
if (!newmem)
{
if (stat)
{
*stat = 1;
return newmem;
}
else
runtime_error ("ALLOCATE: Out of memory.");
}
if (stat)
*stat = 0;
return newmem;
}
extern void *allocate (GFC_INTEGER_4, GFC_INTEGER_4 *);
export_proto(allocate);
void *
allocate (GFC_INTEGER_4 size, GFC_INTEGER_4 * stat)
{
if (size < 0)
runtime_error ("Attempt to allocate negative amount of memory. "
"Possible integer overflow");
return allocate_size ((size_t) size, stat);
}
extern void *allocate64 (GFC_INTEGER_8, GFC_INTEGER_4 *);
export_proto(allocate64);
void *
allocate64 (GFC_INTEGER_8 size, GFC_INTEGER_4 * stat)
{
if (size < 0)
runtime_error ("ALLOCATE64: Attempt to allocate negative amount of "
"memory. Possible integer overflow");
return allocate_size ((size_t) size, stat);
}
extern void *allocate_array (void *, GFC_INTEGER_4, GFC_INTEGER_4 *);
export_proto(allocate_array);
void *
allocate_array (void *mem, GFC_INTEGER_4 size, GFC_INTEGER_4 * stat)
{
if (mem == NULL)
return allocate (size, stat);
if (stat)
{
free (mem);
mem = allocate (size, stat);
*stat = ERROR_ALLOCATION;
return mem;
}
runtime_error ("Attempting to allocate already allocated array.");
}
extern void *allocate64_array (void *, GFC_INTEGER_8, GFC_INTEGER_4 *);
export_proto(allocate64_array);
void *
allocate64_array (void *mem, GFC_INTEGER_8 size, GFC_INTEGER_4 * stat)
{
if (mem == NULL)
return allocate64 (size, stat);
if (stat)
{
free (mem);
mem = allocate (size, stat);
*stat = ERROR_ALLOCATION;
return mem;
}
runtime_error ("Attempting to allocate already allocated array.");
}
extern void deallocate (void *, GFC_INTEGER_4 *);
export_proto(deallocate);
void
deallocate (void *mem, GFC_INTEGER_4 * stat)
{
if (!mem)
{
if (stat)
{
*stat = 1;
return;
}
else
runtime_error ("Internal: Attempt to DEALLOCATE unallocated memory.");
}
free (mem);
if (stat)
*stat = 0;
}