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); }