オレオレLisp処理系を実装してみた(2日目)

Lisp処理系の実装メモ2日目です。(1日目、3日目)

例によって最後にその日の最後の時点くらいのコードを載せますが、
結構がっつり書き換えたりしてるんで、あんまりメモ内の記述と整合性がないかもしれません。あくまで参考ということで。




== 2日目 ==

evalにむけて少し関数を書いてたけど eval より reader のほうが先か、ということでreaderを実装する。

最初カッコの対応つけるのに、カッコのネストレベルを
渡すようなインターフェースにしてたんだけど、
printer同様'('を読んだらread_list()に飛んでそいつは
reader()を呼ぶ、という感じで再帰的な感じで書くと、スッキリできた。
再帰的に作ってやればread_list()が同一レベルのカッコの対応に責任を持つことが
できるので、 そもそもネストのレベルなんて見なくてもread_list()でEOFか
reader()本体で')'を読んだ時点カッコ対応 の不備を検出できる。
read自体はread_list(), read_string(), read_symbol()とかへのディスパッチャ
のみって感じ。

どうでもいいけど相互再帰ってハノイの塔みたいなある種の再帰関数を書くときの
不思議な感覚はあんましないね。パーツとしてはそれぞれ完成してる、あるいは
別物に見えるからかな。

しかしLispのパーサは書いてみると非常に簡単だった
他のパーサを真面目に書いたことないけど、何種類もの予約語とそれに
対応する何種類もの構文の正しさを検証するとか考えただけでめんどくさそう。
一方Lispは(パーサにとっての)構文はシンボルかリストのみだからなー。
しかも意味論的構文は基本的にapplyで、例外的な特殊形式があるとは言え、そのへんはevalが計らってくれるわけだからreaderはほんと何もしなくていい。
抽象度の高いプログラミング言語の中では他に類を見ないほど簡単なんじゃ無かろうか。
よく「Lispを実装するのは簡単」というのはパーサの難易度が低いことに起因してる
のかも。

**

reader の次は eval を書く。

evalのインターフェースは
lptr eval(const lptr& expr, const lptr& env);
exprはS式、つまりリスト(ConsかTHE_NIL)かアトム(Symbol, String, Fixnumのどれか)
が入ってくる。envのほうはもちろんEnv, applyをまだ実装してないので
今のところTHE_ENVIRONMENTしか入ってこない。

中身はとりあえずisAtomでアトムかCons or Listじゃないことを判定できるようにして、
アトムの場合はシンボルが指すオブジェクトを探して返す。

ここに来て、 reader で String, Fixnum を読んだときは Symbol としてではなく
直接それぞれのクラスを生成してreaderの結果で返すS式に埋め込んでやるほうが
良さそうだなと気づく。なので一旦readerをそのように改造し、evalのほうは結局
アトムの場合でかつシンボルの場合はそれが指すオブジェクトを探して返し、
シンボルじゃなければそのまま返すようにした。

途中でFixnumとかにはスーパークラスとしてSelfEvaluateみたいなクラスが
必要かなと思って書いてみたが、SelfEvaluateをevalするときに自分を返す以外
することが何もないので結局アトムでシンボルでなければ自身として評価される、
という理解でよさそう。

**

evalの続き。

さて、exprがアトムじゃなければ関数か特殊形式なので、
オペレータ＋オペランドなS式とみなして処理すればよさげ。

オペレータが関数か特殊形式でオペランドの評価順序が変わるので
たぶんまずオペレータ位置にあるS式だけ eval し、その後その評価結果が
関数か特殊形式かで分岐させてみる。

特殊形式は Syntax クラスとし、それを親として持つ SpecialForm クラスで
組み込みの特殊形式を表す。もうひとつのサブクラスとしてMacroを作るつもりだけど
今は置いとく。
一方、関数のほうは Proc クラスとして、それを親として持つ PrimitiveProc と
CompoundProc を作る。Syntax と Proc は名前の他はそれぞれ eval_syntax, apply という
純仮想関数を持たせてサブクラスで実装を強制させる。
Syntax は virtual lptr eval_syntax(lptr& args, lptr& env) = 0;
Proc は virtual lptr apply(lptr& values) = 0;
て感じ。

関数のほうのapplyに env がなくなっていいのか自身ないけど、
apply に渡すオペランドは先に全部 eval した結果として渡すので
現時点の環境はいらないはず。
CompoundProcは評価時に環境が必要になるけど、それは関数の
オブジェクト生成時の環境と、引数から作る新しい環境のはずなので問題ないはず
evalから環境を渡して使っちゃうと、レキシカルスコープにならず、
ダイナミックスコープになっちゃう気がするし。

結局オペレータが Syntax の場合はすぐにその eval_syntax() に渡す。
関数の場合、S式のcdrにあるS式を1個ずつ個別に評価してリストにして返す関数
eval_apply_values()に渡し、その結果を関数の apply() に渡してやる。
これで
「特殊形式は引数の eval の順序が不定なので個別の場合で評価する」
「関数は引数を全部評価してからオペレータをapplyする」
という動きになるはず。

