vm_obj put_nat(vm_obj const & n, vm_obj const &) {
if (is_simple(n))
std::cout << cidx(n);
else
std::cout << to_mpz(n);
return mk_vm_unit();
}
vm_obj put_nat(vm_obj const & n, vm_obj const &) {
if (is_simple(n))
get_global_ios().get_regular_stream() << cidx(n);
else
get_global_ios().get_regular_stream() << to_mpz(n);
return mk_vm_unit();
}
static mpz const & to_mpz2(vm_obj const & o) {
if (is_simple(o)) {
mpz & r = get_mpz2();
r = cidx(o);
return r;
} else {
return to_mpz(o);
}
}
vm_obj nat_to_string(vm_obj const & a) {
std::ostringstream out;
if (is_simple(a)) {
out << cidx(a);
} else {
out << to_mpz(a);
}
return to_obj(out.str());
}
unsigned long to_ulong(obj_t *o) {
mpz_t *x = to_mpz(o);
unsigned int r = 0;
if (mpz_fits_ulong_p(*x)) {
r = mpz_get_ui(*x);
} else {
error("Argument too big.\n");
}
return r;
}
optional<unsigned> try_to_unsigned(vm_obj const & o) {
if (is_simple(o)) {
return optional<unsigned>(cidx(o));
} else {
mpz const & v = to_mpz(o);
if (v.is_unsigned_int())
return optional<unsigned>(v.get_unsigned_int());
else
return optional<unsigned>();
}
}
mpq to_mpq_ext(lua_State * L, int idx) {
switch (lua_type(L, idx)) {
case LUA_TNUMBER: return mpq(lua_tonumber(L, idx));
case LUA_TSTRING: return mpq(lua_tostring(L, idx));
case LUA_TUSERDATA:
if (is_mpz(L, idx)) {
return mpq(to_mpz(L, idx));
} else {
return *static_cast<mpq*>(luaL_checkudata(L, idx, mpq_mt));
}
default: throw exception(sstream() << "arg #" << idx << " must be a number, string, mpz or mpq");
}
}
static mpq const & to_mpq(lua_State * L) {
static LEAN_THREAD_LOCAL mpq arg;
switch (lua_type(L, idx)) {
case LUA_TNUMBER: arg = lua_tonumber(L, idx); return arg;
case LUA_TSTRING: arg = mpq(lua_tostring(L, idx)); return arg;
case LUA_TUSERDATA:
if (is_mpz(L, idx)) {
arg = mpq(to_mpz(L, idx));
return arg;
} else {
return *static_cast<mpq*>(luaL_checkudata(L, idx, mpq_mt));
}
default: throw exception(sstream() << "arg #" << idx << " must be a number, string, mpz or mpq");
}
}
vm_obj nat_repeat(vm_obj const &, vm_obj const & f, vm_obj const & n, vm_obj const & a) {
if (is_simple(n)) {
unsigned _n = cidx(n);
vm_obj r = a;
for (unsigned i = 0; i < _n ; i++) {
r = invoke(f, mk_vm_simple(i), r);
}
return r;
} else {
mpz _n = to_mpz(n);
mpz i(0);
vm_obj r = a;
while (i < _n) {
r = invoke(f, mk_vm_nat(i), r);
i++;
}
return r;
}
}
static void mpz_migrate(lua_State * src, int i, lua_State * tgt) {
push_mpz(tgt, to_mpz(src, i));
}
vm_obj format_of_nat(vm_obj const & n) {
if (is_simple(n))
return to_obj(format(cidx(n)));
else
return to_obj(format(to_mpz(n).to_string()));
}
/* The actual interpreter loop */
void interp(state_t *st) {
while (1) {
obj_t *x, *y, *z;
char *p, c;
int i;
unsigned long u;
/* fprintf(stderr, "Executing '%c'\n", *st->pc); */
switch (c = *st->pc++) {
case '\0':
return;
case '\r':
case '\n':
case '\t':
case ' ': /* nop */
break;
case '!': /* call */
POP(x);
if (x->type != function) {
error("Not a function.\n");
} else {
CALL(x);
decref(x);
}
break;
case '"': /* output string */
p = skip_string(st->pc);
c = *p; /* Save old character */
*p = '\0'; /* Change it to NUL */
fputs(st->pc, stdout); /* Print the string */
*p = c; /* Replace original character */
st->pc = p + 1; /* Set the PC to one past the closing quote*/
break;
case '#': /* over */
POP(y); POP(x);
PUS(x); PUS(y); PUSH(x);
break;
case '$': /* dup */
POP(x);
PUS(x); PUSH(x);
break;
case '%': /* mod */
BINOP(mpz_mod);
break;
case '&': /* && */
BINBOOL(NONZERO(x) && NONZERO(y));
break;
case '\'': /* Set multi */
for (p = st->pc; *p && *p != '\''; p++);
st->pc = p + 1;
for (p--; *p != '\''; p--) {
if (*p >= 'a' && *p <= 'z') {
/* local */
POP(x);
i = *p - 'a';
if ((y = st->frame->vars[i]) != NULL) decref(y);
st->frame->vars[i] = x;
} else if (*p >= 'A' && *p <= 'Z') {
/* global */
POP(x);
i = *p - 'A';
if ((y = st->vars[i]) != NULL) decref(y);
st->vars[i] = x;
} else if (*p != '\n' && *p != '\t' && *p != ' ') {
error("Not a variable: '%c'", *p);
}
}
break;
case '(': /* Comment; can't be nested */
st->pc = skip_comment(st->pc);
break;
case '*': /* mul */
BINOP(mpz_mul);
break;
case '+': /* add */
BINOP(mpz_add);
break;
case ',': /* print character */
POP(x);
u = to_ulong(x);
putchar(u);
decref(x);
break;
case '-': /* sub */
BINOP(mpz_sub);
break;
case '.': /* print */
POP(x);
print_obj(stdout, x);
decref(x);
break;
case '/': /* div */
BINOP(mpz_fdiv_q);
break;
case '0':
case '1':
case '2':
case '3':
case '4':
case '5':
case '6':
case '7':
case '8':
case '9':
p = st->pc;
/* Skip to the first non-digit */
while ((c = *p) >= '0' && c <= '9') p++;
*p = '\0'; /* Temporarily put a NUL there */
PUS(num_new_from_str(st->pc-1));
*p = c; /* Replace original character */
st->pc = p;
break;
case ':': /* Set variable */
POP(x);
c = *st->pc++;
if (c >= 'A' && c <= 'Z') {
/* global */
i = c - 'A';
if ((y = st->vars[i]) != NULL) decref(y);
st->vars[i] = x;
} else if (c >= 'a' && c <= 'z') {
/* local */
i = c - 'a';
if ((y = st->frame->vars[i]) != NULL) decref(y);
st->frame->vars[i] = x;
} else {
error("Not a variable: '%c'\n", *st->pc);
}
break;
/* case ';': */
/* break; */
case '<': /* less than */
BINBOOL(mpz_cmp(*to_mpz(x), *to_mpz(y)) < 0);
break;
case '=': /* equal to */
BINBOOL(mpz_cmp(*to_mpz(x), *to_mpz(y)) == 0);
break;
case '>': /* greater than */
BINBOOL(mpz_cmp(*to_mpz(x), *to_mpz(y)) > 0);
break;
case '?': /* if */
POP(z); POP(y); POP(x);
if (x->type != number || y->type != function || z->type != function)
error("Wrong argument type.");
CALL(NONZERO(x) ? y : z);
decref(z); decref(y); decref(x);
break;
case '@': /* rot */
POP(z); POP(y); POP(x);
PUS(y); PUS(z); PUS(x);
break;
/* global variables */
case 'A':
case 'B':
case 'C':
case 'D':
case 'E':
case 'F':
case 'G':
case 'H':
case 'I':
case 'J':
case 'K':
case 'L':
case 'M':
case 'N':
case 'O':
case 'P':
case 'Q':
case 'R':
case 'S':
case 'T':
case 'U':
case 'V':
case 'W':
case 'X':
case 'Y':
case 'Z':
/* global variables */
i = c - 'A';
if ((x = st->vars[i]) == NULL) {
error("Uninitialized variable '%c'\n", c);
}
if (x->type == function) {
CALL(x);
} else {
PUSH(x);
}
break;
case '[':
PUS(fun_new(st->pc));
i = 1;
while (*st->pc) {
switch (*st->pc++) {
case '"':
st->pc = skip_string(st->pc) + 1;
break;
case '(':
st->pc = skip_comment(st->pc) + 1;
break;
case '[':
i++;
break;
case ']':
if (--i <= 0) goto done;
break;
}
}
done:
break;
case '\\': /* swap */
POP(y); POP(x);
PUS(y); PUS(x);
break;
case ']':
POPRET();
break;
case '^': /* trace */
print_trace(st);
break;
/* case '^': /\* pow *\/ */
/* POP(y); POP(x); */
/* z = num_new(); */
/* mpz_pow_ui(z->data.mpz, *to_mpz(x), to_ulong(y)); */
/* PUSH(z); */
/* decref(y); decref(x); */
/* break; *\/ */
case '_': /* neg */
POP(x);
mpz_neg(*to_mpz(x), x->data.mpz);
PUS(x);
break;
case '`': /* drop */
POP(x);
decref(x);
break;
case 'a':
case 'b':
case 'c':
case 'd':
case 'e':
case 'f':
case 'g':
case 'h':
case 'i':
case 'j':
case 'k':
case 'l':
case 'm':
case 'n':
case 'o':
case 'p':
case 'q':
case 'r':
case 's':
case 't':
case 'u':
case 'v':
case 'w':
case 'x':
case 'y':
case 'z':
/* local variables */
i = c - 'a';
if ((x = st->frame->vars[i]) == NULL) {
error("Uninitialized variable '%c'\n", c);
}
if (x->type == function) {
CALL(x);
} else {
PUSH(x);
}
break;
/* case '{': */
/* break; */
case '|': /* or */
BINBOOL(NONZERO(x) || NONZERO(y));
break;
/* case '}': */
/* break; */
case '~': /* not */
POP(x);
PUSH(ZERO(x) ? one : zero);
decref(x);
break;
default:
error("Undefined token '%c'\n", c);
}
}
}
unsigned to_unsigned(vm_obj const & o) {
if (is_simple(o))
return cidx(o);
else
return to_mpz(o).get_unsigned_int();
}
