toylisp-day2.cc

/*-
 * Copyright (c) 2014 Katsuyuki Tateishi <kt@wheel.jp>
 * All rights reserved.
 *
 * Redistribution and use in source and binary forms, with or without
 * modification, are permitted provided that the following conditions
 * are met:
 * 1. Redistributions of source code must retain the above copyright
 *    notice, this list of conditions and the following disclaimer.
 * 2. Redistributions in binary form must reproduce the above copyright
 *    notice, this list of conditions and the following disclaimer in the
 *    documentation and/or other materials provided with the distribution.
 *
 * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
 * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
 * ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
 * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
 * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
 * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
 * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
 * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
 * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
 * SUCH DAMAGE.
 *
 */
#define dbg(...) fprintf(stderr,__VA_ARGS__)
#define dpr(x) cerr<<"*DBG: "<<#x<<": "<<x<<endl;
#define dprc(c) do{cerr<<#c<<":";for(auto&_i:(c)){cerr<<" "<<_i;}cerr<<endl;}while(0)
#include <bits/stdc++.h>
using namespace std;
typedef pair<int, int> pii;
typedef vector<int> vi;
typedef vector<vi> vvi;
int INF = 1e9+7;
#define all(c) begin(c), end(c)
#define tr(i,c) for(auto i=begin(c);i!=end(c);i++)
#define rtr(i,c) for(auto i=(c).rbegin();i!=(c).rend();i++)
#define rep(i,b) for(auto i=0;i<(b);i++)
#define pb push_back
#define sz(c) int((c).size())

class LObj {
public:
  virtual ~LObj() {}
  virtual string str() const = 0;
  template <typename T> T *rawptr() {
    return dynamic_cast<T *>(this);
  }

  template <typename T> bool eqtype() {
    return typeid(T) == typeid(*this);
  }

  template <typename T> bool isa() {
    return dynamic_cast<T *>(this) != nullptr;
  }
};

typedef shared_ptr<LObj> lptr;
typedef function<lptr(const lptr&)> primfunc_t;
typedef function<lptr(const lptr&, const lptr&)> specialform_t;

lptr eval(const lptr& expr, const lptr& env);

bool eq(const lptr& l, const lptr& r) {
  return l.get() == r.get();
}

template <typename T>
bool eqtype(const lptr& p) {
  return typeid(T) == typeid(*p);
}

template <typename T>
T *rawptr(const lptr& p) {
  return dynamic_cast<T *>(p.get());
}

template <typename T>
bool isa(const lptr& p) {
  return rawptr<T>(p) != nullptr;
}

class True : virtual public LObj {
public:
  virtual string str() const { return "T"; }
};

const lptr THE_T(new True());

class Error : public True {
private:
  string name;
public:
  Error(const string& s) : name(s) {}
  virtual string str() const {
    return "#<Error: " + name + ">";
  }
};

lptr makeError(const string& s) {
  return lptr(new Error(s));
}

class List : virtual public LObj {
public:
};

bool isList(const lptr& p) { return isa<List>(p); }

class Nil : public List {
public:
  Nil() {}
  virtual string str() const { return string("NIL"); }
};
const lptr THE_NIL(new Nil());

bool isNIL(const lptr& p) { return eq(p, THE_NIL); }

class Cons : public True, public List {
private:
  lptr car;
  lptr cdr;
public:
  Cons(const lptr& a, const lptr& d) : car(a), cdr(d) {}

  lptr getcar() const { return car; }
  lptr getcdr() const { return cdr; }

  void setcar(const lptr& val) { car = val; }
  void setcdr(const lptr& val) { cdr = val; }

  virtual string str() const {
    return string("(" + car->str() + " . " + cdr->str() + ")");
  }
};

bool isCons(const lptr& p) {
  return eqtype<Cons>(p);
}

lptr makeCons(const lptr& x, const lptr& y) {
  return lptr(new Cons(x, y));
}

lptr prmcar(const lptr& p) {
  return p->rawptr<Cons>()->getcar();
}

lptr prmcdr(const lptr& p) {
  return p->rawptr<Cons>()->getcdr();
}

lptr prmcadr(const lptr& p) {
  return prmcar(prmcdr(p));
}

