diff options
| -rw-r--r-- | Makefile | 2 | ||||
| -rw-r--r-- | builtin.cpp | 649 | ||||
| -rw-r--r-- | builtin.h | 178 | ||||
| -rw-r--r-- | eval.h | 1 | ||||
| -rw-r--r-- | model.cpp | 297 | ||||
| -rw-r--r-- | model.h | 371 | ||||
| -rw-r--r-- | types.cpp | 906 | ||||
| -rw-r--r-- | types.h | 521 |
8 files changed, 1472 insertions, 1453 deletions
@@ -1,4 +1,4 @@ -main: main.o parser.o builtin.o model.o eval.o exc.o consts.o +main: main.o parser.o builtin.o model.o eval.o exc.o consts.o types.o g++ -o main $^ -pg -lgmp .cpp.o: diff --git a/builtin.cpp b/builtin.cpp index eebde5e..1c76053 100644 --- a/builtin.cpp +++ b/builtin.cpp @@ -1,23 +1,15 @@ +#include <cstdio> +#include <cctype> +#include <cstdlib> + #include "consts.h" #include "builtin.h" #include "model.h" #include "exc.h" -#include <cstdio> -#include <sstream> -#include <cctype> -#include <cstdlib> -#include <cmath> -#include <iomanip> +#include "types.h" 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; -const double EPS = 1e-16; -const int PREC = 16; #define ARGS_EXACTLY_TWO \ if (args == empty_list || \ @@ -34,611 +26,6 @@ const int PREC = 16; if (args == empty_list) \ throw TokenError(name, RUN_ERR_WRONG_NUM_OF_ARGS) - -string double_to_str(double val, bool force_sign = false) { - stringstream ss; - if (force_sign) ss << std::showpos; - ss << std::setprecision(PREC); - 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 || endptr != nptr + repr.length()) - { - flag = false; - return 0; - } - flag = true; - return val; -} - -int str_to_int(string repr, bool &flag) { - const char *nptr = repr.c_str(); - char *endptr; - int val = strtol(nptr, &endptr, 10); - if (endptr == nptr || 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 abs(a); -} - -bool is_zero(double x) { - return -EPS < x && x < EPS; -} - -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 - long long spos = -1, ipos = -1; - size_t len = repr.length(); - bool sign; - for (size_t 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; - - double real = 0, imag = 1; - IntNumObj *int_ptr; - RatNumObj *rat_ptr; - RealNumObj *real_ptr; - if (spos > 0) - { - string real_str = repr.substr(0, spos); - if ((int_ptr = IntNumObj::from_string(real_str))) -#ifndef GMP_SUPPORT - real = int_ptr->val; -#else - real = int_ptr->val.get_d(); -#endif - else if ((rat_ptr = RatNumObj::from_string(real_str))) -#ifndef GMP_SUPPORT - real = rat_ptr->a / double(rat_ptr->b); -#else - real = rat_ptr->val.get_d(); -#endif - else if ((real_ptr = RealNumObj::from_string(real_str))) - real = real_ptr->real; - else return NULL; - } - if (ipos > spos + 1) - { - string imag_str = repr.substr(spos + 1, ipos - spos - 1); - if ((int_ptr = IntNumObj::from_string(imag_str))) -#ifndef GMP_SUPPORT - imag = int_ptr->val; -#else - imag = int_ptr->val.get_d(); -#endif - else if ((rat_ptr = RatNumObj::from_string(imag_str))) -#ifndef GMP_SUPPORT - imag = rat_ptr->a / double(rat_ptr->b); -#else - imag = rat_ptr->val.get_d(); -#endif - else if ((real_ptr = RealNumObj::from_string(imag_str))) - imag = real_ptr->real; - else 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<CompNumObj*>(obj); break; - case NUM_LVL_REAL : - return new CompNumObj(static_cast<RealNumObj*>(obj)->real, 0); - break; - case NUM_LVL_RAT : - { - RatNumObj *rat = static_cast<RatNumObj*>(obj); -#ifndef GMP_SUPPORT - return new CompNumObj(rat->a / double(rat->b), 0); -#else - return new CompNumObj(rat->val.get_d(), 0); -#endif - break; - } - case NUM_LVL_INT : -#ifndef GMP_SUPPORT - return new CompNumObj(static_cast<IntNumObj*>(obj)->val, 0); -#else - return new CompNumObj(static_cast<IntNumObj*>(obj)->val.get_d(), 0); -#endif - } - throw NormalError(INT_ERR); -} - -#define A (real) -#define B (imag) -#define C (r->real) -#define D (r->imag) - -NumObj *CompNumObj::add(NumObj *_r) { - CompNumObj *r = static_cast<CompNumObj*>(_r); - return new CompNumObj(A + C, B + D); -} - -NumObj *CompNumObj::sub(NumObj *_r) { - CompNumObj *r = static_cast<CompNumObj*>(_r); - return new CompNumObj(A - C, B - D); -} - -NumObj *CompNumObj::mul(NumObj *_r) { - CompNumObj *r = static_cast<CompNumObj*>(_r); - return new CompNumObj(A * C - B * D, - B * C + A * D); -} - -NumObj *CompNumObj::div(NumObj *_r) { - CompNumObj *r = static_cast<CompNumObj*>(_r); - double f = C * C + D * D; - if (f == 0) - throw NormalError(RUN_ERR_NUMERIC_OVERFLOW); - f = 1 / f; - return new CompNumObj((A * C + B * D) * f, - (B * C - A * D) * f); -} - -bool NumObj::lt(NumObj *_r) { - throw TokenError("a comparable number", RUN_ERR_WRONG_TYPE); -} - -bool NumObj::gt(NumObj *_r) { - throw TokenError("a comparable number", RUN_ERR_WRONG_TYPE); -} - -bool NumObj::le(NumObj *_r) { - throw TokenError("a comparable number", RUN_ERR_WRONG_TYPE); -} - -bool NumObj::ge(NumObj *_r) { - throw TokenError("a comparable number", RUN_ERR_WRONG_TYPE); -} - -NumObj *NumObj::abs() { - throw TokenError("a real number", RUN_ERR_WRONG_TYPE); -} - - -bool CompNumObj::eq(NumObj *_r) { - CompNumObj *r = static_cast<CompNumObj*>(_r); - return A == C && B == D; // TODO: more proper judgement -} - - -ReprCons *CompNumObj::get_repr_cons() { - return new ReprStr(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<RealNumObj*>(obj); break; - case NUM_LVL_RAT: - { - RatNumObj *rat = static_cast<RatNumObj*>(obj); -#ifndef GMP_SUPPORT - return new RealNumObj(rat->a / double(rat->b)); -#else - return new RealNumObj(rat->val.get_d()); -#endif - break; - } - case NUM_LVL_INT: -#ifndef GMP_SUPPORT - return new RealNumObj(static_cast<IntNumObj*>(obj)->val); -#else - return new RealNumObj(static_cast<IntNumObj*>(obj)->val.get_d()); -#endif - - } - throw NormalError(INT_ERR); -} - -NumObj *RealNumObj::add(NumObj *_r) { - return new RealNumObj(real + static_cast<RealNumObj*>(_r)->real); -} - -NumObj *RealNumObj::sub(NumObj *_r) { - return new RealNumObj(real - static_cast<RealNumObj*>(_r)->real); -} - -NumObj *RealNumObj::mul(NumObj *_r) { - return new RealNumObj(real * static_cast<RealNumObj*>(_r)->real); -} - -NumObj *RealNumObj::div(NumObj *_r) { - return new RealNumObj(real / static_cast<RealNumObj*>(_r)->real); -} - -NumObj *RealNumObj::abs() { - return new RealNumObj(fabs(real)); -} - -bool RealNumObj::eq(NumObj *_r) { - return real == static_cast<RealNumObj*>(_r)->real; -} - -bool RealNumObj::lt(NumObj *_r) { - return real < static_cast<RealNumObj*>(_r)->real; -} - -bool RealNumObj::gt(NumObj *_r) { - return real > static_cast<RealNumObj*>(_r)->real; -} - -bool RealNumObj::le(NumObj *_r) { - return real <= static_cast<RealNumObj*>(_r)->real; -} - -bool RealNumObj::ge(NumObj *_r) { - return real >= static_cast<RealNumObj*>(_r)->real; -} - - -ReprCons *RealNumObj::get_repr_cons() { - return new ReprStr(double_to_str(real)); -} - -ExactNumObj::ExactNumObj(NumLvl level) : NumObj(level, true) {} - -#ifndef GMP_SUPPORT -RatNumObj::RatNumObj(int _a, int _b) : - ExactNumObj(NUM_LVL_RAT), a(_a), b(_b) { - if (b == 0) - throw NormalError(RUN_ERR_NUMERIC_OVERFLOW); - if (b < 0) a = -a, b = -b; - int g = gcd(a, b); - a /= g; - b /= g; - } - -RatNumObj *RatNumObj::from_string(string repr) { - int a, b; - size_t len = repr.length(); - int pos = -1; - for (size_t i = 0; i < len; i++) - if (repr[i] == '/') { pos = i; break; } - bool flag; - a = str_to_int(repr.substr(0, pos), flag); - if (!flag) return NULL; - b = str_to_int(repr.substr(pos + 1, len - pos - 1), flag); - if (!flag) return NULL; - - return new RatNumObj(a, b); -} -#else -RatNumObj::RatNumObj(mpq_class _val) : - ExactNumObj(NUM_LVL_RAT), val(_val) { - val.canonicalize(); -} - -RatNumObj *RatNumObj::from_string(string repr) { - try - { - mpq_class ret(repr, 10); - if (ret.get_den() == 0) - throw NormalError(RUN_ERR_NUMERIC_OVERFLOW); - ret.canonicalize(); - return new RatNumObj(ret); - } - catch (std::invalid_argument &e) - { - return NULL; - } -} -#endif - - -RatNumObj *RatNumObj::convert(NumObj *obj) { - switch (obj->level) - { - case NUM_LVL_RAT: - return static_cast<RatNumObj*>(obj); break; - case NUM_LVL_INT: -#ifndef GMP_SUPPORT - return new RatNumObj(static_cast<IntNumObj*>(obj)->val, 1); -#else - return new RatNumObj(mpq_class( - static_cast<IntNumObj*>(obj)->val, - mpz_class(1))); -#endif - } - throw NormalError(INT_ERR); -} - -#define A (a) -#define B (b) -#define C (r->a) -#define D (r->b) - -NumObj *RatNumObj::add(NumObj *_r) { - RatNumObj *r = static_cast<RatNumObj*>(_r); -#ifndef GMP_SUPPORT - int na = A * D + B * C, nb = B * D; - int g = gcd(na, nb); - na /= g; - nb /= g; - return new RatNumObj(na, nb); -#else - return new RatNumObj(val + r->val); -#endif -} - -NumObj *RatNumObj::sub(NumObj *_r) { - RatNumObj *r = static_cast<RatNumObj*>(_r); -#ifndef GMP_SUPPORT - int na = A * D - B * C, nb = B * D; - int g = gcd(na, nb); - na /= g; - nb /= g; - return new RatNumObj(na, nb); -#else - return new RatNumObj(val - r->val); -#endif -} - -NumObj *RatNumObj::mul(NumObj *_r) { - RatNumObj *r = static_cast<RatNumObj*>(_r); -#ifndef GMP_SUPPORT - int na = A * C, nb = B * D; - int g = gcd(na, nb); - na /= g; - nb /= g; - return new RatNumObj(na, nb); -#else - return new RatNumObj(val * r->val); -#endif -} - -NumObj *RatNumObj::div(NumObj *_r) { - RatNumObj *r = static_cast<RatNumObj*>(_r); -#ifndef GMP_SUPPORT - int na = A * D, nb = B * C; - int g = gcd(na, nb); - na /= g; - nb /= g; - return new RatNumObj(na, nb); -#else - return new RatNumObj(val / r->val); -#endif -} - -bool RatNumObj::lt(NumObj *_r) { - RatNumObj *r = static_cast<RatNumObj*>(_r); -#ifndef GMP_SUPPORT - return A * D < C * B; -#else - return val < r->val; -#endif -} - -bool RatNumObj::gt(NumObj *_r) { - RatNumObj *r = static_cast<RatNumObj*>(_r); -#ifndef GMP_SUPPORT - return A * D > C * B; -#else - return val > r->val; -#endif -} - -bool RatNumObj::le(NumObj *_r) { - RatNumObj *r = static_cast<RatNumObj*>(_r); -#ifndef GMP_SUPPORT - return A * D <= C * B; -#else - return val <= r->val; -#endif -} - -bool RatNumObj::ge(NumObj *_r) { - RatNumObj *r = static_cast<RatNumObj*>(_r); -#ifndef GMP_SUPPORT - return A * D >= C * B; -#else - return val >= r->val; -#endif -} - - -bool RatNumObj::eq(NumObj *_r) { - RatNumObj *r = static_cast<RatNumObj*>(_r); -#ifndef GMP_SUPPORT - return A * D == C * B; -#else - return val == r->val; -#endif -} - -NumObj *RatNumObj::abs() { -#ifndef GMP_SUPPORT - return new RatNumObj((a > 0 ? a : -a), b); -#else - return new RatNumObj(std::abs(val)); -#endif -} - -ReprCons *RatNumObj::get_repr_cons() { -#ifndef GMP_SUPPORT - return new ReprStr(int_to_str(A) + "/" + int_to_str(B)); -#else - return new ReprStr(val.get_str()); -#endif -} - - -#ifndef GMP_SUPPORT -IntNumObj::IntNumObj(int _val) : ExactNumObj(NUM_LVL_INT), val(_val) {} -IntNumObj *IntNumObj::from_string(string repr) { - int val = 0; - for (size_t 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); -} -int IntNumObj::get_i() { return val; } -#else -IntNumObj::IntNumObj(mpz_class _val) : ExactNumObj(NUM_LVL_INT), val(_val) {} -IntNumObj *IntNumObj::from_string(string repr) { - try - { - mpz_class ret(repr, 10); - return new IntNumObj(ret); - } - catch (std::invalid_argument &e) - { - return NULL; - } -} -int IntNumObj::get_i() { return val.get_si(); } -#endif - -IntNumObj *IntNumObj::convert(NumObj *obj) { - switch (obj->level) - { - case NUM_LVL_INT : - return static_cast<IntNumObj*>(obj); - default: - throw NormalError(INT_ERR); - } -} - -NumObj *IntNumObj::add(NumObj *_r) { - return new IntNumObj(val + static_cast<IntNumObj*>(_r)->val); -} - -NumObj *IntNumObj::sub(NumObj *_r) { - return new IntNumObj(val - static_cast<IntNumObj*>(_r)->val); -} - -NumObj *IntNumObj::mul(NumObj *_r) { - return new IntNumObj(val * static_cast<IntNumObj*>(_r)->val); -} - -NumObj *IntNumObj::div(NumObj *_r) { -#ifndef GMP_SUPPORT - return new RatNumObj(val, static_cast<IntNumObj*>(_r)->val); -#else - mpz_class d(static_cast<IntNumObj*>(_r)->val); - if (d == 0) throw NormalError(RUN_ERR_NUMERIC_OVERFLOW); - return new RatNumObj(mpq_class(val, d)); -#endif -} - -NumObj *IntNumObj::abs() { - return new IntNumObj(std::abs(val)); -} - -NumObj *IntNumObj::rem(NumObj *_r) { - return new IntNumObj(val % static_cast<IntNumObj*>(_r)->val); -} - -NumObj *IntNumObj::mod(NumObj *_r) { - const mpz_class &rval = static_cast<IntNumObj*>(_r)->val; - mpz_class ret = val % rval; - if (sgn(ret) != sgn(rval)) - ret = ret + rval; - return new IntNumObj(ret); -} - -NumObj *IntNumObj::quo(NumObj *_r) { - return new IntNumObj(val / static_cast<IntNumObj*>(_r)->val); -} - -NumObj *IntNumObj::gcd(NumObj *_r) { - mpz_t g; - mpz_gcd(g, val.get_mpz_t(), static_cast<IntNumObj*>(_r)->val.get_mpz_t()); - return new IntNumObj(mpz_class(g)); -} - -NumObj *IntNumObj::lcm(NumObj *_r) { - mpz_t l; - mpz_lcm(l, val.get_mpz_t(), static_cast<IntNumObj*>(_r)->val.get_mpz_t()); - return new IntNumObj(mpz_class(l)); -} - -bool IntNumObj::lt(NumObj *_r) { - return val < static_cast<IntNumObj*>(_r)->val; -} - -bool IntNumObj::gt(NumObj *_r) { - return val > static_cast<IntNumObj*>(_r)->val; -} - -bool IntNumObj::le(NumObj *_r) { - return val <= static_cast<IntNumObj*>(_r)->val; -} - -bool IntNumObj::ge(NumObj *_r) { - return val >= static_cast<IntNumObj*>(_r)->val; -} - - -bool IntNumObj::eq(NumObj *_r) { - return val == static_cast<IntNumObj*>(_r)->val; -} - -ReprCons *IntNumObj::get_repr_cons() { -#ifndef GMP_SUPPORT - return new ReprStr(int_to_str(val)); -#else - return new ReprStr(val.get_str()); -#endif -} - SpecialOptIf::SpecialOptIf() : SpecialOptObj("if") {} void SpecialOptIf::prepare(Pair *pc) { @@ -673,7 +60,7 @@ void SpecialOptIf::prepare(Pair *pc) { first->next = NULL; // skip <consequence> and <alternative> } -void SpecialOptIf::pre_call(ArgList *args, Pair *pc, +void SpecialOptIf::pre_call(Pair *args, Pair *pc, Environment *envt) { // prepare has guaranteed ... pc = TO_PAIR(pc->car); @@ -696,13 +83,13 @@ void SpecialOptIf::pre_call(ArgList *args, Pair *pc, } } -EvalObj *SpecialOptIf::post_call(ArgList *args, Pair *pc, +EvalObj *SpecialOptIf::post_call(Pair *args, Pair *pc, Environment *envt) { // Value already evaluated, so just return it return TO_PAIR(args->cdr)->car; } -Pair *SpecialOptIf::call(ArgList *args, Environment * &envt, +Pair *SpecialOptIf::call(Pair *args, Environment * &envt, Continuation * &cont, FrameObj ** &top_ptr) { Pair *ret_addr = static_cast<RetAddr*>(*top_ptr)->addr; if (state) @@ -773,7 +160,7 @@ void SpecialOptLambda::prepare(Pair *pc) { pc->next = NULL; } -Pair *SpecialOptLambda::call(ArgList *args, Environment * &envt, +Pair *SpecialOptLambda::call(Pair *args, Environment * &envt, Continuation * &cont, FrameObj ** &top_ptr) { Pair *ret_addr = static_cast<RetAddr*>(*top_ptr)->addr; @@ -831,7 +218,7 @@ void SpecialOptDefine::prepare(Pair *pc) { } } -Pair *SpecialOptDefine::call(ArgList *args, Environment * &envt, +Pair *SpecialOptDefine::call(Pair *args, Environment * &envt, Continuation * &cont, FrameObj ** &top_ptr) { Pair *ret_addr = static_cast<RetAddr*>(*top_ptr)->addr; Pair *pc = static_cast<Pair*>(ret_addr->car); @@ -900,7 +287,7 @@ void SpecialOptSet::prepare(Pair *pc) { second->next = NULL; } -Pair *SpecialOptSet::call(ArgList *args, Environment * &envt, +Pair *SpecialOptSet::call(Pair *args, Environment * &envt, Continuation * &cont, FrameObj ** &top_ptr) { Pair *ret_addr = static_cast<RetAddr*>(*top_ptr)->addr; Pair *pc = static_cast<Pair*>(ret_addr->car); @@ -931,7 +318,7 @@ void SpecialOptQuote::prepare(Pair *pc) { pc->next = NULL; } -Pair *SpecialOptQuote::call(ArgList *args, Environment * &envt, +Pair *SpecialOptQuote::call(Pair *args, Environment * &envt, Continuation * &cont, FrameObj ** &top_ptr) { Pair *ret_addr = static_cast<RetAddr*>(*top_ptr)->addr; Pair *pc = static_cast<Pair*>(ret_addr->car); @@ -951,7 +338,7 @@ void SpecialOptEval::prepare(Pair *pc) { state = 0; } -Pair *SpecialOptEval::call(ArgList *args, Environment * &envt, +Pair *SpecialOptEval::call(Pair *args, Environment * &envt, Continuation * &cont, FrameObj ** &top_ptr) { if (args->cdr == empty_list || TO_PAIR(args->cdr)->cdr != empty_list) @@ -985,7 +372,7 @@ void SpecialOptAnd::prepare(Pair *pc) { } } -Pair *SpecialOptAnd::call(ArgList *args, Environment * &envt, +Pair *SpecialOptAnd::call(Pair *args, Environment * &envt, Continuation * &cont, FrameObj ** &top_ptr) { Pair *ret_addr = static_cast<RetAddr*>(*top_ptr)->addr; Pair *pc = static_cast<Pair*>(ret_addr->car); @@ -1033,7 +420,7 @@ void SpecialOptOr::prepare(Pair *pc) { } } -Pair *SpecialOptOr::call(ArgList *args, Environment * &envt, +Pair *SpecialOptOr::call(Pair *args, Environment * &envt, Continuation * &cont, FrameObj ** &top_ptr) { Pair *ret_addr = static_cast<RetAddr*>(*top_ptr)->addr; Pair *pc = static_cast<Pair*>(ret_addr->car); @@ -1074,7 +461,7 @@ SpecialOptApply::SpecialOptApply() : SpecialOptObj("apply") {} void SpecialOptApply::prepare(Pair *pc) {} -Pair *SpecialOptApply::call(ArgList *args, Environment * &envt, +Pair *SpecialOptApply::call(Pair *args, Environment * &envt, Continuation * &cont, FrameObj ** &top_ptr) { top_ptr++; // Recover the return address if (args->cdr == empty_list) @@ -1122,7 +509,7 @@ void SpecialOptForce::prepare(Pair *pc) { state = 0; } -Pair *SpecialOptForce::call(ArgList *args, Environment * &envt, +Pair *SpecialOptForce::call(Pair *args, Environment * &envt, Continuation * &cont, FrameObj ** &top_ptr) { if (args->cdr == empty_list || TO_PAIR(args->cdr)->cdr != empty_list) @@ -1170,7 +557,7 @@ void SpecialOptDelay::prepare(Pair *pc) { pc->next = NULL; } -Pair *SpecialOptDelay::call(ArgList *args, Environment * &envt, +Pair *SpecialOptDelay::call(Pair *args, Environment * &envt, Continuation * &cont, FrameObj ** &top_ptr) { Pair *ret_addr = static_cast<RetAddr*>(*top_ptr)->addr; Pair *pc = static_cast<Pair*>(ret_addr->car); @@ -2,158 +2,13 @@ #define BUILTIN_H #include "model.h" +#include "types.h" #include <string> -#include <gmpxx.h> using std::string; const int EQUAL_QUEUE_SIZE = 262144; -/** @class InexactNumObj - * Inexact number implementation (using doubles) - */ -class InexactNumObj: public NumObj { - public: - InexactNumObj(NumLvl level); -}; - -/** @class CompNumObj - * Complex numbers - */ -class CompNumObj: public InexactNumObj { - public: - double real, imag; - - /** Construct a complex number */ - CompNumObj(double _real, double _imag); - /** Try to construct an CompNumObj object - * @return NULL if failed - */ - static CompNumObj *from_string(string repr); - /** Convert to a complex number from other numeric types */ - CompNumObj *convert(NumObj* obj); - - NumObj *add(NumObj *r); - NumObj *sub(NumObj *r); - NumObj *mul(NumObj *r); - NumObj *div(NumObj *r); - bool eq(NumObj *r); - ReprCons *get_repr_cons(); -}; - -/** @class RealNumObj - * Real numbers - */ -class RealNumObj: public InexactNumObj { - public: - double real; - /** Construct a real number */ - RealNumObj(double _real); - /** Try to construct an RealNumObj object - * @return NULL if failed - */ - static RealNumObj *from_string(string repr); - /** Convert to a real number from other numeric types */ - RealNumObj *convert(NumObj* obj); - - NumObj *add(NumObj *r); - NumObj *sub(NumObj *r); - NumObj *mul(NumObj *r); - NumObj *div(NumObj *r); - NumObj *abs(); - bool lt(NumObj *r); - bool gt(NumObj *r); - bool le(NumObj *r); - bool ge(NumObj *r); - bool eq(NumObj *r); - ReprCons *get_repr_cons(); - -}; - - -/** @class ExactNumObj - * Exact number implementation (using gmp) - */ -class ExactNumObj: public NumObj { - public: - ExactNumObj(NumLvl level); -}; - -/** @class RatNumObj - * Rational numbers - */ -class RatNumObj: public ExactNumObj { - public: -#ifndef GMP_SUPPORT - int a, b; - /** Construct a rational number */ - RatNumObj(int _a, int _b); -#else - mpq_class val; - RatNumObj(mpq_class val); -#endif - /** Try to construct an RatNumObj object - * @return NULL if failed - */ - static RatNumObj *from_string(string repr); - /** Convert to a Rational number from other numeric types */ - RatNumObj *convert(NumObj* obj); - - NumObj *add(NumObj *r); - NumObj *sub(NumObj *r); - NumObj *mul(NumObj *r); - NumObj *div(NumObj *r); - NumObj *abs(); - bool lt(NumObj *r); - bool gt(NumObj *r); - bool le(NumObj *r); - bool ge(NumObj *r); - bool eq(NumObj *r); - ReprCons *get_repr_cons(); -}; - -/** @class IntNumObj - * Integers - */ -class IntNumObj: public ExactNumObj { - public: -#ifndef GMP_SUPPORT - int val; - /** Construct a integer */ - IntNumObj(int val); - int get_i(); -#else - mpz_class val; - /** Construct a integer */ - IntNumObj(mpz_class val); - int get_i(); -#endif - /** Try to construct an IntNumObj object - * @return NULL if failed - */ - static IntNumObj *from_string(string repr); - /** Convert to a integer from other numeric types */ - IntNumObj *convert(NumObj* obj); - - NumObj *add(NumObj *r); - NumObj *sub(NumObj *r); - NumObj *mul(NumObj *r); - NumObj *div(NumObj *r); - NumObj *abs(); - NumObj *mod(NumObj *r); - NumObj *rem(NumObj *r); - NumObj *quo(NumObj *r); - NumObj *gcd(NumObj *r); - NumObj *lcm(NumObj *r); - bool lt(NumObj *r); - bool gt(NumObj *r); - bool le(NumObj *r); - bool ge(NumObj *r); - bool eq(NumObj *r); - ReprCons *get_repr_cons(); -}; - - /** @class SpecialOptIf * The implementation of `if` operator */ @@ -164,18 +19,18 @@ class SpecialOptIf: public SpecialOptObj { * The evaluator will call this after the <condition> exp is evaluated. * And this function tells the evaluator which of <consequence> and * <alternative> should be evaluted. */ - void pre_call(ArgList *args, Pair *pc, + void pre_call(Pair *args, Pair *pc, Environment *envt); /** The system will call this again after the desired result is * evaluated, so just return it to let the evaluator know the it's the * answer. */ - EvalObj *post_call(ArgList *args, Pair *pc, + EvalObj *post_call(Pair *args, Pair *pc, Environment *envt); public: SpecialOptIf(); void prepare(Pair *pc); - Pair *call(ArgList *args, Environment * &envt, + Pair *call(Pair *args, Environment * &envt, Continuation * &cont, FrameObj ** &top_ptr); ReprCons *get_repr_cons(); }; @@ -187,7 +42,7 @@ class SpecialOptLambda: public SpecialOptObj { public: SpecialOptLambda(); void prepare(Pair *pc); - Pair *call(ArgList *args, Environment * &envt, + Pair *call(Pair *args, Environment * &envt, Continuation * &cont, FrameObj ** &top_ptr); ReprCons *get_repr_cons(); @@ -200,7 +55,7 @@ class SpecialOptDefine: public SpecialOptObj { public: SpecialOptDefine(); void prepare(Pair *pc); - Pair *call(ArgList *args, Environment * &envt, + Pair *call(Pair *args, Environment * &envt, Continuation * &cont, FrameObj ** &top_ptr); ReprCons *get_repr_cons(); }; @@ -212,7 +67,7 @@ class SpecialOptSet: public SpecialOptObj { public: SpecialOptSet(); void prepare(Pair *pc); - Pair *call(ArgList *args, Environment * &envt, + Pair *call(Pair *args, Environment * &envt, Continuation * &cont, FrameObj ** &top_ptr); ReprCons *get_repr_cons(); }; @@ -224,7 +79,7 @@ class SpecialOptQuote: public SpecialOptObj { public: SpecialOptQuote(); void prepare(Pair *pc); - Pair *call(ArgList *args, Environment * &envt, + Pair *call(Pair *args, Environment * &envt, Continuation * &cont, FrameObj ** &top_ptr); ReprCons *get_repr_cons(); @@ -239,7 +94,7 @@ class SpecialOptEval: public SpecialOptObj { public: SpecialOptEval(); void prepare(Pair *pc); - Pair *call(ArgList *args, Environment * &envt, + Pair *call(Pair *args, Environment * &envt, Continuation * &cont, FrameObj ** &top_ptr); ReprCons *get_repr_cons(); @@ -252,7 +107,7 @@ class SpecialOptAnd: public SpecialOptObj { public: SpecialOptAnd(); void prepare(Pair *pc); - Pair *call(ArgList *args, Environment * &envt, + Pair *call(Pair *args, Environment * &envt, Continuation * &cont, FrameObj ** &top_ptr); ReprCons *get_repr_cons(); @@ -265,7 +120,7 @@ class SpecialOptOr: public SpecialOptObj { public: SpecialOptOr(); void prepare(Pair *pc); - Pair *call(ArgList *args, Environment * &envt, + Pair *call(Pair *args, Environment * &envt, Continuation * &cont, FrameObj ** &top_ptr); ReprCons *get_repr_cons(); @@ -278,7 +133,7 @@ class SpecialOptApply: public SpecialOptObj { public: SpecialOptApply(); void prepare(Pair *pc); - Pair *call(ArgList *args, Environment * &envt, + Pair *call(Pair *args, Environment * &envt, Continuation * &cont, FrameObj ** &top_ptr); ReprCons *get_repr_cons(); @@ -291,7 +146,7 @@ class SpecialOptDelay: public SpecialOptObj { public: SpecialOptDelay(); void prepare(Pair *pc); - Pair *call(ArgList *args, Environment * &envt, + Pair *call(Pair *args, Environment * &envt, Continuation * &cont, FrameObj ** &top_ptr); ReprCons *get_repr_cons(); @@ -307,16 +162,14 @@ class SpecialOptForce: public SpecialOptObj { public: SpecialOptForce(); void prepare(Pair *pc); - Pair *call(ArgList *args, Environment * &envt, + Pair *call(Pair *args, Environment * &envt, Continuation * &cont, FrameObj ** &top_ptr); ReprCons *get_repr_cons(); }; - - #define BUILTIN_PROC_DEF(func)\ - EvalObj *(func)(ArgList *args, const string &name) + EvalObj *(func)(Pair *args, const string &name) BUILTIN_PROC_DEF(num_add); BUILTIN_PROC_DEF(num_sub); @@ -372,5 +225,4 @@ BUILTIN_PROC_DEF(string_gt); BUILTIN_PROC_DEF(string_ge); BUILTIN_PROC_DEF(string_eq); - #endif @@ -1,6 +1,7 @@ #ifndef EVAL_H #define EVAL_H #include "model.h" +#include "types.h" const int EVAL_STACK_SIZE = 262144; /** @class Evaluator @@ -1,14 +1,17 @@ #include <cstdio> + #include "model.h" #include "exc.h" #include "consts.h" +#include "types.h" -static ReprCons *repr_stack[REPR_STACK_SIZE]; -EvalObjAddrHash hash; +const int REPR_STACK_SIZE = 262144; +extern EmptyList *empty_list; -FrameObj::FrameObj(ClassType _ftype) : ftype(_ftype) {} +static EvalObjAddrHash hash; +static ReprCons *repr_stack[REPR_STACK_SIZE]; -EmptyList *empty_list = new EmptyList(); +FrameObj::FrameObj(FrameType _ftype) : ftype(_ftype) {} EmptyList::EmptyList() : Pair(NULL, NULL) {} @@ -123,292 +126,6 @@ string EvalObj::ext_repr() { return res; } -Pair::Pair(EvalObj *_car, EvalObj *_cdr) : - EvalObj(CLS_PAIR_OBJ), car(_car), cdr(_cdr), - next(NULL) {} - - ReprCons *Pair::get_repr_cons() { - return new PairReprCons(this, this); - } - -RetAddr::RetAddr(Pair *_addr) : FrameObj(CLS_RET_ADDR), addr(_addr) {} - -ParseBracket::ParseBracket(unsigned char _btype) : - FrameObj(CLS_SIM_OBJ | CLS_PAR_BRA), btype(_btype) {} - - UnspecObj::UnspecObj() : EvalObj(CLS_SIM_OBJ) {} - - ReprCons *UnspecObj::get_repr_cons() { - return new ReprStr("#<Unspecified>"); - } - -SymObj::SymObj(const string &str) : - EvalObj(CLS_SIM_OBJ | CLS_SYM_OBJ), val(str) {} - - ReprCons *SymObj::get_repr_cons() { - return new ReprStr(val); - } - -OptObj::OptObj() : EvalObj(CLS_SIM_OBJ | CLS_OPT_OBJ) {} - -ProcObj::ProcObj(Pair *_body, - Environment *_envt, - EvalObj *_params) : - OptObj(), body(_body), params(_params), envt(_envt) {} - - Pair *ProcObj::call(ArgList *args, Environment * &genvt, - Continuation * &cont, FrameObj ** &top_ptr) { - // Create a new continuation - // static_cast see `call` invocation in eval.cpp - Pair *ret_addr = static_cast<RetAddr*>(*top_ptr)->addr; - Continuation *_cont = new Continuation(genvt, ret_addr, cont, body); - // Create local env and recall the closure - Environment *_envt = new Environment(envt); - // static_cast<SymObj*> because the params is already checked - EvalObj *ppar, *nptr; - for (ppar = params; - ppar->is_pair_obj(); - ppar = TO_PAIR(ppar)->cdr) - { - if ((nptr = args->cdr) != empty_list) - args = TO_PAIR(nptr); - else break; - _envt->add_binding(static_cast<SymObj*>(TO_PAIR(ppar)->car), args->car); - } - - if (ppar->is_sym_obj()) - _envt->add_binding(static_cast<SymObj*>(ppar), args->cdr); // (... . var_n) - else if (args->cdr != empty_list || ppar != empty_list) - throw TokenError("", RUN_ERR_WRONG_NUM_OF_ARGS); - - genvt = _envt; - cont = _cont; - *top_ptr++ = new RetAddr(NULL); // Mark the entrance of a cont - return body; // Move pc to the proc entry point - } - -ReprCons *ProcObj::get_repr_cons() { - return new ReprStr("#<Procedure>"); -} - -SpecialOptObj::SpecialOptObj(string _name) : OptObj(), name(_name) {} - -BoolObj::BoolObj(bool _val) : EvalObj(CLS_SIM_OBJ | CLS_BOOL_OBJ), val(_val) {} - -bool BoolObj::is_true() { return val; } - -ReprCons *BoolObj::get_repr_cons() { - return new ReprStr(val ? "#t" : "#f"); -} - -BoolObj *BoolObj::from_string(string repr) { - if (repr.length() != 2 || repr[0] != '#') - return NULL; - if (repr[1] == 't') - return new BoolObj(true); - else if (repr[1] == 'f') - return new BoolObj(false); - return NULL; -} - -NumObj::NumObj(NumLvl _level, bool _exactness) : - EvalObj(CLS_SIM_OBJ | CLS_NUM_OBJ), exactness(_exactness), level(_level) {} - - bool NumObj::is_exact() { return exactness; } - - StrObj::StrObj(string _str) : EvalObj(CLS_SIM_OBJ | CLS_STR_OBJ), str(_str) {} - - ReprCons *StrObj::get_repr_cons() { - return new ReprStr(str); - } - -CharObj::CharObj(char _ch) : EvalObj(CLS_SIM_OBJ | CLS_CHAR_OBJ), ch(_ch) {} - -CharObj *CharObj::from_string(string repr) { - size_t len = repr.length(); - if (len < 2) return NULL; - if (repr[0] != '#' || repr[1] != '\\') return NULL; - if (len == 3) return new CharObj(repr[2]); - string char_name = repr.substr(2, len - 2); - if (char_name == "newline") return new CharObj('\n'); - if (char_name == "space") return new CharObj(' '); - throw TokenError(char_name, RUN_ERR_UNKNOWN_CHAR_NAME); -} - -ReprCons *CharObj::get_repr_cons() { - string val = ""; - if (ch == ' ') val = "space"; - else if (ch == '\n') val = "newline"; - else val += ch; - return new ReprStr("#\\" + val); -} - -VecObj::VecObj() : EvalObj(CLS_SIM_OBJ | CLS_VECT_OBJ) {} - -EvalObj *VecObj::get_obj(int idx) { - return vec[idx]; -} - -size_t VecObj::get_size() { - return vec.end() - vec.begin(); -} - -void VecObj::resize(int new_size) { - vec.resize(new_size); -} - -void VecObj::push_back(EvalObj *new_elem) { - vec.push_back(new_elem); -} - -ReprCons *VecObj::get_repr_cons() { - return new VectReprCons(this, this); -} - -StrObj *StrObj::from_string(string repr) { - size_t len = repr.length(); - if (repr[0] == '\"' && repr[len - 1] == '\"') - return new StrObj(repr.substr(1, len - 2)); - return NULL; -} - -bool StrObj::lt(StrObj *r) { - return str < r->str; -} - -bool StrObj::gt(StrObj *r) { - return str > r->str; -} - -bool StrObj::le(StrObj *r) { - return str <= r->str; -} - -bool StrObj::ge(StrObj *r) { - return str >= r->str; -} - -bool StrObj::eq(StrObj *r) { - return str == r->str; -} - -BuiltinProcObj::BuiltinProcObj(BuiltinProc f, string _name) : - OptObj(), handler(f), name(_name) {} - - Pair *BuiltinProcObj::call(ArgList *args, Environment * &envt, - Continuation * &cont, FrameObj ** &top_ptr) { - - Pair *ret_addr = static_cast<RetAddr*>(*top_ptr)->addr; - *top_ptr++ = handler(TO_PAIR(args->cdr), name); - return ret_addr->next; // Move to the next instruction - } - -ReprCons *BuiltinProcObj::get_repr_cons() { - return new ReprStr("#<Builtin Procedure: " + name + ">"); -} - -Environment::Environment(Environment *_prev_envt) : prev_envt(_prev_envt) {} - -bool Environment::add_binding(SymObj *sym_obj, EvalObj *eval_obj, bool def) { - bool has_key = binding.count(sym_obj->val); - if (!def && !has_key) return false; - binding[sym_obj->val] = eval_obj; - return true; -} - -EvalObj *Environment::get_obj(EvalObj *obj) { - if (!obj->is_sym_obj()) return obj; - SymObj *sym_obj = static_cast<SymObj*>(obj); - - string name(sym_obj->val); - for (Environment *ptr = this; ptr; ptr = ptr->prev_envt) - { - bool has_key = ptr->binding.count(name); - if (has_key) return ptr->binding[name]; - } - // Object not found - throw TokenError(name, RUN_ERR_UNBOUND_VAR); -} - -Continuation::Continuation(Environment *_envt, Pair *_pc, - Continuation *_prev_cont, - Pair *_proc_body) : - prev_cont(_prev_cont), envt(_envt), pc(_pc), - proc_body(_proc_body) {} - - ReprCons::ReprCons(bool _done, EvalObj *_ori) : ori(_ori), done(_done) {} - ReprStr::ReprStr(string _repr) : ReprCons(true) { repr = _repr; } - EvalObj *ReprStr::next(const string &prev) { - throw NormalError(INT_ERR); - } - -PairReprCons::PairReprCons(Pair *_ptr, EvalObj *_ori) : - ReprCons(false, _ori), state(0), ptr(_ptr) {} - - EvalObj *PairReprCons::next(const string &prev) { - repr += prev; - EvalObj *res; - if (state == 0) - { - state = 1; - res = TO_PAIR(ptr)->car; - if (res->is_pair_obj()) - repr += "("; - return res; - } - else if (state == 1) - { - state = 2; - if (TO_PAIR(ptr)->car->is_pair_obj()) - repr += ")"; - ptr = TO_PAIR(ptr)->cdr; - if (ptr == empty_list) - return NULL; - repr += " "; - if (ptr->is_simple_obj()) - repr += ". "; - return ptr; - } - else - { - return NULL; - } - } - -VectReprCons::VectReprCons(VecObj *_ptr, EvalObj *_ori) : - ReprCons(false, _ori), ptr(_ptr), idx(0) { repr = "#("; } - - EvalObj *VectReprCons::next(const string &prev) { - repr += prev; - - if (idx && ptr->get_obj(idx - 1)->is_pair_obj()) - repr += ")"; - - if (idx == ptr->get_size()) - { - repr += ")"; - return NULL; - } - else - { - if (idx) repr += " "; - EvalObj *res = ptr->get_obj(idx++); - if (res->is_pair_obj()) - repr += "("; - return res; - } - } - -PromObj::PromObj(EvalObj *exp) : - EvalObj(CLS_SIM_OBJ | CLS_PROM_OBJ), entry(new Pair(exp, empty_list)), mem(NULL) {} - -Pair *PromObj::get_entry() { return entry; } - -ReprCons *PromObj::get_repr_cons() { return new ReprStr("#<Promise>"); } - -EvalObj *PromObj::get_mem() { return mem; } - -void PromObj::feed_mem(EvalObj *res) { mem = res; } bool make_exec(Pair *ptr) { @@ -2,42 +2,20 @@ #define MODEL_H #include <string> -#include <list> -#include <map> -#include <vector> -#include <set> -using std::list; using std::string; -using std::map; -using std::vector; -using std::set; // the range of unsigned char is enough for these types -typedef unsigned char ClassType; +typedef unsigned char FrameType; typedef unsigned char NumLvl; const int CLS_RET_ADDR = 1 << 0; const int CLS_EVAL_OBJ = 1 << 1; const int CLS_PAR_BRA = 1 << 2; -const int CLS_REPR_CONS = 1 << 3; -const int CLS_REPR_STR = 1 << 4; const int CLS_SIM_OBJ = 1 << 0; const int CLS_PAIR_OBJ = 1 << 1; -const int CLS_OPT_OBJ = 1 << 3; -const int CLS_PROM_OBJ = 1 << 9; - -const int CLS_SYM_OBJ = 1 << 2; -const int CLS_NUM_OBJ = 1 << 4; -const int CLS_BOOL_OBJ = 1 << 5; -const int CLS_CHAR_OBJ = 1 << 6; -const int CLS_STR_OBJ = 1 << 7; -const int CLS_VECT_OBJ = 1 << 8; - -const int REPR_STACK_SIZE = 262144; - #define TO_PAIR(ptr) \ (static_cast<Pair*>(ptr)) @@ -50,14 +28,14 @@ class FrameObj { * Report the type of the FrameObj, which can avoid the use of * dynamic_cast to improve efficiency. See the constructor for detail */ - ClassType ftype; + FrameType ftype; public: /** * Construct an EvalObj * @param ftype the type of the FrameObj (CLS_EVAL_OBJ for an EvalObj, * CLS_RET_ADDR for a return address) */ - FrameObj(ClassType ftype); + FrameObj(FrameType ftype); virtual ~FrameObj() {} /** * Tell whether the object is a return address, according to ftype @@ -120,349 +98,6 @@ class EvalObj : public FrameObj { virtual ReprCons *get_repr_cons() = 0; }; -typedef set<EvalObj*> EvalObjAddrHash; - -class PairReprCons; -/** @class Pair - * Pair construct, which can be used to represent a list, or further - * more, a syntax tree - * (car . cdr) in Scheme - */ -class Pair : public EvalObj { - public: - EvalObj *car; /**< car (as in Scheme) */ - EvalObj *cdr; /**< cdr (as in Scheme) */ - Pair* next; /**< The next branch in effect */ - - Pair(EvalObj *car, EvalObj *cdr); /**< Create a Pair (car . cdr) */ - ReprCons *get_repr_cons(); -}; - -/** @class EmptyList - * The empty list (special situation of a list) - */ -class EmptyList: public Pair { - public: - EmptyList(); - ReprCons *get_repr_cons(); -}; - -/** @class RetAddr - * Tracking the caller's Pair pointer - */ -class RetAddr : public FrameObj { - public: - Pair* addr; /**< The return address */ - /** Constructs a return address object which refers to the node addr in - * the AST */ - RetAddr(Pair *addr); -}; - -class ReprCons { - public: - EvalObj *ori; - bool done; - string repr; - ReprCons(bool done, EvalObj *ori = NULL); - virtual EvalObj *next(const string &prev) = 0; -}; - -class ReprStr : public ReprCons { - public: - ReprStr(string repr); - EvalObj *next(const string &prev); -}; - -class PairReprCons : public ReprCons { - private: - int state; - EvalObj *ptr; - public: - PairReprCons(Pair *ptr, EvalObj *ori); - EvalObj *next(const string &prev); -}; - -class VecObj; -class VectReprCons : public ReprCons { - private: - VecObj *ptr; - size_t idx; - public: - VectReprCons(VecObj *ptr, EvalObj *ori); - EvalObj *next(const string &prev); -}; - -/** @class ParseBracket - * To indiate a left bracket when parsing, used in the parse_stack - */ -class ParseBracket : public FrameObj { - public: - unsigned char btype; /**< The type of the bracket */ - /** Construct a ParseBracket object */ - ParseBracket(unsigned char btype); -}; - -/** @class UnspecObj - * The "unspecified" value returned by some builtin procedures - */ -class UnspecObj: public EvalObj { - public: - UnspecObj(); - ReprCons *get_repr_cons(); -}; - -/** @class SymObj - * Symbols - */ -class SymObj: public EvalObj { - public: - string val; - - SymObj(const string &); - ReprCons *get_repr_cons(); -}; - -// Everything is cons -typedef Pair ArgList; -class Environment; -class Continuation; - -/** @class OptObj - * "Operators" in general sense - */ -class OptObj: public EvalObj { - public: - OptObj(); - /** - * The function is called when an operation is needed. - * @param args The argument list (the first one is the opt itself) - * @param envt The current environment (may be modified) - * @param cont The current continuation (may be modified) - * @param top_ptr Pointing to the top of the stack (may be modified) - * @return New value for pc register - */ - virtual Pair *call(ArgList *args, Environment * &envt, - Continuation * &cont, FrameObj ** &top_ptr) = 0; -}; - -/** @class ProcObj - * User-defined procedures - */ -class ProcObj: public OptObj { - public: - /** The procedure body, a list of expressions to be evaluated */ - Pair *body; - /** The arguments: <list> | var1 ... | var1 var2 ... . varn */ - EvalObj *params; - /** Pointer to the environment */ - Environment *envt; - - /** Conctructs a ProcObj */ - ProcObj(Pair *body, Environment *envt, EvalObj *params); - Pair *call(ArgList *args, Environment * &envt, - Continuation * &cont, FrameObj ** &top_ptr); - ReprCons *get_repr_cons(); -}; - -/** @class SpecialOptObj - * Special builtin syntax (`if`, `define`, `lambda`, etc.) - */ -class SpecialOptObj: public OptObj { - protected: - string name; - public: - SpecialOptObj(string name); -}; - -typedef EvalObj* (*BuiltinProc)(ArgList *, const string &); -/** @class BuiltinProcObj - * Wrapping class for builtin procedures (arithmetic operators, etc.) - */ -class BuiltinProcObj: public OptObj { - private: - /** The function that tackle the inputs in effect */ - BuiltinProc handler; - string name; - public: - /** - * Make a BuiltinProcObj which invokes proc when called - * @param proc the actual handler - * @param name the name of this built-in procedure - */ - BuiltinProcObj(BuiltinProc proc, string name); - Pair *call(ArgList *args, Environment * &envt, - Continuation * &cont, FrameObj ** &top_ptr); - ReprCons *get_repr_cons(); -}; - -/** @class BoolObj - * Booleans - */ -class BoolObj: public EvalObj { - public: - bool val; /**< true for \#t, false for \#f */ - BoolObj(bool); /**< Converts a C bool value to a BoolObj*/ - bool is_true(); /**< Override EvalObj `is_true()` */ - ReprCons *get_repr_cons(); - /** Try to construct an BoolObj object - * @return NULL if failed - */ - static BoolObj *from_string(string repr); -}; - -/** @class NumObj - * The top level abstract of numbers - */ - -class NumObj: public EvalObj { - protected: - /** True if the number is of exact value */ - bool exactness; - public: - /** The level of the specific number. The smaller the level - * is, the more generic that number is. - */ - NumLvl level; - - /** - * Construct a general Numeric object - */ - NumObj(NumLvl level, bool _exactness); - bool is_exact(); - virtual NumObj *convert(NumObj *r) = 0; - virtual NumObj *add(NumObj *r) = 0; - virtual NumObj *sub(NumObj *r) = 0; - virtual NumObj *mul(NumObj *r) = 0; - virtual NumObj *div(NumObj *r) = 0; - virtual NumObj *abs(); - - virtual bool lt(NumObj *r); - virtual bool gt(NumObj *r); - virtual bool le(NumObj *r); - virtual bool ge(NumObj *r); - virtual bool eq(NumObj *r) = 0; -}; - -/** @class StrObj - * String support - */ -class StrObj: public EvalObj { - public: - string str; - - /** Construct a string object */ - StrObj(string str); - /** Try to construct an StrObj object - * @return NULL if failed - */ - static StrObj *from_string(string repr); - bool lt(StrObj *r); - bool gt(StrObj *r); - bool le(StrObj *r); - bool ge(StrObj *r); - bool eq(StrObj *r); - ReprCons *get_repr_cons(); -}; - -/** @class CharObj - * Character type support - */ -class CharObj: public EvalObj { - public: - char ch; - - /** Construct a string object */ - CharObj(char ch); - /** Try to construct an CharObj object - * @return NULL if failed - */ - static CharObj *from_string(string repr); - ReprCons *get_repr_cons(); -}; - - -typedef vector<EvalObj*> EvalObjVec; -/** - * @class VecObj - * Vector support (currently a wrapper of STL vector) - */ -class VecObj: public EvalObj { - public: - EvalObjVec vec; - /** Construct a vector object */ - VecObj(); - size_t get_size(); - EvalObj *get_obj(int idx); - /** Resize the vector */ - void resize(int new_size); - /** Add a new element to the rear */ - void push_back(EvalObj *new_elem); - ReprCons *get_repr_cons(); -}; - -/** - * @class PromObj - * Promise support (partial) - */ -class PromObj: public EvalObj { - private: - Pair *entry; - EvalObj *mem; - public: - PromObj(EvalObj *exp); - Pair *get_entry(); - EvalObj *get_mem(); - void feed_mem(EvalObj *res); - ReprCons *get_repr_cons(); -}; - -typedef map<string, EvalObj*> Str2EvalObj; -/** @class Environment - * The environment of current evaluation, i.e. the local variable binding - */ -class Environment { - private: - Environment *prev_envt; /**< Pointer to the upper-level environment */ - Str2EvalObj binding; /**< Store all pairs of identifier and its - corresponding obj */ - public: - /** Create an runtime environment - * @param prev_envt the outer environment - */ - Environment(Environment *prev_envt); - /** Add a binding entry which binds sym_obj to eval_obj - * @param def true to force the assignment - * @return when def is set to false, this return value is true iff. the - * assignment carried out successfully - */ - bool add_binding(SymObj *sym_obj, EvalObj *eval_obj, bool def = true); - /** Extract the corresponding EvalObj if obj is a SymObj, or just - * simply return obj as it is - * @param obj the object as request - * */ - EvalObj *get_obj(EvalObj *obj); -}; - -/** @class Continuation - * Save the registers and necessary information when a user-defined call is - * being made (Behave like a stack frame in C). When the call has accomplished, - * the system will restore all the registers according to the continuation. - */ -class Continuation { - public: - /** Linking the previous continuation on the chain */ - Continuation *prev_cont; - Environment *envt; /**< The saved envt */ - Pair *pc; /**< The saved pc */ - /** Pointing to the current expression that is being evaluated. - * When its value goes to empty_list, the call is accomplished. - */ - Pair *proc_body; - - /** Create a continuation */ - Continuation(Environment *envt, Pair *pc, Continuation *prev_cont, - Pair *proc_body); -}; bool make_exec(Pair *ptr); diff --git a/types.cpp b/types.cpp new file mode 100644 index 0000000..c2e3bea --- /dev/null +++ b/types.cpp @@ -0,0 +1,906 @@ +#include "types.h" +#include "model.h" +#include "exc.h" +#include "consts.h" + +#include <cmath> +#include <cstdlib> +#include <sstream> +#include <iomanip> + +const double EPS = 1e-16; +const int PREC = 16; + +EmptyList *empty_list = new EmptyList(); + +Pair::Pair(EvalObj *_car, EvalObj *_cdr) : + EvalObj(CLS_PAIR_OBJ), car(_car), cdr(_cdr), + next(NULL) {} + + ReprCons *Pair::get_repr_cons() { + return new PairReprCons(this, this); + } + +RetAddr::RetAddr(Pair *_addr) : FrameObj(CLS_RET_ADDR), addr(_addr) {} + +ParseBracket::ParseBracket(unsigned char _btype) : + FrameObj(CLS_SIM_OBJ | CLS_PAR_BRA), btype(_btype) {} + + UnspecObj::UnspecObj() : EvalObj(CLS_SIM_OBJ) {} + + ReprCons *UnspecObj::get_repr_cons() { + return new ReprStr("#<Unspecified>"); + } + +SymObj::SymObj(const string &str) : + EvalObj(CLS_SIM_OBJ | CLS_SYM_OBJ), val(str) {} + + ReprCons *SymObj::get_repr_cons() { + return new ReprStr(val); + } + +OptObj::OptObj() : EvalObj(CLS_SIM_OBJ | CLS_OPT_OBJ) {} + +ProcObj::ProcObj(Pair *_body, + Environment *_envt, + EvalObj *_params) : + OptObj(), body(_body), params(_params), envt(_envt) {} + + Pair *ProcObj::call(Pair *args, Environment * &genvt, + Continuation * &cont, FrameObj ** &top_ptr) { + // Create a new continuation + // static_cast see `call` invocation in eval.cpp + Pair *ret_addr = static_cast<RetAddr*>(*top_ptr)->addr; + Continuation *_cont = new Continuation(genvt, ret_addr, cont, body); + // Create local env and recall the closure + Environment *_envt = new Environment(envt); + // static_cast<SymObj*> because the params is already checked + EvalObj *ppar, *nptr; + for (ppar = params; + ppar->is_pair_obj(); + ppar = TO_PAIR(ppar)->cdr) + { + if ((nptr = args->cdr) != empty_list) + args = TO_PAIR(nptr); + else break; + _envt->add_binding(static_cast<SymObj*>(TO_PAIR(ppar)->car), args->car); + } + + if (ppar->is_sym_obj()) + _envt->add_binding(static_cast<SymObj*>(ppar), args->cdr); // (... . var_n) + else if (args->cdr != empty_list || ppar != empty_list) + throw TokenError("", RUN_ERR_WRONG_NUM_OF_ARGS); + + genvt = _envt; + cont = _cont; + *top_ptr++ = new RetAddr(NULL); // Mark the entrance of a cont + return body; // Move pc to the proc entry point + } + +ReprCons *ProcObj::get_repr_cons() { + return new ReprStr("#<Procedure>"); +} + +SpecialOptObj::SpecialOptObj(string _name) : OptObj(), name(_name) {} + +BoolObj::BoolObj(bool _val) : EvalObj(CLS_SIM_OBJ | CLS_BOOL_OBJ), val(_val) {} + +bool BoolObj::is_true() { return val; } + +ReprCons *BoolObj::get_repr_cons() { + return new ReprStr(val ? "#t" : "#f"); +} + +BoolObj *BoolObj::from_string(string repr) { + if (repr.length() != 2 || repr[0] != '#') + return NULL; + if (repr[1] == 't') + return new BoolObj(true); + else if (repr[1] == 'f') + return new BoolObj(false); + return NULL; +} + +NumObj::NumObj(NumLvl _level, bool _exactness) : + EvalObj(CLS_SIM_OBJ | CLS_NUM_OBJ), exactness(_exactness), level(_level) {} + + bool NumObj::is_exact() { return exactness; } + + StrObj::StrObj(string _str) : EvalObj(CLS_SIM_OBJ | CLS_STR_OBJ), str(_str) {} + + ReprCons *StrObj::get_repr_cons() { + return new ReprStr(str); + } + +CharObj::CharObj(char _ch) : EvalObj(CLS_SIM_OBJ | CLS_CHAR_OBJ), ch(_ch) {} + +CharObj *CharObj::from_string(string repr) { + size_t len = repr.length(); + if (len < 2) return NULL; + if (repr[0] != '#' || repr[1] != '\\') return NULL; + if (len == 3) return new CharObj(repr[2]); + string char_name = repr.substr(2, len - 2); + if (char_name == "newline") return new CharObj('\n'); + if (char_name == "space") return new CharObj(' '); + throw TokenError(char_name, RUN_ERR_UNKNOWN_CHAR_NAME); +} + +ReprCons *CharObj::get_repr_cons() { + string val = ""; + if (ch == ' ') val = "space"; + else if (ch == '\n') val = "newline"; + else val += ch; + return new ReprStr("#\\" + val); +} + +VecObj::VecObj() : EvalObj(CLS_SIM_OBJ | CLS_VECT_OBJ) {} + +EvalObj *VecObj::get_obj(int idx) { + return vec[idx]; +} + +size_t VecObj::get_size() { + return vec.end() - vec.begin(); +} + +void VecObj::resize(int new_size) { + vec.resize(new_size); +} + +void VecObj::push_back(EvalObj *new_elem) { + vec.push_back(new_elem); +} + +ReprCons *VecObj::get_repr_cons() { + return new VectReprCons(this, this); +} + +StrObj *StrObj::from_string(string repr) { + size_t len = repr.length(); + if (repr[0] == '\"' && repr[len - 1] == '\"') + return new StrObj(repr.substr(1, len - 2)); + return NULL; +} + +bool StrObj::lt(StrObj *r) { + return str < r->str; +} + +bool StrObj::gt(StrObj *r) { + return str > r->str; +} + +bool StrObj::le(StrObj *r) { + return str <= r->str; +} + +bool StrObj::ge(StrObj *r) { + return str >= r->str; +} + +bool StrObj::eq(StrObj *r) { + return str == r->str; +} + +BuiltinProcObj::BuiltinProcObj(BuiltinProc f, string _name) : + OptObj(), handler(f), name(_name) {} + + Pair *BuiltinProcObj::call(Pair *args, Environment * &envt, + Continuation * &cont, FrameObj ** &top_ptr) { + + Pair *ret_addr = static_cast<RetAddr*>(*top_ptr)->addr; + *top_ptr++ = handler(TO_PAIR(args->cdr), name); + return ret_addr->next; // Move to the next instruction + } + +ReprCons *BuiltinProcObj::get_repr_cons() { + return new ReprStr("#<Builtin Procedure: " + name + ">"); +} + +Environment::Environment(Environment *_prev_envt) : prev_envt(_prev_envt) {} + +bool Environment::add_binding(SymObj *sym_obj, EvalObj *eval_obj, bool def) { + bool has_key = binding.count(sym_obj->val); + if (!def && !has_key) return false; + binding[sym_obj->val] = eval_obj; + return true; +} + +EvalObj *Environment::get_obj(EvalObj *obj) { + if (!obj->is_sym_obj()) return obj; + SymObj *sym_obj = static_cast<SymObj*>(obj); + + string name(sym_obj->val); + for (Environment *ptr = this; ptr; ptr = ptr->prev_envt) + { + bool has_key = ptr->binding.count(name); + if (has_key) return ptr->binding[name]; + } + // Object not found + throw TokenError(name, RUN_ERR_UNBOUND_VAR); +} + +Continuation::Continuation(Environment *_envt, Pair *_pc, + Continuation *_prev_cont, + Pair *_proc_body) : + prev_cont(_prev_cont), envt(_envt), pc(_pc), + proc_body(_proc_body) {} + + ReprCons::ReprCons(bool _done, EvalObj *_ori) : ori(_ori), done(_done) {} + ReprStr::ReprStr(string _repr) : ReprCons(true) { repr = _repr; } + EvalObj *ReprStr::next(const string &prev) { + throw NormalError(INT_ERR); + } + +PairReprCons::PairReprCons(Pair *_ptr, EvalObj *_ori) : + ReprCons(false, _ori), state(0), ptr(_ptr) {} + + EvalObj *PairReprCons::next(const string &prev) { + repr += prev; + EvalObj *res; + if (state == 0) + { + state = 1; + res = TO_PAIR(ptr)->car; + if (res->is_pair_obj()) + repr += "("; + return res; + } + else if (state == 1) + { + state = 2; + if (TO_PAIR(ptr)->car->is_pair_obj()) + repr += ")"; + ptr = TO_PAIR(ptr)->cdr; + if (ptr == empty_list) + return NULL; + repr += " "; + if (ptr->is_simple_obj()) + repr += ". "; + return ptr; + } + else + { + return NULL; + } + } + +VectReprCons::VectReprCons(VecObj *_ptr, EvalObj *_ori) : + ReprCons(false, _ori), ptr(_ptr), idx(0) { repr = "#("; } + + EvalObj *VectReprCons::next(const string &prev) { + repr += prev; + + if (idx && ptr->get_obj(idx - 1)->is_pair_obj()) + repr += ")"; + + if (idx == ptr->get_size()) + { + repr += ")"; + return NULL; + } + else + { + if (idx) repr += " "; + EvalObj *res = ptr->get_obj(idx++); + if (res->is_pair_obj()) + repr += "("; + return res; + } + } + +PromObj::PromObj(EvalObj *exp) : + EvalObj(CLS_SIM_OBJ | CLS_PROM_OBJ), entry(new Pair(exp, empty_list)), mem(NULL) {} + +Pair *PromObj::get_entry() { return entry; } + +ReprCons *PromObj::get_repr_cons() { return new ReprStr("#<Promise>"); } + +EvalObj *PromObj::get_mem() { return mem; } + +void PromObj::feed_mem(EvalObj *res) { mem = res; } + + +string double_to_str(double val, bool force_sign = false) { + std::stringstream ss; + if (force_sign) ss << std::showpos; + ss << std::setprecision(PREC); + ss << val; + return ss.str(); +} + +string int_to_str(int val) { + std::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 || endptr != nptr + repr.length()) + { + flag = false; + return 0; + } + flag = true; + return val; +} + +int str_to_int(string repr, bool &flag) { + const char *nptr = repr.c_str(); + char *endptr; + int val = strtol(nptr, &endptr, 10); + if (endptr == nptr || 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 abs(a); +} + +bool is_zero(double x) { + return -EPS < x && x < EPS; +} + +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 + long long spos = -1, ipos = -1; + size_t len = repr.length(); + bool sign; + for (size_t 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; + + double real = 0, imag = 1; + IntNumObj *int_ptr; + RatNumObj *rat_ptr; + RealNumObj *real_ptr; + if (spos > 0) + { + string real_str = repr.substr(0, spos); + if ((int_ptr = IntNumObj::from_string(real_str))) +#ifndef GMP_SUPPORT + real = int_ptr->val; +#else + real = int_ptr->val.get_d(); +#endif + else if ((rat_ptr = RatNumObj::from_string(real_str))) +#ifndef GMP_SUPPORT + real = rat_ptr->a / double(rat_ptr->b); +#else + real = rat_ptr->val.get_d(); +#endif + else if ((real_ptr = RealNumObj::from_string(real_str))) + real = real_ptr->real; + else return NULL; + } + if (ipos > spos + 1) + { + string imag_str = repr.substr(spos + 1, ipos - spos - 1); + if ((int_ptr = IntNumObj::from_string(imag_str))) +#ifndef GMP_SUPPORT + imag = int_ptr->val; +#else + imag = int_ptr->val.get_d(); +#endif + else if ((rat_ptr = RatNumObj::from_string(imag_str))) +#ifndef GMP_SUPPORT + imag = rat_ptr->a / double(rat_ptr->b); +#else + imag = rat_ptr->val.get_d(); +#endif + else if ((real_ptr = RealNumObj::from_string(imag_str))) + imag = real_ptr->real; + else 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<CompNumObj*>(obj); break; + case NUM_LVL_REAL : + return new CompNumObj(static_cast<RealNumObj*>(obj)->real, 0); + break; + case NUM_LVL_RAT : + { + RatNumObj *rat = static_cast<RatNumObj*>(obj); +#ifndef GMP_SUPPORT + return new CompNumObj(rat->a / double(rat->b), 0); +#else + return new CompNumObj(rat->val.get_d(), 0); +#endif + break; + } + case NUM_LVL_INT : +#ifndef GMP_SUPPORT + return new CompNumObj(static_cast<IntNumObj*>(obj)->val, 0); +#else + return new CompNumObj(static_cast<IntNumObj*>(obj)->val.get_d(), 0); +#endif + } + throw NormalError(INT_ERR); +} + +#define A (real) +#define B (imag) +#define C (r->real) +#define D (r->imag) + +NumObj *CompNumObj::add(NumObj *_r) { + CompNumObj *r = static_cast<CompNumObj*>(_r); + return new CompNumObj(A + C, B + D); +} + +NumObj *CompNumObj::sub(NumObj *_r) { + CompNumObj *r = static_cast<CompNumObj*>(_r); + return new CompNumObj(A - C, B - D); +} + +NumObj *CompNumObj::mul(NumObj *_r) { + CompNumObj *r = static_cast<CompNumObj*>(_r); + return new CompNumObj(A * C - B * D, + B * C + A * D); +} + +NumObj *CompNumObj::div(NumObj *_r) { + CompNumObj *r = static_cast<CompNumObj*>(_r); + double f = C * C + D * D; + if (f == 0) + throw NormalError(RUN_ERR_NUMERIC_OVERFLOW); + f = 1 / f; + return new CompNumObj((A * C + B * D) * f, + (B * C - A * D) * f); +} + +bool NumObj::lt(NumObj *_r) { + throw TokenError("a comparable number", RUN_ERR_WRONG_TYPE); +} + +bool NumObj::gt(NumObj *_r) { + throw TokenError("a comparable number", RUN_ERR_WRONG_TYPE); +} + +bool NumObj::le(NumObj *_r) { + throw TokenError("a comparable number", RUN_ERR_WRONG_TYPE); +} + +bool NumObj::ge(NumObj *_r) { + throw TokenError("a comparable number", RUN_ERR_WRONG_TYPE); +} + +NumObj *NumObj::abs() { + throw TokenError("a real number", RUN_ERR_WRONG_TYPE); +} + + +bool CompNumObj::eq(NumObj *_r) { + CompNumObj *r = static_cast<CompNumObj*>(_r); + return A == C && B == D; // TODO: more proper judgement +} + + +ReprCons *CompNumObj::get_repr_cons() { + return new ReprStr(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<RealNumObj*>(obj); break; + case NUM_LVL_RAT: + { + RatNumObj *rat = static_cast<RatNumObj*>(obj); +#ifndef GMP_SUPPORT + return new RealNumObj(rat->a / double(rat->b)); +#else + return new RealNumObj(rat->val.get_d()); +#endif + break; + } + case NUM_LVL_INT: +#ifndef GMP_SUPPORT + return new RealNumObj(static_cast<IntNumObj*>(obj)->val); +#else + return new RealNumObj(static_cast<IntNumObj*>(obj)->val.get_d()); +#endif + + } + throw NormalError(INT_ERR); +} + +NumObj *RealNumObj::add(NumObj *_r) { + return new RealNumObj(real + static_cast<RealNumObj*>(_r)->real); +} + +NumObj *RealNumObj::sub(NumObj *_r) { + return new RealNumObj(real - static_cast<RealNumObj*>(_r)->real); +} + +NumObj *RealNumObj::mul(NumObj *_r) { + return new RealNumObj(real * static_cast<RealNumObj*>(_r)->real); +} + +NumObj *RealNumObj::div(NumObj *_r) { + return new RealNumObj(real / static_cast<RealNumObj*>(_r)->real); +} + +NumObj *RealNumObj::abs() { + return new RealNumObj(fabs(real)); +} + +bool RealNumObj::eq(NumObj *_r) { + return real == static_cast<RealNumObj*>(_r)->real; +} + +bool RealNumObj::lt(NumObj *_r) { + return real < static_cast<RealNumObj*>(_r)->real; +} + +bool RealNumObj::gt(NumObj *_r) { + return real > static_cast<RealNumObj*>(_r)->real; +} + +bool RealNumObj::le(NumObj *_r) { + return real <= static_cast<RealNumObj*>(_r)->real; +} + +bool RealNumObj::ge(NumObj *_r) { + return real >= static_cast<RealNumObj*>(_r)->real; +} + + +ReprCons *RealNumObj::get_repr_cons() { + return new ReprStr(double_to_str(real)); +} + +ExactNumObj::ExactNumObj(NumLvl level) : NumObj(level, true) {} + +#ifndef GMP_SUPPORT +RatNumObj::RatNumObj(int _a, int _b) : + ExactNumObj(NUM_LVL_RAT), a(_a), b(_b) { + if (b == 0) + throw NormalError(RUN_ERR_NUMERIC_OVERFLOW); + if (b < 0) a = -a, b = -b; + int g = gcd(a, b); + a /= g; + b /= g; + } + +RatNumObj *RatNumObj::from_string(string repr) { + int a, b; + size_t len = repr.length(); + int pos = -1; + for (size_t i = 0; i < len; i++) + if (repr[i] == '/') { pos = i; break; } + bool flag; + a = str_to_int(repr.substr(0, pos), flag); + if (!flag) return NULL; + b = str_to_int(repr.substr(pos + 1, len - pos - 1), flag); + if (!flag) return NULL; + + return new RatNumObj(a, b); +} +#else +RatNumObj::RatNumObj(mpq_class _val) : + ExactNumObj(NUM_LVL_RAT), val(_val) { + val.canonicalize(); +} + +RatNumObj *RatNumObj::from_string(string repr) { + try + { + mpq_class ret(repr, 10); + if (ret.get_den() == 0) + throw NormalError(RUN_ERR_NUMERIC_OVERFLOW); + ret.canonicalize(); + return new RatNumObj(ret); + } + catch (std::invalid_argument &e) + { + return NULL; + } +} +#endif + + +RatNumObj *RatNumObj::convert(NumObj *obj) { + switch (obj->level) + { + case NUM_LVL_RAT: + return static_cast<RatNumObj*>(obj); break; + case NUM_LVL_INT: +#ifndef GMP_SUPPORT + return new RatNumObj(static_cast<IntNumObj*>(obj)->val, 1); +#else + return new RatNumObj(mpq_class( + static_cast<IntNumObj*>(obj)->val, + mpz_class(1))); +#endif + } + throw NormalError(INT_ERR); +} + +#define A (a) +#define B (b) +#define C (r->a) +#define D (r->b) + +NumObj *RatNumObj::add(NumObj *_r) { + RatNumObj *r = static_cast<RatNumObj*>(_r); +#ifndef GMP_SUPPORT + int na = A * D + B * C, nb = B * D; + int g = gcd(na, nb); + na /= g; + nb /= g; + return new RatNumObj(na, nb); +#else + return new RatNumObj(val + r->val); +#endif +} + +NumObj *RatNumObj::sub(NumObj *_r) { + RatNumObj *r = static_cast<RatNumObj*>(_r); +#ifndef GMP_SUPPORT + int na = A * D - B * C, nb = B * D; + int g = gcd(na, nb); + na /= g; + nb /= g; + return new RatNumObj(na, nb); +#else + return new RatNumObj(val - r->val); +#endif +} + +NumObj *RatNumObj::mul(NumObj *_r) { + RatNumObj *r = static_cast<RatNumObj*>(_r); +#ifndef GMP_SUPPORT + int na = A * C, nb = B * D; + int g = gcd(na, nb); + na /= g; + nb /= g; + return new RatNumObj(na, nb); +#else + return new RatNumObj(val * r->val); +#endif +} + +NumObj *RatNumObj::div(NumObj *_r) { + RatNumObj *r = static_cast<RatNumObj*>(_r); +#ifndef GMP_SUPPORT + int na = A * D, nb = B * C; + int g = gcd(na, nb); + na /= g; + nb /= g; + return new RatNumObj(na, nb); +#else + return new RatNumObj(val / r->val); +#endif +} + +bool RatNumObj::lt(NumObj *_r) { + RatNumObj *r = static_cast<RatNumObj*>(_r); +#ifndef GMP_SUPPORT + return A * D < C * B; +#else + return val < r->val; +#endif +} + +bool RatNumObj::gt(NumObj *_r) { + RatNumObj *r = static_cast<RatNumObj*>(_r); +#ifndef GMP_SUPPORT + return A * D > C * B; +#else + return val > r->val; +#endif +} + +bool RatNumObj::le(NumObj *_r) { + RatNumObj *r = static_cast<RatNumObj*>(_r); +#ifndef GMP_SUPPORT + return A * D <= C * B; +#else + return val <= r->val; +#endif +} + +bool RatNumObj::ge(NumObj *_r) { + RatNumObj *r = static_cast<RatNumObj*>(_r); +#ifndef GMP_SUPPORT + return A * D >= C * B; +#else + return val >= r->val; +#endif +} + + +bool RatNumObj::eq(NumObj *_r) { + RatNumObj *r = static_cast<RatNumObj*>(_r); +#ifndef GMP_SUPPORT + return A * D == C * B; +#else + return val == r->val; +#endif +} + +NumObj *RatNumObj::abs() { +#ifndef GMP_SUPPORT + return new RatNumObj((a > 0 ? a : -a), b); +#else + return new RatNumObj(std::abs(val)); +#endif +} + +ReprCons *RatNumObj::get_repr_cons() { +#ifndef GMP_SUPPORT + return new ReprStr(int_to_str(A) + "/" + int_to_str(B)); +#else + return new ReprStr(val.get_str()); +#endif +} + + +#ifndef GMP_SUPPORT +IntNumObj::IntNumObj(int _val) : ExactNumObj(NUM_LVL_INT), val(_val) {} +IntNumObj *IntNumObj::from_string(string repr) { + int val = 0; + for (size_t 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); +} +int IntNumObj::get_i() { return val; } +#else +IntNumObj::IntNumObj(mpz_class _val) : ExactNumObj(NUM_LVL_INT), val(_val) {} +IntNumObj *IntNumObj::from_string(string repr) { + try + { + mpz_class ret(repr, 10); + return new IntNumObj(ret); + } + catch (std::invalid_argument &e) + { + return NULL; + } +} +int IntNumObj::get_i() { return val.get_si(); } +#endif + +IntNumObj *IntNumObj::convert(NumObj *obj) { + switch (obj->level) + { + case NUM_LVL_INT : + return static_cast<IntNumObj*>(obj); + default: + throw NormalError(INT_ERR); + } +} + +NumObj *IntNumObj::add(NumObj *_r) { + return new IntNumObj(val + static_cast<IntNumObj*>(_r)->val); +} + +NumObj *IntNumObj::sub(NumObj *_r) { + return new IntNumObj(val - static_cast<IntNumObj*>(_r)->val); +} + +NumObj *IntNumObj::mul(NumObj *_r) { + return new IntNumObj(val * static_cast<IntNumObj*>(_r)->val); +} + +NumObj *IntNumObj::div(NumObj *_r) { +#ifndef GMP_SUPPORT + return new RatNumObj(val, static_cast<IntNumObj*>(_r)->val); +#else + mpz_class d(static_cast<IntNumObj*>(_r)->val); + if (d == 0) throw NormalError(RUN_ERR_NUMERIC_OVERFLOW); + return new RatNumObj(mpq_class(val, d)); +#endif +} + +NumObj *IntNumObj::abs() { + return new IntNumObj(std::abs(val)); +} + +NumObj *IntNumObj::rem(NumObj *_r) { + return new IntNumObj(val % static_cast<IntNumObj*>(_r)->val); +} + +NumObj *IntNumObj::mod(NumObj *_r) { + const mpz_class &rval = static_cast<IntNumObj*>(_r)->val; + mpz_class ret = val % rval; + if (sgn(ret) != sgn(rval)) + ret = ret + rval; + return new IntNumObj(ret); +} + +NumObj *IntNumObj::quo(NumObj *_r) { + return new IntNumObj(val / static_cast<IntNumObj*>(_r)->val); +} + +NumObj *IntNumObj::gcd(NumObj *_r) { + mpz_t g; + mpz_gcd(g, val.get_mpz_t(), static_cast<IntNumObj*>(_r)->val.get_mpz_t()); + return new IntNumObj(mpz_class(g)); +} + +NumObj *IntNumObj::lcm(NumObj *_r) { + mpz_t l; + mpz_lcm(l, val.get_mpz_t(), static_cast<IntNumObj*>(_r)->val.get_mpz_t()); + return new IntNumObj(mpz_class(l)); +} + +bool IntNumObj::lt(NumObj *_r) { + return val < static_cast<IntNumObj*>(_r)->val; +} + +bool IntNumObj::gt(NumObj *_r) { + return val > static_cast<IntNumObj*>(_r)->val; +} + +bool IntNumObj::le(NumObj *_r) { + return val <= static_cast<IntNumObj*>(_r)->val; +} + +bool IntNumObj::ge(NumObj *_r) { + return val >= static_cast<IntNumObj*>(_r)->val; +} + + +bool IntNumObj::eq(NumObj *_r) { + return val == static_cast<IntNumObj*>(_r)->val; +} + +ReprCons *IntNumObj::get_repr_cons() { +#ifndef GMP_SUPPORT + return new ReprStr(int_to_str(val)); +#else + return new ReprStr(val.get_str()); +#endif +} @@ -0,0 +1,521 @@ +#ifndef TYPES_H +#define TYPES_H + +#include "model.h" +#include <string> +#include <list> +#include <map> +#include <vector> +#include <set> +#include <gmpxx.h> + +using std::list; +using std::string; +using std::map; +using std::vector; +using std::set; + +const int CLS_OPT_OBJ = 1 << 3; +const int CLS_PROM_OBJ = 1 << 9; + +const int CLS_SYM_OBJ = 1 << 2; +const int CLS_NUM_OBJ = 1 << 4; +const int CLS_BOOL_OBJ = 1 << 5; +const int CLS_CHAR_OBJ = 1 << 6; +const int CLS_STR_OBJ = 1 << 7; +const int CLS_VECT_OBJ = 1 << 8; + +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; + +typedef set<EvalObj*> EvalObjAddrHash; +typedef vector<EvalObj*> EvalObjVec; +typedef map<string, EvalObj*> Str2EvalObj; +typedef EvalObj* (*BuiltinProc)(Pair *, const string &); + +class PairReprCons; +/** @class Pair + * Pair construct, which can be used to represent a list, or further + * more, a syntax tree + * (car . cdr) in Scheme + */ +class Pair : public EvalObj {/*{{{*/ + public: + EvalObj *car; /**< car (as in Scheme) */ + EvalObj *cdr; /**< cdr (as in Scheme) */ + Pair* next; /**< The next branch in effect */ + + Pair(EvalObj *car, EvalObj *cdr); /**< Create a Pair (car . cdr) */ + ReprCons *get_repr_cons(); +};/*}}}*/ + +/** @class EmptyList + * The empty list (special situation of a list) + */ +class EmptyList: public Pair {/*{{{*/ + public: + EmptyList(); + ReprCons *get_repr_cons(); +};/*}}}*/ + +/** @class RetAddr + * Tracking the caller's Pair pointer + */ +class RetAddr : public FrameObj {/*{{{*/ + public: + Pair* addr; /**< The return address */ + /** Constructs a return address object which refers to the node addr in + * the AST */ + RetAddr(Pair *addr); +};/*}}}*/ + +class ReprCons {/*{{{*/ + public: + EvalObj *ori; + bool done; + string repr; + ReprCons(bool done, EvalObj *ori = NULL); + virtual EvalObj *next(const string &prev) = 0; +};/*}}}*/ + +class ReprStr : public ReprCons {/*{{{*/ + public: + ReprStr(string repr); + EvalObj *next(const string &prev); +};/*}}}*/ + +class PairReprCons : public ReprCons {/*{{{*/ + private: + int state; + EvalObj *ptr; + public: + PairReprCons(Pair *ptr, EvalObj *ori); + EvalObj *next(const string &prev); +};/*}}}*/ + +class VecObj; +class VectReprCons : public ReprCons {/*{{{*/ + private: + VecObj *ptr; + size_t idx; + public: + VectReprCons(VecObj *ptr, EvalObj *ori); + EvalObj *next(const string &prev); +};/*}}}*/ + +/** @class ParseBracket + * To indiate a left bracket when parsing, used in the parse_stack + */ +class ParseBracket : public FrameObj {/*{{{*/ + public: + unsigned char btype; /**< The type of the bracket */ + /** Construct a ParseBracket object */ + ParseBracket(unsigned char btype); +};/*}}}*/ + +/** @class UnspecObj + * The "unspecified" value returned by some builtin procedures + */ +class UnspecObj: public EvalObj {/*{{{*/ + public: + UnspecObj(); + ReprCons *get_repr_cons(); +};/*}}}*/ + +/** @class SymObj + * Symbols + */ +class SymObj: public EvalObj {/*{{{*/ + public: + string val; + + SymObj(const string &); + ReprCons *get_repr_cons(); +};/*}}}*/ + +// Everything is cons +class Environment; +class Continuation; + +/** @class OptObj + * "Operators" in general sense + */ +class OptObj: public EvalObj {/*{{{*/ + public: + OptObj(); + /** + * The function is called when an operation is needed. + * @param args The argument list (the first one is the opt itself) + * @param envt The current environment (may be modified) + * @param cont The current continuation (may be modified) + * @param top_ptr Pointing to the top of the stack (may be modified) + * @return New value for pc register + */ + virtual Pair *call(Pair *args, Environment * &envt, + Continuation * &cont, FrameObj ** &top_ptr) = 0; +};/*}}}*/ + +/** @class ProcObj + * User-defined procedures + */ +class ProcObj: public OptObj {/*{{{*/ + public: + /** The procedure body, a list of expressions to be evaluated */ + Pair *body; + /** The arguments: <list> | var1 ... | var1 var2 ... . varn */ + EvalObj *params; + /** Pointer to the environment */ + Environment *envt; + + /** Conctructs a ProcObj */ + ProcObj(Pair *body, Environment *envt, EvalObj *params); + Pair *call(Pair *args, Environment * &envt, + Continuation * &cont, FrameObj ** &top_ptr); + ReprCons *get_repr_cons(); +};/*}}}*/ + +/** @class SpecialOptObj + * Special builtin syntax (`if`, `define`, `lambda`, etc.) + */ +class SpecialOptObj: public OptObj {/*{{{*/ + protected: + string name; + public: + SpecialOptObj(string name); +};/*}}}*/ + +/** @class BuiltinProcObj + * Wrapping class for builtin procedures (arithmetic operators, etc.) + */ +class BuiltinProcObj: public OptObj {/*{{{*/ + private: + /** The function that tackle the inputs in effect */ + BuiltinProc handler; + string name; + public: + /** + * Make a BuiltinProcObj which invokes proc when called + * @param proc the actual handler + * @param name the name of this built-in procedure + */ + BuiltinProcObj(BuiltinProc proc, string name); + Pair *call(Pair *args, Environment * &envt, + Continuation * &cont, FrameObj ** &top_ptr); + ReprCons *get_repr_cons(); +};/*}}}*/ + +/** @class BoolObj + * Booleans + */ +class BoolObj: public EvalObj {/*{{{*/ + public: + bool val; /**< true for \#t, false for \#f */ + BoolObj(bool); /**< Converts a C bool value to a BoolObj*/ + bool is_true(); /**< Override EvalObj `is_true()` */ + ReprCons *get_repr_cons(); + /** Try to construct an BoolObj object + * @return NULL if failed + */ + static BoolObj *from_string(string repr); +};/*}}}*/ + +/** @class NumObj + * The top level abstract of numbers + */ + +class NumObj: public EvalObj {/*{{{*/ + protected: + /** True if the number is of exact value */ + bool exactness; + public: + /** The level of the specific number. The smaller the level + * is, the more generic that number is. + */ + NumLvl level; + + /** + * Construct a general Numeric object + */ + NumObj(NumLvl level, bool _exactness); + bool is_exact(); + virtual NumObj *convert(NumObj *r) = 0; + virtual NumObj *add(NumObj *r) = 0; + virtual NumObj *sub(NumObj *r) = 0; + virtual NumObj *mul(NumObj *r) = 0; + virtual NumObj *div(NumObj *r) = 0; + virtual NumObj *abs(); + + virtual bool lt(NumObj *r); + virtual bool gt(NumObj *r); + virtual bool le(NumObj *r); + virtual bool ge(NumObj *r); + virtual bool eq(NumObj *r) = 0; +};/*}}}*/ + +/** @class StrObj + * String support + */ +class StrObj: public EvalObj {/*{{{*/ + public: + string str; + + /** Construct a string object */ + StrObj(string str); + /** Try to construct an StrObj object + * @return NULL if failed + */ + static StrObj *from_string(string repr); + bool lt(StrObj *r); + bool gt(StrObj *r); + bool le(StrObj *r); + bool ge(StrObj *r); + bool eq(StrObj *r); + ReprCons *get_repr_cons(); +};/*}}}*/ + +/** @class CharObj + * Character type support + */ +class CharObj: public EvalObj {/*{{{*/ + public: + char ch; + + /** Construct a string object */ + CharObj(char ch); + /** Try to construct an CharObj object + * @return NULL if failed + */ + static CharObj *from_string(string repr); + ReprCons *get_repr_cons(); +};/*}}}*/ + + +/** + * @class VecObj + * Vector support (currently a wrapper of STL vector) + */ +class VecObj: public EvalObj {/*{{{*/ + public: + EvalObjVec vec; + /** Construct a vector object */ + VecObj(); + size_t get_size(); + EvalObj *get_obj(int idx); + /** Resize the vector */ + void resize(int new_size); + /** Add a new element to the rear */ + void push_back(EvalObj *new_elem); + ReprCons *get_repr_cons(); +};/*}}}*/ + +/** + * @class PromObj + * Promise support (partial) + */ +class PromObj: public EvalObj {/*{{{*/ + private: + Pair *entry; + EvalObj *mem; + public: + PromObj(EvalObj *exp); + Pair *get_entry(); + EvalObj *get_mem(); + void feed_mem(EvalObj *res); + ReprCons *get_repr_cons(); +};/*}}}*/ + +/** @class Environment + * The environment of current evaluation, i.e. the local variable binding + */ +class Environment {/*{{{*/ + private: + Environment *prev_envt; /**< Pointer to the upper-level environment */ + Str2EvalObj binding; /**< Store all pairs of identifier and its + corresponding obj */ + public: + /** Create an runtime environment + * @param prev_envt the outer environment + */ + Environment(Environment *prev_envt); + /** Add a binding entry which binds sym_obj to eval_obj + * @param def true to force the assignment + * @return when def is set to false, this return value is true iff. the + * assignment carried out successfully + */ + bool add_binding(SymObj *sym_obj, EvalObj *eval_obj, bool def = true); + /** Extract the corresponding EvalObj if obj is a SymObj, or just + * simply return obj as it is + * @param obj the object as request + * */ + EvalObj *get_obj(EvalObj *obj); +};/*}}}*/ + +/** @class Continuation + * Save the registers and necessary information when a user-defined call is + * being made (Behave like a stack frame in C). When the call has accomplished, + * the system will restore all the registers according to the continuation. + */ +class Continuation {/*{{{*/ + public: + /** Linking the previous continuation on the chain */ + Continuation *prev_cont; + Environment *envt; /**< The saved envt */ + Pair *pc; /**< The saved pc */ + /** Pointing to the current expression that is being evaluated. + * When its value goes to empty_list, the call is accomplished. + */ + Pair *proc_body; + + /** Create a continuation */ + Continuation(Environment *envt, Pair *pc, Continuation *prev_cont, + Pair *proc_body); +};/*}}}*/ + +/** @class InexactNumObj + * Inexact number implementation (using doubles) + */ +class InexactNumObj: public NumObj {/*{{{*/ + public: + InexactNumObj(NumLvl level); +};/*}}}*/ + +/** @class CompNumObj + * Complex numbers + */ +class CompNumObj: public InexactNumObj {/*{{{*/ + public: + double real, imag; + + /** Construct a complex number */ + CompNumObj(double _real, double _imag); + /** Try to construct an CompNumObj object + * @return NULL if failed + */ + static CompNumObj *from_string(string repr); + /** Convert to a complex number from other numeric types */ + CompNumObj *convert(NumObj* obj); + + NumObj *add(NumObj *r); + NumObj *sub(NumObj *r); + NumObj *mul(NumObj *r); + NumObj *div(NumObj *r); + bool eq(NumObj *r); + ReprCons *get_repr_cons(); +};/*}}}*/ + +/** @class RealNumObj + * Real numbers + */ +class RealNumObj: public InexactNumObj {/*{{{*/ + public: + double real; + /** Construct a real number */ + RealNumObj(double _real); + /** Try to construct an RealNumObj object + * @return NULL if failed + */ + static RealNumObj *from_string(string repr); + /** Convert to a real number from other numeric types */ + RealNumObj *convert(NumObj* obj); + + NumObj *add(NumObj *r); + NumObj *sub(NumObj *r); + NumObj *mul(NumObj *r); + NumObj *div(NumObj *r); + NumObj *abs(); + bool lt(NumObj *r); + bool gt(NumObj *r); + bool le(NumObj *r); + bool ge(NumObj *r); + bool eq(NumObj *r); + ReprCons *get_repr_cons(); + +};/*}}}*/ + + +/** @class ExactNumObj + * Exact number implementation (using gmp) + */ +class ExactNumObj: public NumObj {/*{{{*/ + public: + ExactNumObj(NumLvl level); +};/*}}}*/ + +/** @class RatNumObj + * Rational numbers + */ +class RatNumObj: public ExactNumObj {/*{{{*/ + public: +#ifndef GMP_SUPPORT + int a, b; + /** Construct a rational number */ + RatNumObj(int _a, int _b); +#else + mpq_class val; + RatNumObj(mpq_class val); +#endif + /** Try to construct an RatNumObj object + * @return NULL if failed + */ + static RatNumObj *from_string(string repr); + /** Convert to a Rational number from other numeric types */ + RatNumObj *convert(NumObj* obj); + + NumObj *add(NumObj *r); + NumObj *sub(NumObj *r); + NumObj *mul(NumObj *r); + NumObj *div(NumObj *r); + NumObj *abs(); + bool lt(NumObj *r); + bool gt(NumObj *r); + bool le(NumObj *r); + bool ge(NumObj *r); + bool eq(NumObj *r); + ReprCons *get_repr_cons(); +};/*}}}*/ + +/** @class IntNumObj + * Integers + */ +class IntNumObj: public ExactNumObj {/*{{{*/ + public: +#ifndef GMP_SUPPORT + int val; + /** Construct a integer */ + IntNumObj(int val); + int get_i(); +#else + mpz_class val; + /** Construct a integer */ + IntNumObj(mpz_class val); + int get_i(); +#endif + /** Try to construct an IntNumObj object + * @return NULL if failed + */ + static IntNumObj *from_string(string repr); + /** Convert to a integer from other numeric types */ + IntNumObj *convert(NumObj* obj); + + NumObj *add(NumObj *r); + NumObj *sub(NumObj *r); + NumObj *mul(NumObj *r); + NumObj *div(NumObj *r); + NumObj *abs(); + NumObj *mod(NumObj *r); + NumObj *rem(NumObj *r); + NumObj *quo(NumObj *r); + NumObj *gcd(NumObj *r); + NumObj *lcm(NumObj *r); + bool lt(NumObj *r); + bool gt(NumObj *r); + bool le(NumObj *r); + bool ge(NumObj *r); + bool eq(NumObj *r); + ReprCons *get_repr_cons(); +};/*}}}*/ + +bool is_zero(double); +#endif |