static CELLP push(CELLP keys, CELLP value, CELLP env)
{
int q;
CELLP newcell();
// printf("\nPUSH: Current Value is: ");
//print_s(value, ESCOFF);
//printf("\n");
// printf("\nPUSH: Current *SP is: ");
//print_s(*sp, ESCOFF);
//printf("\n");
stackcheck;
q = on(&env);
on(&keys);
on(&value);
//printf("=%d= ", __LINE__);
*++sp = newcell();//N//
//printf("=%d= ", __LINE__);
off(q);//N//
ec;//N//
(*sp)->cdr = env;
env = *sp;
q = on(&env);
on(&keys);
on(&value);
//printf("=%d= ", __LINE__);
env->car = newcell();//N//
//printf("=%d= ", __LINE__);
off(q);//N//
ec;//N//
env->car->car = keys;
env->car->cdr = value;
return *sp--;
}
static Cell *maketypevariable(char name[])
{
Cell *temp;
int k = strlen(name), l;
for(l=0; l<k; l++)
if(name[l] != '*') parseerror(6);
switch(checktypevariable)
{
case COLLECT:
push(typevariables);
push(temp = newcell(TYPEVAR));
temp->value = k;
make(LIST);
typevariables = pop();
return temp;
case CHECK:
temp = typevariables;
while(temp->tag==LIST && temp->left->value != k) temp = temp->right;
if(temp->tag != LIST) parseerror(7);
return temp->left;
default:
temp = newcell(TYPEVAR);
temp->value = k;
return temp;
}
}
void make_IF(void)
{
Cell *temp = newcell(_IF);
temp->right = newcell(_IF);
temp->right->right = pop();
temp->right->left = pop();
temp->left = pop();
push(temp);
}
static void apply_SECTION(void)
{
Cell *temp;
push(temp = newcell(APPLY));
temp->right = getN(3);
temp = temp->left = newcell(APPLY);
temp->right = getN(4);
temp->left = getN(2);
}
void make(TagType tag)
{
Cell *temp = newcell(tag);
temp->left = pop();
temp->right = pop();
push(temp);
}
Lexp
Lappl(Lexp left, Lexp right) {
Cellidx c = newcell(APPL);
Cleft(c) = left;
Cright(c) = right;
return c;
}
Lexp
Labst(Var bv, Lexp body) {
Cellidx c = newcell(ABST);
Cbv(c) = bv;
Cbody(c) = body;
return c;
}
CELLP divide_f(CELLP args)
{
CELLP cp;
stackcheck;
*(++sp) = quotient_f(args); ec;
stackcheck;
*(++sp) = remainder_f(args); ec;
stackcheck;
*(++sp) = newcell(); ec;
cp = newcell(); ec;
cp->car = *(sp-2);
cp->cdr = *sp;
(*sp)->car = *(sp-1);
sp -= 3;
return cp;
}
static void applySTRICT(void)
{
push(getN(2));
eval();
popN(1);
push(newcell(APPLY));
top()->left = getN(2);
top()->right = getN(3);
}
static void applyUPDATE(void)
{
Cell *r1 = getN(1), *r2 = getN(2), *temp;
evaluate(r1);
evaluate(r2);
if(r1->tag != RECORD || r2->tag != RECORD || r1->value != r2->value) runtimeerror(ERROR, template_update->value);
push(temp = newcell(RECORD));
temp->value = r1->value;
for(;;)
{
temp->left = r2->left->tag == UNDEFINED ? r1->left : r2->left;
r1 = r1->right;
r2 = r2->right;
if(r1->tag != RECORD || r2->tag != RECORD) break;
temp = temp->right = newcell(RECORD);
}
temp->right = template_match;
if(r1->tag == RECORD || r2->tag == RECORD) runtimeerror(ERROR, template_update->value);
}
void makeset(TagType tag, int n)
{
Cell *temp;
makecompound(PAIR, n+2);
temp = newcell(tag);
temp->value = n;
temp->left = pop();
temp->right = template_nil;
push(temp);
}
void makecompound(TagType tag, int n)
{
push(template_match);
while(n-- > 0)
{
Cell *temp = newcell(tag);
temp->right = pop();
temp->left = pop();
push(temp);
}
}
void makeAPPLICATION(int value, int n)
{
Cell *temp;
if(n == 0)
push(newcell(APPLICATION));
else if(n == 1)
{
temp = newcell(APPLICATION);
temp->right = pop();
push(temp);
}
else
while(n-- > 1)
{
temp = newcell(APPLICATION);
temp->right = pop();
temp->left = pop();
push(temp);
}
top()->value = value;
}
static void randblip (struct state *st, int doit)
{
int n;
int b = 0;
if (!doit
&& (st->blastcount-- >= 0)
&& (RAND_FLOAT > st->anychan))
{
return;
}
if (st->blastcount < 0)
{
b = 1;
n = 2;
st->blastcount = random_life_value (st);
if (RAND_FLOAT < st->instantdeathchan)
{
/* clear everything every so often to keep from getting into a
* rut */
setup_arr (st);
b = 0;
}
}
else if (RAND_FLOAT <= st->minorchan)
{
n = 2;
}
else
{
n = random () % 3 + 3;
}
while (n--)
{
int x = st->arr_width ? random () % st->arr_width : 0;
int y = st->arr_height ? random () % st->arr_height : 0;
int c;
FLOAT s;
if (b)
{
c = 0;
s = RAND_FLOAT * (st->maxdeathspeed - st->mindeathspeed) + st->mindeathspeed;
}
else
{
c = ((st->count - 1) ? random () % (st->count-1) : 0) + 1;
s = RAND_FLOAT * (st->maxlifespeed - st->minlifespeed) + st->minlifespeed;
}
newcell (st, &st->arr[y * st->arr_width + x], c, s);
}
}
/************************************************************************
pushes a list of characters (based on s)
*************************************************************************/
static void buildstring(char *s)
{
Cell *temp;
if(*s == '\0')
{
push(template_nil);
return;
}
push(temp = newcell(LIST));
for(;;)
{
temp->left = newcell(CHAR);
temp->left->value = *s++;
if(*s == '\0')
{
temp->right = template_nil;
return;
}
temp = temp->right = newcell(LIST);
}
}
/*********************************************************************
everything between a list bar and a rbrack is transformed in a
generator structure:
GENERATOR ---- GENERATOR ---- ... NULL
| |
GENERATOR --
|
in case of an ordinary expression the right part is NULL
in case of a generator the variable(list) is left and the list-expr(list) right
**********************************************************************/
static void parsegenerators(int *count)
{
Cell *temp;
for(;;)
{
int varcount = 0, exprcount = 0;
while(tokentype == SEP) gettoken();
if(tokentype == RBRACK) break;
push(temp = newcell(GENERATOR));
temp->value = getPositionCode();
(*count)++;
for(;;)
{
parseexpression(MAXPRIO);
varcount++;
if(tokentype != COMMA) break;
gettoken();
}
if(tokentype == GENER || tokentype == ASSIGNMENT)
{
bool assignment = tokentype == ASSIGNMENT;
do
{
gettoken();
parseexpression(MAXPRIO);
exprcount++;
if(assignment)
{
push(template_nil);
makeinverse(LIST);
}
}
while(tokentype == COMMA);
if(exprcount != varcount) parseerror(32);
push(template_nil);
while(exprcount-- > 0) makeinverse(LIST);
temp->right = pop();
push(template_nil);
while(varcount-- > 0) makeinverse(LIST);
checkpattern(temp->left = pop());
}
else if(varcount > 1)
parseerror(31);
else
temp->left = pop();
}
}
static void makerecordfield(Cell *recordtype, Cell *field, Cell *fieldtype)
{
char *fieldname = getfunction(field->value)->name;
Cell *var = newcell(VARIABLE);
var->value = 1;
var->left = field;
push(fieldtype);
push(recordtype);
make(APPLY);
if(!inserttypeexpr(fieldname, pop())) parseerror(12);
push(var);
push(var);
push(field);
make(ALIAS);
makecompound(RECORD, 1);
push(field);
make(APPLY);
make(LIST);
if(!insert(fieldname, 1, FUNC, pop(), NULL)) parseerror(18);
}
static void parsetype(TypeType typetype)
{
switch(tokentype)
{
case IDENTIFIER:
if(strcmp(tokenval, "num") == 0)
{
push(newcell(INT));
gettoken();
}
else if(strcmp(tokenval, "char") == 0)
{
push(newcell(CHAR));
gettoken();
}
else if(strcmp(tokenval, "bool") == 0)
{
push(newcell(BOOLEAN));
gettoken();
}
else
{
int count = 1;
push(gettemplate(tokenval));
gettoken();
if(typetype == TYPEEXPR)
while(tokentype == IDENTIFIER
|| tokentype == OPERATOR
|| tokentype == LBRACK
|| tokentype == LPAR)
{
parsetype(TYPETERM);
count++;
}
makecompound(STRUCT, count);
}
break;
case OPERATOR:
push(maketypevariable(tokenval));
gettoken();
break;
case LPAR:
gettoken();
if(tokentype == RPAR)
push(newcell(NULLTUPLE));
else
{
parsetype(TYPEEXPR);
if(tokentype == COMMA)
{
int count = 1;
while(tokentype == COMMA)
{
gettoken();
parsetype(TYPEEXPR);
count++;
}
makecompound(PAIR, count);
}
}
if(tokentype != RPAR) parseerror(2);
gettoken();
break;
case LBRACK:
gettoken();
parsetype(TYPEEXPR);
push(template_nil);
makeinverse(LIST);
if(tokentype != RBRACK) parseerror(1);
gettoken();
break;
default:
parseerror(8);
}
if(typetype == TYPEEXPR && tokentype == ARROW)
{
gettoken();
parsetype(TYPEEXPR);
makeinverse(APPLY);
}
}
CELLP evallist(CELLP args, CELLP env)
{
int q;
CELLP cp1, newcell(), eval();
//引き数のリストがcellでない場合はおそらくnilなのでnilを返却する
//printf("evallist args=");
//print_s(args, ESCOFF);
if(args->id != _CELL) {
return (CELLP)nil;
}
stackcheck;
q = on(&args);
on(&env);
//stackに新しいcellを用意する
//printf("=%d= ", __LINE__);
*++sp = newcell();//N//
//printf("=%d= ", __LINE__);
off(q);//N//
ec;//N//
//現在のスタックポインタを一旦保存しておく
cp1 = *sp;
//保存したcellのcarに引き数の一つ目を評価した物を入れる
q = on(&cp1); //CP1を追加保護
on(&args);
on(&env);
//printf("=%d= ", __LINE__);
cp1->car = eval(args->car, env);//N//
//printf("=%d= ", __LINE__);
off(q);//N//
ec;//N//
//次の引き数に移る
//printf("\n***(*sp)は%p番地に存在し、内容は%pである。そこには", sp, *sp);print_s(*sp,ESCOFF);printf("がある。");
args = args->cdr;
//引き数がcell型である限り、処理を進める
//printf("=%d= ", __LINE__);
while(args->id == _CELL) {
//printf("=%d= ", __LINE__);
q = on(&env);
on(&args);
on(&cp1);
//保存したcellのcdrに新しいcellを確保する
//printf("\n***2つ目以降の引数のためにnewcell()を呼び出しcp1（*sp1と同じ）のcdrにつなぐ。");
//printf("=%d= ", __LINE__);
cp1->cdr = newcell();//N//
//printf("=%d= ", __LINE__);
//print_s(args, ESCOFF);
//printf("\n***(*sp)は%p番地に存在し、内容は%pである。そこには", sp, *sp);print_s(*sp,ESCOFF);printf("がある。");
//printf("\n***cp1は%p番地に存在し、内容は%pである。そこには", &cp1, cp1);print_s(cp1,ESCOFF);printf("がある。");
off(q);//N//
//printf("=%d= ", __LINE__);
ec;//N//
//printf("=%d= ", __LINE__);
//保存したcellのcdrに評価結果を入れる
//printf("=%d= ", __LINE__);
cp1 = cp1->cdr;
//printf("=%d= ", __LINE__);
q = on(&env);
on(&args);
on(&cp1);
//printf("\n***cp1は%p番地に存在し、内容は%pである。そこには", &cp1, cp1);print_s(cp1,ESCOFF);printf("がある。");
//printf("\n***argsは%p番地に存在し、内容は%pである。そこには", &args, args);print_s(args,ESCOFF);printf("がある。");
//printf("\n***envは%p番地に存在し、内容は%pである。そこには", &env, env);print_s(env,ESCOFF);printf("がある。");
//printf("\n***args->carをenvのもとでevalしたところ、その結果tmpは…");
//printf("=%d= ", __LINE__);
{
CELLP tmp = eval(args->car, env);
//printf("=%d= ", __LINE__);
//printf("\n***evalした結果tmpは%p番地に存在し、内容は%pである。そこには", &tmp, tmp);print_s(tmp,ESCOFF);printf("がある。");
//printf("\n***evalを経て、cp1、args、envは…");
//printf("\n***cp1は%p番地に存在し、内容は%pである。そこには", &cp1, cp1);print_s(cp1,ESCOFF);printf("がある。");
//printf("\n***argsは%p番地に存在し、内容は%pである。そこには", &args, args);print_s(args,ESCOFF);printf("がある。");
//printf("\n***envは%p番地に存在し、内容は%pである。そこには", &env, env);print_s(env,ESCOFF);printf("がある。");
cp1->car = tmp;
//printf("\n***cp1->carにtmpを代入して…");
//printf("\n***cp1は%p番地に存在し、内容は%pである。そこには", &cp1, cp1);print_s(cp1,ESCOFF);printf("がある。");
//printf("\n***(*sp)は%p番地に存在し、内容は%pである。そこには", sp, *sp);print_s(*sp,ESCOFF);printf("がある。");
}//N//
off(q);//N//
//printf("=%d= ", __LINE__);
ec;//N//
//printf("=%d= ", __LINE__);
args = args->cdr;
//printf("=%d= ", __LINE__);
}
//これを抜けた辞典でスタックにはすべての引き数の評価結果が入っているそしてnilでしめる。
//printf("=%d= ", __LINE__);
cp1->cdr = (CELLP)nil;
//スタックポインタを返し、その後spを一つ減らす
//printf("=%d= ", __LINE__);
return *sp--;
}
static void update (struct state *st)
{
cell *a;
for (a = st->head->next; a != st->tail; a = a->next)
{
static const XPoint all_coords[] = {{-1, -1}, {-1, 1}, {1, -1}, {1, 1},
{-1, 0}, { 1, 0}, {0, -1}, {0, 1},
{99, 99}};
const XPoint *coords = 0;
if (a->speed == 0) continue;
a->growth += a->speed;
if (a->growth >= st->diaglim)
{
coords = all_coords;
}
else if (a->growth >= st->orthlim)
{
coords = &all_coords[4];
}
else
{
continue;
}
while (coords->x != 99)
{
int x = cell_x(a) + coords->x;
int y = cell_y(a) + coords->y;
coords++;
if (x < 0) x = st->arr_width - 1;
else if (x >= st->arr_width) x = 0;
if (y < 0) y = st->arr_height - 1;
else if (y >= st->arr_height) y = 0;
newcell (st, &st->arr[y * st->arr_width + x], a->col, a->speed);
}
if (a->growth >= st->diaglim)
killcell (st, a);
}
randblip (st, (st->head->next) == st->tail);
for (a = st->head->next; a != st->tail; a = a->next)
{
if (a->isnext)
{
a->isnext = 0;
a->speed = a->nextspeed;
a->growth = 0.0;
a->col = a->nextcol;
drawblock (st, cell_x(a), cell_y(a), a->col + st->count);
}
}
}
Lexp
Lnewvar(Var v) {
Cellidx c = newcell(VAR);
Cvar(c) = v;
return c;
}
