nialint
writechars(FILE * file, char *buf, nialint n, int nlflag)
{
static int calls = 0; /* internal counter used for breakchecking */
if (keeplog && (file == stdout))
writelog(buf, n, nlflag);
/* every 25 calls check for a signal (approx one screen full) */
if (++calls > 25) {
calls = 0;
checksignal(NC_CS_OUTPUT);
}
if (file == stdout) {
NC_Write(buf, n, nlflag);
}
else {
int i;
for (i = 0; i < n; i++)
putc(buf[i], file);
if (nlflag)
putc('\n', file);
fflush(file);
}
return (n);
}
static int Lemit(lua_State *L) {
ls_EventSignal *signal = checksignal(L, 1);
int evtid = luaL_checkint(L, 2);
void **ud = (void**)lua_touserdata(L, 3);
lua_pushinteger(L, lua_gettop(L) - 2);
ls_event_emit(signal, evtid, ud == NULL ? NULL : *ud);
return 0;
}
static int Lconnect(lua_State *L) {
ls_EventSignal *signal = checksignal(L, 1);
ls_EventSlot *slot = checkslot(L, 2);
ls_event_connect(signal, slot);
lua_pushvalue(L, 1);
setcbinfo(L, slot, UV_SIGN);
lua_pushvalue(L, 2);
lua_setupvalue(L, -2, UV_SELF);
lua_settop(L, 2);
return 1;
}
int
loaddefs(int fromfile, char *fname, int mode)
{
nialptr ts;
int repeatloop,
keepreading,
nolines,
inremark,
linecnt;
FILE *f1 = NULL; /* initialized to avoid complaint */
int errorsfound;
if (fromfile) {
f1 = openfile(fname, 'r', 't');
if (f1 == OPENFAILED)
return (false);
pushsysfile(f1);
}
/* a loaddefs always affects the global environment. We reset current_env to
relect this. The code to restore the environment is below. This must be
saved on the stack, otherwise it can get thrown away since it may only
be owned by a transient definition value. The following example failed
before I protected this on the stack: retry is { host 'vi bug.ndf';
loaddefs"bug l } where this definition was in the file bug.ndf. */
apush(current_env);
current_env = Null;
ts = topstack; /* to monitor stack growth on each action */
errorsfound = 0; /* reset parse error counter */
repeatloop = true;
linecnt = 0;
/* loop to pick up groups of lines */
while (repeatloop) {
/* continue as long as their are line groups */
/* test on each circuit if an interrupt signal has been posted */
#ifdef USER_BREAK_FLAG
if (fromfile)
checksignal(NC_CS_NORMAL);
#endif
inremark = false;
nolines = 0;
keepreading = true;
/* loop to pick up lines until a whitespace line occurs */
while (keepreading) {
if (fromfile) {
/* reading a line from the file */
readfileline(f1, (mode ? 2 : 0)); /* mode==2 only in a loaddefs */
/* readfileline places result on the stack */
if (top == Eoffault) {
apop(); /* to remove the end of file marker */
repeatloop = false;
break; /* to end read loop */
}
}
else {
/* select a line from array defsndf loadded from defstbl.h */
char *line;
line = defsndf[linecnt++];
if (linecnt == NOLINES) {
repeatloop = false;
keepreading = false; /* to end read loop */
}
mkstring(line); /* convert the line to a Nial string and push it */
}
if (nolines == 0) { /* check first line of group for a remark */
char firstchar;
int i = 0;
/* loop to skip blanks */
while (i < tally(top) && fetch_char(top, i) <= BLANK)
i++;
/* note whether first char is "#" */
firstchar = fetch_char(top, i);
if (tally(top))
inremark = firstchar == HASHSYMBOL;
else
inremark = false;
}
/* if the line is all while space then we are at the end of a group */
if (top == Null || allwhitespace(pfirstchar(top))) {
keepreading = false;
freeup(apop()); /* to get rid of the empty line */
}
else /* count the line on the stack */
nolines++;
}
/* we have a group of lines to process */
if (nolines > 0) {
mklist(nolines); /* create a list of lines and link them*/
ilink();
if (inremark) {
freeup(apop()); /* remarks are ignored */
}
else
{
/* carry out the actions of the main loop */
iscan();
parse(true);
/* check whether parse produced an error */
if (kind(top) == faulttype) {
if (top != Nullexpr) {
errorsfound++;
if (mode == 0) { /* show error message */
apush(top);
ipicture();
show(apop());
}
}
}
/* evaluate the parse tree, if it is a fault, it is the value returned */
ieval();
#ifdef DEBUG
memchk();
#endif
if (mode) { /* show the result */
if (top != Nullexpr) {
ipicture();
show(apop());
}
else
apop(); /* the Nullexpr */
}
else
freeup(apop()); /* free because it might not be Nullexpr */
}
if (mode) { /* now display empty line */
writechars(STDOUT, "", (nialint) 0, true);
if (keeplog && f1 == STDIN)
writelog("", 0, true);
}
}
/* check that the stack hasn't grown */
if (ts != topstack) {
while (ts != topstack)
freeup(apop());
exit_cover(NC_STACK_GROWN_I);
}
}
/* done reading groups of lines */
if (fromfile) {
closefile(f1);
popsysfile();
}
/* restore the current_env */
current_env = apop();
if (errorsfound > 0)
nprintf(OF_NORMAL_LOG, "errors found: %d\n", errorsfound);
return (true);
}
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);
}
static int
Gausselim(double *a, double *b, int n, int p, char *errmsg)
{
int i,
i1,
j,
max,
ii,
k,
kk,
maxk;
double temp,
norm,
rowsum,
maxval,
sum,
mult;
/* find infinity norm of matrix a (max of abs row sums) */
/* the following code walks the matrix in row major order */
norm = 0.;
k = 0;
for (i = 0; i < n; i++) {
rowsum = 0;
for (j = 0; j < n; j++)
rowsum += fabs(*(a + (k++)));
if (norm < rowsum)
norm = rowsum;
}
/* main loop of elimination */
for (i = 0; i < n - 1; i++) {
/* find position of max element in ith column on or below diagonal */
ii = n * i + i;
max = i;
maxval = fabs(*(a + ii));
for (j = i + 1; j < n; j++) {
k = n * j + i;
if (fabs(*(a + k)) > maxval) {
maxval = fabs(*(a + k));
max = j;
}
}
/* interchange pivot row and max row if necessary */
if (max != i) { /* exchange rows i and max on and to the right
* of diagonal */
k = ii;
maxk = max * n + i;
for (j = i; j < n; j++) {
temp = *(a + k);
*(a + k) = *(a + maxk);
*(a + maxk) = temp;
k++;
maxk++;
}
/* exchange rows i and max of b */
k = i * p;
maxk = max * p;
for (j = 0; j < p; j++) {
temp = *(b + k);
*(b + k) = *(b + maxk);
*(b + maxk) = temp;
k++;
maxk++;
}
}
/* test for singularity */
if (fabs(*(a + ii)) <= (tol * norm))
goto singular;
/* compute multipliers and do elimination */
for (i1 = i + 1; i1 < n; i1++) {
kk = ii;
k = i1 * n + i;
mult = *(a + k) / *(a + kk);
/* do row reduction on a */
for (j = i + 1; j < n; j++) {
k++;
kk++;
*(a + k) = *(a + k) - mult * *(a + kk);
}
/* do row reduction on b */
kk = i * p;
k = i1 * p;
for (j = 0; j < p; j++) {
*(b + k) = *(b + k) - mult * *(b + kk);
k++;
kk++;
}
}
checksignal(NC_CS_NORMAL);
}
/* test for singularity in last pivot */
ii = (n - 1) * n + n - 1;
if (fabs(*(a + ii)) <= (tol * norm)) {
singular:
strcpy(errmsg, "singular matrix");
return (false);
}
/* backsolve the right hand sides in place */
for (j = 0; j < p; j++) {
for (i = n - 1; i >= 0; i--) {
sum = 0.;
for (k = i + 1; k < n; k++)
sum += *(a + (n * i + k)) * *(b + (p * k + j));
*(b + (p * i + j)) = (*(b + (p * i + j)) - sum) / *(a + (n * i + i));
}
checksignal(NC_CS_NORMAL);
}
return (true);
}
