home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Frozen Fish 1: Amiga
/
FrozenFish-Apr94.iso
/
bbs
/
alib
/
d5xx
/
d524
/
kamin.lha
/
Kamin
/
src.lzh
/
clu.c
< prev
next >
Wrap
C/C++ Source or Header
|
1991-06-28
|
29KB
|
1,331 lines
/* Output from p2c, the Pascal-to-C translator */
/* From input file "clu.p" */
/*****************************************************************
* DECLARATIONS *
*****************************************************************/
#include <p2c/p2c.h>
#define NAMELENG 20 /* Maximum length of a name */
#define MAXNAMES 150 /* Maximum number of different names */
#define MAXINPUT 5000 /* Maximum length of an input */
#define PROMPT "-> "
#define PROMPT2 "> "
#define COMMENTCHAR ";"
#define TABCODE 9 /* in ASCII */
typedef Char NAMESTRING[NAMELENG];
/* a NAME is an index in printNames */
typedef enum {
ONEPART, TWOPART
} FNAMETYPE;
typedef struct FUNNAME {
uchar funpart;
FNAMETYPE nametype;
union {
uchar clpart;
} UU;
} FUNNAME;
typedef enum {
IFOP, WHILEOP, SETOP, BEGINOP, PLUSOP, MINUSOP, TIMESOP, DIVOP, EQOP, LTOP,
GTOP, PRINTOP
} BUILTINOP;
typedef enum {
PRIM, USER
} CLUVALUETYPE;
typedef struct CLUVALUEREC {
CLUVALUETYPE vtype;
union {
long intval;
struct ENVREC *userval;
} UU;
} CLUVALUEREC;
typedef enum {
VALEXP, VAREXP, APEXP
} EXPTYPE;
typedef struct EXPREC {
EXPTYPE etype;
union {
CLUVALUEREC *valu;
uchar varble;
struct {
FUNNAME optr;
struct EXPLISTREC *args;
} U2;
} UU;
} EXPREC;
typedef struct EXPLISTREC {
EXPREC *head;
struct EXPLISTREC *tail;
} EXPLISTREC;
typedef struct VALUELISTREC {
CLUVALUEREC *head;
struct VALUELISTREC *tail;
} VALUELISTREC;
typedef struct NAMELISTREC {
uchar head;
struct NAMELISTREC *tail;
} NAMELISTREC;
typedef struct ENVREC {
NAMELISTREC *vars;
VALUELISTREC *values;
} ENVREC;
typedef enum {
NORMAL, CONSTRUCTOR, SELECTOR, SETTOR
} FUNTYPE;
typedef struct FUNDEFREC {
uchar funname;
struct FUNDEFREC *nextfundef;
FUNTYPE ftype;
union {
struct {
NAMELISTREC *formals;
EXPREC *body;
} U0;
uchar selname;
} UU;
} FUNDEFREC;
typedef struct CLUSTERREC {
uchar clname;
NAMELISTREC *clrep;
FUNDEFREC *exported, *nonexported;
struct CLUSTERREC *nextcluster;
} CLUSTERREC;
Static FUNDEFREC *fundefs;
Static CLUSTERREC *clusters;
Static ENVREC *globalEnv;
Static EXPREC *currentExp;
Static Char userinput[MAXINPUT];
Static short inputleng, pos_;
Static NAMESTRING printNames[MAXNAMES];
Static uchar numNames, numBuiltins;
Static boolean quittingtime;
/*****************************************************************
* DATA STRUCTURE OP'S *
*****************************************************************/
/* mkVALEXP - return an EXP of type VALEXP with valu v */
Static EXPREC *mkVALEXP(v)
CLUVALUEREC *v;
{
EXPREC *e;
e = (EXPREC *)Malloc(sizeof(EXPREC));
e->etype = VALEXP;
e->UU.valu = v;
return e;
} /* mkVALEXP */
/* mkVAREXP - return an EXP of type VAREXP with varble nm */
Static EXPREC *mkVAREXP(nm)
uchar nm;
{
EXPREC *e;
e = (EXPREC *)Malloc(sizeof(EXPREC));
e->etype = VAREXP;
e->UU.varble = nm;
return e;
} /* mkVAREXP */
/* mkAPEXP - return EXP of type APEXP w/ optr op or cl$op */
Static EXPREC *mkAPEXP(ot, op, cl, el)
FNAMETYPE ot;
uchar op, cl;
EXPLISTREC *el;
{
EXPREC *e;
e = (EXPREC *)Malloc(sizeof(EXPREC));
e->etype = APEXP;
e->UU.U2.optr.funpart = op;
e->UU.U2.optr.nametype = ot;
if (ot == TWOPART)
e->UU.U2.optr.UU.clpart = cl;
e->UU.U2.args = el;
return e;
} /* mkAPEXP */
/* mkPRIM - return a CLUVALUE with integer value n */
Static CLUVALUEREC *mkPRIM(n)
long n;
{
CLUVALUEREC *newval;
newval = (CLUVALUEREC *)Malloc(sizeof(CLUVALUEREC));
newval->vtype = PRIM;
newval->UU.intval = n;
return newval;
} /* mkPRIM */
/* mkUSER - return a user-type CLUVALUE */
Static CLUVALUEREC *mkUSER(rho)
ENVREC *rho;
{
CLUVALUEREC *newval;
newval = (CLUVALUEREC *)Malloc(sizeof(CLUVALUEREC));
newval->vtype = USER;
newval->UU.userval = rho;
return newval;
} /* mkUSER */
/* mkExplist - return an EXPLIST with head e and tail el */
Static EXPLISTREC *mkExplist(e, el)
EXPREC *e;
EXPLISTREC *el;
{
EXPLISTREC *newel;
newel = (EXPLISTREC *)Malloc(sizeof(EXPLISTREC));
newel->head = e;
newel->tail = el;
return newel;
} /* mkExplist */
/* mkNamelist - return a NAMELIST with head n and tail nl */
Static NAMELISTREC *mkNamelist(nm, nl)
uchar nm;
NAMELISTREC *nl;
{
NAMELISTREC *newnl;
newnl = (NAMELISTREC *)Malloc(sizeof(NAMELISTREC));
newnl->head = nm;
newnl->tail = nl;
return newnl;
} /* mkNamelist */
/* mkValuelist - return an VALUELIST with head v and tail vl */
Static VALUELISTREC *mkValuelist(v, vl)
CLUVALUEREC *v;
VALUELISTREC *vl;
{
VALUELISTREC *newvl;
newvl = (VALUELISTREC *)Malloc(sizeof(VALUELISTREC));
newvl->head = v;
newvl->tail = vl;
return newvl;
} /* mkValuelist */
/* mkEnv - return an ENV with vars nl and values vl */
Static ENVREC *mkEnv(nl, vl)
NAMELISTREC *nl;
VALUELISTREC *vl;
{
ENVREC *rho;
rho = (ENVREC *)Malloc(sizeof(ENVREC));
rho->vars = nl;
rho->values = vl;
return rho;
} /* mkEnv */
/* lengthVL - return length of VALUELIST vl */
Static long lengthVL(vl)
VALUELISTREC *vl;
{
long i;
i = 0;
while (vl != NULL) {
i++;
vl = vl->tail;
}
return i;
} /* lengthVL */
/* lengthNL - return length of NAMELIST nl */
Static long lengthNL(nl)
NAMELISTREC *nl;
{
long i;
i = 0;
while (nl != NULL) {
i++;
nl = nl->tail;
}
return i;
} /* lengthNL */
/*****************************************************************
* NAME MANAGEMENT *
*****************************************************************/
/* fetchCluster - get cluster definition of cname from clusters */
Static CLUSTERREC *fetchCluster(cname)
uchar cname;
{
CLUSTERREC *cl;
boolean found;
found = false;
cl = clusters;
while (cl != NULL && !found) {
if (cl->clname == cname)
found = true;
else
cl = cl->nextcluster;
}
return cl;
} /* fetchCluster */
/* newCluster - add new cluster cname to clusters */
Static CLUSTERREC *newCluster(cname)
uchar cname;
{
CLUSTERREC *cl;
cl = fetchCluster(cname);
if (cl != NULL) /* cname not yet defined as cluster */
return cl;
cl = (CLUSTERREC *)Malloc(sizeof(CLUSTERREC));
cl->clname = cname;
cl->nextcluster = clusters; /* place new CLUSTERREC */
clusters = cl; /* on clusters list */
return cl;
} /* newCluster */
/* fetchFun - get function definition of NAME fname from fenv */
Static FUNDEFREC *fetchFun(fname, fenv)
uchar fname;
FUNDEFREC *fenv;
{
boolean found;
found = false;
while (fenv != NULL && !found) {
if (fenv->funname == fname)
found = true;
else
fenv = fenv->nextfundef;
}
return fenv;
} /* fetchFun */
/* newFunDef - add new function fname to fenv */
Static FUNDEFREC *newFunDef(fname, fenv)
uchar fname;
FUNDEFREC **fenv;
{
FUNDEFREC *f;
f = fetchFun(fname, *fenv);
if (f != NULL) /* fname not yet defined as a function */
return f;
f = (FUNDEFREC *)Malloc(sizeof(FUNDEFREC));
f->funname = fname;
f->nextfundef = *fenv; /* place new FUNDEFREC */
*fenv = f; /* on fenv list */
return f;
} /* newFunDef */
/* initNames - place all pre-defined names into printNames */
Static Void initNames()
{
long i;
fundefs = NULL;
clusters = NULL;
i = 1;
memcpy(printNames[i - 1], "if ", sizeof(NAMESTRING));
i++;
memcpy(printNames[i - 1], "while ", sizeof(NAMESTRING));
i++;
memcpy(printNames[i - 1], "set ", sizeof(NAMESTRING));
i++;
memcpy(printNames[i - 1], "begin ", sizeof(NAMESTRING));
i++;
memcpy(printNames[i - 1], "+ ", sizeof(NAMESTRING));
i++;
memcpy(printNames[i - 1], "- ", sizeof(NAMESTRING));
i++;
memcpy(printNames[i - 1], "* ", sizeof(NAMESTRING));
i++;
memcpy(printNames[i - 1], "/ ", sizeof(NAMESTRING));
i++;
memcpy(printNames[i - 1], "= ", sizeof(NAMESTRING));
i++;
memcpy(printNames[i - 1], "< ", sizeof(NAMESTRING));
i++;
memcpy(printNames[i - 1], "> ", sizeof(NAMESTRING));
i++;
memcpy(printNames[i - 1], "print ", sizeof(NAMESTRING));
numNames = i;
numBuiltins = i;
} /* initNames */
Static jmp_buf _JL99;
/* install - insert new name into printNames */
Static uchar install(nm)
Char *nm;
{
long i;
boolean found;
i = 1;
found = false;
while (i <= numNames && !found) {
if (!memcmp(nm, printNames[i - 1], sizeof(NAMESTRING)))
found = true;
else
i++;
}
if (found)
return i;
if (i > MAXNAMES) {
printf("No more room for names\n");
longjmp(_JL99, 1);
}
numNames = i;
memcpy(printNames[i - 1], nm, sizeof(NAMESTRING));
return i;
} /* install */
/* prName - print name nm */
Static Void prName(nm)
uchar nm;
{
long i;
i = 1;
while (i <= NAMELENG) {
if (printNames[nm - 1][i - 1] != ' ') {
putchar(printNames[nm - 1][i - 1]);
i++;
} else
i = NAMELENG + 1;
}
} /* prName */
/* primOp - translate NAME optr to corresponding BUILTINOP */
Static BUILTINOP primOp(optr)
uchar optr;
{
BUILTINOP op;
long i;
op = IFOP; /* N.B. IFOP is first value in BUILTINOPS */
for (i = 1; i < optr; i++)
op = (BUILTINOP)((long)op + 1);
return op;
} /* primOp */
/*****************************************************************
* INPUT *
*****************************************************************/
/* isDelim - check if c is a delimiter */
Static boolean isDelim(c)
Char c;
{
return (c == ';' || c == '$' || c == ' ' || c == ')' || c == '(');
} /* isDelim */
/* skipblanks - return next non-blank position in userinput */
Static long skipblanks(p)
long p;
{
while (userinput[p - 1] == ' ')
p++;
return p;
} /* skipblanks */
/* matches - check if string nm matches userinput[s .. s+leng] */
Static boolean matches(s, leng, nm)
long s;
char leng;
Char *nm;
{
boolean match;
long i;
match = true;
i = 1;
while (match && i <= leng) {
if (userinput[s - 1] != nm[i - 1])
match = false;
i++;
s++;
}
if (!isDelim(userinput[s - 1]))
match = false;
return match;
} /* matches */
/* nextchar - read next char - filter tabs and comments */
Local Void nextchar(c)
Char *c;
{
Char STR1[256];
*c = getchar();
if (*c == '\n')
*c = ' ';
if (*c == (Char)TABCODE) {
*c = ' ';
return;
}
sprintf(STR1, "%c", *c);
if (strcmp(STR1, COMMENTCHAR))
return;
while (!P_eoln(stdin)) {
*c = getchar();
if (*c == '\n')
*c = ' ';
}
*c = ' ';
} /* nextchar */
/* readParens - read char's, ignoring newlines, to matching ')' */
Local Void readParens()
{
long parencnt; /* current depth of parentheses */
Char c;
parencnt = 1; /* '(' just read */
do {
if (P_eoln(stdin))
fputs(PROMPT2, stdout);
nextchar(&c);
pos_++;
if (pos_ == MAXINPUT) {
printf("User input too long\n");
longjmp(_JL99, 1);
}
userinput[pos_ - 1] = c;
if (c == '(')
parencnt++;
if (c == ')')
parencnt--;
} while (parencnt != 0); /* readParens */
}
Local Void readInput()
{
Char c;
fputs(PROMPT, stdout);
pos_ = 0;
do {
pos_++;
if (pos_ == MAXINPUT) {
printf("User input too long\n");
longjmp(_JL99, 1);
}
nextchar(&c);
userinput[pos_ - 1] = c;
if (userinput[pos_ - 1] == '(')
readParens();
} while (!P_eoln(stdin));
inputleng = pos_;
userinput[pos_] = ';'; /* sentinel */
} /* readInput */
/* reader - read char's into userinput; be sure input not blank */
Static Void reader()
{
/* readInput - read char's into userinput */
do {
readInput();
pos_ = skipblanks(1L); /* ignore blank lines */
} while (pos_ > inputleng); /* reader */
}
/* parseName - return (installed) NAME starting at userinput[pos]*/
Static uchar parseName()
{
NAMESTRING nm; /* array to accumulate characters */
char leng; /* length of name */
leng = 0;
while ((pos_ <= inputleng) & (!isDelim(userinput[pos_ - 1]))) {
if (leng == NAMELENG) {
printf("Name too long, begins: %.*s\n", NAMELENG, nm);
longjmp(_JL99, 1);
}
leng++;
nm[leng - 1] = userinput[pos_ - 1];
pos_++;
}
if (leng == 0) {
printf("Error: expected name, instead read: %c\n", userinput[pos_ - 1]);
longjmp(_JL99, 1);
}
for (; leng < NAMELENG; leng++)
nm[leng] = ' ';
pos_ = skipblanks((long)pos_); /* skip blanks after name */
return (install(nm));
} /* parseName */
Local boolean isDigits(pos)
long pos;
{
boolean Result;
if (!isdigit(userinput[pos - 1]))
return false;
Result = true;
while (isdigit(userinput[pos - 1]))
pos++;
if (!isDelim(userinput[pos - 1]))
return false;
return Result;
} /* isDigits */
/* isNumber - check if a number begins at pos */
Static boolean isNumber(pos)
long pos;
{
/* isDigits - check if sequence of digits begins at pos */
return (isDigits(pos) | ((userinput[pos - 1] == '-') & isDigits(pos + 1)));
} /* isNumber */
/* parseVal - return number starting at userinput[pos] */
Static CLUVALUEREC *parseVal()
{
long n, sign;
n = 0;
sign = 1;
if (userinput[pos_ - 1] == '-') {
sign = -1;
pos_++;
}
while (isdigit(userinput[pos_ - 1])) {
n = n * 10 + userinput[pos_ - 1] - '0';
pos_++;
}
pos_ = skipblanks((long)pos_); /* skip blanks after number */
return (mkPRIM(n * sign));
} /* parseVal */
Static EXPLISTREC *parseEL PV();
/* parseExp - return EXP starting at userinput[pos] */
Static EXPREC *parseExp()
{
uchar fnm, cnm;
EXPLISTREC *el;
FNAMETYPE optrtype;
if (userinput[pos_ - 1] == '(') { /* APEXP */
pos_ = skipblanks(pos_ + 1L); /* skip '( ..' */
optrtype = ONEPART;
cnm = 1; /* arbitrary name */
fnm = parseName();
if (userinput[pos_ - 1] == '$') { /* two-part name */
pos_++;
cnm = fnm;
optrtype = TWOPART;
fnm = parseName();
}
el = parseEL();
return (mkAPEXP(optrtype, fnm, cnm, el));
} else if (isNumber((long)pos_))
return (mkVALEXP(parseVal())); /* VALEXP */
else
return (mkVAREXP(parseName())); /* VAREXP */
} /* parseExp */
/* parseEL - return EXPLIST starting at userinput[pos] */
Static EXPLISTREC *parseEL()
{
EXPREC *e;
EXPLISTREC *el;
if (userinput[pos_ - 1] == ')') {
pos_ = skipblanks(pos_ + 1L); /* skip ') ..' */
return NULL;
} else {
e = parseExp();
el = parseEL();
return (mkExplist(e, el));
}
} /* parseEL */
/* parseNL - return NAMELIST starting at userinput[pos] */
Static NAMELISTREC *parseNL()
{
uchar nm;
NAMELISTREC *nl;
if (userinput[pos_ - 1] == ')') {
pos_ = skipblanks(pos_ + 1L); /* skip ') ..' */
return NULL;
} else {
nm = parseName();
nl = parseNL();
return (mkNamelist(nm, nl));
}
} /* parseNL */
/* parseDef - parse function definition at userinput[pos] */
Static uchar parseDef(fenv)
FUNDEFREC **fenv;
{
uchar fname; /* function name */
FUNDEFREC *newfun; /* new FUNDEFREC */
pos_ = skipblanks(pos_ + 1L); /* skip '( ..' */
pos_ = skipblanks(pos_ + 6L); /* skip 'define ..' */
fname = parseName();
newfun = newFunDef(fname, fenv);
newfun->ftype = NORMAL;
pos_ = skipblanks(pos_ + 1L); /* skip '( ..' */
newfun->UU.U0.formals = parseNL();
newfun->UU.U0.body = parseExp();
pos_ = skipblanks(pos_ + 1L); /* skip ') ..' */
return fname;
} /* parseDef */
/* mkSetName - make name of settor corresponding to selector nm */
Local uchar mkSetName(nm)
uchar nm;
{
NAMESTRING setname;
long i;
memcpy(setname, "set- ", sizeof(NAMESTRING));
if (printNames[nm - 1][NAMELENG - 4] != ' ') {
printf("Selector name too long: ");
prName(nm);
putchar('\n');
longjmp(_JL99, 1);
}
for (i = 1; i <= NAMELENG - 4; i++)
setname[i + 3] = printNames[nm - 1][i - 1];
return (install(setname));
} /* mkSetName */
/* parseCluster - parse cluster definition at userinput[pos] */
Static uchar parseCluster()
{
uchar cname, sel, fname;
CLUSTERREC *newclust;
NAMELISTREC *rep;
FUNDEFREC *cenv, *confun, *selfun, *setfun;
pos_ = skipblanks(pos_ + 1L); /* skip '( ..' */
pos_ = skipblanks(pos_ + 7L); /* skip 'cluster ...' */
cname = parseName();
newclust = newCluster(cname);
pos_ = skipblanks(pos_ + 1L); /* skip '( ...' */
pos_ = skipblanks(pos_ + 3L); /* skip 'rep ...' */
rep = parseNL(); /* selector names */
newclust->clrep = rep;
cenv = NULL;
while (userinput[pos_ - 1] == '(') {
fname = parseDef(&cenv);
prName(fname);
putchar('\n');
}
newclust->exported = cenv;
cenv = NULL;
confun = newFunDef(cname, &cenv);
confun->ftype = CONSTRUCTOR;
while (rep != NULL) {
sel = rep->head;
selfun = newFunDef(sel, &cenv);
selfun->ftype = SELECTOR;
setfun = newFunDef(mkSetName(sel), &cenv);
setfun->ftype = SETTOR;
setfun->UU.selname = sel;
rep = rep->tail;
}
newclust->nonexported = cenv;
pos_ = skipblanks(pos_ + 1L); /* skip ') ..' */
return cname;
} /* parseCluster */
/*****************************************************************
* ENVIRONMENTS *
*****************************************************************/
/* emptyEnv - return an environment with no bindings */
Static ENVREC *emptyEnv()
{
return (mkEnv(NULL, NULL));
} /* emptyEnv */
/* bindVar - bind variable nm to value n in environment rho */
Static Void bindVar(nm, v, rho)
uchar nm;
CLUVALUEREC *v;
ENVREC *rho;
{
rho->vars = mkNamelist(nm, rho->vars);
rho->values = mkValuelist(v, rho->values);
} /* bindVar */
/* findVar - look up nm in rho */
Static VALUELISTREC *findVar(nm, rho)
uchar nm;
ENVREC *rho;
{
NAMELISTREC *nl;
VALUELISTREC *vl;
boolean found;
found = false;
nl = rho->vars;
vl = rho->values;
while (nl != NULL && !found) {
if (nl->head == nm)
found = true;
else {
nl = nl->tail;
vl = vl->tail;
}
}
return vl;
} /* findVar */
/* assign - assign value n to variable nm in rho */
Static Void assign(nm, v, rho)
uchar nm;
CLUVALUEREC *v;
ENVREC *rho;
{
VALUELISTREC *varloc;
varloc = findVar(nm, rho);
varloc->head = v;
} /* assign */
/* fetch - return number bound to nm in rho */
Static CLUVALUEREC *fetch(nm, rho)
uchar nm;
ENVREC *rho;
{
VALUELISTREC *vl;
vl = findVar(nm, rho);
return (vl->head);
} /* fetch */
/* isBound - check if nm is bound in rho */
Static boolean isBound(nm, rho)
uchar nm;
ENVREC *rho;
{
return (findVar(nm, rho) != NULL);
} /* isBound */
/*****************************************************************
* VALUES *
*****************************************************************/
/* prValue - print value v */
Static Void prValue(v)
CLUVALUEREC *v;
{
if (v->vtype == PRIM)
printf("%ld", v->UU.intval);
else
printf("<userval>");
} /* prValue */
/* isTrueVal - return true if v is true (non-zero) value */
Static boolean isTrueVal(v)
CLUVALUEREC *v;
{
if (v->vtype == USER)
return true;
else
return (v->UU.intval != 0);
} /* isTrueVal */
/* arity - return number of arguments expected by op */
Local long arity(op)
BUILTINOP op;
{
if (((1L << ((long)op)) & ((1 << ((long)GTOP + 1)) - (1 << ((long)PLUSOP)))) != 0)
return 2;
else
return 1;
} /* arity */
/* applyValueOp - apply VALUEOP op to arguments in VALUELIST vl */
Static CLUVALUEREC *applyValueOp(op, vl)
BUILTINOP op;
VALUELISTREC *vl;
{
long n, n1, n2;
if (arity(op) != lengthVL(vl)) {
printf("Wrong number of arguments to ");
prName((int)op + 1);
putchar('\n');
longjmp(_JL99, 1);
}
if (op == PRINTOP) {
prValue(vl->head);
putchar('\n');
return (vl->head);
} else {
if (vl->head->vtype != PRIM || vl->tail->head->vtype != PRIM) {
printf("Arguments to primitive op not primitive: ");
prName((int)op+1);
putchar('\n');
longjmp(_JL99, 1);
}
n1 = vl->head->UU.intval; /* 1st actual */
n2 = vl->tail->head->UU.intval; /* 2nd actual */
switch (op) {
case PLUSOP:
n = n1 + n2;
break;
case MINUSOP:
n = n1 - n2;
break;
case TIMESOP:
n = n1 * n2;
break;
case DIVOP:
n = n1 / n2;
break;
case EQOP:
if (n1 == n2)
n = 1;
else
n = 0;
break;
case LTOP:
if (n1 < n2)
n = 1;
else
n = 0;
break;
case GTOP:
if (n1 > n2)
n = 1;
else
n = 0;
break;
}/* case */
return (mkPRIM(n));
}
} /* applyValueOp */
Static CLUVALUEREC *eval PP((EXPREC *e, ENVREC *rho, CLUSTERREC *c));
/* Local variables for eval: */
struct LOC_eval {
ENVREC *rho;
CLUSTERREC *c;
} ;
/* evalList - evaluate each expression in el */
Local VALUELISTREC *evalList(el, LINK)
EXPLISTREC *el;
struct LOC_eval *LINK;
{
CLUVALUEREC *h;
VALUELISTREC *t;
if (el == NULL)
return NULL;
else {
h = eval(el->head, LINK->rho, LINK->c);
t = evalList(el->tail, LINK);
return (mkValuelist(h, t));
}
} /* evalList */
/* Local variables for applyUserFun: */
struct LOC_applyUserFun {
struct LOC_eval *LINK;
VALUELISTREC *actuals;
} ;
/* Local variables for checkArgs: */
struct LOC_checkArgs {
struct LOC_applyUserFun *LINK;
FUNNAME nm;
FUNDEFREC *f;
CLUSTERREC *cl;
} ;
Local long arity_(LINK)
struct LOC_checkArgs *LINK;
{
long Result;
FUNDEFREC *WITH;
WITH = LINK->f;
switch (WITH->ftype) {
case NORMAL:
Result = lengthNL(WITH->UU.U0.formals);
break;
case CONSTRUCTOR:
Result = lengthNL(LINK->cl->clrep);
break;
case SELECTOR:
Result = 1;
break;
case SETTOR:
Result = 2;
break;
}/* case and with */
return Result;
} /* arity */
/* typeError - print type error message */
Local Void typeError(LINK)
struct LOC_checkArgs *LINK;
{
printf("Wrong type argument to: ");
prName(LINK->nm.funpart);
putchar('\n');
longjmp(_JL99, 1);
} /* typeError */
/* checkArgs - check number/type (as far as possible) of args */
Local Void checkArgs(nm_, f_, cl_, LINK)
FUNNAME nm_;
FUNDEFREC *f_;
CLUSTERREC *cl_;
struct LOC_applyUserFun *LINK;
{
/* arity - number of arguments expected by f */
struct LOC_checkArgs V;
FUNDEFREC *WITH;
V.LINK = LINK;
V.nm = nm_;
V.f = f_;
V.cl = cl_;
if (arity_(&V) != lengthVL(LINK->actuals)) {
printf("Wrong number of arguments to: ");
prName(V.nm.funpart);
putchar('\n');
longjmp(_JL99, 1);
}
WITH = V.f;
if (((1L << ((long)WITH->ftype)) &
((1L << ((long)SELECTOR)) | (1 << ((long)SETTOR)))) != 0) {
if (LINK->actuals->head->vtype == PRIM)
typeError(&V);
}
if (WITH->ftype == SELECTOR) {
if (!isBound(V.nm.funpart, LINK->actuals->head->UU.userval))
typeError(&V);
}
if (WITH->ftype == SETTOR) {
if (!isBound(WITH->UU.selname, LINK->actuals->head->UU.userval))
typeError(&V);
}
} /* checkArgs */
/* applyUserFun - look up definition of nm and apply to actuals */
Local CLUVALUEREC *applyUserFun(nm, actuals_, LINK)
FUNNAME nm;
VALUELISTREC *actuals_;
struct LOC_eval *LINK;
{
struct LOC_applyUserFun V;
CLUVALUEREC *Result;
FUNDEFREC *f;
ENVREC *rho, *valrho;
CLUVALUEREC *v;
CLUSTERREC *cl;
V.LINK = LINK;
V.actuals = actuals_;
if (nm.nametype == TWOPART) {
cl = fetchCluster(nm.UU.clpart);
if (cl == NULL) {
printf("Non-existent cluster: ");
prName(nm.UU.clpart);
putchar('\n');
longjmp(_JL99, 1);
}
f = fetchFun(nm.funpart, cl->exported);
} else { /* one-part name */
cl = LINK->c;
if (cl == NULL) /* called from top level */
f = fetchFun(nm.funpart, fundefs);
else { /* try exported function first */
f = fetchFun(nm.funpart, cl->exported);
if (f == NULL) { /* else non-exported */
f = fetchFun(nm.funpart, cl->nonexported);
if (f == NULL) { /* else top-level */
cl = NULL;
f = fetchFun(nm.funpart, fundefs);
}
}
}
}
if (f == NULL) {
printf("Undefined function: ");
prName(nm.funpart);
putchar('\n');
longjmp(_JL99, 1);
}
checkArgs(nm, f, cl, &V);
switch (f->ftype) {
case NORMAL:
rho = mkEnv(f->UU.U0.formals, V.actuals);
Result = eval(f->UU.U0.body, rho, cl);
break;
case CONSTRUCTOR:
Result = mkUSER(mkEnv(cl->clrep, V.actuals));
break;
case SELECTOR:
valrho = V.actuals->head->UU.userval;
Result = fetch(nm.funpart, valrho);
break;
case SETTOR:
valrho = V.actuals->head->UU.userval;
v = V.actuals->tail->head;
assign(f->UU.selname, v, valrho);
Result = v;
break;
}/* case and with */
return Result;
} /* applyUserFun */
/* applyCtrlOp - apply CONTROLOP op to args in rho */
Local CLUVALUEREC *applyCtrlOp(op, args, LINK)
BUILTINOP op;
EXPLISTREC *args;
struct LOC_eval *LINK;
{
CLUVALUEREC *Result, *v;
EXPLISTREC *WITH;
WITH = args;
switch (op) {
case IFOP:
if (isTrueVal(eval(WITH->head, LINK->rho, LINK->c)))
Result = eval(WITH->tail->head, LINK->rho, LINK->c);
else
Result = eval(WITH->tail->tail->head, LINK->rho, LINK->c);
break;
case WHILEOP:
v = eval(WITH->head, LINK->rho, LINK->c);
while (isTrueVal(v)) {
v = eval(WITH->tail->head, LINK->rho, LINK->c);
v = eval(WITH->head, LINK->rho, LINK->c);
}
Result = v;
break;
case SETOP:
v = eval(WITH->tail->head, LINK->rho, LINK->c);
if (isBound(WITH->head->UU.varble, LINK->rho))
assign(WITH->head->UU.varble, v, LINK->rho);
else if (isBound(WITH->head->UU.varble, globalEnv))
assign(WITH->head->UU.varble, v, globalEnv);
else
bindVar(WITH->head->UU.varble, v, globalEnv);
Result = v;
break;
case BEGINOP:
while (args->tail != NULL) {
v = eval(args->head, LINK->rho, LINK->c);
args = args->tail;
}
Result = eval(args->head, LINK->rho, LINK->c);
break;
}/* case and with */
return Result;
} /* applyCtrlOp */
/*****************************************************************
* EVALUATION *
*****************************************************************/
/* eval - return value of e in environment rho, cluster c */
Static CLUVALUEREC *eval(e, rho_, c_)
EXPREC *e;
ENVREC *rho_;
CLUSTERREC *c_;
{
struct LOC_eval V;
CLUVALUEREC *Result;
BUILTINOP op;
V.rho = rho_;
V.c = c_;
switch (e->etype) {
case VALEXP:
Result = e->UU.valu;
break;
case VAREXP:
if (isBound(e->UU.varble, V.rho))
Result = fetch(e->UU.varble, V.rho);
else if (isBound(e->UU.varble, globalEnv))
Result = fetch(e->UU.varble, globalEnv);
else {
printf("Undefined variable: ");
prName(e->UU.varble);
putchar('\n');
longjmp(_JL99, 1);
}
break;
case APEXP:
if (e->UU.U2.optr.funpart > numBuiltins)
Result = applyUserFun(e->UU.U2.optr, evalList(e->UU.U2.args, &V), &V);
else {
op = primOp(e->UU.U2.optr.funpart);
if (((1L << ((long)op)) &
((1 << ((long)BEGINOP + 1)) - (1 << ((long)IFOP)))) != 0)
Result = applyCtrlOp(op, e->UU.U2.args, &V);
else
Result = applyValueOp(op, evalList(e->UU.U2.args, &V));
}
break;
}/* case and with */
return Result;
} /* eval */
/*****************************************************************
* READ-EVAL-PRINT LOOP *
*****************************************************************/
main(argc, argv)
int argc;
Char *argv[];
{ /* clu main */
PASCAL_MAIN(argc, argv);
if (setjmp(_JL99))
goto _L99;
initNames();
globalEnv = emptyEnv();
quittingtime = false;
_L99:
while (!quittingtime) {
reader();
if (matches((long)pos_, 4, "quit ")) {
quittingtime = true;
break;
}
if ((userinput[pos_ - 1] == '(') & matches(skipblanks(pos_ + 1L), 6,
"define ")) {
prName(parseDef(&fundefs));
putchar('\n');
} else if ((userinput[pos_ - 1] == '(') & matches(skipblanks(pos_ + 1L),
7, "cluster ")) {
prName(parseCluster());
putchar('\n');
} else {
currentExp = parseExp();
prValue(eval(currentExp, emptyEnv(), NULL));
printf("\n\n");
}
} /* while */
exit(0);
} /* clu */
/* End. */