object *bs_eval(object *exp, object *env)
{
tailcall:
if (is_empty_list(exp)) {
error("unable to evaluate empty list");
} else if (is_self_evaluating(exp)) {
return exp;
} else if (is_variable(exp)) {
return lookup_variable_value(exp, env);
} else if (is_quoted(exp)) {
return quoted_expression(exp);
} else if (is_assignment(exp)) {
return eval_assignment(exp, env);
} else if (is_definition(exp)) {
return eval_definition(exp, env);
} else if (is_if(exp)) {
if (is_true(bs_eval(if_predicate(exp), env))) {
exp = if_consequent(exp);
} else {
exp = if_alternate(exp);
}
goto tailcall;
} else if (is_lambda(exp)) {
return make_compound_proc(lambda_parameters(exp),
lambda_body(exp),
env);
} else if (is_begin(exp)) {
exp = begin_actions(exp);
if (is_empty_list(exp)) {
error("empty begin block");
}
while (!is_empty_list(cdr(exp))) {
bs_eval(car(exp), env);
exp = cdr(exp);
}
exp = car(exp);
goto tailcall;
} else if (is_cond(exp)) {
exp = cond_to_if(exp);
goto tailcall;
} else if (is_let(exp)) {
exp = let_to_application(exp);
goto tailcall;
} else if (is_and(exp)) {
exp = and_tests(exp);
if (is_empty_list(exp)) {
return get_boolean(1);
}
object *result;
while (!is_empty_list(cdr(exp))) {
result = bs_eval(car(exp), env);
if (is_false(result)) {
return result;
}
exp = cdr(exp);
}
exp = car(exp);
goto tailcall;
} else if (is_or(exp)) {
exp = or_tests(exp);
if (is_empty_list(exp)) {
return get_boolean(0);
}
object *result;
while (!is_empty_list(cdr(exp))) {
result = bs_eval(car(exp), env);
if (is_true(result)) {
return result;
}
exp = cdr(exp);
}
exp = car(exp);
goto tailcall;
} else if (is_application(exp)) {
object *procedure = bs_eval(application_operator(exp), env);
object *parameters = eval_parameters(application_operands(exp), env);
// handle eval specially for tailcall requirement.
if (is_primitive_proc(procedure) &&
procedure->value.primitive_proc == eval_proc) {
exp = eval_expression(parameters);
env = eval_environment(parameters);
goto tailcall;
}
// handle apply specially for tailcall requirement.
if (is_primitive_proc(procedure) &&
procedure->value.primitive_proc == apply_proc) {
procedure = apply_operator(parameters);
parameters = apply_operands(parameters);
}
if (is_primitive_proc(procedure)) {
return (procedure->value.primitive_proc)(parameters);
} else if (is_compound_proc(procedure)) {
env = extend_environment(
procedure->value.compound_proc.parameters,
parameters,
procedure->value.compound_proc.env);
exp = make_begin(procedure->value.compound_proc.body);
goto tailcall;
} else {
error("unable to apply unknown procedure type");
}
} else {
error("unable to evaluate expression");
}
}
void assignmentValue(Register result, Register exp)
{
cdr(result, exp);
cdr(result, result);
car(result, result);
}
void main()
{
int gd=VGA,gm=VGAHI,errorcode,area,i,j,play=1,rndplay,rac,r,ch,chh,n=1,speed=151,sp=1,si=1,carx,cary,gear=0,aspeed,booster=100,drumx,drumy,drumv,drumx1,drumy1,spp,coin=200;
int life_=10;
int fire=20;
char info[4];
int soun;
char *buff;
char *fir;
char *boost;
int mouse=23;
int x,y,button;
char *tyre1;
float feul=100;
char *car1buf;
char *pcar4buf;
char *fcar5buf;
int recsize;
FILE *fp;
struct record
{
int coins;
int lifes;
float feuls;
int speeds;
int boosters;
int gear_;
int fire_;
}rec;
recsize=sizeof(rec);
initgraph(&gd,&gm,"c:\bagger");
errorcode = graphresult();
if (errorcode != grOk)
{
printf("Graphics error: %s\n", grapherrormsg(errorcode));
printf("Press any key to halt:");
getch();
exit(1);
}
fp=fopen("c:\\rruunn.r4l","r");
fread(&rec,recsize,1,fp);
coin=rec.coins;
feul=rec.feuls;
speed=rec.speeds;
booster=rec.boosters;
gear=rec.gear_;
fire=rec.fire_;
life_=rec.lifes;
fclose(fp);
remove("c:\\rruunn.r4l");
if(coin>0 && feul>0 && life_>0)
{
//geting car's image*****************************************
setcolor(RED);
settextstyle(8,1,4);
outtextxy(100,100+60,"You have : ");
car(125,75);
area=imagesize(85,15,165,405);
buff=malloc(area);
getimage(85,15,165,405,buff);
putimage(85,15,buff,XOR_PUT);
setcolor(8);
setfillstyle(1,8);
bar((getmaxx()/2)-130,0,(getmaxx()/2)+130,getmaxy());
roadstru();
basicstructure1();
sean1();
gears(5);
speedgrp(151-speed);
feulgrp(100);
coingrp(200);
boostergrp(100);
firee(20);
lifee(10);
car(250,400);
setcolor(WHITE);
setfillstyle(1,WHITE);
for(i=-2000;i<+25000;i+=100)
bar((getmaxx()/2)-5,i,(getmaxx()/2)+5,i+80);
delay(1000);
setcolor(getbkcolor());
setfillstyle(1,getbkcolor());
for(i=1;i<320;i++)
{
bar(getmaxx()/2,0,(getmaxx()/2)-i,getmaxy());
bar(getmaxx()/2,0,(getmaxx()/2)+i,getmaxy());
delay(5);
}
delay(1000);
setcolor(YELLOW);
settextstyle(7,0,15);
outtextxy(100-20,100,"R");
settextstyle(7,0,15);
outtextxy(495-20,100,"E");
setcolor(LIGHTBLUE);
settextstyle(7,0,7);
outtextxy(198-20,130,"UN LIF");
setcolor(BLUE);
setlinestyle(0,0,3);
line(275,155,385,155);
line(275-2,160,385-2,160);
line(275-4,165,385-4,165);
line(275-6,170,385-6,170);
line(275-8,175,385-8,175);
line(275-9,180,385-9,180);
line(275-10,185,385-10,185);
line(275-12,190,385-12,190);
setcolor(YELLOW);
settextstyle(10,0,7);
outtextxy(295,95,"4");
setcolor(LIGHTBLUE);
for(i=1;i<=465;i++)
{
line(80,228,80+i,228);
delay(5);
}
for(i=1;i<20;i++)
{
line(80,228+i,545,228+i);
delay(7);
}
delay(500);
setcolor(LIGHTRED);
settextstyle(8,0,5);
setusercharsize(2,1,1,2);
textdisp1(80,225,"Run For Life",RED,LIGHTRED);
setcolor(LIGHTRED);
settextstyle(8,0,6);
setusercharsize(2,1,1,1);
textdisp1(80,325,"Stage Clear !!!",LIGHTBLUE,BLUE);
delay(2000);
setcolor(getbkcolor());
setfillstyle(1,getbkcolor());
for(i=1;i<=getmaxx();i++)
{
bar(0,0,0+i,getmaxy());
delay(5);
}
for(i=1;i<450;i+=10)
{
putimage(50,getmaxy()-i,buff,XOR_PUT);
delay(5);
putimage(50,getmaxy()-i,buff,XOR_PUT);
}
putimage(50,getmaxy()-450,buff,XOR_PUT);
setcolor(YELLOW);
settextstyle(8,0,2);
outtextxy(200,200,"Coin left : ");
outtextxy(220,240,"Life left : ");
outtextxy(200,280,"Fuel left : ");
outtextxy(220,320,"Booster left : ");
outtextxy(200,360,"Fire left : ");
for(i=1;i<=coin;i++)
{
setcolor(getbkcolor());
setfillstyle(1,getbkcolor());
bar(350,200,400,250);
setcolor(YELLOW);
sprintf(info,"%d",i);
outtextxy(350,200,info);
sound(500);
delay(50);
nosound();
}
for(i=1;i<=life_;i++)
{
setcolor(getbkcolor());
setfillstyle(1,getbkcolor());
bar(400,240,450,290);
setcolor(YELLOW);
sprintf(info,"%d",i);
outtextxy(400,240,info);
sound(400);
delay(50);
nosound();
}
for(i=1;i<=feul;i++)
{
setcolor(getbkcolor());
setfillstyle(1,getbkcolor());
bar(350,280,400,330);
setcolor(YELLOW);
sprintf(info,"%d",i);
outtextxy(350,280,info);
sound(500);
delay(50);
nosound();
}
for(i=1;i<=booster;i++)
{
setcolor(getbkcolor());
setfillstyle(1,getbkcolor());
bar(400,320,450,370);
setcolor(YELLOW);
sprintf(info,"%d",i);
outtextxy(400,320,info);
sound(400);
delay(50);
nosound();
}
for(i=1;i<=fire;i++)
{
setcolor(getbkcolor());
setfillstyle(1,getbkcolor());
bar(350,360,400,410);
setcolor(YELLOW);
sprintf(info,"%d",i);
outtextxy(350,360,info);
sound(500);
delay(50);
nosound();
}
setcolor(LIGHTBLUE);
setfillstyle(1,LIGHTBLUE);
for(i=1;i<400;i++)
{
bar(200,50,200+i,150);
delay(2);
}
setcolor(YELLOW);
rectangle(200,50,600,150);
setcolor(LIGHTRED);
rectangle(200+5,50+5,600-5,150-5);
setcolor(RED);
settextstyle(3,0,3);
textdisp(220,60,"Do u accept the next challange");
setcolor(LIGHTRED);
rectangle(215,110,400,135);
rectangle(410,110,585,135);
setcolor(RED);
rectangle(215+2,110+2,400-2,135-2);
rectangle(410+2,110+2,585-2,135-2);
settextstyle(8,0,1);
outtextxy(235,106,"Yes, I accept !!!");
outtextxy(435,106,"No, I Quit");
change(c);
show();
while(mouse==23)
{
show();
moupos(&button,&x,&y);
if((button & 1)==1)
{
if(x>410 && x<585 && y>110 && y<135)
{
setcolor(getbkcolor());
setfillstyle(1,getbkcolor());
for(i=1;i<=getmaxx();i++)
{
bar(0,0,0+i,getmaxy());
delay(5);
}
hide();
//one step here
setcolor(RED);
settextstyle(4,0,8);
outtextxy(180,200,"Looser !!!");
coin=0;
feul=0;
speed=0;
booster=0;
gear=0;
fire=0;
life_=0;
mouse=0;
delay(1000);
//************************************************************************
setfillstyle(8,WHITE); //background color and style
bar(1,1,getmaxx(),getmaxy());
setfillstyle(7,YELLOW); //bagger plate
bar(150,5,500,55);
setcolor(BLUE);
for(i=1;i<=5;i++)
{ //border of bagger plate
setfillstyle(1,BLUE);
rectangle(150-i,5-i,500+i,55+i);
}
settextstyle(1,0,5);
setcolor(WHITE); // the bagger writen
outtextxy(200,3,"Run 4 Life");
setcolor(WHITE); //work place designed
setfillstyle(1,WHITE);
bar(100,100,550,350);
setcolor(BLUE);
for(i=1;i<=5;i++)
{ //work place border
rectangle(100-i,100-i,550+i,350+i);
}
setcolor(getbkcolor()); //man's face
ellipse(300,190,0,360,35,40);
setfillstyle(1,getbkcolor()); //man's hat
for(i=1;i<=33;i++)
{
arc(300,172,0,180,i);
}
for(i=1;i<=12;i+=2)
{
setlinestyle(0,0,0); //his hair
arc(322-i,195,150,200,50);
}
for(i=1;i<=10;i+=5) //his hair
{
setlinestyle(0,0,3);
arc(322-i,195,150,200,50);
}
for(i=1;i<=12;i+=2)
{
setlinestyle(0,0,0); //his hair
arc(277+i,195,338,30,50);
}
for(i=1;i<=10;i+=5) //his hair
{
setlinestyle(0,0,3);
arc(277+i,195,338,30,50);
}
fillellipse(285,185,18,10); //his eye masks
fillellipse(315,185,18,10);
setcolor(WHITE); //his eye
setfillstyle(1,WHITE);
fillellipse(285,185,5,1);
fillellipse(315,185,5,1);
setcolor(getbkcolor());
setfillstyle(1,getbkcolor());
fillellipse(285,185,1,1); //his eye ball
fillellipse(315,185,1,1);
setlinestyle(0,0,0); //his nose
line(295,192,292,205);
line(302,192,304,205);
line(292,205,304,205);
for(i=1;i<6;i+=1) //his mooch
arc(300,232,60,120,20+i);
setlinestyle(0,0,3);
line(288,210,280,225); //his mooch
line(311,210,318,225);
setlinestyle(0,0,0);
arc(300,205,230,310,12); //his mouth
arc(300,227,60,120,13);
setlinestyle(0,0,3);
for(i=1;i<=10;i+=4) //his dadhi
line(295+i,220,295+i,230);
setlinestyle(0,0,0);
line(285,227,285,240); //his neck
line(315,227,315,240);
setlinestyle(0,0,3);
line(285,240,235,249); //his coat base and right hand
line(315,240,342,249);
line(230,255,250,320);
arc(237,255,90,180,6);
line(250,320,340,310);
line(270,270,275,290);
line(275,290,330,285);
setlinestyle(0,0,3);
line(330,285,340,310);
line(325,285,335,310);
setlinestyle(0,0,0);
setlinestyle(0,0,0);
arc(340,330,70,100,40);
arc(340,335,70,90,40);
arc(340,340,70,90,40); //his finger
arc(340,345,70,90,40);
arc(340,350,70,90,40);
arc(315,305,350,20,40);
setlinestyle(0,0,3);
line(342,200,342,290);
line(365,200,350,290);
arc(355,232,71,110,35); //his stick
line(342,310,340,320);
line(347,310,349,320);
line(340,320,349,320);
line(285,240,320,250);//his left hand
line(315,240,305,245);
line(320,250,323,285);
circle(310,260,2);
circle(311,270,2);
circle(312,280,2);
line(356,252,360,253);
line(360,253,365,328);
line(330,270,333,290);
line(365,328,280,318);
setcolor(getbkcolor());
setlinestyle(0,0,3);
delay(1000);
for(j=1;j<=250;j++)
{
for(i=1;i<450;i+=30)
{
line(100+i,100,100+i,100+j);
line(103+i,100,103+i,100+j);
}
delay(5);
}
delay(1000);
setcolor(BLUE);
settextstyle(10,0,3);
outtextxy(200,200,"Arrested");
rectangle(190,210,390,250);
delay(1500);
setcolor(getbkcolor());
setlinestyle(0,0,3);
for(i=1;i<=450;i++)
{
line(100,220,100+i,220);
delay(5);
}
for(i=1;i<120;i++)
{
line(100,220-i,550,220-i);
line(100,220+i,550,220+i);
delay(20);
}
setcolor(getbkcolor());
setfillstyle(1,getbkcolor());
bar(100,340,550,350);
settextstyle(8,0,5);
setcolor(RED);
textdisp(150,200,"You Loose");
delay(1000);
setcolor(getbkcolor());
setfillstyle(1,getbkcolor());
for(i=1;i<350;i++)
{
bar(getmaxx()/2,0,(getmaxx()/2)-i,getmaxy());
bar(getmaxx()/2,0,(getmaxx()/2)+i,getmaxy());
delay(5);
}
//**************************************************************************
}
else if(x>215 && x<400 && y>110 && y<135)
{
setcolor(getbkcolor());
setfillstyle(1,getbkcolor());
for(i=1;i<=getmaxx();i++)
{
bar(0,0,0+i,getmaxy());
delay(5);
}
hide();
setcolor(LIGHTGREEN);
settextstyle(4,0,8);
outtextxy(180,200,"Bravo !!!");
mouse=0;
}
}
}
}
//*********************************************************************************************
rec.coins=coin;
rec.feuls=feul;
rec.speeds=speed;
rec.gear_=gear;
rec.lifes=life_;
rec.fire_=fire;
rec.boosters=booster;
fp=fopen("c:\\rruunn.r4l","w");
fwrite(&rec,recsize,1,fp);
fclose(fp);
//closegraph();
delay(1500);
}
void firstOperand(Register result, Register ops)
{
car(result, ops);
}
void procedureBody(Register result, Register procedure)
{
cdr(result, procedure);
cdr(result, result);
car(result, result);
}
void ifPredicate(Register result, Register exp)
{
cdr(result, exp);
car(result, result);
}
void firstExp(Register result, Register exp)
{
car(result, exp);
}
// (as 'any1 . any2) -> any2 | NIL
any doAs(any x) {
x = cdr(x);
if (isNil(EVAL(car(x))))
return Nil;
return cdr(x);
}
// (lit 'any) -> any
any doLit(any x) {
x = cadr(x);
if (isNum(x = EVAL(x)) || isNil(x) || x == T || isCell(x) && isNum(car(x)))
return x;
return cons(Quote, x);
}
/* Evaluate method invocation */
static any evMethod(any o, any expr, any x) {
any y = car(expr);
any cls = TheCls, key = TheKey;
struct { // bindFrame
struct bindFrame *link;
int i, cnt;
struct {any sym; any val;} bnd[length(y)+3];
} f;
f.link = Env.bind, Env.bind = (bindFrame*)&f;
f.i = sizeof(f.bnd) / (2*sizeof(any)) - 2;
f.cnt = 1, f.bnd[0].sym = At, f.bnd[0].val = val(At);
while (isCell(y)) {
f.bnd[f.cnt].sym = car(y);
f.bnd[f.cnt].val = EVAL(car(x));
++f.cnt, x = cdr(x), y = cdr(y);
}
if (isNil(y)) {
while (--f.i > 0) {
x = val(f.bnd[f.i].sym);
val(f.bnd[f.i].sym) = f.bnd[f.i].val;
f.bnd[f.i].val = x;
}
f.bnd[f.cnt].sym = This, f.bnd[f.cnt++].val = val(This), val(This) = o;
y = cls, cls = Env.cls; Env.cls = y;
y = key, key = Env.key; Env.key = y;
x = prog(cdr(expr));
}
else if (y != At) {
f.bnd[f.cnt].sym = y, f.bnd[f.cnt++].val = val(y), val(y) = x;
while (--f.i > 0) {
x = val(f.bnd[f.i].sym);
val(f.bnd[f.i].sym) = f.bnd[f.i].val;
f.bnd[f.i].val = x;
}
f.bnd[f.cnt].sym = This, f.bnd[f.cnt++].val = val(This), val(This) = o;
y = cls, cls = Env.cls; Env.cls = y;
y = key, key = Env.key; Env.key = y;
x = prog(cdr(expr));
}
else {
int n, cnt;
cell *arg;
cell c[n = cnt = length(x)];
while (--n >= 0)
Push(c[n], EVAL(car(x))), x = cdr(x);
while (--f.i > 0) {
x = val(f.bnd[f.i].sym);
val(f.bnd[f.i].sym) = f.bnd[f.i].val;
f.bnd[f.i].val = x;
}
n = Env.next, Env.next = cnt;
arg = Env.arg, Env.arg = c;
f.bnd[f.cnt].sym = This, f.bnd[f.cnt++].val = val(This), val(This) = o;
y = cls, cls = Env.cls; Env.cls = y;
y = key, key = Env.key; Env.key = y;
x = prog(cdr(expr));
if (cnt)
drop(c[cnt-1]);
Env.arg = arg, Env.next = n;
}
while (--f.cnt >= 0)
val(f.bnd[f.cnt].sym) = f.bnd[f.cnt].val;
Env.bind = f.link;
Env.cls = cls, Env.key = key;
return x;
}
// (box 'any) -> sym
any doBox(any x) {
x = cdr(x);
return consSym(EVAL(car(x)), Nil);
}
// (for sym 'num ['any | (NIL 'any . prg) | (T 'any . prg) ..]) -> any
// (for sym|(sym2 . sym) 'lst ['any | (NIL 'any . prg) | (T 'any . prg) ..]) -> any
// (for (sym|(sym2 . sym) 'any1 'any2 [. prg]) ['any | (NIL 'any . prg) | (T 'any . prg) ..]) -> any
any doFor(any x) {
any y, body, cond, a;
cell c1;
struct { // bindFrame
struct bindFrame *link;
int i, cnt;
struct {any sym; any val;} bnd[2];
} f;
f.link = Env.bind, Env.bind = (bindFrame*)&f;
f.i = 0;
if (!isCell(y = car(x = cdr(x))) || !isCell(cdr(y))) {
if (!isCell(y)) {
f.cnt = 1;
f.bnd[0].sym = y;
f.bnd[0].val = val(y);
}
else {
f.cnt = 2;
f.bnd[0].sym = cdr(y);
f.bnd[0].val = val(cdr(y));
f.bnd[1].sym = car(y);
f.bnd[1].val = val(car(y));
val(f.bnd[1].sym) = Zero;
}
y = Nil;
x = cdr(x), Push(c1, EVAL(car(x)));
if (isNum(data(c1)))
val(f.bnd[0].sym) = Zero;
body = x = cdr(x);
for (;;) {
if (isNum(data(c1))) {
val(f.bnd[0].sym) = bigCopy(val(f.bnd[0].sym));
digAdd(val(f.bnd[0].sym), 2);
if (bigCompare(val(f.bnd[0].sym), data(c1)) > 0)
break;
}
else {
if (!isCell(data(c1)))
break;
val(f.bnd[0].sym) = car(data(c1));
if (!isCell(data(c1) = cdr(data(c1))))
data(c1) = Nil;
}
if (f.cnt == 2) {
val(f.bnd[1].sym) = bigCopy(val(f.bnd[1].sym));
digAdd(val(f.bnd[1].sym), 2);
}
do {
if (!isNum(y = car(x))) {
if (isSym(y))
y = val(y);
else if (isNil(car(y))) {
y = cdr(y);
if (isNil(a = EVAL(car(y)))) {
y = prog(cdr(y));
goto for1;
}
val(At) = a;
y = Nil;
}
else if (car(y) == T) {
y = cdr(y);
if (!isNil(a = EVAL(car(y)))) {
val(At) = a;
y = prog(cdr(y));
goto for1;
}
y = Nil;
}
else
y = evList(y);
}
} while (isCell(x = cdr(x)));
x = body;
}
for1:
drop(c1);
if (f.cnt == 2)
val(f.bnd[1].sym) = f.bnd[1].val;
val(f.bnd[0].sym) = f.bnd[0].val;
Env.bind = f.link;
return y;
}
if (!isCell(car(y))) {
f.cnt = 1;
f.bnd[0].sym = car(y);
f.bnd[0].val = val(car(y));
}
else {
f.cnt = 2;
f.bnd[0].sym = cdar(y);
f.bnd[0].val = val(cdar(y));
f.bnd[1].sym = caar(y);
f.bnd[1].val = val(caar(y));
val(f.bnd[1].sym) = Zero;
}
y = cdr(y);
val(f.bnd[0].sym) = EVAL(car(y));
y = cdr(y), cond = car(y), y = cdr(y);
Push(c1,Nil);
body = x = cdr(x);
while (!isNil(a = EVAL(cond))) {
val(At) = a;
if (f.cnt == 2) {
val(f.bnd[1].sym) = bigCopy(val(f.bnd[1].sym));
digAdd(val(f.bnd[1].sym), 2);
}
do {
if (!isNum(data(c1) = car(x))) {
if (isSym(data(c1)))
data(c1) = val(data(c1));
else if (isNil(car(data(c1)))) {
data(c1) = cdr(data(c1));
if (isNil(a = EVAL(car(data(c1))))) {
data(c1) = prog(cdr(data(c1)));
goto for2;
}
val(At) = a;
data(c1) = Nil;
}
else if (car(data(c1)) == T) {
data(c1) = cdr(data(c1));
if (!isNil(a = EVAL(car(data(c1))))) {
val(At) = a;
data(c1) = prog(cdr(data(c1)));
goto for2;
}
data(c1) = Nil;
}
else
data(c1) = evList(data(c1));
}
} while (isCell(x = cdr(x)));
if (isCell(y))
val(f.bnd[0].sym) = prog(y);
x = body;
}
for2:
if (f.cnt == 2)
val(f.bnd[1].sym) = f.bnd[1].val;
val(f.bnd[0].sym) = f.bnd[0].val;
Env.bind = f.link;
return Pop(c1);
}
sExpression *eval(sExpression *exp, sEnvironment *env){
/* ------------------atom-----------------------*/
/* 1, 10, false, null, "abc" */
if(isSelfEval(exp))
{
return exp;
}
/* a symbol */
else if(isVariable(exp, env))
{
return lookupVariable(toSymb(exp), env);
}
/* ------------------list-----------------------*/
/* (quote blur blur) */
else if(isQuoted(exp))
{
return textOfQuoted(exp);
}
/* (set! name value) */
else if(isAssignment(exp))
{
return evalAssignment(exp, env);
}
/* (define name value) */
else if(isDefinition(exp))
{
return evalDefine(exp, env);
}
/* (define-syntax name ...) */
else if(isDefinitionSyntax(exp))
{
return evalDefineSyntax(exp, env);
}
/* (if blur blur blur) */
else if(isIf(exp))
{
return evalIf(toList(exp), env);
}
/* (lambda (args) (body)) */
else if(isLambdaConst(exp))
{
sList *body;
sList *param = toList( cadr(toList(exp)));
sExpression *temp = cdr(toList( cdr(toList(exp))));
if(isList(temp)){
body = toList(temp);
}else{
body = toList(cons(temp, &sNull));
}
return newLambda(param, body, env);
}
/* (syntax blur blur) syntax rule */
else if(isSymbol(car(toList(exp))) && isSyntaxRule(eval(car(toList(exp)), env)))
{
sExpression *exp2 = evalSyntaxRule(toSyntax(eval(car(toList(exp)), env)), exp);
return eval(exp2, env);
}
/* the other list (x . y) */
else if(isApplication(exp))
{
if(LAZY_EVAL){
sExpression *proexp = actualValue(operator(toList(exp)), env);
if(isLambdaType(proexp) || isPrimitiveProc(proexp)){
sExpression *operand = operands(toList(exp));
return applyLazly(proexp, operand, env);
}
}else{
sExpression *proexp = eval(operator(toList(exp)), env);
if(isLambdaType(proexp) || isPrimitiveProc(proexp)){
sExpression *operand = operands(toList(exp));
sExpression *arguments = listOfValues(operand, env);
return apply(proexp, arguments, env);
}
}
}
return &sError;
}
static sExpression *firstExp(sList *exps){
return car(exps);
}
void
symeListSetExtension(SymeList symes, Syme syme)
{
for (; symes; symes = cdr(symes))
symeSetExtension(car(symes), syme);
}
// (eval 'any ['cnt ['lst]]) -> any
any doEval(any x) {
any y;
cell c1;
bindFrame *p;
x = cdr(x), Push(c1, EVAL(car(x))), x = cdr(x);
if (!isNum(y = EVAL(car(x))) || !(p = Env.bind))
data(c1) = EVAL(data(c1));
else {
int cnt, n, i, j;
struct { // bindFrame
struct bindFrame *link;
int i, cnt;
struct {any sym; any val;} bnd[length(x)];
} f;
x = cdr(x), x = EVAL(car(x));
j = cnt = (int)unBox(y);
n = f.i = f.cnt = 0;
do {
++n;
if ((i = p->i) <= 0 && (p->i -= cnt, i == 0)) {
for (i = 0; i < p->cnt; ++i) {
y = val(p->bnd[i].sym);
val(p->bnd[i].sym) = p->bnd[i].val;
p->bnd[i].val = y;
}
if (p->cnt && p->bnd[0].sym == At && !--j)
break;
}
} while (p = p->link);
while (isCell(x)) {
for (p = Env.bind, j = n; ; p = p->link) {
if (p->i < 0)
for (i = 0; i < p->cnt; ++i) {
if (p->bnd[i].sym == car(x)) {
f.bnd[f.cnt].val = val(f.bnd[f.cnt].sym = car(x));
val(car(x)) = p->bnd[i].val;
++f.cnt;
goto next;
}
}
if (!--j)
break;
}
next: x = cdr(x);
}
f.link = Env.bind, Env.bind = (bindFrame*)&f;
data(c1) = EVAL(data(c1));
while (--f.cnt >= 0)
val(f.bnd[f.cnt].sym) = f.bnd[f.cnt].val;
Env.bind = f.link;
do {
for (p = Env.bind, i = n; --i; p = p->link);
if (p->i < 0 && (p->i += cnt) == 0)
for (i = p->cnt; --i >= 0;) {
y = val(p->bnd[i].sym);
val(p->bnd[i].sym) = p->bnd[i].val;
p->bnd[i].val = y;
}
} while (--n);
}
return Pop(c1);
}
void lambdaParameters(Register result, Register exp)
{
cdr(result, exp);
car(result, result);
}
// (xor 'any 'any) -> flg
any doXor(any x) {
bool f;
x = cdr(x), f = isNil(EVAL(car(x))), x = cdr(x);
return f ^ isNil(EVAL(car(x)))? T : Nil;
}
void ifConsequent(Register result, Register exp)
{
cdr(result, exp);
cdr(result, result);
car(result, result);
}
// (nil . prg) -> NIL
any doNil(any x) {
while (isCell(x = cdr(x)))
if (isCell(car(x)))
evList(car(x));
return Nil;
}
void operator(Register result, Register exp)
{
car(result, exp);
}
// (t . prg) -> T
any doT(any x) {
while (isCell(x = cdr(x)))
if (isCell(car(x)))
evList(car(x));
return T;
}
void procedureParameters(Register result, Register procedure)
{
cdr(result, procedure);
car(result, result);
}
int
cmp_expr(U *p1, U *p2)
{
int n;
if (p1 == p2)
return 0;
if (p1 == symbol(NIL))
return -1;
if (p2 == symbol(NIL))
return 1;
if (isnum(p1) && isnum(p2))
return sign(compare_numbers(p1, p2));
if (isnum(p1))
return -1;
if (isnum(p2))
return 1;
if (isstr(p1) && isstr(p2))
return sign(strcmp(p1->u.str, p2->u.str));
if (isstr(p1))
return -1;
if (isstr(p2))
return 1;
if (issymbol(p1) && issymbol(p2))
return sign(strcmp(get_printname(p1), get_printname(p2)));
if (issymbol(p1))
return -1;
if (issymbol(p2))
return 1;
if (istensor(p1) && istensor(p2))
return compare_tensors(p1, p2);
if (istensor(p1))
return -1;
if (istensor(p2))
return 1;
while (iscons(p1) && iscons(p2)) {
n = cmp_expr(car(p1), car(p2));
if (n != 0)
return n;
p1 = cdr(p1);
p2 = cdr(p2);
}
if (iscons(p2))
return -1;
if (iscons(p1))
return 1;
return 0;
}
void textOfQuotation(Register result, Register exp)
{
cdr(result, exp);
car(result, result);
}
atom *fn_cdr(env *e, atom *args) {
if (car(args)->typ != A_PAIR)
return atom_make(A_ERROR, "first arg must be arg list");
return cdr(car(args));
}
// This function evaluates the parse tree given by expr within the given environment.
Value* eval(Value *expr, Environment *env){
Value* operator;
Value* args;
//printf("Here is expression: ");
//printValue(expr);
//printf("\n");
if (!expr){
return NULL;
}
switch (expr->type)
{
case symbolType:
//printf("unknown identifier");
args = envLookup(expr->symbolValue, env);
if (args){
//printf("going here\n");
//printValue(expr);
//printf("\nending here\n");
return args;
}
else{
printf("syntax error: unknown identifier");
return NULL;
}
break;
case cellType:
if (expr->cons->car->type == nullType) {
return expr->cons->car;
}
//printf("Here is expression: ");
//printValue(getFirst(expr));
//printf("\n");
if (getFirst(expr) != NULL && getFirst(expr)->type == openType) {
operator = car(expr);
if (!operator){
printf("syntax error, missing components here");
return NULL;
}
if (operator->type == cellType){
operator = eval(operator, env);
}
if (operator->type == symbolType){
args = getTail(getTail(expr));
//printf("checking args?: ");
//printValue(args);
//printf("\n"); //if (args == NULL){
//return eval(operator,env); // }else
if (strcmp(operator->symbolValue,"define")==0){
return evalDefine(args, env);
}else if (strcmp(operator->symbolValue,"lambda")==0){
/*eval lambda goes here*/
return evalLambda(args, env);
}else if (strcmp(operator->symbolValue,"if")== 0){
return evalIf(args, env);
/*eval if goes here*/
}else if (strcmp(operator->symbolValue,"quote")==0){
/*eval quote goes here*/
return evalQuote(args);
}else if (strcmp(operator->symbolValue,"let")==0){
/*eval let goes here*/
return evalLet(args, env);
}else{
//printf("validation result is shown: %d\n",validateArgs(args, env));
if (validateArgs(args, env)==-1){
printf("Syntax error! Invalid arguments for the procedure: ");
printValue(operator);
printf("\n");
return NULL;
}
Value *evaledOperator = eval(operator, env);
Value *evaledArgs = evalEach(args, env);
if (!evaledOperator){
printf("Unknown procedure: ");
printValue(operator);
printf("\n");
}
//printValue(evaledArgs);
//printf("\n");
return apply(evaledOperator, evaledArgs);
}
}else if (typeCheck(operator)==1){
printf("A literal ");
printValue(operator);
printf(" cannot be a procedure.\n");
return NULL;
}
} else if (typeCheck(getFirst(expr))==1){
//printValue(expr);
//printf("\n");
return evalEach(expr,env);
}else if (getFirst(expr) && getFirst(expr)->type ==cellType && getFirst(getTail(expr)) && getFirst(getTail(expr))->type==closeType){
return eval(getFirst(expr),env);
}else if (getFirst(expr) && getFirst(expr)->type == symbolType){
operator = getFirst(expr);
Value *returnValue = envLookup(operator->symbolValue, env);
if (returnValue){
return returnValue;
}else{
if (strcmp(operator->symbolValue,"define")==0){
printf("define: bad syntax in ");
printValue(expr);
printf("\n");
}else if (strcmp(operator->symbolValue,"lambda")==0){
printf("lambda: bad syntax in ");
printValue(expr);
printf("\n");
}else if (strcmp(operator->symbolValue,"if")==0){
printf("if: bad syntax in ");
printValue(expr);
printf("\n");
}else if (strcmp(operator->symbolValue,"quote")==0){
printf("quote: bad syntax in ");
printValue(expr);
printf("\n");
}else if (strcmp(operator->symbolValue,"let")==0){
printf("let: bad syntax in ");
printValue(expr);
printf("\n");
}else{
printf("Unknown identifier %s.\n",operator->symbolValue);
}
return NULL;
}
}
case closeType:
//printValue(expr);
//printf("\n");
return NULL;
break;
default:
//printValue(expr);
//printf("\n");
if (getTail(expr)){
assert(getFirst(getTail(expr))!=NULL);
assert(getFirst(getTail(expr))->type==closeType);
Value *toRemove = getTail(expr);
free(toRemove->cons->car);
free(toRemove->cons);
free(toRemove);
expr->cons->cdr = NULL;
//assert(1==2);
}
return expr;
}
}
void set_state_constants(void)
{
cellpoint sc = state_constants;
STATE_INIT = car(sc);
sc = cdr(sc);
STATE_SHARP = car(sc);
sc = cdr(sc);
STATE_DOT = car(sc);
sc = cdr(sc);
STATE_ADD = car(sc);
sc = cdr(sc);
STATE_SUB = car(sc);
sc = cdr(sc);
STATE_NUM = car(sc);
sc = cdr(sc);
STATE_CHAR = car(sc);
sc = cdr(sc);
STATE_STR = car(sc);
sc = cdr(sc);
STATE_SYM = car(sc);
sc = cdr(sc);
STATE_LIST = car(sc);
sc = cdr(sc);
STATE_VEC = car(sc);
sc = cdr(sc);
STATE_QUOTE = car(sc);
}
int main(int argc, char **argv){
int i;
char *p;
GC_INIT();
::cgc1::cgc_root_t hash_bucket_root(hash_buckets);
hash_buckets=reinterpret_cast<node*>(::cgc1::cgc_malloc(sizeof(node)*7313));
progname = BaseName(argv[0]);
yyinit();
for (p=argv[0]; *p; p++) if (*p=='/') progname = p+1;
for (i=1; i<argc; i++) {
if (EQUAL == strcmp(argv[i],"--help")) {
usage();
exit(0);
}
if (EQUAL == strcmp(argv[i],"-dep")) {
stop_after_dep = TRUE;
continue;
}
if (EQUAL == strcmp(argv[i],"-cxx")) {
do_cxx = TRUE;
continue;
}
if (EQUAL == strcmp(argv[i],"-noline")) {
noline = TRUE;
continue;
}
if (EQUAL == strcmp(argv[i],"-pthreadlocal")) {
pthreadThreadLocal=TRUE;
compilerThreadLocal=FALSE;
continue;
}
if (EQUAL == strcmp(argv[i],"-typecodes")) {
printtypecodes();
return 0;
}
if (EQUAL == strcmp(argv[i],"-noarraychks")) {
arraychks = FALSE;
continue;
}
if (EQUAL == strcmp(argv[i],"-nocasechks")) {
casechks = FALSE;
continue;
}
if (EQUAL == strcmp(argv[i],"-nomacros")) {
nomacros = TRUE;
continue;
}
if (EQUAL == strcmp(argv[i],"-O")) {
arraychks = FALSE;
casechks = FALSE;
continue;
}
if (EQUAL == strcmp(argv[i],"-tabwidth")) {
i++;
if (i < argc) tabwidth = atoi(argv[i]);
continue;
}
if (EQUAL == strcmp(argv[i],"-yydebug")) {
yydebug = 1;
continue;
}
if (EQUAL == strcmp(argv[i],"-debug")) {
debug = TRUE;
continue;
}
if (EQUAL == strcmp(argv[i],"-v")) {
puts(Version);
puts(Copyright);
continue;
}
if ('-' == argv[i][0] && 'I' == argv[i][1]) {
if (argv[i][2] == 0) {
error("-I option: missing directory");
usage();
exit(1);
}
char buf[256];
strcpy(buf,sigpath);
strcat(buf,":");
strcat(buf,argv[i]+2);
sigpath = strperm(buf);
continue;
}
if ('-' == argv[i][0]) {
error("unrecognized option %s\n",argv[i]);
usage();
exit(1);
}
if ( EQUAL == strcmp(".d",tail(argv[i])) || EQUAL == strcmp(".dd",tail(argv[i])) ) {
node f;
do_this_cxx = do_cxx || EQUAL == strcmp(".dd",tail(argv[i]));
global_scope = new(struct SCOPE);
readsetup(global_scope);
targetname = newsuffixbase(argv[i],"");
f = readfile(argv[i]);
if (debug) {
char *n = newsuffixbase(argv[i],".out");
if (NULL == freopen(n,"w", stdout)) {
fatal("can't open file %s",n);
}
put("After parsing:\n");
pp(f);
fflush(stdout);
}
outfilename = newsuffixbase(argv[i], do_this_cxx ? "-tmp.cc" : "-tmp.c");
{
char *n = newsuffixbase(argv[i],".dep.tmp");
dependfile = fopen(n,"w");
if (dependfile == NULL) fatal("can't open file %s",n);
}
f = chkprogram(f);
if (debug) {
char *n = newsuffixbase(argv[i],".log");
if (NULL == freopen(n,"w", stdout)) {
fatal("can't open file %s",n);
}
pprintl(f);
}
{
node t = global_scope->signature;
char *n = newsuffixbase(argv[i],".sig.tmp");
if (NULL == freopen(n,"w", stdout)) {
fatal("can't open file %s",n);
}
printf("-- generated by %s\n\n",progname);
while (t != NULL) {
dprint(CAR(t));
put(";\n");
t = CDR(t);
}
}
if (stop_after_dep) quit();
checkfordeferredsymbols();
if (debug) {
char *n = newsuffixbase(argv[i],".sym");
if (NULL == freopen(n,"w", stdout)) {
fatal("can't open file %s",n);
}
printsymboltable();
printtypelist();
printstringlist();
}
if (n_errors > 0) {
quit();
}
if (TRUE) {
char *n = newsuffixbase(argv[i],"-exports.h.tmp");
if (NULL == freopen(n,"w", stdout)) {
fatal("can't open file %s",n);
}
printf("#ifndef %s_included\n",targetname);
printf("#define %s_included\n",targetname);
declarationsstrings = reverse(declarationsstrings);
while (declarationsstrings) {
node s = unpos(car(declarationsstrings));
assert(isstrconst(s));
put_unescape(s->body.string_const.characters);
put("\n");
declarationsstrings = cdr(declarationsstrings);
}
put(declarations_header);
/* printtypecodes(); */
cprinttypes();
put(declarations_trailer);
put("#endif\n");
}
if (TRUE) {
if (NULL == freopen(outfilename,"w", stdout)) {
fatal("can't open file %s",outfilename);
}
printf("#include \"%s\"\n",newsuffixbase(argv[i],"-exports.h"));
put(code_header);
headerstrings = reverse(headerstrings);
while (headerstrings) {
locn(car(headerstrings));
printpos();
node s = unpos(car(headerstrings));
assert(isstrconst(s));
put_unescape(s->body.string_const.characters);
put("\n");
locn(NULL);
headerstrings = cdr(headerstrings);
}
cprintsemi(f);
}
}
else {
fprintf(stderr,"unknown file type %s\n",argv[i]);
usage();
exit(1);
}
}
quit();
return 0;
}
static inline object *application_operator(object *exp)
{
return car(exp);
}