// grenuoille.cpp // #include #include #include #include #include #include #include #include #include #include #include #include //#include "memCheck.h" using namespace std; // TODO: typechecking, ariety, cond, load, contexts // ast ---------------------------------------------------------------------- // class Sexpr; typedef double Real; typedef Sexpr* (*funcptr) (Sexpr* args, Sexpr* env); enum SexprType { NUMBER, SYMBOL, CONS, PROCEDURE, LAMBDA }; class MemoryManager { public: virtual ~MemoryManager (); // lazy implementation static MemoryManager* instance () { static MemoryManager instance; return &instance; } void attach (Sexpr* s) { ++m_alloc; m_collection.push_front (s); } void collect (Sexpr* root) { mark (root); sweep (); } void mark (Sexpr* p); // lazy implementation private: void sweep (); // lazy implementation MemoryManager () { m_alloc = 0; } MemoryManager (MemoryManager const&); void operator= (MemoryManager const&); std::deque m_collection; long m_alloc; }; struct Sexpr { protected: Sexpr () { type = CONS; val = 0; //lexeme = ""; car = cdr = 0; action = 0; mark = false; MemoryManager::instance ()->attach (this); } public: virtual ~Sexpr () {} SexprType type; Real val; std::string lexeme; Sexpr* car; Sexpr* cdr; funcptr action; bool mark; }; struct Number : public Sexpr { Number (Real v) { type = NUMBER; val = v; } }; struct Symbol : public Sexpr { private: Symbol (const std::string& lex) { type = SYMBOL; lexeme = lex; } public: static Symbol* make (const std::string& lex) { static std::map symbols; std::map::iterator it = symbols.find (lex); if (it == symbols.end ()) { Symbol* s = new Symbol (lex); symbols[lex] = s; return s; } return it->second; } }; Symbol* nil = Symbol::make ("nil"); Symbol* true_s = Symbol::make ("#t"); Symbol* false_s = Symbol::make ("#f"); Symbol* quote = Symbol::make ("quote"); Symbol* if_s = Symbol::make ("if"); Symbol* lambda = Symbol::make ("lambda"); Symbol* define = Symbol::make ("define"); Symbol* set_s = Symbol::make ("set!"); Symbol* begin_s = Symbol::make ("begin"); struct Cons : public Sexpr { Cons (Sexpr* car, Sexpr* cdr) { type = CONS; Sexpr::car = car; Sexpr::cdr = cdr; } }; Sexpr* cons (Sexpr* car, Sexpr* cdr) { return new Cons (car, cdr); } struct Procedure : public Sexpr { Procedure (funcptr action, const std::string& lex) { type = PROCEDURE; Sexpr::action = action; lexeme = lex; } }; struct Lambda : public Sexpr { Lambda (Sexpr* body, Sexpr* args, Sexpr* env) { type = LAMBDA; car = env; cdr = cons (body, args); } }; #define car(x)(x->car) #define cdr(x)(x->cdr) #define setcar(x,y)(x->car = y) #define setcdr(x,y)(x->cdr = y) #define isnil(x)(x == 0 || x == nil) void MemoryManager::mark (Sexpr* p) { if (!p) return; if (p->mark == false) { p->mark = true; mark (car (p)); mark (cdr (p)); } } void display (Sexpr* node, std::ostream& out); void MemoryManager::sweep () { std::deque::iterator it = m_collection.begin (); while (it != m_collection.end ()) { Sexpr* elem = *it; if (elem->mark == true) { elem->mark = false; ++it; } else { --m_alloc; // cout << "delete " << elem << " " << endl; delete elem; it = m_collection.erase (it); } } } MemoryManager::~MemoryManager () { sweep (); } // lexing ------------------------------------------------------------------- // void replace (std::string &s, std::string from, std::string to) { int idx = 0; int next; while ((next = s.find (from, idx)) != std::string::npos) { s.replace (next, from.size (), to); idx = next + to.size (); } } std::deque& tokenize (std::string& s, std::deque& result) { replace (s, "(", " ( "); replace (s, ")", " ) "); replace (s, "'", " ' "); std::istringstream iss (s); result.insert (result.end (), std::istream_iterator (iss), std::istream_iterator ()); return result; } template bool isNumber (const char* s) { std::istringstream iss (s); T dummy; iss >> std::noskipws >> dummy; return iss && iss.eof (); } // parsing ------------------------------------------------------------------ // Sexpr* read_cons (std::deque& tokens); Sexpr* read_atom (std::deque& tokens) { std::string token = tokens.front (); tokens.pop_front (); if (token == "(") return read_cons (tokens); else if (token == "'") { return cons (quote, cons (read_atom (tokens), nil)); } else if (isNumber (token.c_str ())) { return new Number (atof (token.c_str ())); } else { return Symbol::make (token); } } Sexpr* read_cons (std::deque& tokens) { if (!tokens.size ()) throw runtime_error ("syntax error"); std::string token = tokens.front (); tokens.pop_front (); if (token == ")") return nil; tokens.push_front (token); Sexpr* tmp = read_atom (tokens); return cons (tmp, read_cons (tokens)); } // evaluation --------------------------------------------------------------- // void display (Sexpr* node, std::ostream& out) { if (isnil (node)) { out << "()"; return; } if (node->type == CONS) { out << "("; for (;;) { display (car (node), out); if (isnil (cdr (node))) { out << ")"; break; } node = cdr (node); if (node->type != CONS) { out << " . "; display (node, out); out << ")"; break; } out << " "; } } else if (node->type == NUMBER) { out << node->val; } else if (node->type == SYMBOL) { out << node->lexeme; } else if (node->type == PROCEDURE) { out << "lexeme << ">"; } else if (node->type == LAMBDA) { std::stringstream body; std::stringstream args; display (cdr(cdr(node)), args); display (car(cdr(node)), body); out << ""; } } Sexpr* assoc (Sexpr* env, Sexpr* symbol) { tail_call: Sexpr* parent = car (env); Sexpr* bs = cdr (env); while (!isnil (bs)) { Sexpr* b = car (bs); if (car (b) == symbol) { return b; } bs = cdr (bs); } if (isnil (parent)) return nil; // return assoc (parent, symbol); env = parent; goto tail_call; } Sexpr* extend (Sexpr* env, Sexpr* symbol, Sexpr* value) { Sexpr* bs = cdr (env); Sexpr* b = assoc (env, symbol); if (b != nil) setcdr (b, value); else { b = cons (symbol, value); setcdr (env, cons (b, cdr (env))); } return value; } Sexpr* null_env = cons (nil, nil); //////////////////////////////////////////////////////////////////////////////// Sexpr* evlis (Sexpr* alist, Sexpr* env); Sexpr* eval (Sexpr* node, Sexpr* env) { static int stack_counter = 0; tail_call: if (isnil (node)) return nil; switch (node->type) { case PROCEDURE: return node; case LAMBDA: return node; case NUMBER: return node; case SYMBOL: { Sexpr* s = assoc (env, node); if (s == nil) { stringstream msg; msg << "unbound symbol " << node->lexeme; throw runtime_error (msg.str ()); } return cdr (s); } case CONS: { if (car (node) == quote) { return car (cdr (node)); } else if (car (node) == if_s) { if (eval (car (cdr (node)), env) != false_s) { node = car (cdr (cdr (node))); } else { Sexpr* b = cdr (cdr (cdr (node))); if (b) node = car (b); else node = false_s; } goto tail_call; } else if (car (node) == lambda) { Sexpr* body = car (cdr (cdr (node))); Sexpr* args = (car (cdr (node))); return new Lambda (body, args, env); } else if (car (node) == begin_s) { node = cdr (node); if (isnil (node)) return nil; for (;;) { if (isnil (cdr (node))) { node = car (node); goto tail_call; } eval (car (node), env); node = cdr (node); } } else if (car (node) == define) { Sexpr* key = car (cdr (node)); Sexpr* val = eval (car (cdr (cdr (node))), env); return extend (env, key, val); } else if (car (node) == set_s) { Sexpr* s = assoc (env, car (cdr (node))); if (s == nil) { stringstream msg; msg << "unbound symbol " << node->lexeme; throw runtime_error (msg.str ()); } Sexpr* val = eval (car (cdr (cdr (node))), env); setcdr (s, val); return val; } #ifdef GARBAGE_COLLECTION if (stack_counter == 0) { MemoryManager::instance ()->mark (null_env); MemoryManager::instance ()->mark (env); MemoryManager::instance ()->collect (node); } #endif Sexpr* fun = eval (car (node), env); ++stack_counter; Sexpr* params = evlis (cdr (node), env); --stack_counter; if (fun->type == PROCEDURE) { return fun->action (params, env); } if (fun->type == LAMBDA) { // static scope = use car (fun) // dynamic scope = use env Sexpr* nenv = cons (car (fun), nil); Sexpr* a = cdr (cdr(fun)); Sexpr* p = params; while (!isnil (a)) { extend (nenv, car (a), car (p)); a = cdr (a); p = cdr (p); } //return eval (fun->body, nenv); node = car(cdr(fun)); env = nenv; goto tail_call; } throw runtime_error ("function expected"); } } // not reached return node; } Sexpr* evlis (Sexpr* alist, Sexpr* env) { if (isnil (alist)) return alist ; return cons (eval (car (alist), env), evlis (cdr (alist), env)); } Sexpr* fn_cons (Sexpr* params, Sexpr* env) { return cons (car (params), car (cdr (params))); } Sexpr* fn_car (Sexpr* params, Sexpr* env) { return car (car (params)); } Sexpr* fn_cdr (Sexpr* params, Sexpr* env) { return cdr (car (params)); } Sexpr* fn_eq (Sexpr* params, Sexpr* env) { return (car (params) == car (cdr (params))) ? true_s : false_s; } Sexpr* fn_add (Sexpr* params, Sexpr* env) { Real r = 0; Sexpr* c = params; while (!isnil (c)) { r += car (c)->val; c = cdr (c); } return new Number (r); } Sexpr* fn_sub (Sexpr* params, Sexpr* env) { Real r = car (params)->val; Sexpr* c = cdr (params); while (!isnil (c)) { r -= car (c)->val; c = cdr (c); } return new Number (r); } Sexpr* fn_mul (Sexpr* params, Sexpr* env) { Real r = 1; Sexpr* c = params; while (!isnil (c)) { r *= car (c)->val; c = cdr (c); } return new Number (r); } Sexpr* fn_div (Sexpr* params, Sexpr* env) { Real r = car (params)->val; Sexpr* c = cdr (params); while (!isnil (c)) { r /= car (c)->val; c = cdr (c); } return new Number (r); } Sexpr* fn_same_value (Sexpr* params, Sexpr* env) { Real r = car (params)->val; bool equal = true; Sexpr* c = cdr (params); while (!isnil (c)) { equal = (r == car (c)->val); r = car (c)->val; c = cdr (c); } return equal ? true_s : false_s; } Sexpr* fn_env (Sexpr* params, Sexpr* env) { return env; } Sexpr* fn_display (Sexpr* params, Sexpr* env) { display (car (params), cout); cout << endl; return car (params); } int main (int arcollect, char* argv[]) { try { extend (null_env, define, define); extend (null_env, quote, quote); extend (null_env, if_s, if_s); extend (null_env, lambda, lambda); extend (null_env, begin_s, begin_s); Sexpr* env = cons (nil, nil); extend (env, nil, nil); extend (env, true_s, true_s); extend (env, false_s, false_s); extend (env, Symbol::make ("cons"), new Procedure (fn_cons, "cons")); extend (env, Symbol::make ("car"), new Procedure (fn_car, "car")); extend (env, Symbol::make ("cdr"), new Procedure (fn_cdr, "cdr")); extend (env, Symbol::make ("eq?"), new Procedure (fn_eq, "eq?")); extend (env, Symbol::make ("+"), new Procedure (fn_add, "+")); extend (env, Symbol::make ("-"), new Procedure (fn_sub, "-")); extend (env, Symbol::make ("*"), new Procedure (fn_mul, "*")); extend (env, Symbol::make ("/"), new Procedure (fn_div, "/")); extend (env, Symbol::make ("="), new Procedure (fn_same_value, "=")); extend (env, Symbol::make ("interaction-environment"), new Procedure (fn_env, "interaction-environment")); extend (env, Symbol::make ("display"), new Procedure (fn_display, "display")); Sexpr* e = nil; #ifdef TEST string line = "(define fib (lambda (n)(if (= n 0) 0 (if (= n 1) 1 (+ (fib (- n 1)) (fib (- n 2)))))))"; deque tokens; Sexpr* r = read_atom (tokenize (line, tokens)); e = eval (r, env); line = "(fib 30)"; r = read_atom (tokenize (line, tokens)); clock_t tic = clock (); e = eval (r, env); clock_t toc = clock (); cout << "performance: "<< ((double) toc - tic) / CLOCKS_PER_SEC << " sec." << endl; cout << "result: "; display (e, cout); cout << endl; cout << "press return..."; getchar (); #else while (true) { try { cout << ">> "; string line; getline (cin, line); if (!line.size ()) continue; deque tokens; Sexpr* r = read_atom (tokenize (line, tokens)); e = eval (r, env); display (e, cout); cout << endl; if (tokens.size ()) cout << "warning: " << tokens.size () << " unparsed element(s)" << endl; } catch (runtime_error& e) { cout << "error: " << e.what () << endl; } } #endif } catch (exception& e) { cout << "Error: " << e.what () << endl; } catch (...) { cout << "Fatal error: unknown exception" << endl; } return 0; } // EOF