各特殊形式やeval_apply_values()では eval を呼ぶことになるので(相互再帰)、
コードの実行パスとしては相当複雑なはずだが、evalのコード自体はかなり
シンプルになっている。readerと似てるな。
というか再帰が持つ抽象化力がすごいってことか。

とりあえずPrimitiveProcのインスタンスとしてFixnum同士を足し算する
prm_add_fixnum のみ定義しとく。
あとはS式操作用の cons, car, cdr, nreverse とかも
function<lptr(lptr& args)> なインターフェースになるよう
prmcons, prmcar, prmcdr などを定義しておく。

register_primitive_proc(std::string, function<lptr(lptr& args)>) という
組み込み関数登録用の関数を作って
シンボル"+"とか"CAR"の実体が各prm関数を指すよう THE_ENVIRONMENT に登録
できるようにし、 main() の初期に登録処理を書く。

あとシンボルらしきトークンをreaderで読み込んだときに、全部大文字化して
シンボルを生成するようにした。

特殊形式は一個も登録してないのだが、これで (+ 1 1) は動くはずなので
REPLを実装して動かしてみる。

(+ 1 1)
2

動いた!
すんなりいって嬉しい ( ´∀｀)

次は "CONS"(prmcons) や "CAR"(prmcar), "CDR"(prmcdr) の動きを見る。
動かないｗ
prmcons は想定通りだが prmcar, prmcons がちゃんと動かない。

 * (cons 1 2)
=> (1 . 2)
 * (car (cons 1 2))
=> (1 . 2)
 * (cdr (cons 1 2))
=> NIL

とりあえず apply するときにリストが1個余計にくるんでいるみたいだ。
もしかしたら cons がおかしいのかもと思って大急ぎで
特殊形式 quote を実装してreaderで読んだS式をわたして見るがやっぱり変。
よくわからんので逃避的に ' を読んだら次のS式<next>を読んで (quote <next>) に
変換する処理を reader に実装したりした。
('はREADが読んだ直後(quote ...)に変換するっていろんなとこで読んだ気がするので)

ここで nreverse を組み込み関数として登録した REVERSE! の動きがおかしいことに
気づく。

 * (reverse! '(1 2 3 4))
=> ((1 2 3 4))

eval_apply_values()で呼んでる nreverse がアカンのかと思って
reverseを実装してそれと交換してみたりしたんだけどダメ。

prm* の書き方が悪いのかとも思うが prmcons はちゃんと動いてるし
意味がわからん。

進まないので T のクラスになる True やインスタンスの THE_T を作ったりした。
さらにこのバグはほっといてquote以外の特殊形式を実装する。

プリミティブな特殊形式は function<lptr(lptr&, lptr&)>というシグニチャで実装し、
SpecialFormクラスにもたせるだけ。
register_primitive_proc() と同様、register_specialform() という
インスタンス生成 && THE_ENVIRONMENT 登録用関数を作ってmain開始直後に
シンボルと結びつける。

とりあえず初期から適当に実装してるのが begin, cond, lambda あたり。
begin と cond は、最初に実装してたバージョンほぼそのままで正しく動いた。

lambda は CompoundProc をインスタンス化するだけだけど、 CompoundProc の
構造とその apply には PrimitiveProc と違って少し工夫がいる。
合成関数というかlambdaの適用で何をするのか、を整理してみると
1. 関数定義時の環境を外側の環境フレームとして新しい環境を作る
2. 関数の仮引数(lambda式の第1引数)リストのシンボルを環境に登録する
3. 関数の実引数(applyの引数で渡されたもの)をそれぞれ2のシンボルにセットする
4. lambda の body 部を今作った新しい環境でeval する。
となる。というわけで、lambda のインスタンスである CompoundProcには
* インスタンス作成時の環境フレーム
* 仮引数リスト
* ボディ
を保持しとけば良さそうだ。

apply も上の4ステップを素直に実装に落として完成。


 * ((lambda (x) (+ x x)) 5)
=> #<Error: Cannot Evaluate: 10>

lambda自身は動いているようだがおかしい。
リストになってるぽくてprmcarの問題と同じニオイがする。

prmcarとあわせていろいろ試してみたがわからず。

疲れたので以上で2日目は終わり
クラス構成は以下。

class LObj
class True : virtual public LObj
class TrueInstance : public True
class Error : public True
class List : virtual public LObj
class Nil : public List
class Cons : public True, public List
class String : public True
class Fixnum : public True
class Symbol : public True
class Env : public True
class Proc : public True
class PrimitiveProc : public Proc
class CompoundProc : public Proc
class Syntax : public True
class SpecialForm : public Syntax

コードは以下の通り。次の日のメモはこちら

	/*-
	* 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;
	}

view raw toylisp-day2.cc hosted with ❤ by GitHub