2014年12月23日火曜日

オレオレLisp処理系を実装してみた(3日目=最終日)


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

実装メモとしてはこれが最終日になりますが、感想などのまとめを次の記事としてのせるつもりです。

例によってコードは一番下に載せてます。



== 3日目 ==

car, cdr 等が正しく動かない件、lambda が動かない件は両方とも
1日置いたら解決した。

car, cdr, ... のほうの原因は内部でS式を扱ってる関数をユーザに見せる関数prm*()に
ラップするときのミス。
引数が一つのリストにまとめられてくるので、(まさしくapplyされる状態なので)
それを受け取る側の実装は
lptr prmcar(const lptr& args) { return car(car(args)); }
lptr prmcdr(const lptr& args) { return cdr(car(args)); }
しなきゃいかんのに
lptr prmcar(const lptr& args) { return car(args); }
lptr prmcdr(const lptr& args) { return cdr(args); }
としてた。(2日目はここのcar相当がprmcarという名前であり、それを
そのままシンボル"CAR"にも登録してた)
アホすぎる。

prmconsはちゃんと
lptr prmcons(const lptr& args) { return cons(car(args), cadr(args)); }
してて、たぶんもともとcons()が2引数なので注意深くやってたらしい。
nreverseとかも同様。

**

lambda が動かないほうは、apply の最後で body 部を sf_begin で評価すべきところ
eval を呼んでたのが原因だった。

しかしアホなバグで悩んだものだが、おかげで reader や printer が充実した
(デバッグの過程でいろいろ整理できた)ので良しとしよう。

続いてsf_define をさくっと実装。 MIT形式は非対応。道具は揃ってるので簡単。

**

そろそろ竹内関数も実装できそうなので実装してみる。
cond があればいいかと思ってたが、macroが書けるようになるのは先っぽいので
sf_if を実装。 Fixnum の演算用の関数もとりあえず実装してなんとか
tak 定義ができた。
で、実行したところ・・・

遅いw (tak 12 6 0) が終わらないどころか (tak 10 5 0) も 2秒ぐらい
かかる感じ。

プロファイルとってみたら C++ の dynamic_cast とstrcmp()っぽい内部関数が
かなりの割合を占めていた。 なんでやー、と思って Effective C++ 引っ張りだして
眺めてたら
* dynamic_cast は遅いぞ。中で何回もクラス名を strcmp() で比較するからな！
* shared_ptr 使ってるなら 派生クラスごとに shared_ptr を用意するか
  基底クラスに派生クラスの全メソッドvirtual定義しとけやボケ
ってそのものズバリなのが書いてあって、見事にアンチパターンにはまってたｗ
Effective C++は偉大である。

直すか・・・いや、unionで即値と要GCオブジェクトをわけて再実装したほうが、
とかいろいろ別方向のモチベーションが高まってしまったが、
そもそも関数作るときにbodyを構成するS式はシンボルのまま解決してなかったり、
他にもいろいろ遅くなる原因はたくさんありそげでキリがないし、
とりあえずマクロ組めるところまでこのまま実装することにする。

**

ここらで Emacs の Scheme モードで動かしてみることにする。

何の工夫もなく普通に動いた。
コードは変更しまくるので自分自身を exec で OS プロセス的に再起動するような
"RESTART"コマンドを書く。

**

マクロを実装するまえにとりあえず QUASIQUOTE と UNQUOTE を充実させる。
が、'`(foo ,x) とかを評価すると
 * '`(foo ,x)
=> (QUASIQUOTE FOO (UNQUOTE . X))
となってしまってダサいので、ちゃんと
`(foo ,x) と出して欲しい。

QUASIQUOTE や UNQUOTE のシンボル自体を printlptr で特別扱いしてしまうと、
本当に QUASIQUOTE などのシンボルとして出力したいときにできなくなってしまうので、
 reader で読み込んだ時点で eval を呼んで Syntax オブジェクトとしてパースしたS式に
埋め込むことにした。ついでにQUOTEも同じ扱いにする。reader内で
evalを呼ぶのがやな感じなのでグローバル変数経由に後で変更するかも。

 * '`(foo ,x)
