簡易LISP処理系の実装例（C++17版）

【他言語版へのリンク記事】[簡易LISP処理系の実装例【各言語版まとめ】](https://qiita.com/ytaki0801/items/dcb0fe48cbeab30ac40d)

この記事は，下記拙作記事のC++17版を抜粋・修正したものを利用した，原初LISP処理系（["McCarthy's Original Lisp"](http://paulgraham.com/lispcode.html)）の実装例をまとめたものです．

* ~~[『括弧文字列』簡易パーサ実装例まとめ](https://qiita.com/ytaki0801/items/b8d7d4c778fe98966ce5)~~（C++17版はS式入力を先行作成しました）
* [リスト処理関数（cons,car,cdr,eq,atom）実装例まとめ](https://qiita.com/ytaki0801/items/a11c8143c5c63a406c7f)

最低限の機能をもったLISP処理系の実装の場合，本体である評価器（eval）実装はとても簡単であり，むしろ，字句・構文解析を行うS式入出力やリスト処理実装の方が開発言語ごとの手間が多く，それが敷居になっている人向けにまとめています．

# 処理系の概要
実行例は次の通り．GCC 8.3.0（`--std=c++17`）にて確認．

```lisp
$ c++ jmclisp.cpp --std=c++17
$ ./a.out
(car (cdr '(10 20 30)))

20
$ ./a.out
((lambda (x) (car (cdr x))) '(abc def ghi))

def
$ ./a.out
((lambda (f x y) (f x (f y '()))) 'cons '10 '20)

(10 20)
$ ./a.out
((lambda (f x y) (f x (f y '())))
 '(lambda (x y) (cons x (cons y '())))
 '10 '20)

(10 (20 ()))
$ ./a.out
((lambda (assoc k v) (assoc k v))
 '(lambda (k v)
    (cond ((eq v '()) nil)
          ((eq (car (car v)) k)
           (car v))
          ('t (assoc k (cdr v)))))
 'Orange
 '((Apple . 120) (Orange . 210) (Lemon . 180)))

(Orange . 210)
```

実装内容は次の通り．

* ["McCarthy's Original Lisp"](http://paulgraham.com/lispcode.html)をベースにした評価器
* 数字を含むアトムは全てシンボルとし，変数の値とする場合は`quote`（`'`）を使用
* 構文として`quote`の他，`cond`と`lambda`が使用可能
* 組込関数：`atom` `eq` `cons` `car` `cdr`（内部でコンスセルを作成）
* 真偽値は`t`（真）および`nil`（偽）＝空リスト＝`"nil"`
* エラーチェックなし，モジュール化なし，ガーベジコレクションなし

"McCarthy's Original Lisp"の詳細については[まとめ記事](https://qiita.com/ytaki0801/items/dcb0fe48cbeab30ac40d)を参照．ダイナミックスコープということもあり，実行例ではlambda式を`letrec`（Scheme）や`labels`（Common Lisp）などの代わりに使用しています．

#実装例

##ソースコード一式

```jmclisp.cpp
//
// JMC Lisp: defined in McCarthy's 1960 paper,
// with S-expression input/output and basic list processing
//

#include <iostream>
#include <string>
#include <functional>
#include <variant>

using namespace std;


// basic list processing: cons, car, cdr, eq, atom

struct CELL;

struct CONS {
  vector<CELL> pair;
  CONS() : pair(2) { }
};

struct CELL { variant<string, CONS> node; };

CELL cons(CELL x, CELL y)
{
  CONS c; c.pair[0] = x; c.pair[1] = y;
  CELL s; s.node = c;
  return s;
}

CELL car(CELL x) { return get<1>(x.node).pair[0]; }
CELL cdr(CELL x) { return get<1>(x.node).pair[1]; }
bool atom(CELL s) { return s.node.index() == 0; }

bool eq(CELL x, CELL y) {
  if (atom(x) && atom(y))
    return get<0>(x.node) == get<0>(y.node);
  else
    return false;
}

string c2s(CELL s) { return get<0>(s.node); }
CELL s2c(string s) { CELL r; r.node = s; return r; }
CELL nil(void) { return s2c("nil"); }


// S-expression output: s_display

void s_display(CELL s);

void s_strcons(CELL s) {
  s_display(car(s));
  CELL sd = cdr(s);
  if (eq(sd, nil())) { cout << ""; }
  else if (atom(sd)) {
    cout << " . " << c2s(sd);
  } else { cout << " "; s_strcons(sd); }
}

void s_display(CELL s) {
  if (eq(s, nil())) { cout << "()"; }
  else if (atom(s)) { cout << c2s(s); }
  else {
    cout << "("; s_strcons(s); cout << ")";
  }
}


// S-expression input: s_read

bool s_lc(char c)
{
  return c == '(' || c == ')' || c == '\'';
}

vector<string> s_lex(string s)
{
  vector<string> r;
  string t;

  for (char c: s) {
    if (c == ' ' && t != "") {
      r.push_back(t); t = "";
    } else if (s_lc(c) && t != "") {
      r.push_back(t); t = "";
      r.push_back(string(1, c));
    } else if (s_lc(c)) {
      r.push_back(string(1, c));
    } else {
      if (c != ' ') t.push_back(c);
    }
  }
  if (t != "") r.push_back(t);

  return r;
}

CELL s_quo(CELL x, vector<string> s, int *pos)
{
  if (*pos != -1 && s[*pos] == "'") {
    *pos = *pos - 1;
    return cons(s2c("quote"), cons(x, nil()));
  } else {
    return x;
  }
}

CELL s_syn(vector<string> s, int *pos)
{
  string t = s[*pos];
  *pos = *pos - 1;
  if (t == ")") {
    CELL r = nil();
    while(s[*pos] != "(") {
      if (s[*pos] == ".") {
        *pos = *pos - 1;
        r = cons(s_syn(s, pos), car(r));
      } else {
        r = cons(s_syn(s, pos), r);
      }
    }
    *pos = *pos - 1;
    return s_quo(r, s, pos);
  } else {
    return s_quo(s2c(t), s, pos);
  }
}

CELL s_read(string s)
{
  vector<string> rl;
  rl = s_lex(s);
  int pos = rl.size() - 1;
  return s_syn(rl, &pos);
}


// JMC Lisp evaluator: s_eval

CELL caar(CELL x) { return car(car(x)); }
CELL cadr(CELL x) { return car(cdr(x)); }
CELL cadar(CELL x) { return car(cdr(car(x))); }
CELL caddr(CELL x) { return car(cdr(cdr(x))); }
CELL caddar(CELL x) { return car(cdr(cdr(car(x)))); }

bool s_null(CELL x) { return eq(x, nil()); }

CELL s_append(CELL x, CELL y)
{
  if (s_null(x)) { return y; }
  else { return cons(car(x), s_append(cdr(x), y)); }
}

CELL s_list(CELL x, CELL y)
{
  return cons(x, cons(y, nil()));
}

CELL s_pair(CELL x, CELL y)
{
  if (s_null(x) && s_null(y)) { return nil(); }
  else if (!atom(x) && !atom(y)) {
    return cons(s_list(car(x), car(y)),
                s_pair(cdr(x), cdr(y)));
  } else { return nil(); }
}

CELL s_assoc(CELL x, CELL y)
{
  if (eq(caar(y), x)) { return cadar(y); }
  else { return s_assoc(x, cdr(y)); }
}

CELL s_atom(CELL s)
{
  if (atom(s))
    return s2c("t");
  else
    return nil();
}
CELL s_eq(CELL s1, CELL s2)
{
  if (eq(s1, s2))
    return s2c("t");
  else
    return nil();
}

CELL evcon(CELL c, CELL a);
CELL evlis(CELL m, CELL a);
CELL s_eval(CELL e, CELL a)
{
  if      (eq(e, s2c("t"))) { return s2c("t"); }
  else if (eq(e, nil()))   { return nil(); }
  else if (atom(e)) { return s_assoc(e, a); }
  else if (atom(car(e))) {
    if        (eq(car(e), s2c("quote"))) {
      return cadr(e);
    } else if (eq(car(e), s2c("atom")))  {
      return s_atom(s_eval(cadr(e), a));
    } else if (eq(car(e), s2c("eq"))) {
      return s_eq(s_eval(cadr(e), a),
                  s_eval(caddr(e), a));
    } else if (eq(car(e), s2c("car"))) {
      return car( s_eval(cadr(e), a));
    } else if (eq(car(e), s2c("cdr"))) {
      return cdr( s_eval(cadr(e), a));
    } else if (eq(car(e), s2c("cons"))) {
      return cons(s_eval(cadr(e), a),
                  s_eval(caddr(e), a));
    } else if (eq(car(e), s2c("cond"))) {
      return evcon(cdr(e), a);
    } else {
      return s_eval(cons(s_assoc(car(e), a), cdr(e)), a);
    }
  } else if (eq(caar(e), s2c("lambda"))) {
    return s_eval(caddar(e),
                  s_append(s_pair(cadar(e), evlis(cdr(e), a)),
                           a));
  } else {
    cout << "Error" << endl;
    return nil();
  }
}

CELL evcon(CELL c, CELL a)
{
  if (eq(s_eval(caar(c), a), s2c("t"))) {
    return s_eval(cadar(c), a);
  } else { return evcon(cdr(c), a); }
}

CELL evlis(CELL m, CELL a)
{
  if (s_null(m)) { return nil(); }
  else { return cons(s_eval(car(m), a), evlis(cdr(m), a)); }
}


// REP (no Loop): s_rep
void s_rep(string s)
{
  return s_display(s_eval(s_read(s), nil()));
}


int main(void)
{
  string s = "", i;

  do {
    i = "";
    getline(cin, i);
    s = s + i;
  } while (i != "");

  s_rep(s); cout << endl;

  return (0);
}
```

##解説

* リスト処理：`cons` `car` `cdr` `eq` `atom`，S式出力：`s_display`
[先の記事](https://qiita.com/ytaki0801/items/a11c8143c5c63a406c7f)よりそのまま抜粋．`variant`および`vector`を用いて，文字列とコンスセルの双方を参照可能な相互再帰構造体を構成して実装．

* S式入力：`s_read`
新規に作成．字句解析部`s_lex`は`()`および`'`の識別でひとつの文字列を配列化，抽象構文木生成部`s_syn`は括弧ネスト・ドット対・クォート記号対応とし，リスト処理関数で構文木を生成．

* 評価器：`s_eval`＋ユーティリティ関数
["McCarthy's Original Lisp"](http://paulgraham.com/lispcode.html)をベースに`s_eval`関数およびユーティリティ関数を作成．

* REP (no Loop)：`s_rep`
`s_read`→`s_eval`→`s_display`をまとめた`s_rep`を定義．また，`main`関数で空行を入力するまで複数行を入力してひとつの文字列とし，`s_rep`に渡すよう記述．


#備考

##記事に関する補足
* C++でも17なのは，解説にあるように，コンスセル実装に`variant`と`vector`を用いる必要があったため．つまり，17未満の場合は…[C言語実装版](https://qiita.com/ytaki0801/items/5d56a2ba0ba000f3b795)を参照（手抜き）．

##更新履歴
* 2020-10-11：初版公開