1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220
|
/*
* $Id: fortrn.c,v 1.1 2005-09-18 22:04:05 dhmunro Exp $
* Yorick routines callable from FORTRAN.
* Includes C-callable versions of a simple memory management package
* which is safe against asynchronous interrupts.
*/
/* Copyright (c) 2005, The Regents of the University of California.
* All rights reserved.
* This file is part of yorick (http://yorick.sourceforge.net).
* Read the accompanying LICENSE file for details.
*/
#include "pstdlib.h"
#include "yasync.h"
/* Routines to allocate Cray-style pointers:
memreal8 -- allocate 8 byte reals (C doubles)
memreal4 -- allocate 4 byte reals (C floats -- may be 8 bytes)
meminteg -- allocate integers (C longs)
membyte -- allocate characters (C chars)
memfree -- free any of above
memwork -- call prior to a sequence of allocation calls to remember
the addresses returned. If fblowup is called, or if
memwork is called again before everything has been
freed with memfree since the previous memwork call,
the previous arrays will be freed. Using this requires
some care, but it allows the workspace you allocate to
be made "safe" against asynchronous interrupts of your
FORTRAN code.
If you use memwork, memfree will be most efficient if
called in reverse order from the allocations.
Routine to longjmp out of an error condition:
fblowup -- YError (actually YAsyncError) for FORTRAN
Routine to print a warning (use this sparingly if at all):
fwhine -- YWarning for FORTRAN
*/
/* The C-callable versions of these routies are:
extern void *YAsyncBytes(long n)
extern void YAsyncFree(void *ptr)
extern void YAsyncWork(void)
extern void YAsyncError(const char *msg)
extern void YWarning(const char *msg)
declared in yasync.h
*/
/* FORTRAN routine names may be forced to upper case, forced to lower case,
and terminated with an underscore or not. */
#ifdef f_linkage
#define FORTNAME(x, x_, X, X_) x
#else
#ifdef f_linkage_
#define FORTNAME(x, x_, X, X_) x_
#else
#ifdef F_LINKAGE
#define FORTNAME(x, x_, X, X_) X
#else
#ifdef F_LINKAGE_
#define FORTNAME(x, x_, X, X_) X_
#else
This horrendous syntax error is caused by your failure to define a
FORTRAN linkage I have been trained to understand.
#endif
#endif
#endif
#endif
extern void *FORTNAME(memreal8, memreal8_, MEMREAL8, MEMREAL8_)(long *n);
extern void *FORTNAME(memreal4, memreal4_, MEMREAL4, MEMREAL4_)(long *n);
extern void *FORTNAME(meminteg, meminteg_, MEMINTEG, MEMINTEG_)(long *n);
extern void *FORTNAME(membyte, membyte_, MEMBYTE, MEMBYTE_)(long *n);
extern void FORTNAME(memfree, memfree_, MEMFREE, MEMFREE_)(void *ptr);
extern void FORTNAME(memwork, memwork_, MEMWORK, MEMWORK_)(void);
#ifndef F_STRING_SWAP
#define F_STRING_ARG(msg, len) (char *msg, long len)
#else
#define F_STRING_ARG(msg, len) (long len, char *msg)
#endif
extern void FORTNAME(fblowup, fblowup_, FBLOWUP, FBLOWUP_)
F_STRING_ARG(msg, len);
extern void FORTNAME(fwhine, fwhine_, FWHINE, FWHINE_)
F_STRING_ARG(msg, len);
static void **memlist= 0;
static long nlist= 0;
static int keeplist= 0;
static void ClearList(void);
static void *ListAppend(void *);
static void CopyFortranString(char *src, char *dst, long len);
void FORTNAME(fblowup, fblowup_, FBLOWUP, FBLOWUP_)
F_STRING_ARG(msg, len)
{
char mess[128];
if (len>127) len= 127;
CopyFortranString(msg, mess, len);
YAsyncError(mess);
}
void FORTNAME(fwhine, fwhine_, FWHINE, FWHINE_)
F_STRING_ARG(msg, len)
{
char mess[128];
if (len>127) len= 127;
CopyFortranString(msg, mess, len);
YWarning(mess);
}
void YAsyncError(const char *msg)
{
extern void YError(const char *msg);
ClearList();
if (*msg) YError(msg);
else YError("<YAsyncError or FBLOWUP called>");
}
static void CopyFortranString(char *src, char *dst, long len)
{
char *last= 0;
while ((len--)>0) {
*dst= *src++;
if (*dst!=' ' && *dst!='\t') last= dst;
dst++;
}
if (last) last[1]= '\0';
else *dst= '\0';
}
static void ClearList(void)
{
void *item, **list= memlist;
if (list) {
while (nlist>0) {
item= list[--nlist];
list[nlist]= 0;
if (item) p_free(item);
}
memlist= 0;
p_free(list);
}
keeplist= 0;
}
static void *ListAppend(void *ptr)
{
if (!(nlist&0x1f)) memlist= p_realloc(memlist, (nlist+32)*sizeof(void *));
return memlist[nlist++]= ptr;
}
void FORTNAME(memwork, memwork_, MEMWORK, MEMWORK_)(void)
{
YAsyncWork();
}
void YAsyncWork(void)
{
if (keeplist) ClearList();
keeplist= 1;
}
void FORTNAME(memfree, memfree_, MEMFREE, MEMFREE_)(void *ptr)
{
YAsyncFree(ptr);
}
void YAsyncFree(void *ptr)
{
if (keeplist) {
long i;
int flag= 0;
for (i=nlist-1 ; i>=0 ; i--) {
if (!memlist[i]) continue;
if (memlist[i]==ptr) {
memlist[i]= 0;
if (flag) break;
flag|= 1;
} else {
if (flag&1) break;
flag|= 2;
}
}
if (i<0) { nlist= 0; ClearList(); }
p_free(ptr);
} else {
p_free(ptr);
if (memlist) ClearList();
}
}
void *FORTNAME(memreal8, memreal8_, MEMREAL8, MEMREAL8_)(long *n)
{
return YAsyncBytes(sizeof(double)*n[0]);
}
void *FORTNAME(memreal4, memreal4_, MEMREAL4, MEMREAL4_)(long *n)
{
return YAsyncBytes(sizeof(float)*n[0]);
}
void *FORTNAME(meminteg, meminteg_, MEMINTEG, MEMINTEG_)(long *n)
{
return YAsyncBytes(sizeof(long)*n[0]);
}
void *FORTNAME(membyte, membyte_, MEMBYTE, MEMBYTE_)(long *n)
{
return YAsyncBytes(n[0]);
}
void *YAsyncBytes(long n)
{
void *ptr= p_malloc(n);
return keeplist? ListAppend(ptr) : ptr;
}
|