=> `(FOO ,X)

うまく動くようだ。QUASIQUOTE, UNQUOTE のネスト対応チェックとか(必要性の
検討も含めて)真面目にやってないけどとりあえずよしとする。

UNQUOTEなどがちゃんと出力されるようになったので、
ついでに sf_lambda をシンボル "^" にも対応させて

 * ((^ (^) `(,^ ',^)) '(^ (^) `(,^ ',^)))
=> ((^ (^) `(,^ ',^)) '(^ (^) `(,^ ',^)))

というQuineを書けるようになったｗ

reader を見てたら read_list で (foo . bar) を読んだときの考慮が
抜けてたのでなおした。

これによって lambda の引数で可変長引数を書いたら正しく動くようになった。

関数の define 時にいちいち lambda と書くのが面倒になったので
define を MIT 形式に対応させる。 Macro はまだない上に、それほど
難しい変換でもないので sf_define 内に実装する。
sf_define に渡ってくる引数の car が Cons だったら、
(define (<name> . <args>) . <body>)
のはずなので、分解して
(define <name> (lambda <args> . <body>))
に再構築、再度 eval に食わせることでこれまでの sf_define
が再帰的に呼びだされて正しく評価される。
特に苦労なく実装完了。

**

次はMacroを実装していく。
Macro のセマンティックから想像して、呼びだされたときにやることを整理してみると:
1 eval_syntax 経由でその時点に評価中のS式を渡される
2 自身が保持している変換器(lambda)にS式を食わせて処理する
3 結果がまたS式になっているはずなので、それをevalする。

変換器自体はdefine-macroを評価した時点の環境を持ってればいいはず。
変換器は入力されたS式に現れるシンボルを評価したりはせず、
単なるシンボルのリストとして扱い(つまりマクロ呼び出し時の
環境は不要)、結果としてできたS式をマクロ呼び出し時の環境下で
評価することになるはずだ。

ということで、Macro には変換器となる Proc (lambda)を1個持たせておけばよさげ。
Macor の eval_syntax は上の手順通りに実装。

define-macroの実体となる sf_define_macro は Macro インスタンスを作って THE_ENVIRONMENTに登録するラッパーとして実装。
(本来はDEFINE-MACRO呼び出し時の環境に登録すべきだろうか？)

最後にシンボル "DEFINE-MACRO" を sf_define_macro に対応させ、
実際に使えるようにする。

**

続いてマクロの動作確認。

 * (define-macro (foo x y)
     `(list ,x ,y))
=> #<Syntax FOO>
 * (foo 1 2)
; #<Error: Undefined symbol: LIST>

list を定義してなかったｗ

 * (define (list . x) x)
=> LIST
 * (foo 1 2)
=> (1 2)

おｋ

これ以上複雑な(といってもletとかの)マクロを書くには色々材料が足りないので、
いくつか関数を追加してみる。

例えばシンプルなLETの定義は
(define-macro (let binds . body)
 `((lambda ,(map car binds)
                 ,@body)
         ,@(map cadr binds)))
になるので、mapと, mapのために(ユーザに見せる)apply が必要になる。
結果は:
=============================================================
 * (define (list . x) x)
=> LIST
 * (define-macro (let binds . body)
     `((lambda ,(map car binds)
         ,@body)
       ,@(map cadr binds)))
=> #<Syntax LET>
 * (let ((x 10)
         (y 20))
     (let ((x 12)
           (a x)
           (z (let ((a 7)
                    (b 11))
                (* a b x y))))
       (list a x y z)))
=> (10 12 20 15400)
=============================================================
できた。ついでに LET* も実装してみる。
=============================================================
 * (define (null? x)
     (eq x NIL))
=> NULL?
 * (define (fold fn seed lst)
     (if (null? lst)
         seed
         (fold fn (fn (car lst) seed) (cdr lst))))
=> FOLD
 * (define-macro (let* binds . body)
     (fold (lambda (bind body)
             `(let (,bind) ,body))
           `(begin ,@body)
           (reverse binds)))
=> #<Syntax LET*>
 * (let* ((x 10)
          (y 20))
     (let* ((x 12)
            (a x)
            (z (let* ((a 7)
                      (b 11))
                 (* a b x y))))
       (list a x y z)))
=> (12 12 20 18480)
=============================================================
おｋぽい

さっきのletをlet*に置き換えただけだが、各束縛時に見える束縛がletのときと
かわるので評価値も変わる。
一応ほかのLisp処理系でも同じS式をevalしてみて
同じ答えになることを確認。

こういうのが一発で決まるとキモチいいね。

と、いうわけで、Lispのプリミティブな機能はある程度実装できた気がする。
# Fixnumの演算子とか全然だけど

マクロも実装できたし、上にレイヤを重ねていけばたいていのことはできる
であろうLispになった(性能は低いが)。

まだまだ処理系自身にバグがたくさんあって、効率も悪い実装だとわかってるけど、
自分で書いてみることで色々わかって勉強になったし、言語処理系を
書くってのは普通のアプリを書くのとはちょっと違った面白さがあることがわかって
満足したので、とりあえずここを区切りとする。


最終日のクラス構成は下記のとおり

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
class Macro : 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 <unistd.h>
#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);
void printlptr(ostream& os, const lptr& p);
ostream& operator<<(ostream& os, const lptr& p) {
printlptr(os, p);
return os;
}
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 {
};
class TrueInstance : public True {
public:
virtual string str() const { return "T"; }
};
const lptr THE_T(new TrueInstance());
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));
}
bool isError(const lptr& p) {
return isa<Error>(p);
}
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) {
//cerr << "cons@" << this << endl;
}
~Cons() {
//cerr << "dest@" << this << endl;
}
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 cons(const lptr& x, const lptr& y) {
return lptr(new Cons(x, y));
}
lptr getSymbol(const string& s);
lptr cons(const string& s, const lptr& rest) {
return cons(getSymbol(s), rest);
}
bool isAtom(const lptr& p);
lptr car(const lptr& p) {
if (eq(p, THE_NIL)) return THE_NIL;
if (isAtom(p)) return makeError("CAR: Argument is an atom");
return p->rawptr<Cons>()->getcar();
}
lptr cdr(const lptr& p) {
if (eq(p, THE_NIL)) return THE_NIL;
if (isAtom(p)) return makeError("CDR: Argument is an atom");
return p->rawptr<Cons>()->getcdr();
}
lptr cadr(const lptr& p) {
return car(cdr(p));
}
lptr set_car(const lptr& c, const lptr& val) {
c->rawptr<Cons>()->setcar(val);
return c;
}
lptr set_cdr(const lptr& c, const lptr& val) {
c->rawptr<Cons>()->setcdr(val);
return c;
}
lptr reverse(const lptr& p) {
auto acc = THE_NIL, lst = p;
while (!isNIL(lst)) {
acc = cons(car(lst), acc);
lst = cdr(lst);
}
return acc;
}
lptr nreverse(const lptr& p) {
lptr acc, lst, head, rest;
acc = THE_NIL;
lst = p;
while (!isNIL(lst)) {
rest = cdr(lst);
acc = set_cdr(lst, acc);
lst = rest;
}
return acc;
}
lptr last(const lptr& p) {
auto c = p;
while (!isNIL(cdr(c))) c = cdr(c);
return c;
}
lptr clist(initializer_list<const lptr> args) {
auto acc = THE_NIL;
for (auto& i:args) {
acc = cons(i, acc);
}
return nreverse(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) {}
string value() {
return val;
}
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));
}
int valFixnum(const lptr& p) {
return rawptr<Fixnum>(p)->value();
}
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 {
auto res = makeSymbol(s);
THE_SYMBOL_TABLE.emplace(s, res);
return res;
}
}
class Env : public True {
private:
unordered_map<string, 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)) {
ret->second = 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(car(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 prmcons(const lptr& args) {
return cons(car(args), cadr(args));
}
lptr prmcar(const lptr& args) {
return car(car(args));
}
lptr prmcdr(const lptr& args) {
return cdr(car(args));
}
lptr prmcadr(const lptr& args) {
return cadr(car(args));
}
lptr prmset_car(const lptr& args) {
return set_car(car(args), cadr(args));
}
lptr prmset_cdr(const lptr& args) {
return set_cdr(car(args), cadr(args));
}
lptr prmreverse(const lptr& args) {
return reverse(car(args));
}
lptr prmnreverse(const lptr& args) {
return nreverse(car(args));
}
lptr prmliststar(const lptr& args) {
if (isNIL(args)) return THE_NIL;
if (isNIL(cdr(args))) return car(args);
lptr acc = THE_NIL;
lptr rest = args;
while (!isNIL(cdr(rest))) {
acc = cons(car(rest), acc);
rest = cdr(rest);
}
lptr head = nreverse(acc);
set_cdr(acc, car(rest));
return head;
}
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, car(args), car(values));
return setupenv(env, cdr(args), cdr(values));
} else {
envdefine(env, args, values);
return THE_NIL;
}
}
lptr apply(const lptr& values) const {
auto newenv = makeEnv(env);
auto status = setupenv(newenv, args, values);
if (isError(status)) {
return status;
} else {
return sf_begin(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 = cdr(rest)) {
Fixnum *tmp = rawptr<Fixnum>(car(rest));
res += tmp->value();
}
return lptr(new Fixnum(res));
}
lptr prm_minus(const lptr& args) {
lptr first = car(args);
lptr rest = cdr(args);
int res = rawptr<Fixnum>(first)->value();
if (isNIL(rest)) return lptr(new Fixnum(0 - res));;
while (!isNIL(rest)) {
Fixnum *tmp = rawptr<Fixnum>(car(rest));
res -= tmp->value();
rest = cdr(rest);
}
return lptr(new Fixnum(res));
}
lptr prm_multiply(const lptr& args) {
lptr rest;
int res = 1;
for (rest = args; !isNIL(rest); rest = cdr(rest)) {
Fixnum *tmp = rawptr<Fixnum>(car(rest));
res *= tmp->value();
}
return lptr(new Fixnum(res));
}
lptr prm_lessequal(const lptr& args) {
int lhs, rhs;
lptr rest;
rhs = valFixnum(car(args));
rest = cdr(args);
while (!isNIL(rest)) {
lhs = rhs;
rhs = valFixnum(car(rest));
if (lhs > rhs) return THE_NIL;
rest = cdr(rest);
}
return THE_T;
}
/*
* 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(car(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; !isError(ret) && !isNIL(lst); lst = cdr(lst)) {
ret = eval(car(lst), env);
}
return ret;
}
lptr sf_cond(const lptr& args, const lptr& env) {
lptr clause, rest, cond;
for (rest = args; !isNIL(rest); rest = cdr(rest)) {
clause = car(rest);
cond = eval(car(clause), env);
if (isNIL(cond)) continue;
return sf_begin(cdr(clause), env);
}
return THE_NIL;
}
lptr sf_if (const lptr& args, const lptr& env) {
lptr cond, thenc, elsec;
cond = eval(car(args), env);
thenc = cadr(args);
if (isNIL(cdr(cdr(args)))) elsec = THE_NIL;
else elsec = cadr(cdr(args));
if (!isNIL(cond)) return eval(thenc, env);
else return eval(elsec, env);
}
lptr sf_quote(const lptr& args, const lptr& env) {
return car(args);
}
// Dummy specal form for unquote
lptr sf_unquote(const lptr& args, const lptr& env) {
return THE_NIL;
}
// Dummy specal form for unquote-splicing
lptr sf_unquote_splicing(const lptr& args, const lptr& env) {
return THE_NIL;
}
lptr sf_quasiquote_helper(const lptr& args, const lptr& env) {
if (isAtom(args)) return args;
auto acc = THE_NIL;
for (auto lst = args; !isNIL(lst); lst = cdr(lst)) {
auto tmp = car(lst);
if (!isCons(tmp)) {
;
} else if (eq(car(tmp), eval(getSymbol("QUOTE"), THE_ENVIRONMENT))) {
tmp = cons(car(tmp), sf_quasiquote_helper(cdr(tmp), env));
} else if (eq(car(tmp), eval(getSymbol("UNQUOTE"), THE_ENVIRONMENT))) {
tmp = eval(cadr(tmp), env);
} else if (eq(car(tmp), eval(getSymbol("UNQUOTE-SPLICING"), THE_ENVIRONMENT))) {
tmp = eval(cadr(tmp), env);
if (isError(tmp)) return tmp;
if (isAtom(tmp)) return makeError(",@: cannot splice atom: " + tmp->str());
while (!isNIL(tmp)) {
acc = cons(car(tmp), acc);
tmp = cdr(tmp);
}
continue;
} else {
tmp = sf_quasiquote_helper(tmp, env);
}
acc = cons(tmp, acc);
}
return nreverse(acc);
}
lptr sf_quasiquote(const lptr& args, const lptr& env) {
return sf_quasiquote_helper(car(args), env);
}
lptr sf_lambda(const lptr& args, const lptr& env) {
return makeCompoundProc("", car(args), cdr(args), env);
}
lptr sf_define(const lptr& args, const lptr& env) {
lptr first, second;
first = car(args);
second = car(cdr(args));
if (isCons(first)) {
// for MIT Style define
lptr procname = car(first);
lptr procargs = cdr(first);
lptr body = cdr(args);
return eval(clist({getSymbol("DEFINE"),
procname,
cons(getSymbol("LAMBDA"),
cons(procargs, body))}),
env);
} else {
envdefine(env, first, THE_NIL);
second = eval(second, env);
envset(env, first, second);
if (isProc(second)) {
Proc *p = rawptr<Proc>(second);
if (p->getname() == string("")) {
p->setname(first->str());
}
}
return first;
}
}
/*
* Macro
*/
class Macro : public Syntax {
private:
lptr tf;
public:
Macro(const string& s, const lptr& proc) : Syntax(s), tf(proc) {}
lptr eval_syntax(const lptr& expr, const lptr& env) const {
lptr res = tf->rawptr<Proc>()->apply(expr);
if (isError(res)) return res;
return eval(res, env);
}
};
lptr makeMacro(const string& s, const lptr& proc) {
return lptr(new Macro(s, proc));
}
lptr register_macro(const string& name, const lptr& macro) {
lptr sym = getSymbol(name);
return envdefine(THE_ENVIRONMENT, sym, macro);
}
lptr sf_define_macro(const lptr& args, const lptr& env) {
lptr first, second;
first = car(args);
second = car(cdr(args));
if (isCons(first)) {
// define-macro is similer to MIT Style define
lptr macroname = car(first);
lptr procargs = cdr(first);
lptr body = cdr(args);
lptr proc = makeCompoundProc("macro-transformer " + macroname->str(),
procargs, body, env);
if (isError(proc)) return proc;
lptr macro = makeMacro(macroname->str(), proc);
if (isError(macro)) return macro;
return register_macro(macroname->str(), macro);
} else {
return makeError("DEFINE-MACRO: Invalid argument"
" (define-macro (name args) body): " + args->str());
}
}
lptr sf_set(const lptr& args, const lptr& env) {
lptr val = eval(cadr(args), env);
if (isError(val)) return val;
envset(env, car(args), val);
return val;
}
/*
* Printer
*/
void printCons(ostream& os, const lptr& p) {
auto x = car(p);
auto rest = cdr(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)) {
auto first = car(p);
if (eq(first, eval(getSymbol("QUOTE"), THE_ENVIRONMENT))) {
os << "'";
printlptr(os, cadr(p));
} else if (eq(first, eval(getSymbol("QUASIQUOTE"), THE_ENVIRONMENT))) {
os << "`";
printlptr(os, cadr(p));
} else if (eq(first, eval(getSymbol("UNQUOTE"), THE_ENVIRONMENT))) {
os << ",";
printlptr(os, cadr(p));
} else {
os << "(";
printCons(os, p);
os << ")";
}
} else if (eqtype<String>(p)) {
os << "\"";
printString(os, p);
os << "\"";
} else {
os << p->str();
}
}
/*
* 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 = cdr(rest)) {
tmp = eval(car(rest), env);
if (isError(tmp)) return tmp;
acc = cons(tmp, acc);
}
return nreverse(acc);
}
lptr eval(const lptr& expr, const lptr& env) {
//cout << "E> " << expr << endl;
if (isAtom(expr)) {
if (isSymbol(expr)) return eval_symbol(expr, env);
else return expr;
} else {
lptr op = eval(car(expr), env);
if (isError(op)) {
return op;
} else if (isa<Syntax>(op)) {
return rawptr<Syntax>(op)->eval_syntax(cdr(expr), env);
} else if (isa<Proc>(op)) {
lptr av = eval_apply_values(cdr(expr), env);
if (isError(av)) {
return av;
} else {
return rawptr<Proc>(op)->apply(av);
}
} else {
return makeError("Cannot Apply: " + op->str());
}
}
}
lptr prmapply(const lptr& args) {
lptr fn = car(args);
return rawptr<Proc>(fn)->apply(prmliststar(cdr(args)));
}
lptr prmmap(const lptr& args) {
Proc* fn = rawptr<Proc>(car(args));
lptr lists = cdr(args);
if (isNIL(lists)) return makeError("MAP: Too few arguments");
lptr acc = THE_NIL;
while (true) {
lptr appargs = THE_NIL;
lptr remain = THE_NIL;
while (!isNIL(lists)) {
lptr tmp = car(lists);
if (isNIL(tmp)) goto end;
appargs = cons(car(tmp), appargs);
remain = cons(cdr(tmp), remain);
lists = cdr(lists);
}
lptr res = fn->apply(nreverse(appargs));
if (isError(res)) return res;
acc = cons(res, acc);
lists = nreverse(remain);
}
end:
return nreverse(acc);
}
lptr prmeq(const lptr& args) {
if (eq(car(args), cadr(args))) return THE_T;
else return THE_NIL;
}
/*
* 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_dotted(istream& is, const lptr& prefix) {
char c;
auto lastcons = last(prefix);
auto next = reader(is);
bool error = false;
set_cdr(lastcons, next);
while (is.get(c)) {
if (c == ')') {
if (error) return makeError("READ: Additional symbol after '.' ");
else return prefix;
} else if (isspace(c)) {
continue;
} else {
error = true;
}
}
return makeError("READ: Receive EOF");
}
lptr read_list(istream& is) {
char c;
lptr acc, term;
acc = term = THE_NIL;
while (is.get(c)) {
if (c == ')') {
break;
} else {
is.unget();
auto next = reader(is);
if (eq(getSymbol("."), next)) {
return read_dotted(is, nreverse(acc));
}
acc = cons(next, acc);
}
}
return nreverse(acc);
}
lptr read_symbol(istream& is) {
char c;
string token;
while (is.get(c)) {
if (c == '(' || c == ')' || isspace(c)) {
is.unget();
break;
}
token.push_back(toupper(c));
}
try {
return makeFixnum(token);
} catch (invalid_argument) {
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 cons(eval(getSymbol(quote), THE_ENVIRONMENT), cons(reader(is), THE_NIL));
}
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.");
}
/*
* setup
*/
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("IF", sf_if);
register_specialform("QUOTE", sf_quote);
register_specialform("QUASIQUOTE", sf_quasiquote);
register_specialform("UNQUOTE", sf_unquote);
register_specialform("UNQUOTE-SPLICING", sf_unquote_splicing);
register_specialform("LAMBDA", sf_lambda);
register_specialform("^", sf_lambda);
register_specialform("DEFINE", sf_define);
register_specialform("DEFINE-MACRO", sf_define_macro);
register_specialform("SET!", sf_set);
}
char * const *prog_argv;
lptr prmrestart(const lptr& args) {
execv(prog_argv[0], prog_argv);
return THE_NIL; // Dummy
}
lptr prmexit(const lptr& args) {
exit(0);
return THE_NIL; // Dummy
}
lptr load_file(const string& file) {
ifstream is(file);
auto expr = reader(is);
if (isError(expr)) return expr;
return eval(expr, THE_ENVIRONMENT);
}
lptr prmload_file(const lptr& args) {
return load_file(rawptr<String>(car(args))->value());
}
lptr prmeval(const lptr& args) {
return eval(args, THE_ENVIRONMENT);
}
lptr prmread(const lptr& args) {
return reader(cin);
}
lptr prmdisplay(const lptr& args) {
printlptr(cout, car(args));
return THE_NIL;
}
lptr prmprint(const lptr& args) {
lptr rest = args;
while (!isNIL(rest)) {
if (eqtype<String>(car(rest))) cout << car(rest)->str();
else printlptr(cout, car(rest));
rest = cdr(rest);
}
cout << endl;
return THE_NIL;
}
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("REVERSE", prmreverse);
register_primitive_proc("LIST*", prmliststar);
register_primitive_proc("APPLY", prmapply);
register_primitive_proc("MAP", prmmap);
register_primitive_proc("EQ", prmeq);
register_primitive_proc("+", prm_plus);
register_primitive_proc("-", prm_minus);
register_primitive_proc("*", prm_multiply);
register_primitive_proc("<=", prm_lessequal);
register_primitive_proc("RESTART", prmrestart);
register_primitive_proc("EXIT", prmexit);
register_primitive_proc("LOAD-FILE", prmload_file);
register_primitive_proc("EVAL", prmeval);
register_primitive_proc("READ", prmread);
register_primitive_proc("DISPLAY", prmdisplay);
register_primitive_proc("PRINT", prmprint);
}
void setup_self_evaluatings() {
auto 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();
}
void repl(istream& is, ostream& os, const string& prompt,
const string& value_prompt, const string& error_prompt) {
while (!is.eof()) {
os << prompt;
os.flush();
auto val = reader(is);
//os << "R> " << val << endl;
if (isError(val)) goto error;
val = eval(val, THE_ENVIRONMENT);
if (isError(val)) goto error;
os << value_prompt << val << endl;
continue;
error:
os << error_prompt << val << endl;
}
}
int main(int argc, char **argv) {
prog_argv = argv;
setup();
//ifstream is("/home/kt/tlisp/src/tak.lisp");
istream& is = cin;
repl(is, cout, " * ", "=> ", "; ");
return 0;
}
view raw toylisp-day3.cc hosted with ❤ by GitHub
投稿者 時刻:
ラベル:

0 件のコメント:

コメントを投稿

登録: コメントの投稿 (Atom)