lptr prmcons(const lptr& args) {
  return makeCons(prmcar(args), prmcadr(args));
}

lptr set_car(const lptr& c, const lptr& val) {
  c->rawptr<Cons>()->setcar(val);
  return c;
}

lptr prmset_car(const lptr& args) {
  return set_car(prmcar(args), prmcadr(args));
}

lptr set_cdr(const lptr& c, const lptr& val) {
  c->rawptr<Cons>()->setcdr(val);
  return c;
}

lptr prmset_cdr(const lptr& args) {
  return set_cdr(prmcar(args), prmcadr(args));
}

lptr prmnreverse(const lptr& p) {
  lptr acc, lst, head, rest;

  acc = THE_NIL;
  lst = p;
  while (!isNIL(lst)) {
    rest = prmcdr(lst);
    acc = set_cdr(lst, acc);
    lst = rest;
  }
  return acc;
}

bool isAtom(const lptr& p) {
  return isNIL(p) || !isList(p);
}

class String : public True {
private:
  string val;
public:
  String(const string& s) : val(s) {}

  virtual string str() const {
    return val;
  }
};

lptr makeString(const string& s) {
  return lptr(new String(s));
}

class Fixnum : public True {
private:
  int val;
public:
  Fixnum(const string& s) {
    val = stoi(s);
  }

  Fixnum(int i) {
    val = i;
  }

  int value() {
    return val;
  }

  virtual string str() const {
    return to_string(val);
  }
};

lptr makeFixnum(const string& s) {
  return lptr(new Fixnum(s));
}

class Symbol : public True {
private:
  string name;

public:
  Symbol(string str) {
    name = str;
  }

  virtual string str() const {
    return name;
  }
};

bool isSymbol(const lptr& p) {
  return eqtype<Symbol>(p);
}

unordered_map<string, const lptr> THE_SYMBOL_TABLE;

lptr makeSymbol(const string& s) {
  return lptr(new Symbol(s));
}

lptr getSymbol(const string& s) {
  auto got = THE_SYMBOL_TABLE.find(s);
  if (got != end(THE_SYMBOL_TABLE)) {
    return got->second;
  } else {
    lptr res = makeSymbol(s);
    THE_SYMBOL_TABLE.emplace(s, res);
    return res;
  }
}

class Env : public True {
private:
  unordered_map<string, const lptr> hash;
  lptr parent;
public:
  Env() : parent(THE_NIL) {}
  Env(const lptr& p) : parent(p) {}

  lptr get(const string& s) {
    auto ret = hash.find(s);
    if (ret != end(hash)) {
      return ret->second;
    } else if (!isNIL(parent)) {
      return parent->rawptr<Env>()->get(s);
    } else {
      return makeError("Undefined symbol: " + s);
    }
  }

  lptr get(const lptr& sym) {
    return get(sym->rawptr<Symbol>()->str());
  }

  lptr set(const string& s, const lptr& val) {
    auto ret = hash.find(s);
    if (ret != end(hash)) {
      hash.emplace(s, val);
      return val;
    } else if (!isNIL(parent)) {
      return parent->rawptr<Env>()->set(s, val);
    } else {
      return makeError("Undefined symbol: " + s);
    }
  }

  lptr set(const lptr& sym, const lptr& val) {
    return set(sym->rawptr<Symbol>()->str(), val);
  }

  lptr define(const string& s, const lptr& val) {
    hash.emplace(s, val);
    return val;
  }

  lptr define(const lptr& sym, const lptr& val) {
    return define(sym->rawptr<Symbol>()->str(), val);
  }

  virtual string str() const {
    return string("#<Environment >");
  }
};

template <typename T>
lptr envget(const lptr& env, const T& sym) {
  return rawptr<Env>(env)->get(sym);
}

template <typename T>
lptr envset(const lptr& env, const T& sym, const lptr& val) {
  return rawptr<Env>(env)->set(sym, val);
}

template <typename T>
lptr envdefine(const lptr& env, const T& sym, const lptr& val) {
  return rawptr<Env>(env)->define(sym, val);
}

lptr makeEnv(const lptr& parent) {
  return lptr(new Env(parent));
}

lptr THE_ENVIRONMENT(new Env());

