#include "exc.h" #include "consts.h" #include "builtin.h" #include "model.h" #include "exc.h" #include #include #include #include using std::stringstream; extern EmptyList *empty_list; static const int NUM_LVL_COMP = 0; static const int NUM_LVL_REAL = 1; static const int NUM_LVL_RAT = 2; static const int NUM_LVL_INT = 3; string double_to_str(double val, bool force_sign = false) { stringstream ss; if (force_sign) ss << std::showpos; ss << val; return ss.str(); } string int_to_str(int val) { stringstream ss; ss << val; return ss.str(); } double str_to_double(string repr, bool &flag) { const char *nptr = repr.c_str(); char *endptr; double val = strtod(nptr, &endptr); if (endptr != nptr + repr.length()) { flag = false; return 0; } flag = true; return val; } int gcd(int a, int b) { int t; while (b) t = b, b = a % b, a = t; return a; } InexactNumObj::InexactNumObj(NumLvl level) : NumObj(level, false) {} CompNumObj::CompNumObj(double _real, double _imag) : InexactNumObj(NUM_LVL_COMP), real(_real), imag(_imag) {} CompNumObj *CompNumObj::from_string(string repr) { // spos: the position of the last sign // ipos: the position of i int spos = -1, ipos = -1, len = repr.length(); bool sign; for (int i = 0; i < len; i++) if (repr[i] == '+' || repr[i] == '-') { spos = i; sign = repr[i] == '-'; } else if (repr[i] == 'i' || repr[i] == 'I') ipos = i; if (spos == -1 || ipos == -1 || !(spos < ipos)) return NULL; bool flag; double real = 0, imag = 1; if (spos > 0) { real = str_to_double(repr.substr(0, spos), flag); if (!flag) return NULL; } if (ipos > spos + 1) { imag = str_to_double(repr.substr(spos + 1, ipos - spos - 1), flag); if (!flag) return NULL; } if (sign) imag = -imag; return new CompNumObj(real, imag); } CompNumObj *CompNumObj::convert(NumObj *obj) { switch (obj->level) { case NUM_LVL_COMP : return static_cast(obj); break; case NUM_LVL_REAL : return new CompNumObj(static_cast(obj)->real, 0); break; case NUM_LVL_RAT : { RatNumObj *rat = static_cast(obj); return new CompNumObj(rat->a / double(rat->b), 0); break; } case NUM_LVL_INT : return new CompNumObj(static_cast(obj)->val, 0); } throw NormalError(INT_ERR); } #define A (real) #define B (imag) #define C (r->real) #define D (r->imag) NumObj *CompNumObj::plus(NumObj *_r) { CompNumObj *r = CompNumObj::convert(_r); return new CompNumObj(A + C, B + D); } NumObj *CompNumObj::minus(NumObj *_r) { CompNumObj *r = CompNumObj::convert(_r); return new CompNumObj(A - C, B - D); } NumObj *CompNumObj::multi(NumObj *_r) { CompNumObj *r = CompNumObj::convert(_r); return new CompNumObj(A * C - B * D, B * C + A * D); } NumObj *CompNumObj::div(NumObj *_r) { CompNumObj *r = CompNumObj::convert(_r); double f = 1.0 / (C * C + D * D); return new CompNumObj((A * C + B * D) * f, (B * C - A * D) * f); } BoolObj *CompNumObj::eq(NumObj *_r) { CompNumObj *r = CompNumObj::convert(_r); return new BoolObj(A == C && B == D); // TODO: more proper judgement } string CompNumObj::ext_repr() { return double_to_str(real) + double_to_str(imag, true) + "i"; } #undef A #undef B #undef C #undef D RealNumObj::RealNumObj(double _real) : InexactNumObj(NUM_LVL_REAL), real(_real) {} RealNumObj *RealNumObj::from_string(string repr) { bool flag; double real = str_to_double(repr, flag); if (!flag) return NULL; return new RealNumObj(real); } RealNumObj *RealNumObj::convert(NumObj *obj) { switch (obj->level) { case NUM_LVL_REAL: return static_cast(obj); break; case NUM_LVL_RAT: { RatNumObj *rat = static_cast(obj); return new RealNumObj(rat->a / double(rat->b)); break; } case NUM_LVL_INT: return new RealNumObj(static_cast(obj)->val); } throw NormalError(INT_ERR); } NumObj *RealNumObj::plus(NumObj *_r) { return new RealNumObj(real + RealNumObj::convert(_r)->real); } NumObj *RealNumObj::minus(NumObj *_r) { return new RealNumObj(real - RealNumObj::convert(_r)->real); } NumObj *RealNumObj::multi(NumObj *_r) { return new RealNumObj(real * RealNumObj::convert(_r)->real); } NumObj *RealNumObj::div(NumObj *_r) { return new RealNumObj(real / RealNumObj::convert(_r)->real); } BoolObj *RealNumObj::eq(NumObj *_r) { return new BoolObj(real == RealNumObj::convert(_r)->real); } BoolObj *RealNumObj::lt(NumObj *_r) { return new BoolObj(real < RealNumObj::convert(_r)->real); } BoolObj *RealNumObj::gt(NumObj *_r) { return new BoolObj(real > RealNumObj::convert(_r)->real); } string RealNumObj::ext_repr() { return double_to_str(real); } ExactNumObj::ExactNumObj(NumLvl level) : NumObj(level, false) {} RatNumObj::RatNumObj(int _a, int _b) : ExactNumObj(NUM_LVL_RAT), a(_a), b(_b) { int g = gcd(a, b); a /= g; b /= g; } RatNumObj *RatNumObj::from_string(string repr) { int a, b; if (sscanf(repr.c_str(), "%d/%d", &a, &b) != 2) return NULL; return new RatNumObj(a, b); } RatNumObj *RatNumObj::convert(NumObj *obj) { switch (obj->level) { case NUM_LVL_RAT: return static_cast(obj); break; case NUM_LVL_INT: return new RatNumObj(static_cast(obj)->val, 1); } throw NormalError(INT_ERR); } #define A (a) #define B (b) #define C (r->a) #define D (r->b) NumObj *RatNumObj::plus(NumObj *_r) { RatNumObj *r = RatNumObj::convert(_r); int na = A * D + B * C, nb = B * D; int g = gcd(na, nb); na /= g; nb /= g; return new RatNumObj(na, nb); } NumObj *RatNumObj::minus(NumObj *_r) { RatNumObj *r = RatNumObj::convert(_r); int na = A * D - B * C, nb = B * D; int g = gcd(na, nb); na /= g; nb /= g; return new RatNumObj(na, nb); } NumObj *RatNumObj::multi(NumObj *_r) { RatNumObj *r = RatNumObj::convert(_r); int na = A * C, nb = B * D; int g = gcd(na, nb); na /= g; nb /= g; return new RatNumObj(na, nb); } NumObj *RatNumObj::div(NumObj *_r) { RatNumObj *r = RatNumObj::convert(_r); int na = A * D, nb = B * C; int g = gcd(na, nb); na /= g; nb /= g; return new RatNumObj(na, nb); } BoolObj *RatNumObj::lt(NumObj *_r) { RatNumObj *r = RatNumObj::convert(_r); return new BoolObj(A * D < C * B); } BoolObj *RatNumObj::gt(NumObj *_r) { RatNumObj *r = RatNumObj::convert(_r); return new BoolObj(A * D > C * B); } BoolObj *RatNumObj::eq(NumObj *_r) { RatNumObj *r = RatNumObj::convert(_r); return new BoolObj(A * D == C * B); } string RatNumObj::ext_repr() { return int_to_str(A) + "/" + int_to_str(B); } IntNumObj::IntNumObj(int _val) : ExactNumObj(NUM_LVL_INT), val(_val) {} IntNumObj *IntNumObj::from_string(string repr) { int val = 0; for (int i = 0; i < repr.length(); i++) { if (!('0' <= repr[i] && repr[i] <= '9')) return NULL; val = val * 10 + repr[i] - '0'; } return new IntNumObj(val); } IntNumObj *IntNumObj::convert(NumObj *obj) { switch (obj->level) { case NUM_LVL_INT : return static_cast(obj); default: throw NormalError(INT_ERR); } } NumObj *IntNumObj::plus(NumObj *_r) { return new IntNumObj(val + IntNumObj::convert(_r)->val); } NumObj *IntNumObj::minus(NumObj *_r) { return new IntNumObj(val - IntNumObj::convert(_r)->val); } NumObj *IntNumObj::multi(NumObj *_r) { return new IntNumObj(val * IntNumObj::convert(_r)->val); } NumObj *IntNumObj::div(NumObj *_r) { return new IntNumObj(val / IntNumObj::convert(_r)->val); } BoolObj *IntNumObj::lt(NumObj *_r) { return new BoolObj(val < IntNumObj::convert(_r)->val); } BoolObj *IntNumObj::gt(NumObj *_r) { return new BoolObj(val > IntNumObj::convert(_r)->val); } BoolObj *IntNumObj::eq(NumObj *_r) { return new BoolObj(val == IntNumObj::convert(_r)->val); } string IntNumObj::ext_repr() { return int_to_str(val); } SpecialOptIf::SpecialOptIf() : SpecialOptObj() {} void SpecialOptIf::prepare(Cons *pc) { state = 0; // Prepared pc = TO_CONS(pc->cdr); if (pc == empty_list) throw TokenError("if", SYN_ERR_MISS_OR_EXTRA_EXP); pc->skip = false; pc = TO_CONS(pc->cdr); if (pc == empty_list) throw TokenError("if", SYN_ERR_MISS_OR_EXTRA_EXP); pc->skip = true; if (pc->cdr != empty_list) TO_CONS(pc->cdr)->skip = true; } void SpecialOptIf::pre_call(ArgList *args, Cons *pc, Environment *envt) { // static_cast because it's a call invocation pc = TO_CONS(TO_CONS(pc->car)->cdr); // Condition evaluated and the decision is made state = 1; if (TO_CONS(args->cdr)->car->is_true()) { pc->skip = true; pc = TO_CONS(pc->cdr); pc->skip = false; if (pc->cdr != empty_list) TO_CONS(pc->cdr)->skip = true; // Eval the former } else { pc->skip = true; pc = TO_CONS(pc->cdr); TO_CONS(pc->cdr)->skip = true; if (pc->cdr != empty_list) TO_CONS(pc->cdr)->skip = false; //Eval the latter } } EvalObj *SpecialOptIf::post_call(ArgList *args, Cons *pc, Environment *envt) { // Value already evaluated, so just return it return TO_CONS(args->cdr)->car; } Cons *SpecialOptIf::call(ArgList *args, Environment * &envt, Continuation * &cont, FrameObj ** &top_ptr) { Cons *ret_addr = static_cast(*top_ptr)->addr; if (state) { *top_ptr++ = post_call(args, ret_addr, envt); return ret_addr->next; // Move to the next instruction } else { pre_call(args, ret_addr, envt); top_ptr += 2; // Undo pop and invoke again // static_cast because it's a call invocation return static_cast(ret_addr->car)->next; } } string SpecialOptIf::ext_repr() { return string("#"); } SpecialOptLambda::SpecialOptLambda() : SpecialOptObj() {} #define FILL_MARKS(pc, flag) \ for (Cons *ptr = TO_CONS(pc->cdr); \ ptr != empty_list; ptr = TO_CONS(ptr->cdr)) \ ptr->skip = flag void SpecialOptLambda::prepare(Cons *pc) { //TODO check number of arguments // Do not evaluate anything FILL_MARKS(pc, true); } Cons *SpecialOptLambda::call(ArgList *args, Environment * &envt, Continuation * &cont, FrameObj ** &top_ptr) { Cons *ret_addr = static_cast(*top_ptr)->addr; Cons *pc = static_cast(ret_addr->car); if (pc->cdr == empty_list) throw TokenError("lambda", SYN_ERR_EMPTY_PARA_LIST); if (TO_CONS(pc->cdr)->cdr == empty_list) throw TokenError("lambda", SYN_ERR_MISS_OR_EXTRA_EXP); SymbolList *para_list = static_cast(TO_CONS(pc->cdr)->car); // Clear the flag to avoid side-effects (e.g. proc calling) FILL_MARKS(pc, false); // store a list of expressions inside ASTList *body = TO_CONS(TO_CONS(pc->cdr)->cdr); // Truncate the expression list for (Cons *ptr = body; ptr != empty_list; ptr = TO_CONS(ptr->cdr)) ptr->next = NULL; // Make each expression an orphan *top_ptr++ = new ProcObj(body, envt, para_list); return ret_addr->next; // Move to the next instruction } string SpecialOptLambda::ext_repr() { return string("#"); } SpecialOptDefine::SpecialOptDefine() : SpecialOptObj() {} void SpecialOptDefine::prepare(Cons *pc) { if (pc->cdr == empty_list) throw TokenError("define", SYN_ERR_MISS_OR_EXTRA_EXP); if (TO_CONS(pc->cdr)->car->is_simple_obj()) // Simple value assignment { pc = TO_CONS(pc->cdr); if (pc->cdr == empty_list) throw TokenError("define", SYN_ERR_MISS_OR_EXTRA_EXP); pc->skip = true; // Skip the identifier TO_CONS(pc->cdr)->skip = false; } // Procedure definition else FILL_MARKS(pc, true); // Skip all parts } Cons *SpecialOptDefine::call(ArgList *args, Environment * &envt, Continuation * &cont, FrameObj ** &top_ptr) { Cons *ret_addr = static_cast(*top_ptr)->addr; Cons *pc = static_cast(ret_addr->car); EvalObj *obj; SymObj *id; // TODO: check identifier EvalObj *first = TO_CONS(pc->cdr)->car; if (first->is_simple_obj()) { if (!first->is_sym_obj()) throw TokenError(first->ext_repr(), SYN_ERR_NOT_AN_ID); id = static_cast(first); obj = TO_CONS(args->cdr)->car; } else { // static_cast because of is_simple_obj() is false Cons *plst = static_cast(TO_CONS(pc->cdr)->car); if (plst == empty_list) throw TokenError("if", SYN_ERR_EMPTY_PARA_LIST); if (!plst->car->is_sym_obj()) throw TokenError(first->ext_repr(), SYN_ERR_NOT_AN_ID); id = static_cast(plst->car); ArgList *para_list = TO_CONS(plst->cdr); // Clear the flag to avoid side-effects (e.g. proc calling) FILL_MARKS(pc, false); ASTList *body = TO_CONS(TO_CONS(pc->cdr)->cdr); // Truncate the expression list if (body == empty_list) throw TokenError("define", SYN_ERR_MISS_OR_EXTRA_EXP); for (Cons *ptr = body; ptr != empty_list; ptr = TO_CONS(ptr->cdr)) ptr->next = NULL; // Make each expression a orphan obj = new ProcObj(body, envt, para_list); } envt->add_binding(id, obj); *top_ptr++ = new UnspecObj(); return ret_addr->next; } string SpecialOptDefine::ext_repr() { return string("#"); } void SpecialOptSet::prepare(Cons *pc) { pc = TO_CONS(pc->cdr); if (pc == empty_list) throw TokenError("set!", SYN_ERR_MISS_OR_EXTRA_EXP); pc->skip = true; // Skip the identifier pc = TO_CONS(pc->cdr); if (pc == empty_list) throw TokenError("set!", SYN_ERR_MISS_OR_EXTRA_EXP); pc->skip = false; } Cons *SpecialOptSet::call(ArgList *args, Environment * &envt, Continuation * &cont, FrameObj ** &top_ptr) { Cons *ret_addr = static_cast(*top_ptr)->addr; Cons *pc = static_cast(ret_addr->car); EvalObj *first = TO_CONS(pc->cdr)->car; if (!first->is_sym_obj()) throw TokenError(first->ext_repr(), SYN_ERR_NOT_AN_ID); SymObj *id = static_cast(first); bool flag = envt->add_binding(id, TO_CONS(args->cdr)->car, false); if (!flag) throw TokenError(id->ext_repr(), RUN_ERR_UNBOUND_VAR); *top_ptr++ = new UnspecObj(); return ret_addr->next; } SpecialOptSet::SpecialOptSet() {} string SpecialOptSet::ext_repr() { return string("#"); } EvalObj *builtin_cons(ArgList *args) { if (args == empty_list || args->cdr == empty_list || TO_CONS(args->cdr)->cdr != empty_list) throw TokenError("cons", RUN_ERR_WRONG_NUM_OF_ARGS); return new Cons(args->car, TO_CONS(args->cdr)->car); } EvalObj *builtin_car(ArgList *args) { if (args == empty_list || args->cdr != empty_list) throw TokenError("car", RUN_ERR_WRONG_NUM_OF_ARGS); if (args->car == empty_list || !args->car->is_cons_obj()) throw TokenError("pair", RUN_ERR_WRONG_TYPE); return TO_CONS(args->car)->car; } EvalObj *builtin_cdr(ArgList *args) { if (args == empty_list || args->cdr != empty_list) throw TokenError("cdr", RUN_ERR_WRONG_NUM_OF_ARGS); if (args->car == empty_list || !args->car->is_cons_obj()) throw TokenError("pair", RUN_ERR_WRONG_TYPE); return TO_CONS(args->car)->cdr; } EvalObj *builtin_list(ArgList *args) { return args; } EvalObj *builtin_plus(ArgList *args) { NumObj *res = new IntNumObj(0), *opr; // the most accurate type for (Cons *ptr = args; ptr != empty_list; ptr = TO_CONS(ptr->cdr)) { if (!ptr->car->is_num_obj()) // not a number throw TokenError(ptr->car->ext_repr(), RUN_ERR_WRONG_TYPE); opr = static_cast(ptr->car); if (res->level < opr->level) // upper type conversion res = res->plus(opr); else res = opr->plus(res); } return res; } EvalObj *builtin_display(ArgList *args) { printf("%s\n", args->car->ext_repr().c_str()); return new UnspecObj(); }