LISP evalclosure (LISP func, LISP expr)
{
LISP ctx = closurectx (func), body = closurebody (func);
LISP arg = car (body);
/* Расширяем контекст аргументами вызова */
while (istype (arg, TPAIR)) {
LISP val;
if (istype (expr, TPAIR)) {
val = car (expr);
expr = cdr (expr);
} else
/* Недостающие аргументы получают значение NIL */
val = NIL;
if (istype (car (arg), TSYMBOL))
ctx = cons (cons (car (arg), val), ctx);
arg = cdr (arg);
}
if (istype (arg, TSYMBOL))
ctx = cons (cons (arg, expr), ctx);
if (trace) {
printf ("CALL ");
putexpr (cdr (body), stdout);
printf ("\nCONTEXT ");
putexpr (ctx, stdout);
printf ("\n");
}
return (evalblock (cdr (body), ctx));
}
/* Arithmetic IF */
void
prarif(bigptr p, int neg, int zer, int pos)
{
bigptr x1 = fmktemp(p->vtype, NULL);
putexpr(mkexpr(OPASSIGN, cpexpr(x1), p));
putif(mkexpr(OPGE, cpexpr(x1), MKICON(0)), neg);
putif(mkexpr(OPLE, x1, MKICON(0)), pos);
putgoto(zer);
}
void putexpr (LISP p, FILE *fd)
{
LISP h, a;
if (! istype (p, TPAIR)) {
putatom (p, fd);
return;
}
if (istype (h = car (p), TSYMBOL) &&
istype (a = cdr (p), TPAIR) &&
cdr (a) == NIL) {
char *funcname = symname (h);
if (!strcmp (funcname, "quote")) {
putc ('\'', fd);
putexpr (car (a), fd);
return;
}
if (!strcmp (funcname, "quasiquote")) {
putc ('`', fd);
putexpr (car (a), fd);
return;
}
if (!strcmp (funcname, "unquote")) {
putc (',', fd);
putexpr (car (a), fd);
return;
}
if (!strcmp (funcname, "unquote-splicing")) {
putc (',', fd);
putc ('@', fd);
putexpr (car (a), fd);
return;
}
}
putc ('(', fd);
putlist (p, fd);
putc (')', fd);
}
void putlist (LISP p, FILE *fd)
{
int first = 1;
while (istype (p, TPAIR)) {
if (first)
first = 0;
else
putc (' ', fd);
putexpr (car (p), fd);
p = cdr (p);
}
if (p != NIL) {
fputs (" . ", fd);
putatom (p, fd);
}
}
void putvector (LISP p, FILE *fd)
{
int len;
LISP *s;
assert (p>=0 && p<memsz && mem[p].type==TVECTOR);
len = mem[p].as.vector.length;
s = mem[p].as.vector.array;
fputs ("#(", fd);
while (--len >= 0) {
putexpr (*s++, fd);
if (len)
putc (' ', fd);
}
putc (')', fd);
}
void
putcmgo(bigptr x, int nlab, struct labelblock *labels[])
{
bigptr y;
int i;
if (!ISINT(x->vtype)) {
execerr("computed goto index must be integer", NULL);
return;
}
y = fmktemp(x->vtype, NULL);
putexpr(mkexpr(OPASSIGN, cpexpr(y), x));
#ifdef notyet /* target-specific computed goto */
vaxgoto(y, nlab, labels);
#else
/*
* Primitive implementation, should use table here.
*/
for(i = 0 ; i < nlab ; ++i)
putif(mkexpr(OPNE, cpexpr(y), MKICON(i+1)), labels[i]->labelno);
frexpr(y);
#endif
}
puteq(expptr lp, expptr rp)
#endif
{
putexpr(mkexpr(OPASSIGN, lp, rp) );
}
/*
* Convert a f77 tree statement to something that looks like a
* pcc expression tree.
*/
NODE *
putx(bigptr q)
{
struct bigblock *x1;
NODE *p = NULL; /* XXX */
int opc;
int type, k;
#ifdef PCC_DEBUG
if (tflag) {
printf("putx %p\n", q);
fprint(q, 0);
}
#endif
switch(q->tag) {
case TERROR:
ckfree(q);
break;
case TCONST:
switch(type = q->vtype) {
case TYLOGICAL:
type = tyint;
case TYLONG:
case TYSHORT:
p = mklnode(ICON, q->b_const.fconst.ci,
0, types2[type]);
ckfree(q);
break;
case TYADDR:
p = mklnode(ICON, 0, 0, types2[type]);
p->n_name = copys(memname(STGCONST,
(int)q->b_const.fconst.ci));
ckfree(q);
break;
default:
p = putx(putconst(q));
break;
}
break;
case TEXPR:
switch(opc = q->b_expr.opcode) {
case OPCALL:
case OPCCALL:
if( ISCOMPLEX(q->vtype) )
p = putcxop(q);
else {
putcall(q);
p = callval;
}
break;
case OPMIN:
case OPMAX:
p = putmnmx(q);
break;
case OPASSIGN:
if (ISCOMPLEX(q->b_expr.leftp->vtype) ||
ISCOMPLEX(q->b_expr.rightp->vtype)) {
frexpr(putcxeq(q));
} else if (ISCHAR(q))
p = putcheq(q);
else
goto putopp;
break;
case OPEQ:
case OPNE:
if (ISCOMPLEX(q->b_expr.leftp->vtype) ||
ISCOMPLEX(q->b_expr.rightp->vtype) ) {
p = putcxcmp(q);
break;
}
case OPLT:
case OPLE:
case OPGT:
case OPGE:
if(ISCHAR(q->b_expr.leftp))
p = putchcmp(q);
else
goto putopp;
break;
case OPPOWER:
p = putpower(q);
break;
case OPSTAR:
/* m * (2**k) -> m<<k */
if (XINT(q->b_expr.leftp->vtype) &&
ISICON(q->b_expr.rightp) &&
((k = flog2(q->b_expr.rightp->b_const.fconst.ci))>0) ) {
q->b_expr.opcode = OPLSHIFT;
frexpr(q->b_expr.rightp);
q->b_expr.rightp = MKICON(k);
goto putopp;
}
case OPMOD:
goto putopp;
case OPPLUS:
case OPMINUS:
case OPSLASH:
case OPNEG:
if( ISCOMPLEX(q->vtype) )
p = putcxop(q);
else
goto putopp;
break;
case OPCONV:
if( ISCOMPLEX(q->vtype) )
p = putcxop(q);
else if (ISCOMPLEX(q->b_expr.leftp->vtype)) {
p = putx(mkconv(q->vtype,
realpart(putcx1(q->b_expr.leftp))));
ckfree(q);
} else
goto putopp;
break;
case OPAND:
/* Create logical AND */
x1 = fmktemp(TYLOGICAL, NULL);
putexpr(mkexpr(OPASSIGN, cpexpr(x1),
mklogcon(0)));
k = newlabel();
putif(q->b_expr.leftp, k);
putif(q->b_expr.rightp, k);
putexpr(mkexpr(OPASSIGN, cpexpr(x1),
mklogcon(1)));
putlabel(k);
p = putx(x1);
break;
case OPNOT: /* Logical NOT */
x1 = fmktemp(TYLOGICAL, NULL);
putexpr(mkexpr(OPASSIGN, cpexpr(x1),
mklogcon(1)));
k = newlabel();
putif(q->b_expr.leftp, k);
putexpr(mkexpr(OPASSIGN, cpexpr(x1),
mklogcon(0)));
putlabel(k);
p = putx(x1);
break;
case OPOR: /* Create logical OR */
x1 = fmktemp(TYLOGICAL, NULL);
putexpr(mkexpr(OPASSIGN, cpexpr(x1),
mklogcon(1)));
k = newlabel();
putif(mkexpr(OPEQ, q->b_expr.leftp,
mklogcon(0)), k);
putif(mkexpr(OPEQ, q->b_expr.rightp,
mklogcon(0)), k);
putexpr(mkexpr(OPASSIGN, cpexpr(x1),
mklogcon(0)));
putlabel(k);
p = putx(x1);
break;
case OPCOMMA:
for (x1 = q; x1->b_expr.opcode == OPCOMMA;
x1 = x1->b_expr.leftp)
putexpr(x1->b_expr.rightp);
p = putx(x1);
break;
case OPEQV:
case OPNEQV:
case OPADDR:
case OPBITOR:
case OPBITAND:
case OPBITXOR:
case OPBITNOT:
case OPLSHIFT:
case OPRSHIFT:
putopp:
p = putop(q);
break;
default:
fatal1("putx: invalid opcode %d", opc);
}
break;
case TADDR:
p = putaddr(q, YES);
break;
default:
fatal1("putx: impossible tag %d", q->tag);
}
return p;
}
int main (int argc, char **argv)
{
LISP expr, val;
char *progname, *prog = 0;
progname = *argv++;
for (--argc; argc>0 && **argv=='-'; --argc, ++argv) {
char *p;
for (p=1+*argv; *p; ++p) switch (*p) {
case 'h':
fprintf (stderr, "Usage: %s [-h] [-v] [-t] [-m#] prog [arg...]\n",
progname);
return (0);
case 't':
++trace;
break;
case 'v':
++verbose;
break;
case 'm':
if (! *++p) {
if (argc <= 1)
break;
p = *++argv;
--argc;
}
memsz = atoi (p);
p += strlen (p) - 1;
break;
}
}
if (argc > 0) {
prog = *argv++;
--argc;
}
if (memsz < 1000)
memsz = (sizeof (unsigned) < 4 ? 64000 : 256000) / sizeof (cell);
if (verbose) {
fprintf (stderr, "Micro Scheme Interpreter, Release 1.0\n");
fprintf (stderr, "Memory size = %d bytes\n", memsz * sizeof (cell));
}
mem = (cell *) malloc (sizeof (cell) * memsz);
gclabel = malloc (memsz);
if (!mem || !gclabel) {
fprintf (stderr, "Out of memory\n");
return (-1);
}
if (prog && freopen (prog, "r", stdin) != stdin) {
fprintf (stderr, "Cannot open %s\n", prog);
return (-1);
}
initmem ();
T = alloc (TBOOL); /* логическая истина #t */
ZERO = number (0); /* целый ноль */
ENV = cons (cons (symbol ("version"), number (10)), NIL);
initcontext (stdfunc);
for (;;) {
gc ();
if (isatty (0))
printf ("> ");
expr = getexpr ();
if (feof (stdin))
break;
val = eval (expr, 0);
if (verbose) {
putexpr (expr, stdout);
printf (" --> ");
putexpr (val, stdout);
putchar ('\n');
}
}
return (0);
}