class Proc : public True {
private:
  string name;
public:
  Proc(const string& s) : name(s) {}

  string getname() const { return name; }
  
  void setname(const string& s) {
    name = s;
  }

  virtual string str() const {
    return string("#<Procedure " + name + ">");
  }

  virtual lptr apply(const lptr& values) const = 0;
};

bool isProc(const lptr& p) {
  return isa<Proc>(p);
}

bool isProcForm(const lptr& expr) {
  return isCons(expr) && isProc(prmcar(expr));
}

class PrimitiveProc : public Proc {
private:
  primfunc_t primproc;
public:
  PrimitiveProc(const string& s, primfunc_t f) : Proc(s), primproc(f) {};

  lptr apply(const lptr& values) const {
    return primproc(values);
  }
};

lptr makePrimitiveProc(const string& name, primfunc_t f) {
  return lptr(new PrimitiveProc(name, f));
}

lptr sf_begin(const lptr& args, const lptr& env);
class CompoundProc : public Proc {
private:
  lptr args;
  lptr body;
  lptr env;
public:
  CompoundProc(const string& s, const lptr& a, const lptr& b, const lptr& e) :
    Proc(s), args(a), body(b), env(e) {}

  lptr setupenv(const lptr& env, const lptr& args, const lptr& values) const {
    if (isNIL(args) && isNIL(values)) return THE_NIL;
    if (isNIL(args)) return makeError("Applying Procedure: Too much arguments");
    if (isNIL(values)) return makeError("Applying Procedure: Too few arguments");
    if (args->eqtype<Cons>()) {
      envdefine(env, prmcar(args), prmcar(values));
      return setupenv(env, prmcdr(args), prmcdr(values));
    } else {
      envdefine(env, args, values);
      return THE_NIL;
    }
  }

  lptr apply(const lptr& values) const {
    lptr newenv = makeEnv(env);
    lptr status = setupenv(newenv, args, values);
    if (status->isa<Error>()) {
      return status;
    } else {
      return sf_begin(body, newenv);
      return eval(body, newenv);
    }
  }
};

lptr makeCompoundProc(const string& name, const lptr& args,
                                    const lptr& body, const lptr& env) {
  return lptr(new CompoundProc(name, args, body, env));
}

lptr prm_plus(const lptr& args) {
  lptr rest;
  int res = 0;

  for (rest = args; !isNIL(rest); rest = prmcdr(rest)) {
    Fixnum *tmp = rawptr<Fixnum>(prmcar(rest));
    res += tmp->value();
  }
  return lptr(new Fixnum(res));
}

lptr prm_multiply(const lptr& args) {
  lptr rest;
  int res = 1;

  for (rest = args; !isNIL(rest); rest = prmcdr(rest)) {
    Fixnum *tmp = rawptr<Fixnum>(prmcar(rest));
    res *= tmp->value();
  }
  return lptr(new Fixnum(res));
}

/*
 * Syntax
 */
class Syntax : public True {
private:
  string name;
public:
  Syntax(const string& s) : name(s) {}

  string getname() const { return name; }
  
  void setname(const string& s) {
    name = s;
  }

  virtual string str() const {
    return string("#<Syntax " + name + ">");
  }

  virtual lptr eval_syntax(const lptr& expr, const lptr& env) const = 0;
};

bool isSyntax(const lptr& p) {
  return isa<Syntax>(p);
}

bool isSyntaxForm(const lptr& expr) {
  return isCons(expr) && isSyntax(prmcar(expr));
}

class SpecialForm : public Syntax {
private:
  specialform_t sf;
public:
  SpecialForm(const string& s, specialform_t f) : Syntax(s), sf(f) {}

  lptr eval_syntax(const lptr& expr, const lptr& env) const {
    return sf(expr, env);
  }
};

lptr makeSpecialForm(const string& s, specialform_t f) {
  return lptr(new SpecialForm(s, f));
}

lptr sf_begin(const lptr& args, const lptr& env) {
  lptr clause, lst, ret;
  ret = THE_NIL;
  for (lst = args; !isNIL(lst); lst = prmcdr(lst)) {
    ret = eval(prmcar(lst), env);
  }
  return ret;
}

