nialptr
arithconvert(nialptr x, int *newk)
{
int k,
ki,
changed;
nialint i,
t = tally(x);
nialptr z,
x0,
xi;
if (t == 0) { /* x is empty */
*newk = kind(x);
return (x);
}
/* set k based on kind of first item */
x0 = fetch_array(x, 0); /* first item */
k = kind(x0);
/* loop to find maximum kind in x */
for (i = 1; i < t; i++) {
xi = fetch_array(x, i);
ki = kind(xi);
if (ki > k)
k = ki;
}
/* convert to highest kind */
changed = true;
if (homotype(k) && k != chartype) {
switch (k) {
case inttype:
z = to_int(x);
break;
case realtype:
z = to_real(x);
break;
default:
z = x;
changed = false;
break;
}
}
else {
z = x;
changed = false;
}
if (changed) /* argument has been converted */
freeup(x);
*newk = k;
return (z);
}
void
iloaddefs(void)
{
nialptr nm,
x = apop();
int mode;
/* get the file name as a Nial array */
if (atomic(x) || kind(x) == chartype)
nm = x;
else if (kind(x) == atype)
nm = fetch_array(x, 0);
else {
buildfault("invalid file name");
freeup(x);
return;
}
mode = 0; /* default to silent mode */
if (kind(x) == atype && tally(x) == 2) {
/* argument has a mode filed, select it */
nialptr it = fetch_array(x, 1);
if (kind(it) == inttype)
mode = intval(it);
if (kind(it) == booltype)
mode = boolval(it);
}
/* try to put filename into gcharbuf */
if (!ngetname(nm, gcharbuf)) {
buildfault("invalid file name");
freeup(x);
}
else
{ /* check the extension as .ndf */
check_ext(gcharbuf, ".ndf",NOFORCE_EXTENSION);
freeup(x); /* do freeup here so file name doesn't show in iusedspace */
/* load the definition file */
if (loaddefs(true, gcharbuf, mode)) {
apush(Nullexpr);
}
else
buildfault(errmsgptr); /* this is safe since call is from iloaddefs */
}
#ifdef DEBUG
memchk();
#endif
}
nialptr
testfaults(nialptr x, nialptr stdfault)
{
int found = false;
nialint t = tally(x),
i = 0;
nialptr xi = Null,
z;
/* find first fault */
while (!found && i < t) {
xi = fetch_array(x, i++);
if (kind(xi) == chartype || kind(xi) == phrasetype)
return (stdfault); /* result is stdfault if other literal types occur */
found = kind(xi) == faulttype;
}
if (!found)
return (stdfault); /* used in "and" and "or" in cases like "and o -12" */
z = xi;
#ifdef V4AT
if (stdfault==Logical)
{ /* Logical faults are different in V4 */
i = 0; /* scan all the items */
/* find other faults and compare */
while (i < t) {
xi = fetch_array(x, i++);
if ((kind(xi) == faulttype && z != xi) || kind(xi) != faulttype)
/* result is stdfault if fault value changes or other type */
return (stdfault);
}
}
else
#endif
/* find other faults and compare */
{ while (i < t) {
xi = fetch_array(x, i++);
if ((kind(xi) == faulttype && z != xi) || kind(xi) == chartype ||
kind(xi) == phrasetype) /* result is stdfault if fault value changes
or other literal type */
return (stdfault);
}
}
freeup(stdfault); /* since this is a temporary and not used */
return (z);
}
nialptr
to_real(nialptr x)
{
nialptr z,
xi;
nialint i,
t = tally(x);
int v = valence(x);
double r = 0.0;
/* create the result container */
z = new_create_array(realtype, v, 0, shpptr(x, v));
for (i = 0; i < t; i++) {
int k;
xi = fetch_array(x, i);
k = kind(xi);
if (k == realtype)
r = *pfirstreal(xi);
else /* must be boolean or integer */
if (k == inttype)
r = 1.0 * intval(xi);
else
if (k == booltype)
r = 1.0 * boolval(xi);
store_real(z, i, r);
}
return (z);
}
/*
;@cc_solv(a, b, n)
;@ Solve a general linear system A*x = b.
;
; int solv(double a[],double b[],int n)
;
; a = array containing system matrix A in row order
; (altered to L-U factored form by computation)
;
; b = array containing system vector b at entry and
; solution vector x at exit
;
; n = dimension of system
;@
;@
*/
static LISP cc_solv1(LISP a1, LISP a2, LISP b1, LISP b2)
{
int row, col, sheet;
buffer *buf;
int ax1 = get_c_long(CAR(a1)), ay1 = get_c_long(CDR(a1));
int ax2 = get_c_long(CAR(a2)), ay2 = get_c_long(CDR(a2));
int bx1 = get_c_long(CAR(b1)), by1 = get_c_long(CDR(b1));
int bx2 = get_c_long(CDR(b2)), by2 = get_c_long(CDR(b2));
int n = by2-by1+1;
double *a = fetch_array(ax1, ay1, ax2, ay2);
double *b = fetch_array(bx1, by1, bx2, by2);
if (a == NULL || b == NULL || solv(a, b, n) == 0) return NIL;
get_siod_coords(&row, &col, &sheet, &buf);
store_array(row, col, row+n-1, col, b);
return flocons(b[0]);
}
nialptr
testbinfaults(nialptr x, nialptr stdfault, int divflag)
{
nialptr x0 = fetch_array(x, 0),
x1 = fetch_array(x, 1);
switch (kind(x0)) {
case booltype:
case inttype:
case realtype:
freeup(stdfault);
return (x1);
case chartype:
case phrasetype: /* fall out to return stdfault */
break;
case faulttype:
switch (kind(x1)) {
case booltype:
if (divflag && boolval(x1) == 0)
break;
freeup(stdfault);
return (x0);
case inttype:
if (divflag && intval(x1) == 0)
break;
freeup(stdfault);
return (x0);
case realtype:
if (divflag && realval(x1) == 0.0)
break;
freeup(stdfault);
return (x0);
case chartype:
case phrasetype:
break;
case faulttype:
if (x0 == x1) {
freeup(stdfault);
return (x0);
}
break;
}
}
return (stdfault);
}
static nialptr
to_int(nialptr x)
{
nialptr z,
xi;
nialint i,
t = tally(x);
int v = valence(x);
/* create the result container */
z = new_create_array(inttype, v, 0, shpptr(x, v));
for (i = 0; i < t; i++) {
xi = fetch_array(x, i);
if (kind(xi) == inttype) {
copy1(z, i, xi, 0);
}
else /* type must be boolean */
store_int(z, i, boolval(xi));
}
return (z);
}
void
ifromraw(void)
{
nialptr z = apop();
nialptr res;
int slen;
int totype;
int dataerror = 0;
int numelements;
nialptr bools;
if (tally(z) != 2) {
apush(makefault("?Must supply a type and a value to fromraw"));
freeup(z);
return;
}
totype = kind(fetch_array(z, 0));
if (totype == atype) {
apush(makefault("?fromraw cannot convert to a nested array"));
freeup(z);
return;
}
bools = fetch_array(z, 1);
if ((kind(bools) != booltype)) {
apush(makefault("?Must supply a Boolean value to fromraw"));
freeup(z);
return;
}
/* no conversion needed */
if (totype == booltype) {
apush(bools);
freeup(z);
return;
}
/* compute number of elements by type and validate length of bools */
slen = 0;
switch (totype) {
case inttype:
numelements = tally(bools) / sizeof(int);
if (tally(bools) % sizeof(int) != 0)
dataerror = 1;
break;
case realtype:
numelements = tally(bools) / sizeof(double);
if (tally(bools) % sizeof(double) != 0)
dataerror = 1;
break;
case phrasetype:
case faulttype:
slen = tally(bools) / sizeof(char);
numelements = 1;
case chartype:
numelements = tally(bools) / sizeof(char);
break;
}
numelements /= 8;
if (dataerror) {
apush(makefault("?fromraw must have correct multiple of bools for desired datatype"));
freeup(z);
return;
}
/* create the result copy */
res = new_create_array(totype, 1, slen, &numelements);
/* do the data copy */
switch (totype) {
case inttype:
memcpy(pfirstchar(res), pfirstchar(bools), tally(bools) / 8);
break;
case realtype:
memcpy_fwo(pfirstchar(res), pfirstchar(bools), tally(bools) / 8, MCPY_FROMRAW);
break;
/* Have to use strncpy here to preserve the data */
case chartype:
case phrasetype:
case faulttype:
memcpy_fbo(pfirstchar(res), pfirstchar(bools), tally(bools) / 8, MCPY_FROMRAW);
break;
}
if (totype == chartype)
*(pfirstchar(res) + numelements) = '\0';
apush(res);
freeup(z);
return;
}
void
iregisterdllfun(void)
{
int i,
index;
ResType argtypes[MAX_ARGS]; /* list of types of arguments */
bool vararg[MAX_ARGS]; /* is the argument a variable arg */
bool ispointer[MAX_ARGS]; /* is the argument a pointer */
int varargcount = 0; /* number of variable args */
int ispointercount = 0; /* number of pointer args */
nialptr z = apop();
char *nialname; /* names used by calldllfun */
char *dllname; /* the real name of the function */
/* in the DLL file */
char *library; /* name of the DLL file */
ResType resulttype; /* the type of the result */
nialptr nargtypes; /* the arg type array */
int argcount;
int j;
int sz;
nialptr current; /* usually hold the current entry in the dlllist */
int is_register;
/* if we have 5 args we are registering a function */
if ((tally(z) == 5) && (kind(z) == atype))
is_register = 1; /* register mode */
else
/* only one arg and it is a char or a phrase, we are deleting the fun */
if ((kind(z) == chartype) || (kind(z) == phrasetype))
is_register = 0; /* delete mode */
else { /* error mode */
apush(makefault("?Incorrect number of arguments to registerdllfun"));
freeup(z);
return;
}
if (is_register) {
/* The Nial level name for the DLL function */
STRING_CHECK(z, 0)
nialname = STRING_GET(z, 0);
/* The internal DLL name for the function */
STRING_CHECK(z, 1)
dllname = STRING_GET(z, 1);
/* The name of the library file */
STRING_CHECK(z, 2)
library = STRING_GET(z, 2);
/* The name of the result type */
STRING_CHECK(z, 3)
resulttype = StringToTypeID(STRING_GET(z, 3));
/* did we find an unrecognized result type? */
if (resulttype < 0) {
apush(makefault("?Return type not recognized"));
freeup(z);
return;
}
if (kind(fetch_array(z, 4)) != atype) {
apush(makefault("?Argument must be a list of strings or phrases"));
freeup(z);
return;
}
nargtypes = fetch_array(z, 4);
argcount = tally(nargtypes);
/* Check each of the argument type */
for (j = 0; j < argcount; j++)
STRING_CHECK_FREEUP(nargtypes, j, z)
/* create an integer list of argument types from the phrase/string list */
for (i = 0; i < argcount; i++) {
char *tmp;
tmp = pfirstchar(fetch_array(nargtypes, i)); /* safe: no allocation */
argtypes[i] = StringToTypeID(tmp);
/* the ith argument name was not recognized */
if (argtypes[i] < 0) {
char stmp[256];
wsprintf(stmp, "?Type \"%s\" for argument %d not recognized", tmp, i + 1);
apush(makefault(stmp));
freeup(z);
return;
}
/* set the vararg and ispointer flags for this arg */
vararg[i] = IsVarArg(tmp);
ispointer[i] = IsPointer(tmp);
/* keep count of these special args */
if (vararg[i])
varargcount++;
if (ispointer[i])
ispointercount++;
}
/* NEW workspace Version */
/* If the list does not yet exist, then create a one element list here */
if (tally(dlllist) == 0) {
nialptr tmp = create_new_dll_entry; /* build a empty entry */
setup_dll_entry(tmp) /* fill it with empty data */
apush(tmp);
isolitary(); /* make it a list */
decrrefcnt(dlllist);
freeup(dlllist);
dlllist = apop();
incrrefcnt(dlllist);
index = 0;
}
else {
int pos;
/* does the requested name already exist in out list? */
if ((pos = inlist(nialname)) >= 0) {
/* yes it's here already, so note its position, and free the old
* entry */
index = pos;
freeEntry(index);
}
else {
/* if we got here, then we need to create a new entry and add it to
* and existing dlllist */
nialptr tmp = create_new_dll_entry;
setup_dll_entry(tmp)
decrrefcnt(dlllist);
append(dlllist, tmp);
dlllist = apop();
incrrefcnt(dlllist);
index = tally(dlllist) - 1; /* this is the location of the new entry */
}
}
/* grab the entry to work on */
current = fetch_array(dlllist, index);
/* fill in data */
set_handle(current, NULL);
set_nialname(current, nialname);
set_dllname(current, dllname);
set_callingconvention(current, (dllname[0] == '_' ? C_CALL : PASCAL_CALL));
set_library(current, library);
set_isloaded(current, false);
set_resulttype(current, resulttype);
set_argcount(current, argcount);
set_varargcount(current, varargcount);
set_ispointercount(current, ispointercount);
sz = argcount;
replace_array(current, 10, (sz == 0 ? Null : new_create_array(inttype, 1, 0, &sz)));
for (j = 0; j < sz; j++)
set_argtypes(current, j, argtypes[j]);
replace_array(current, 11, (sz == 0 ? Null : new_create_array(booltype, 1, 0, &sz)));
for (j = 0; j < sz; j++)
set_ispointer(current, j, ispointer[j]);
replace_array(current, 14, (sz == 0 ? Null : new_create_array(booltype, 1, 0, &sz)));
for (j = 0; j < sz; j++)
set_vararg(current, j, vararg[j]);
}
else { /* delete entry code */
void
iinnerproduct()
{
nialptr z,
a,
b,
x;
int va,
vb,
vx,
replicatea,
replicateb;
nialint m,
n,
bn,
p,
i,
j,
k,
sh[2];
double sum,
*ap,
*bp,
*xp;
z = apop();
if (tally(z) != 2) {
buildfault("arg to innerproduct not a pair");
freeup(z);
return;
}
splitfb(z, &a, &b);
va = valence(a);
vb = valence(b);
if (va > 2 || vb > 2) {
buildfault("incorrect valence in innerproduct");
freeup(a);
freeup(b);
freeup(z);
return;
}
/* ensure b is realtype */
switch (kind(b)) {
case booltype:
b = bool_to_real(b);
break;
case inttype:
b = int_to_real(b);
break;
case realtype:
break;
case chartype:
case phrasetype:
case faulttype:
{
buildfault("second arg not numeric type in innerproduct");
freeup(a);
freeup(b);
freeup(z);
return;
}
case atype:
{
nialint i = 0;
if (!simple(b)) {
buildfault("arg not simple in innerproduct");
freeup(a);
freeup(b);
freeup(z);
return;
}
while (i < tally(b)) {
if (!numeric(kind(fetch_array(b, i)))) {
buildfault("second arg not numeric type in innerproduct");
freeup(a);
freeup(b);
freeup(z);
return;
}
i++;
}
b = to_real(b); /* safe because freeup(z) will clear old b */
}
}
/* ensure a is realtype */
switch (kind(a)) {
case booltype:
a = bool_to_real(a);
break;
case inttype:
a = int_to_real(a);
break;
case realtype:
break;
case chartype:
case phrasetype:
case faulttype:
{
buildfault("first arg not numeric type in innerproduct");
freeup(a);
freeup(b);
freeup(z);
return;
}
case atype:
{
nialint i = 0;
if (!simple(a)) {
buildfault("first arg not simple in innerproduct");
freeup(a);
freeup(b);
freeup(z);
return;
}
while (i < tally(a)) {
if (!numeric(kind(fetch_array(a, i)))) {
buildfault("first arg not numeric type in innerproduct");
freeup(a);
freeup(b);
freeup(z);
return;
}
i++;
}
a = to_real(a); /* safe becasue freeup of z clears old a */
}
}
if (va == 0) {
m = 1;
n = 1;
}
else if (va == 1) {
m = 1;
n = pickshape(a, 0);
}
else {
m = pickshape(a, 0);
n = pickshape(a, 1);
}
if (vb == 0) {
bn = 1;
p = 1;
}
else if (vb == 1) {
bn = pickshape(b, 0);
p = 1;
}
else {
bn = pickshape(b, 0);
p = pickshape(b, 1);
}
replicatea = (va == 0);
replicateb = (vb == 0);
if (!(replicatea || replicateb) && n != bn) {
buildfault("conform error in innerproduct");
freeup(a);
freeup(b);
freeup(z);
return;
}
/* get valence for the result */
vx = (va <= 1 ? (vb <= 1 ? 0 : 1) : (vb <= 1 ? 1 : 2));
if (vx == 2) {
sh[0] = m;
sh[1] = p;
}
else if (vx == 1)
sh[0] = (va == 2 ? m : p);
/* if vx==0 then sh is not used */
/* allocate space for the result matrix */
x = new_create_array(realtype, vx, 0, sh);
ap = pfirstreal(a); /* safe: no allocations */
bp = pfirstreal(b); /* safe: no allocations */
xp = pfirstreal(x); /* safe: no allocations */
/* type of loop chosen on the kind of ip being done */
if (vx == 2) { /* matrix - matrix */
for (i = 0; i < m; i++) {
for (j = 0; j < p; j++) {
sum = 0.;
for (k = 0; k < n; k++)
sum += *(ap + (n * i + k)) * *(bp + (p * k + j));
*(xp + (p * i + j)) = sum;
}
checksignal(NC_CS_NORMAL);
}
}
else if (va == 2) { /* matrix - vector */
for (i = 0; i < m; i++) {
sum = 0.;
if (replicateb)
for (k = 0; k < n; k++)
sum += *(ap + (n * i + k)) * *bp;
else
for (k = 0; k < n; k++)
sum += *(ap + (n * i + k)) * *(bp + k);
*(xp + i) = sum;
}
}
else if (vb == 2) { /* vector - matrix */
for (j = 0; j < p; j++) {
sum = 0.;
if (replicatea)
for (k = 0; k < bn; k++)
sum += *ap * *(bp + (p * k + j));
else
for (k = 0; k < bn; k++)
sum += *(ap + k) * *(bp + (p * k + j));
*(xp + j) = sum;
}
}
else { /* vector - vector */
sum = 0.;
if (replicatea)
for (k = 0; k < bn; k++)
sum += *ap * *(bp + k);
else if (replicateb)
for (k = 0; k < n; k++)
sum += *(ap + k) * *bp;
else
for (k = 0; k < n; k++)
sum += *(ap + k) * *(bp + k);
*xp = sum;
}
apush(x);
freeup(a);
freeup(b);
freeup(z);
}
void
isolve()
{
nialptr z,
a,
aa = Null,
b,
x = Null;
int va,
vb,
afreed,
bfreed;
nialint n,
nrhs;
char errmsg[80];
z = apop();
if (tally(z) != 2) {
buildfault("arg to solve not a pair");
freeup(z);
return;
}
splitfb(z, &a, &b);
va = valence(a);
vb = valence(b);
if (va != 2 || vb > 2) {
buildfault("incorrect valence in solve");
freeup(a);
freeup(b);
freeup(z);
return;
}
n = pickshape(a, 0);
if (n != pickshape(a, 1) || n != pickshape(b, 0)) {
buildfault("shapes do not conform in solve");
freeup(a);
freeup(b);
freeup(z);
return;
}
bfreed = false;
switch (kind(b)) {
case booltype:
x = bool_to_real(b);
bfreed = true;
break;
case inttype:
x = int_to_real(b);
bfreed = true;
break;
case realtype:
{ /* make a copy of b in x */
x = new_create_array(realtype, vb, 0, shpptr(b, vb));
copy(x, 0, b, 0, tally(b));
break;
}
case chartype:
case phrasetype:
case faulttype:
{
buildfault("second arg not numeric type in solve");
freeup(a);
freeup(b);
freeup(z);
return;
}
case atype:
{
nialint i = 0;
if (!simple(b)) {
buildfault("second arg not simple in solve");
freeup(a);
freeup(b);
freeup(z);
return;
}
while (i < tally(b)) {
if (!numeric(kind(fetch_array(b, i)))) {
buildfault("second arg not numeric type in solve");
freeup(a);
freeup(b);
freeup(z);
return;
}
i++;
}
x = to_real(b); /* makes a copy of b as reals */
}
}
afreed = false;
switch (kind(a)) {
case booltype:
aa = bool_to_real(a); /* makes a copy of a as reals */
afreed = true;
break;
case inttype:
aa = int_to_real(a); /* makes a copy of a as reals */
afreed = true;
break;
case realtype:
{ /* makes a copy of a */
aa = new_create_array(realtype, va, 0, shpptr(a, va));
copy(aa, 0, a, 0, tally(a));
break;
}
case chartype:
case phrasetype:
case faulttype:
{
buildfault("first arg not numeric type in solve");
freeup(a);
if (!bfreed)
freeup(b);
freeup(z);
freeup(x);
return;
}
case atype:
{
nialint i = 0;
if (!simple(a)) {
buildfault("first arg not simple in solve");
freeup(a);
if (!bfreed)
freeup(b);
freeup(z);
freeup(x);
return;
}
while (i < tally(a)) {
if (!numeric(kind(fetch_array(a, i)))) {
buildfault("first arg not numeric type in solve");
freeup(a);
if (!bfreed)
freeup(b);
freeup(z);
freeup(x);
return;
}
i++;
}
aa = to_real(a); /* makes a copy of a as reals */
}
}
nrhs = (vb == 1 ? 1 : pickshape(x, 1));
/* use the Gaussian elimination algorithm to solve the equation(s) */
if (Gausselim(pfirstreal(aa), pfirstreal(x), n, nrhs, errmsg)) {
apush(x);
}
else {
buildfault(errmsg);
freeup(x);
}
freeup(aa); /* the modified copy of a has to be freed */
if (!bfreed)
freeup(b);
if (!afreed)
freeup(a);
freeup(z);
}
void
iinverse()
{
nialptr a,
aa = Null,
x;
int va,
afreed;
nialint n,
i,
j;
double *ptr;
char errmsg[80];
a = apop();
va = valence(a);
if (va != 2) {
buildfault("incorrect valence in inverse");
freeup(a);
return;
}
n = pickshape(a, 0);
if (n != pickshape(a, 1)) {
buildfault("matrix is not square in inverse");
freeup(a);
return;
}
afreed = false;
switch (kind(a)) {
case booltype:
aa = bool_to_real(a); /* makes a real copy of a */
afreed = true;
break;
case inttype:
aa = int_to_real(a); /* makes a real copy of a */
afreed = true;
break;
case realtype:
{ /* make a real copy of a */
aa = new_create_array(realtype, va, 0, shpptr(a, va));
copy(aa, 0, a, 0, tally(a));
break;
}
case chartype:
case phrasetype:
case faulttype:
{
buildfault("arg not numeric type in inverse");
freeup(a);
return;
}
case atype:
{
nialint i = 0;
if (!simple(a)) {
buildfault("arg not simple in inverse");
freeup(a);
return;
}
while (i < tally(a)) {
if (!numeric(kind(fetch_array(a, i)))) {
buildfault("arg not numeric type in inverse");
freeup(a);
return;
}
i++;
}
aa = to_real(a); /* makes a real copy of a */
}
}
/* initialize x to a real identity matrix */
x = new_create_array(realtype, va, 0, shpptr(aa, va));
ptr = pfirstreal(x);
for (i = 0; i < n; i++)
for (j = 0; j < n; j++)
*ptr++ = (i == j ? 1.0 : 0.0);
if (Gausselim(pfirstreal(aa), pfirstreal(x), n, n, errmsg)) {
apush(x);
}
else {
buildfault(errmsg);
freeup(x);
}
freeup(aa); /* the modified copy of a has to be freed */
/* if a direct copies of a was made, then it needs to be freed up. the
* conversion routine does its own freeup. */
if (!afreed)
freeup(a);
}
