summaryrefslogtreecommitdiff
path: root/src/runtime/fmisc.r
diff options
context:
space:
mode:
Diffstat (limited to 'src/runtime/fmisc.r')
-rw-r--r--src/runtime/fmisc.r1041
1 files changed, 22 insertions, 1019 deletions
diff --git a/src/runtime/fmisc.r b/src/runtime/fmisc.r
index 6691241..2c4474d 100644
--- a/src/runtime/fmisc.r
+++ b/src/runtime/fmisc.r
@@ -5,9 +5,7 @@
* ishift, ixor, [keyword], [load], ord, name, runerr, seq, sort, sortf,
* type, variable
*/
-#if !COMPILER
#include "../h/opdefs.h"
-#endif /* !COMPILER */
"args(p) - produce number of arguments for procedure p."
@@ -24,53 +22,6 @@ function{1} args(x)
}
end
-#if !COMPILER
-#ifdef ExternalFunctions
-
-/*
- * callout - call a C library routine (or any C routine that doesn't call Icon)
- * with an argument count and a list of descriptors. This routine
- * doesn't build a procedure frame to prepare for calling Icon back.
- */
-function{1} callout(x[nargs])
- body {
- dptr retval;
- int signal;
-
- /*
- * Little cheat here. Although this is a var-arg procedure, we need
- * at least one argument to get started: pretend there is a null on
- * the stack. NOTE: Actually, at present, varargs functions always
- * have at least one argument, so this doesn't plug the hole.
- */
- if (nargs < 1)
- runerr(103, nulldesc);
-
- /*
- * Call the 'C routine caller' with a pointer to an array of descriptors.
- * Note that these are being left on the stack. We are passing
- * the name of the routine as part of the convention of calling
- * routines with an argc/argv technique.
- */
- signal = -1; /* presume successful completiong */
- retval = extcall(x, nargs, &signal);
- if (signal >= 0) {
- if (retval == NULL)
- runerr(signal);
- else
- runerr(signal, *retval);
- }
- if (retval != NULL) {
- return *retval;
- }
- else
- fail;
- }
-end
-
-#endif /* ExternalFunctions */
-#endif /* !COMPILER */
-
"char(i) - produce a string consisting of character i."
@@ -174,11 +125,6 @@ function{1} copy(x)
}
table: {
body {
-#ifdef TableFix
- if (cptable(&x, &result, BlkLoc(x)->table.size) == Error)
- runerr(0);
- return result;
-#else /* TableFix */
register int i;
register word slotnum;
tended union block *src;
@@ -195,7 +141,10 @@ function{1} copy(x)
runerr(0);
dst->table.size = src->table.size;
dst->table.mask = src->table.mask;
- dst->table.defvalue = src->table.defvalue;
+ /* dst->table.defvalue = src->table.defvalue; */
+ /* to avoid gcc 4.2.2 bug on Sparc, do instead: */
+ memcpy(&dst->table.defvalue, &src->table.defvalue,
+ sizeof(struct descrip));
for (i = 0; i < HSegs && src->table.hdir[i] != NULL; i++)
memcpy((char *)dst->table.hdir[i], (char *)src->table.hdir[i],
src->table.hdir[i]->blksize);
@@ -221,9 +170,7 @@ function{1} copy(x)
if (TooSparse(dst))
hshrink(dst);
- Desc_EVValD(dst, E_Tcreate, D_Table);
return table(dst);
-#endif /* TableFix */
}
}
@@ -262,14 +209,17 @@ function{1} copy(x)
d2 = old_rec->fields;
while (i--)
*d1++ = *d2++;
- Desc_EVValD(new_rec, E_Rcreate, D_Record);
return record(new_rec);
}
}
- default: body {
- runerr(123,x);
- }
+ default:
+ body {
+ if (Type(x) == T_External)
+ return callextfunc(&extlcopy, &x, NULL);
+ else
+ runerr(123,x);
+ }
}
end
@@ -278,15 +228,7 @@ end
" procedure activations, plus global variables."
" Output to file f (default &errout)."
-#ifdef MultiThread
-function{1} display(i,f,c)
- declare {
- struct b_coexpr *ce = NULL;
- struct progstate *prog, *savedprog;
- }
-#else /* MultiThread */
function{1} display(i,f)
-#endif /* MultiThread */
if !def:C_integer(i,(C_integer)k_level) then
runerr(101, i)
@@ -299,15 +241,6 @@ function{1} display(i,f)
else if !is:file(f) then
runerr(105, f)
-#ifdef MultiThread
- if !is:null(c) then inline {
- if (!is:coexpr(c)) runerr(118,c);
- else if (BlkLoc(c) != BlkLoc(k_current))
- ce = (struct b_coexpr *)BlkLoc(c);
- savedprog = curpstate;
- }
-#endif /* MultiThread */
-
abstract {
return null
}
@@ -340,16 +273,7 @@ function{1} display(i,f)
(long)BlkLoc(k_current)->coexpr.id,
(long)BlkLoc(k_current)->coexpr.size);
fflush(std_f);
-#ifdef MultiThread
- if (ce) {
- if ((ce->es_pfp == NULL) || (ce->es_argp == NULL)) fail;
- ENTERPSTATE(ce->program);
- r = xdisp(ce->es_pfp, ce->es_argp, (int)i, std_f);
- ENTERPSTATE(savedprog);
- }
- else
-#endif /* MultiThread */
- r = xdisp(pfp, glbl_argp, (int)i, std_f);
+ r = xdisp(pfp, glbl_argp, (int)i, std_f);
if (r == Failed)
runerr(305);
return nulldesc;
@@ -372,7 +296,6 @@ function{1} errorclear()
}
end
-#if !COMPILER
"function() - generate the names of the functions."
@@ -389,7 +312,6 @@ function{*} function()
fail;
}
end
-#endif /* !COMPILER */
/*
@@ -412,13 +334,11 @@ function{1} func_name(i,j)
return integer
}
inline {
-#ifdef LargeInts
if ((Type(i)==T_Lrgint) || (Type(j)==T_Lrgint)) {
big_ ## c_op(i,j);
}
else
-#endif /* LargeInts */
- return C_integer IntVal(i) c_op IntVal(j);
+ return C_integer IntVal(i) c_op IntVal(j);
}
end
#enddef
@@ -466,7 +386,6 @@ function{1} icom(i)
return integer
}
inline {
-#ifdef LargeInts
if (Type(i) == T_Lrgint) {
struct descrip td;
@@ -477,8 +396,7 @@ function{1} icom(i)
return result;
}
else
-#endif /* LargeInts */
- return C_integer ~IntVal(i);
+ return C_integer ~IntVal(i);
}
end
@@ -514,7 +432,6 @@ function{1} ishift(i,j)
body {
uword ci; /* shift in 0s, even if negative */
C_integer cj;
-#ifdef LargeInts
if (Type(j) == T_Lrgint)
runerr(101,j);
cj = IntVal(j);
@@ -524,10 +441,6 @@ function{1} ishift(i,j)
runerr(0);
return result;
}
-#else /* LargeInts */
- ci = (uword)IntVal(i);
- cj = IntVal(j);
-#endif /* LargeInts */
/*
* Check for a shift of WordSize or greater; handle specially because
* this is beyond C's defined behavior. Otherwise shift as requested.
@@ -564,14 +477,7 @@ end
"name(v) - return the name of a variable."
-#ifdef MultiThread
-function{1} name(underef v, c)
- declare {
- struct progstate *prog, *savedprog;
- }
-#else /* MultiThread */
function{1} name(underef v)
-#endif /* MultiThread */
/*
* v must be a variable
*/
@@ -586,27 +492,7 @@ function{1} name(underef v)
C_integer i;
if (!debug_info)
runerr(402);
-
-#ifdef MultiThread
- savedprog = curpstate;
- if (is:null(c)) {
- prog = curpstate;
- }
- else if (is:coexpr(c)) {
- prog = BlkLoc(c)->coexpr.program;
- }
- else {
- runerr(118,c);
- }
-
- ENTERPSTATE(prog);
-#endif /* MultiThread */
i = get_name(&v, &result); /* return val ? #%#% */
-
-#ifdef MultiThread
- ENTERPSTATE(savedprog);
-#endif /* MultiThread */
-
if (i == Error)
runerr(0);
return result;
@@ -672,7 +558,6 @@ function{1,*} seq(from, by)
}
while (from >= seq_lb && from <= seq_ub);
-#if !COMPILER
{
/*
* Suspending wipes out some things needed by the trace back code to
@@ -684,7 +569,6 @@ function{1,*} seq(from, by)
r_args[0].dword = D_Proc;
r_args[0].vword.bptr = (union block *)&Bseq;
}
-#endif /* COMPILER */
runerr(203);
}
@@ -724,8 +608,12 @@ function {0,1} serial(x)
}
}
#endif /* Graphics */
- default:
- inline { fail; }
+ default: inline {
+ if (Type(x) == T_External)
+ return C_integer BlkLoc(x)->externl.id;
+ else
+ fail;
+ }
}
end
@@ -750,7 +638,6 @@ function{1} sort(t, i)
qsort((char *)BlkLoc(result)->list.listhead->lelem.lslots,
(int)size, sizeof(struct descrip), (int (*)()) anycmp);
- Desc_EVValD(BlkLoc(result), E_Lcreate, D_List);
return result;
}
}
@@ -775,9 +662,6 @@ function{1} sort(t, i)
Protect(lp = alclist(size), runerr(0));
Protect(ep = (union block *)alclstb(size,(word)0,size), runerr(0));
lp->listhead = lp->listtail = ep;
-#ifdef ListFix
- ep->lelem.listprev = ep->lelem.listnext = (union block *) lp;
-#endif /* ListFix */
bp = BlkLoc(t); /* need not be tended if not set until now */
if (size > 0) { /* only need to sort non-empty records */
@@ -788,7 +672,6 @@ function{1} sort(t, i)
sizeof(struct descrip), (int (*)())anycmp);
}
- Desc_EVValD(lp, E_Lcreate, D_List);
return list(lp);
}
}
@@ -814,9 +697,6 @@ function{1} sort(t, i)
Protect(lp = alclist(size), runerr(0));
Protect(ep = (union block *)alclstb(size,(word)0,size), runerr(0));
lp->listhead = lp->listtail = ep;
-#ifdef ListFix
- ep->lelem.listprev = ep->lelem.listnext = (union block *)lp;
-#endif /* ListFix */
bp = BlkLoc(t); /* need not be tended if not set until now */
if (size > 0) { /* only need to sort non-empty sets */
@@ -829,7 +709,6 @@ function{1} sort(t, i)
sizeof(struct descrip), (int (*)())anycmp);
}
- Desc_EVValD(lp, E_Lcreate, D_List);
return list(lp);
}
}
@@ -883,9 +762,6 @@ function{1} sort(t, i)
Protect(lp = alclist(size), runerr(0));
Protect(ep=(union block *)alclstb(size,(word)0,size),runerr(0));
lp->listtail = lp->listhead = ep;
-#ifdef ListFix
- ep->lelem.listprev = ep->lelem.listnext = (union block *) lp;
-#endif /* ListFix */
/*
* If the table is empty, there is no need to sort anything.
*/
@@ -904,20 +780,12 @@ function{1} sort(t, i)
for (j = 0; j < HSegs && (seg = bp->hdir[j]) != NULL; j++)
for (k = segsize[j] - 1; k >= 0; k--)
for (ep= seg->hslots[k];
-#ifdef TableFix
- BlkType(ep) == T_Telem;
-#else /* TableFix */
ep != NULL;
-#endif /* TableFix */
ep = ep->telem.clink){
Protect(tp = alclist((word)2), runerr(0));
Protect(ev = (union block *)alclstb((word)2,
(word)0, (word)2), runerr(0));
tp->listhead = tp->listtail = ev;
-#ifdef ListFix
- ev->lelem.listprev = ev->lelem.listnext =
- (union block *)tp;
-#endif /* ListFix */
tp->listhead->lelem.lslots[0] = ep->telem.tref;
tp->listhead->lelem.lslots[1] = ep->telem.tval;
d1 = &lp->listhead->lelem.lslots[n++];
@@ -958,9 +826,6 @@ function{1} sort(t, i)
Protect(lp = alclist(size), runerr(0));
Protect(ep = (union block *)alclstb(size,(word)0,size), runerr(0));
lp->listhead = lp->listtail = ep;
-#ifdef ListFix
- ep->lelem.listprev = ep->lelem.listnext = (union block *)lp;
-#endif /* ListFix */
/*
* If the table is empty there's no need to sort anything.
*/
@@ -983,11 +848,7 @@ function{1} sort(t, i)
for (j = 0; j < HSegs && (seg = bp->hdir[j]) != NULL; j++)
for (k = segsize[j] - 1; k >= 0; k--)
for (ep = seg->hslots[k];
-#ifdef TableFix
- BlkType(ep) == T_Telem;
-#else /* TableFix */
ep != NULL;
-#endif /* TableFix */
ep = ep->telem.clink) {
*d1++ = ep->telem.tref;
*d1++ = ep->telem.tval;
@@ -1016,7 +877,6 @@ function{1} sort(t, i)
* Make result point at the sorted list.
*/
- Desc_EVValD(lp, E_Lcreate, D_List);
return list(lp);
}
}
@@ -1033,12 +893,6 @@ end
int trefcmp(d1,d2)
dptr d1, d2;
{
-
-#ifdef DeBug
- if (d1->dword != D_List || d2->dword != D_List)
- syserr("trefcmp: internal consistency check fails.");
-#endif /* DeBug */
-
return (anycmp(&(BlkLoc(*d1)->list.listhead->lelem.lslots[0]),
&(BlkLoc(*d2)->list.listhead->lelem.lslots[0])));
}
@@ -1050,12 +904,6 @@ dptr d1, d2;
int tvalcmp(d1,d2)
dptr d1, d2;
{
-
-#ifdef DeBug
- if (d1->dword != D_List || d2->dword != D_List)
- syserr("tvalcmp: internal consistency check fails.");
-#endif /* DeBug */
-
return (anycmp(&(BlkLoc(*d1)->list.listhead->lelem.lslots[1]),
&(BlkLoc(*d2)->list.listhead->lelem.lslots[1])));
}
@@ -1113,7 +961,6 @@ function{1} sortf(t, i)
qsort((char *)BlkLoc(result)->list.listhead->lelem.lslots,
(int)size, sizeof(struct descrip), (int (*)()) nthcmp);
- Desc_EVValD(BlkLoc(result), E_Lcreate, D_List);
return result;
}
}
@@ -1146,9 +993,6 @@ function{1} sortf(t, i)
Protect(lp = alclist(size), runerr(0));
Protect(ep = (union block *)alclstb(size,(word)0,size), runerr(0));
lp->listhead = lp->listtail = ep;
-#ifdef ListFix
- ep->lelem.listprev = ep->lelem.listnext = (union block *) lp;
-#endif /* ListFix */
bp = BlkLoc(t); /* need not be tended if not set until now */
if (size > 0) { /* only need to sort non-empty records */
@@ -1160,7 +1004,6 @@ function{1} sortf(t, i)
sizeof(struct descrip), (int (*)())nthcmp);
}
- Desc_EVValD(lp, E_Lcreate, D_List);
return list(lp);
}
}
@@ -1194,9 +1037,6 @@ function{1} sortf(t, i)
Protect(lp = alclist(size), runerr(0));
Protect(ep = (union block *)alclstb(size,(word)0,size), runerr(0));
lp->listhead = lp->listtail = ep;
-#ifdef ListFix
- ep->lelem.listprev = ep->lelem.listnext = (union block *)lp;
-#endif /* ListFix */
bp = BlkLoc(t); /* need not be tended if not set until now */
if (size > 0) { /* only need to sort non-empty sets */
@@ -1210,7 +1050,6 @@ function{1} sortf(t, i)
sizeof(struct descrip), (int (*)())nthcmp);
}
- Desc_EVValD(lp, E_Lcreate, D_List);
return list(lp);
}
}
@@ -1337,12 +1176,9 @@ function{1} type(x)
coexpr: inline { return C_string "co-expression"; }
default:
inline {
-#if !COMPILER
- if (!Qual(x) && (Type(x)==T_External)) {
- return C_string "external";
- }
+ if (!Qual(x) && (Type(x) == T_External))
+ return callextfunc(&extlname, &x, NULL);
else
-#endif /* !COMPILER */
runerr(123,x);
}
}
@@ -1352,853 +1188,20 @@ end
"variable(s) - find the variable with name s and return a"
" variable descriptor which points to its value."
-#ifdef MultiThread
-function{0,1} variable(s,c,i)
-#else /* MultiThread */
function{0,1} variable(s)
-#endif /* MultiThread */
-
if !cnv:C_string(s) then
runerr(103, s)
-#ifdef MultiThread
- if !def:C_integer(i,0) then
- runerr(101,i)
-#endif /* MultiThread */
-
abstract {
return variable
}
body {
register int rv;
-
-#ifdef MultiThread
- struct progstate *prog, *savedprog;
- struct pf_marker *tmp_pfp = pfp;
- dptr tmp_argp = glbl_argp;
-
- savedprog = curpstate;
- if (!is:null(c)) {
- if (is:coexpr(c)) {
- prog = BlkLoc(c)->coexpr.program;
- pfp = BlkLoc(c)->coexpr.es_pfp;
- glbl_argp = BlkLoc(c)->coexpr.es_argp;
- ENTERPSTATE(prog);
- }
- else {
- runerr(118, c);
- }
- }
-
- /*
- * Produce error if i is negative
- */
- if (i < 0) {
- irunerr(205, i);
- errorfail;
- }
-
- while (i--) {
- if (pfp == NULL) fail;
- glbl_argp = pfp->pf_argp;
- pfp = pfp->pf_pfp;
- }
-#endif /* MultiThread */
-
rv = getvar(s, &result);
-
-#ifdef MultiThread
- if (is:coexpr(c)) {
- ENTERPSTATE(savedprog);
- pfp = tmp_pfp;
- glbl_argp = tmp_argp;
-
- if ((rv == LocalName) || (rv == StaticName)) {
- Deref(result);
- }
- }
-#endif /* MultiThread */
-
if (rv != Failed)
return result;
else
fail;
}
end
-
-#ifdef MultiThread
-
-"cofail(CE) - transmit a co-expression failure to CE"
-
-function{0,1} cofail(CE)
- abstract {
- return any_value
- }
- if is:null(CE) then
- body {
- struct b_coexpr *ce = topact((struct b_coexpr *)BlkLoc(k_current));
- if (ce != NULL) {
- CE.dword = D_Coexpr;
- BlkLoc(CE) = (union block *)ce;
- }
- else runerr(118,CE);
- }
- else if !is:coexpr(CE) then
- runerr(118,CE)
- body {
- struct b_coexpr *ncp = (struct b_coexpr *)BlkLoc(CE);
- if (co_chng(ncp, NULL, &result, A_Cofail, 1) == A_Cofail) fail;
- return result;
- }
-end
-
-
-"fieldnames(r) - generate the fieldnames of record r"
-
-function{*} fieldnames(r)
- abstract {
- return string
- }
- if !is:record(r) then runerr(107,r)
- body {
- int i;
- for(i=0;i<BlkLoc(r)->record.recdesc->proc.nfields;i++) {
- suspend BlkLoc(r)->record.recdesc->proc.lnames[i];
- }
- fail;
- }
-end
-
-
-"localnames(ce,i) - produce the names of local variables"
-" in the procedure activation i levels up in ce"
-function{*} localnames(ce,i)
- declare {
- tended struct descrip d;
- }
- abstract {
- return string
- }
- if is:null(ce) then inline {
- d = k_current;
- BlkLoc(k_current)->coexpr.es_pfp = pfp; /* sync w/ current value */
- }
- else if is:proc(ce) then inline {
- int j;
- struct b_proc *cproc = (struct b_proc *)BlkLoc(ce);
- for(j = 0; j < cproc->ndynam; j++) {
- result = cproc->lnames[j + cproc->nparam];
- suspend result;
- }
- fail;
- }
- else if is:coexpr(ce) then inline {
- d = ce;
- BlkLoc(k_current)->coexpr.es_pfp = pfp; /* sync w/ current value */
- }
- else runerr(118, ce)
- if !def:C_integer(i,0) then
- runerr(101,i)
- body {
-#if !COMPILER
- int j;
- dptr arg;
- struct b_proc *cproc;
- struct pf_marker *thePfp = BlkLoc(d)->coexpr.es_pfp;
-
- if (thePfp == NULL) fail;
-
- /*
- * Produce error if i is negative
- */
- if (i < 0) {
- irunerr(205, i);
- errorfail;
- }
-
- while (i--) {
- thePfp = thePfp->pf_pfp;
- if (thePfp == NULL) fail;
- }
-
- arg = &((dptr)thePfp)[-(thePfp->pf_nargs) - 1];
- cproc = (struct b_proc *)BlkLoc(arg[0]);
- for(j = 0; j < cproc->ndynam; j++) {
- result = cproc->lnames[j + cproc->nparam];
- suspend result;
- }
-#endif /* !COMPILER */
- fail;
- }
-end
-
-
-
-"staticnames(ce,i) - produce the names of static variables"
-" in the current procedure activation in ce"
-
-function{*} staticnames(ce,i)
- declare {
- tended struct descrip d;
- }
- abstract {
- return string
- }
- if is:null(ce) then inline {
- d = k_current;
- BlkLoc(k_current)->coexpr.es_pfp = pfp; /* sync w/ current value */
- }
- else if is:proc(ce) then inline {
- int j;
- struct b_proc *cproc = (struct b_proc *)BlkLoc(ce);
- for(j = 0; j < cproc->nstatic; j++) {
- result = cproc->lnames[j + cproc->nparam + cproc->ndynam];
- suspend result;
- }
- fail;
- }
- else if is:coexpr(ce) then inline {
- d = ce;
- BlkLoc(k_current)->coexpr.es_pfp = pfp; /* sync w/ current value */
- }
- else runerr(118,ce)
- if !def:C_integer(i,0) then
- runerr(101,i)
- body {
-#if !COMPILER
- int j;
- dptr arg;
- struct b_proc *cproc;
- struct pf_marker *thePfp = BlkLoc(d)->coexpr.es_pfp;
- if (thePfp == NULL) fail;
-
- /*
- * Produce error if i is negative
- */
- if (i < 0) {
- irunerr(205, i);
- errorfail;
- }
-
- while (i--) {
- thePfp = thePfp->pf_pfp;
- if (thePfp == NULL) fail;
- }
-
- arg = &((dptr)thePfp)[-(thePfp->pf_nargs) - 1];
- cproc = (struct b_proc *)BlkLoc(arg[0]);
- for(j=0; j < cproc->nstatic; j++) {
- result = cproc->lnames[j + cproc->nparam + cproc->ndynam];
- suspend result;
- }
-#endif /* !COMPILER */
- fail;
- }
-end
-
-"paramnames(ce,i) - produce the names of the parameters"
-" in the current procedure activation in ce"
-
-function{1,*} paramnames(ce,i)
- declare {
- tended struct descrip d;
- }
- abstract {
- return string
- }
- if is:null(ce) then inline {
- d = k_main;
- BlkLoc(k_main)->coexpr.es_pfp = pfp; /* sync w/ current value */
- }
- else if is:proc(ce) then inline {
- int j;
- struct b_proc *cproc = (struct b_proc *)BlkLoc(ce);
- for(j = 0; j < cproc->nparam; j++) {
- result = cproc->lnames[j];
- suspend result;
- }
- fail;
- }
- else if is:coexpr(ce) then inline {
- d = ce;
- BlkLoc(k_main)->coexpr.es_pfp = pfp; /* sync w/ current value */
- }
- else runerr(118,ce)
- if !def:C_integer(i,0) then
- runerr(101,i)
- body {
-#if !COMPILER
- int j;
- dptr arg;
- struct b_proc *cproc;
- struct pf_marker *thePfp = BlkLoc(d)->coexpr.es_pfp;
-
- if (thePfp == NULL) fail;
-
- /*
- * Produce error if i is negative
- */
- if (i < 0) {
- irunerr(205, i);
- errorfail;
- }
-
- while (i--) {
- thePfp = thePfp->pf_pfp;
- if (thePfp == NULL) fail;
- }
-
- arg = &((dptr)thePfp)[-(thePfp->pf_nargs) - 1];
- cproc = (struct b_proc *)BlkLoc(arg[0]);
- for(j = 0; j < cproc->nparam; j++) {
- result = cproc->lnames[j];
- suspend result;
- }
-#endif /* !COMPILER */
- fail;
- }
-end
-
-
-"load(s,arglist,input,output,error,blocksize,stringsize,stacksize) - load"
-" an icode file corresponding to string s as a co-expression."
-
-function{1} load(s,arglist,infile,outfile,errfile,
- blocksize, stringsize, stacksize)
- declare {
- tended char *loadstring;
- C_integer _bs_, _ss_, _stk_;
- }
- if !cnv:C_string(s,loadstring) then
- runerr(103,s)
- if !def:C_integer(blocksize,abrsize,_bs_) then
- runerr(101,blocksize)
- if !def:C_integer(stringsize,ssize,_ss_) then
- runerr(101,stringsize)
- if !def:C_integer(stacksize,mstksize,_stk_) then
- runerr(101,stacksize)
- abstract {
- return coexpr
- }
- body {
- word *stack;
- struct progstate *pstate;
- char sbuf1[MaxCvtLen], sbuf2[MaxCvtLen];
- register struct b_coexpr *sblkp;
- register struct b_refresh *rblkp;
- struct ef_marker *newefp;
- register dptr dp, ndp, dsp;
- register word *newsp, *savedsp;
- int na, nl, i, j, num_fileargs = 0;
- struct b_file *theInput = NULL, *theOutput = NULL, *theError = NULL;
- struct b_proc *cproc;
- extern char *prog_name;
-
- /*
- * Fragments of pseudo-icode to get loaded programs started,
- * and to handle termination.
- */
- static word pstart[7];
- static word *lterm;
-
- inst tipc;
-
- tipc.opnd = pstart;
- *tipc.op++ = Op_Noop; /* aligns Invokes operand */ /* ?cj? */
- *tipc.op++ = Op_Invoke;
- *tipc.opnd++ = 1;
- *tipc.op++ = Op_Coret;
- *tipc.op++ = Op_Efail;
-
- lterm = (word *)(tipc.op);
-
- *tipc.op++ = Op_Cofail;
- *tipc.op++ = Op_Agoto;
- *tipc.opnd = (word)lterm;
-
- prog_name = loadstring; /* set up for &progname */
-
- /*
- * arglist must be a list
- */
- if (!is:null(arglist) && !is:list(arglist))
- runerr(108,arglist);
-
- /*
- * input, output, and error must be files
- */
- if (is:null(infile))
- theInput = &(curpstate->K_input);
- else {
- if (!is:file(infile))
- runerr(105,infile);
- else theInput = &(BlkLoc(infile)->file);
- }
- if (is:null(outfile))
- theOutput = &(curpstate->K_output);
- else {
- if (!is:file(outfile))
- runerr(105,outfile);
- else theOutput = &(BlkLoc(outfile)->file);
- }
- if (is:null(errfile))
- theError = &(curpstate->K_errout);
- else {
- if (!is:file(errfile))
- runerr(105,errfile);
- else theError = &(BlkLoc(errfile)->file);
- }
-
- stack =
- (word *)(sblkp = loadicode(loadstring,theInput,theOutput,theError,
- _bs_,_ss_,_stk_));
- if(!stack) {
- fail;
- }
- pstate = sblkp->program;
- pstate->parent = curpstate;
- pstate->parentdesc = k_main;
-
- savedsp = sp;
- sp = stack + Wsizeof(struct b_coexpr)
- + Wsizeof(struct progstate) + pstate->hsize/WordSize;
- if (pstate->hsize % WordSize) sp++;
-
-#ifdef UpStack
- sblkp->cstate[0] =
- ((word)((char *)sblkp + (mstksize - (sizeof(*sblkp)+sizeof(struct progstate)+pstate->hsize))/2)
- &~((word)WordSize*StackAlign-1));
-#else /* UpStack */
- sblkp->cstate[0] =
- ((word)((char *)sblkp + mstksize - WordSize + sizeof(struct progstate) + pstate->hsize)
- &~((word)WordSize*StackAlign-1));
-#endif /* UpStack */
-
- sblkp->es_argp = NULL;
- sblkp->es_gfp = NULL;
- pstate->Mainhead->freshblk = nulldesc;/* &main has no refresh block. */
- /* This really is a bug. */
-
- /*
- * Set up expression frame marker to contain execution of the
- * main procedure. If failure occurs in this context, control
- * is transferred to lterm, the address of an ...
- */
- newefp = (struct ef_marker *)(sp+1);
-#if IntBits != WordBits
- newefp->ef_failure.op = (int *)lterm;
-#else /* IntBits != WordBits */
- newefp->ef_failure.op = lterm;
-#endif /* IntBits != WordBits */
-
- newefp->ef_gfp = 0;
- newefp->ef_efp = 0;
- newefp->ef_ilevel = ilevel/*1*/;
- sp += Wsizeof(*newefp) - 1;
- sblkp->es_efp = newefp;
-
- /*
- * The first global variable holds the value of "main". If it
- * is not of type procedure, this is noted as run-time error 117.
- * Otherwise, this value is pushed on the stack.
- */
- if (pstate->Globals[0].dword != D_Proc)
- fatalerr(117, NULL);
-
- PushDesc(pstate->Globals[0]);
-
- /*
- * Create a list from arguments using Ollist and push a descriptor
- * onto new stack. Then create procedure frame on new stack. Push
- * two new null descriptors, and set sblkp->es_sp when all finished.
- */
- if (!is:null(arglist)) {
- PushDesc(arglist);
- pstate->Glbl_argp = (dptr)(sp - 1);
- }
- else {
- PushNull;
- pstate->Glbl_argp = (dptr)(sp - 1);
- {
- dptr tmpargp = (dptr) (sp - 1);
- Ollist(0, tmpargp);
- sp = (word *)tmpargp + 1;
- }
- }
- sblkp->es_sp = (word *)sp;
- sblkp->es_ipc.opnd = pstart;
-
- result.dword = D_Coexpr;
- BlkLoc(result) = (union block *)sblkp;
- sp = savedsp;
- return result;
- }
-end
-
-
-"parent(ce) - given a ce, return &main for that ce's parent"
-
-function{1} parent(ce)
- if is:null(ce) then inline { ce = k_current; }
- else if !is:coexpr(ce) then runerr(118,ce)
- abstract {
- return coexpr
- }
- body {
- if (BlkLoc(ce)->coexpr.program->parent == NULL) fail;
-
- result.dword = D_Coexpr;
- BlkLoc(result) =
- (union block *)(BlkLoc(ce)->coexpr.program->parent->Mainhead);
- return result;
- }
-end
-
-#ifdef EventMon
-
-"eventmask(ce,cs) - given a ce, get or set that program's event mask"
-
-function{1} eventmask(ce,cs)
- if !is:coexpr(ce) then runerr(118,ce)
-
- if is:null(cs) then {
- abstract {
- return cset++null
- }
- body {
- result = BlkLoc(ce)->coexpr.program->eventmask;
- return result;
- }
- }
- else if !cnv:cset(cs) then runerr(104,cs)
- else {
- abstract {
- return cset
- }
- body {
- ((struct b_coexpr *)BlkLoc(ce))->program->eventmask = cs;
- return cs;
- }
- }
-end
-#endif /* EventMon */
-
-
-"globalnames(ce) - produce the names of identifiers global to ce"
-
-function{*} globalnames(ce)
- declare {
- struct progstate *ps;
- }
- abstract {
- return string
- }
- if is:null(ce) then inline { ps = curpstate; }
- else if is:coexpr(ce) then
- inline { ps = BlkLoc(ce)->coexpr.program; }
- else runerr(118,ce)
- body {
- struct descrip *dp;
- for (dp = ps->Gnames; dp != ps->Egnames; dp++) {
- suspend *dp;
- }
- fail;
- }
-end
-
-"keyword(kname,ce) - produce a keyword in ce's thread"
-function{*} keyword(keyname,ce)
- declare {
- tended struct descrip d;
- tended char *kyname;
- }
- abstract {
- return any_value
- }
- if !cnv:C_string(keyname,kyname) then runerr(103,keyname)
- if is:null(ce) then inline {
- d = k_current;
- BlkLoc(k_current)->coexpr.es_pfp = pfp; /* sync w/ current value */
- BlkLoc(k_current)->coexpr.es_ipc.opnd = ipc.opnd;
- }
- else if is:coexpr(ce) then
- inline { d = ce; }
- else runerr(118, ce)
- body {
- struct progstate *p = BlkLoc(d)->coexpr.program;
- char *kname = kyname;
- if (kname[0] == '&') kname++;
- if (strcmp(kname,"allocated") == 0) {
- suspend C_integer stattotal + p->stringtotal + p->blocktotal;
- suspend C_integer stattotal;
- suspend C_integer p->stringtotal;
- return C_integer p->blocktotal;
- }
- else if (strcmp(kname,"collections") == 0) {
- suspend C_integer p->colltot;
- suspend C_integer p->collstat;
- suspend C_integer p->collstr;
- return C_integer p->collblk;
- }
- else if (strcmp(kname,"column") == 0) {
- struct progstate *savedp = curpstate;
- int i;
- ENTERPSTATE(p);
- i = findcol(BlkLoc(d)->coexpr.es_ipc.opnd);
- ENTERPSTATE(savedp);
- return C_integer i;
- }
- else if (strcmp(kname,"current") == 0) {
- return p->K_current;
- }
- else if (strcmp(kname,"error") == 0) {
- return kywdint(&(p->Kywd_err));
- }
- else if (strcmp(kname,"errornumber") == 0) {
- return C_integer p->K_errornumber;
- }
- else if (strcmp(kname,"errortext") == 0) {
- return C_string p->K_errortext;
- }
- else if (strcmp(kname,"errorvalue") == 0) {
- return p->K_errorvalue;
- }
- else if (strcmp(kname,"errout") == 0) {
- return file(&(p->K_errout));
- }
- else if (strcmp(kname,"eventcode") == 0) {
- return kywdevent(&(p->eventcode));
- }
- else if (strcmp(kname,"eventsource") == 0) {
- return kywdevent(&(p->eventsource));
- }
- else if (strcmp(kname,"eventvalue") == 0) {
- return kywdevent(&(p->eventval));
- }
- else if (strcmp(kname,"file") == 0) {
- struct progstate *savedp = curpstate;
- struct descrip s;
- ENTERPSTATE(p);
- StrLoc(s) = findfile(BlkLoc(d)->coexpr.es_ipc.opnd);
- StrLen(s) = strlen(StrLoc(s));
- ENTERPSTATE(savedp);
- if (!strcmp(StrLoc(s),"?")) fail;
- return s;
- }
- else if (strcmp(kname,"input") == 0) {
- return file(&(p->K_input));
- }
- else if (strcmp(kname,"level") == 0) {
- /*
- * Bug; levels aren't maintained per program yet.
- * But shouldn't they be per co-expression, not per program?
- */
- }
- else if (strcmp(kname,"line") == 0) {
- struct progstate *savedp = curpstate;
- int i;
- ENTERPSTATE(p);
- i = findline(BlkLoc(d)->coexpr.es_ipc.opnd);
- ENTERPSTATE(savedp);
- return C_integer i;
- }
- else if (strcmp(kname,"main") == 0) {
- return p->K_main;
- }
- else if (strcmp(kname,"output") == 0) {
- return file(&(p->K_output));
- }
- else if (strcmp(kname,"pos") == 0) {
- return kywdpos(&(p->Kywd_pos));
- }
- else if (strcmp(kname,"progname") == 0) {
- return kywdstr(&(p->Kywd_prog));
- }
- else if (strcmp(kname,"random") == 0) {
- return kywdint(&(p->Kywd_ran));
- }
- else if (strcmp(kname,"regions") == 0) {
- word allRegions = 0;
- struct region *rp;
-
- suspend C_integer 0;
- for (rp = p->stringregion; rp; rp = rp->next)
- allRegions += DiffPtrs(rp->end,rp->base);
- for (rp = p->stringregion->prev; rp; rp = rp->prev)
- allRegions += DiffPtrs(rp->end,rp->base);
- suspend C_integer allRegions;
-
- allRegions = 0;
- for (rp = p->blockregion; rp; rp = rp->next)
- allRegions += DiffPtrs(rp->end,rp->base);
- for (rp = p->blockregion->prev; rp; rp = rp->prev)
- allRegions += DiffPtrs(rp->end,rp->base);
- return C_integer allRegions;
- }
- else if (strcmp(kname,"source") == 0) {
- return coexpr(topact((struct b_coexpr *)BlkLoc(BlkLoc(d)->coexpr.program->K_current)));
-/*
- if (BlkLoc(d)->coexpr.es_actstk)
- return coexpr(topact((struct b_coexpr *)BlkLoc(d)));
- else return BlkLoc(d)->coexpr.program->parent->K_main;
-*/
- }
- else if (strcmp(kname,"storage") == 0) {
- word allRegions = 0;
- struct region *rp;
- suspend C_integer 0;
- for (rp = p->stringregion; rp; rp = rp->next)
- allRegions += DiffPtrs(rp->free,rp->base);
- for (rp = p->stringregion->prev; rp; rp = rp->prev)
- allRegions += DiffPtrs(rp->free,rp->base);
- suspend C_integer allRegions;
-
- allRegions = 0;
- for (rp = p->blockregion; rp; rp = rp->next)
- allRegions += DiffPtrs(rp->free,rp->base);
- for (rp = p->blockregion->prev; rp; rp = rp->prev)
- allRegions += DiffPtrs(rp->free,rp->base);
- return C_integer allRegions;
- }
- else if (strcmp(kname,"subject") == 0) {
- return kywdsubj(&(p->ksub));
- }
- else if (strcmp(kname,"trace") == 0) {
- return kywdint(&(p->Kywd_trc));
- }
-#ifdef Graphics
- else if (strcmp(kname,"window") == 0) {
- return kywdwin(&(p->Kywd_xwin[XKey_Window]));
- }
- else if (strcmp(kname,"col") == 0) {
- return kywdint(&(p->AmperCol));
- }
- else if (strcmp(kname,"row") == 0) {
- return kywdint(&(p->AmperRow));
- }
- else if (strcmp(kname,"x") == 0) {
- return kywdint(&(p->AmperX));
- }
- else if (strcmp(kname,"y") == 0) {
- return kywdint(&(p->AmperY));
- }
- else if (strcmp(kname,"interval") == 0) {
- return kywdint(&(p->AmperInterval));
- }
- else if (strcmp(kname,"control") == 0) {
- if (p->Xmod_Control)
- return nulldesc;
- else
- fail;
- }
- else if (strcmp(kname,"shift") == 0) {
- if (p->Xmod_Shift)
- return nulldesc;
- else
- fail;
- }
- else if (strcmp(kname,"meta") == 0) {
- if (p->Xmod_Meta)
- return nulldesc;
- else
- fail;
- }
-#endif /* Graphics */
- runerr(205, keyname);
- }
-end
-#ifdef EventMon
-
-"opmask(ce,cs) - get or set ce's program's opcode mask"
-
-function{1} opmask(ce,cs)
- if !is:coexpr(ce) then runerr(118,ce)
-
- if is:null(cs) then {
- abstract {
- return cset++null
- }
- body {
- result = BlkLoc(ce)->coexpr.program->opcodemask;
- return result;
- }
- }
- else if !cnv:cset(cs) then runerr(104,cs)
- else {
- abstract {
- return cset
- }
- body {
- ((struct b_coexpr *)BlkLoc(ce))->program->opcodemask = cs;
- return cs;
- }
- }
-end
-#endif /* EventMon */
-
-
-"structure(x) -- generate all structures allocated in program x"
-function {*} structure(x)
-
- if !is:coexpr(x) then
- runerr(118, x)
-
- abstract {
- return list ++ set ++ table ++ record
- }
-
- body {
- tended char *bp;
- char *free;
- tended struct descrip descr;
- word type;
- struct region *theregion, *rp;
-
-#ifdef MultiThread
- theregion = ((struct b_coexpr *)BlkLoc(x))->program->blockregion;
-#else
- theregion = curblock;
-#endif
- for(rp = theregion; rp; rp = rp->next) {
- bp = rp->base;
- free = rp->free;
- while (bp < free) {
- type = BlkType(bp);
- switch (type) {
- case T_List:
- case T_Set:
- case T_Table:
- case T_Record: {
- BlkLoc(descr) = (union block *)bp;
- descr.dword = type | F_Ptr | D_Typecode;
- suspend descr;
- }
- }
- bp += BlkSize(bp);
- }
- }
- for(rp = theregion->prev; rp; rp = rp->prev) {
- bp = rp->base;
- free = rp->free;
- while (bp < free) {
- type = BlkType(bp);
- switch (type) {
- case T_List:
- case T_Set:
- case T_Table:
- case T_Record: {
- BlkLoc(descr) = (union block *)bp;
- descr.dword = type | F_Ptr | D_Typecode;
- suspend descr;
- }
- }
- bp += BlkSize(bp);
- }
- }
- fail;
- }
-end
-
-
-#endif /* MultiThread */
generated by cgit v1.2.3 (git 2.39.1) at 2024-05-17 10:22:36 +0000