lptr sf_cond(const lptr& args, const lptr& env) {
  lptr clause, rest, cond;

  for (rest = args; !isNIL(rest); rest = prmcdr(rest)) {
    clause = prmcar(rest);
    cond = eval(prmcar(clause), env);
    if (isNIL(cond)) continue;
    return sf_begin(prmcdr(clause), env);
  }
  return THE_NIL;
}

lptr sf_quote(const lptr& args, const lptr& env) {
  return args;
}

lptr sf_lambda(const lptr& args, const lptr& env) {
  return makeCompoundProc("Anonymous", prmcar(args), prmcdr(args), env);
}

/*
 * Evaluator
 */

lptr eval_symbol(const lptr& sym, const lptr& env) {
  return envget(env, sym);
}

lptr eval_apply_values(const lptr& expr, const lptr& env) {
  lptr acc, rest, tmp;
  for (acc = THE_NIL, rest = expr; !isNIL(rest); rest = prmcdr(rest)) {
    tmp = eval(prmcar(rest), env);
    if (eqtype<Error>(tmp)) return tmp;
    acc = makeCons(tmp, acc);
  }
  
  //return acc;
  return prmnreverse(acc);
}

lptr eval(const lptr& expr, const lptr& env) {
  if (isAtom(expr)) {
    if (isSymbol(expr)) return eval_symbol(expr, env);
    else return expr;
  } else {
    lptr car = eval(prmcar(expr), env);
    if (isa<Syntax>(car)) {
      return rawptr<Syntax>(car)->eval_syntax(prmcdr(expr), env);
    } else if (isa<Proc>(car)) {
      lptr av = eval_apply_values(prmcdr(expr), env);
      if (eqtype<Error>(av)) {
        return av;
      } else {
        //dpr(av->str());
        return rawptr<Proc>(car)->apply(av);
      }
    } else {
      return makeError("Cannot Evaluate: " + car->str());
    }
  }
}

/*
 * Reader
 */
lptr reader(istream& is);

void read_skip_space(istream& is) {
  char c;

  while (is.get(c)) {
    if (!isspace(c)) {
      is.unget();
      break;
    }
  }
}

lptr read_list(istream& is) {
  char c;
  lptr acc = THE_NIL;

  while (is.get(c)) {
    if (c == ')') {
        break;
    } else {
      is.unget();
      acc = makeCons(reader(is), acc);
    }
  }
  return prmnreverse(acc);
}

lptr read_symbol(istream& is) {
  char c;
  string token;
  bool fixnum = true;
  while (is.get(c)) {
    if (c == '(' || c == ')' || isspace(c)) {
      is.unget();
      break;
    }
    fixnum = (fixnum && isdigit(c));
    token.push_back(toupper(c));
  }
  if (fixnum) {
    return makeFixnum(token);
  } else {
  return getSymbol(token);
  }
}

lptr read_string(istream& is) {
  char c;
  string token;

  while (is.get(c)) {
    if (c == '\\') {
      is.get(c);
    } else if (c == '"') {
      break;
    }
    token.push_back(c);
  }

  return makeString(token);
}

lptr read_quote(istream& is, char q) {
  string quote;

  switch (q) {
  case '\'':
    quote = "QUOTE";
    break;
  case '`':
    quote = "QUASIQUOTE";
    break;
  case ',':
    char c;
    is.get(c);
    if (c == '@') {
      quote = "UNQUOTE-SPLICING";
    } else {
      is.unget();
      quote = "UNQUOTE";
    }
    break;
  }
  return makeCons(getSymbol(quote), reader(is));
}

lptr reader(istream& is) {
  char c;

  read_skip_space(is);
  if (is.get(c)) {
    if (c == '(') {
      return read_list(is);
    } else if (c == ')') {
      return makeError("READ: Additional close paren.");
    } else if (c == '"') {
      return read_string(is);
    } else if (c == '\'' || c == '`' || c == ',') {
      return read_quote(is, c);
    } else {
      is.unget();
      return read_symbol(is);
    }
  }
  return makeError("READ: Recieve EOF.");
}

/*
 * Printer
 */
void printlptr(ostream& os, const lptr& p);

void printCons(ostream& os, const lptr& p) {
  lptr x = prmcar(p);
  lptr rest = prmcdr(p);
  printlptr(os, x);
  if (isNIL(rest)) {
    return;
  } else if (eqtype<Cons>(rest)) {
    os << " ";
    printCons(os, rest);
  } else {
    os << " . ";
    printlptr(os, rest);
  }
}

void printString(ostream& os, const lptr& p) {
  for (auto& c:p->str()) {
    if (c == '"') os << '\\';
    os << c;
  }
}

void printlptr(ostream& os, const lptr& p) {
  if (eqtype<Cons>(p)) {
    os << "(";
    printCons(os, p);
    os << ")";
  } else if (eqtype<String>(p)) {
    os << "\"";
    printString(os, p);
    os << "\"";
  } else {
    os << p->str();
  }
}

ostream& operator<<(ostream& os, const lptr& p) {
  printlptr(os, p);
  return os;
}


void register_specialform(const string& name, specialform_t sf) {
  lptr sym = getSymbol(name);
  envdefine(THE_ENVIRONMENT, sym, makeSpecialForm(name, sf));
}

void register_primitive_proc(const string& name, primfunc_t f) {
  lptr sym = getSymbol(name);
  envdefine(THE_ENVIRONMENT, sym, makePrimitiveProc(name, f));
}

void setup_specialforms() {
  register_specialform("BEGIN", sf_begin);
  register_specialform("COND", sf_cond);
  register_specialform("QUOTE", sf_quote);
  register_specialform("LAMBDA", sf_lambda);
}

void setup_primitive_procs() {
  register_primitive_proc("CAR", prmcar);
  register_primitive_proc("CDR", prmcdr);
  register_primitive_proc("CADR", prmcadr);
  register_primitive_proc("CONS", prmcons);
  register_primitive_proc("SET-CAR!", prmset_car);
  register_primitive_proc("SET-CDR!", prmset_cdr);
  register_primitive_proc("REVERSE!", prmnreverse);
  register_primitive_proc("+", prm_plus);
  register_primitive_proc("*", prm_multiply);
}

void setup_self_evaluatings() {
  lptr sym;
  
  sym = getSymbol("NIL");
  envdefine(THE_ENVIRONMENT, sym, THE_NIL);
  sym = getSymbol("T");
  envdefine(THE_ENVIRONMENT, sym, THE_T);
}

void setup() {
  setup_self_evaluatings();
  setup_specialforms();
  setup_primitive_procs();
}


int main(int argc, char **argv) {
  setup();
  while (!cin.eof()) {
    cout << " * ";
    cout.flush();
    lptr val = reader(cin);
    //dpr(val->str());
    //cout << "-> " << val << endl;
    cout << "=> " << eval(val, THE_ENVIRONMENT) << endl;
  }
  /*
  lptr x = lptr(new Fixnum(10));
  lptr y = lptr(new Fixnum(1));
  lptr z = lptr(new Fixnum(3));
  lptr a = lptr(new Fixnum(5));
  lptr b = lptr(new Fixnum(7));
  lptr c = makeCons(x, makeCons(y, makeCons(z, makeCons(a, makeCons(b, THE_NIL)))));

  dpr(THE_NIL);

  dpr(x);
  dpr(x->eqtype<Fixnum>());
  dpr(eqtype<Fixnum>(x));
  dpr(eqtype<Cons>(x));
  cout << endl;
  dpr(y);
  cout << endl;
  dpr(c);
  c = prmnreverse(c);
  dpr(c);
  cout << endl;
  lptr d = makeCons(x, y);
  dpr(d);
  dpr(prmcar(d));
  dpr(prmcdr(d));
  lptr tmp = prmcar(d);
  set_car(d, prmcdr(d));
  set_cdr(d, tmp);
  dpr(d);

  cout << endl;
  //dpr(prm_add_fixnum(x, y));

  cout << endl;
  envdefine(THE_ENVIRONMENT, "LST", c);
  dpr(envget(THE_ENVIRONMENT, "LST"));
  dpr(envget(THE_ENVIRONMENT, "CAR"));

  lptr op = getSymbol("CONS");
  lptr form = makeCons(op, makeCons(x, makeCons(b, THE_NIL)));
  dpr(form);
  dpr(eval(form, THE_ENVIRONMENT));
  */

  return 0;
}