C++でSchemeつづき

(define m 1000)
(define p (lambda (x y z) x))
(define q (lambda (x y z) y))
(define r (lambda (x y z) m))
(define t (lambda (x th el) (if (= x 0) (th) (el)))
(p 1 2 3)
  => 1
(q 1 2 3)
  => 2
(r 1 2 3)
  => 1000
(t 0 (lambda () 1111) (lambda () 2222))
  => 1111
(t 1 (lambda () 1111) (lambda () 2222))
  => 2222
(+ 1 2 3)
  => 6

相当が動くようになったよ！

#include "stdafx.h"
#include <boost/mpl/integral_c.hpp>


#define LIST0() nil
#define LIST1(l1) Cons<l1,LIST0()>
#define LIST2(l1,l2) Cons<l1,LIST1(l2)>
#define LIST3(l1,l2,l3) Cons<l1,LIST2(l2,l3)>
#define LIST4(l1,l2,l3,l4) Cons<l1,LIST3(l2,l3,l4)>
#define LIST5(l1,l2,l3,l4,l5) Cons<l1,LIST4(l2,l3,l4,l5)>

//========================= data types =========================
using boost::mpl::int_;
template<char c>
struct Symbol {static const char value=c;};

//empty list.
struct nil {
  template<typename Method,typename Init>
  struct inject {typedef typename Init result;};
};

struct t_tag{};

template<typename CA,typename CD>
struct Cons {
  typedef CA car;
  typedef CD cdr;
  
  template<typename Method,typename Init>
  struct inject {
    typedef typename cdr::inject<Method,typename Method::exec<Init,car>::result>::result result;
  };
};

//for proc
template<typename Args,typename Body,typename Env>
struct Lambda {};

//for primitive proc
template<typename Func>
struct PrimitiveProc {};

// for syntax

struct if_tag {};



//========================= environment =========================
//ユーザーが定義するためのEnvironment
#define DECLARE_ENV(name) \
template<typename P> \
struct name { \
  typedef P parent; \
  template<typename Sym> struct lookup { \
    typedef typename parent::lookup<Sym>::result result; \
  }; \
  template<typename Ss,typename Vs> \
  struct expand { \
    typedef ExtendedEnv<Ss,Vs,name<P>> result; \
  };


#define BIND_SYMBOL(sym,val) \
  template<> struct lookup< Symbol<sym> > { \
    typedef typename val result; \
  };
#define END_ENV() \
};


//シンボルのリスト(a b c ...) と値のリスト(1 2 3 ...)を合成して
//シンボルテーブル((a 1) (b 2) (c 3) ...)を作るヘルパ関数。
//この作業をやっとくと引数不整合がエラーとして検出できるので都合がよろしい。
template<typename Syms,typename Vals>
struct BindArgs;

template<typename S,typename SCdr,typename V,typename VCdr>
struct BindArgs<Cons<S,SCdr>,Cons<V,VCdr>> {
  typedef typename Cons<Cons<S,V>,typename BindArgs<SCdr,VCdr>::result> result;
};

template<>
struct BindArgs<nil,nil> {
  typedef nil result;
};
//for 可変長引数 (lambda (a b c . x) ...)みたいなのに対応できるはず
//struct BindArgs<Symbol<c>,Vals>

//クロージャの適用により拡張されるEnvironment
template<typename Syms,typename Vals,typename Base>
struct ExtendedEnv {
  typedef typename BindArgs<Syms,Vals>::result vars; //(Symbol . value) のリスト
  template<typename Ss,typename Vs>
  struct extend {
    typedef ExtendedEnv<Ss,Vs,ExtendedEnv<Syms,Vals,Base>> result;
  };

  //============= 名前探索関係 ==================
  template<typename S,typename List>
  struct lookup_impl;

  template<char S,char HeadS,typename HeadV,typename Rest>
  struct lookup_impl< Symbol<S>, Cons< Cons<Symbol<HeadS>,HeadV> ,Rest> > {
    typedef typename lookup_impl<Symbol<S>,Rest>::result result;
  };
  //match
  template<char S,typename V,typename Rest>
  struct lookup_impl<Symbol<S>,Cons<Cons<Symbol<S>,V>,Rest> > {
    typedef typename V result;
  };
  //symbol not found in current env. lookup from parent.
  template<char S>
  struct lookup_impl<Symbol<S>,nil> {
    typedef typename Base::lookup< Symbol<S> >::result result;
  };

  template<typename S>
  struct lookup;
  template<char S>
  struct lookup<Symbol<S> > {
    typedef typename lookup_impl<Symbol<S>,vars>::result result;
  };
};

//=================== Evaluator ==========================

//eval constant
template<typename S,class Env>
struct Evaluator {
  typedef S result;
};

//eval Symbol
template<char c,class Env>
struct Evaluator<Symbol<c>,Env> {
  typedef typename Env::lookup<Symbol<c> >::result result;
};



//与えられたリストの各要素をevalして新しいリストを返すヘルパ関数
//クロージャ呼び出しのとき引数を評価するのに使う
template<typename Arg,typename Env>
struct eval_each;

template<typename Car,typename Cdr,typename Env>
struct eval_each<Cons<Car,Cdr>,Env>{
  typedef Cons<typename Evaluator<Car,Env>::result,typename eval_each<Cdr,Env>::result> result;
};

template<typename Env>
struct eval_each<nil,Env> {
  typedef nil result;
};


//eval list
template<typename F,typename Arglist,typename Env>
struct Evaluator<Cons<F,Arglist>,Env> {
  typedef typename Evaluator<F,Env>::result apply_target;
  typedef typename eval_each<Arglist,Env>::result apply_args;

  template<typename Tgt,typename Params>
  struct apply;

  template<typename Arglist,typename Body,typename InnerEnv,typename Params>
  struct apply<Lambda<Arglist,Body,InnerEnv>,Params> {
    typedef typename InnerEnv::expand<Arglist,Params>::result new_env;
    struct ev{ 
      template<typename A,typename B> 
      struct exec{
        typedef typename Evaluator<B,new_env>::result result;
      };
    };
    typedef typename Body::inject<ev,nil>::result result;
  };
  template<typename Func,typename Params>
  struct apply<PrimitiveProc<Func>,Params> {
    typedef typename Func::exec<Params>::result result;
  };

  typedef typename apply<apply_target,apply_args>::result result;
};

//eval syntax(if)
template<typename Cond,typename Th,typename El,typename Env>
struct Evaluator<Cons<if_tag,Cons<Cond,Cons<Th,Cons<El,nil>>>>,Env> {
  template<typename cond,typename th,typename el>
  struct eval_if_impl { typedef typename Evaluator<th,Env>::result result; };
  template<typename th,typename el>
  struct eval_if_impl<nil,th,el> { typedef typename Evaluator<el,Env>::result result; };

  typedef typename eval_if_impl<typename Evaluator<Cond,Env>::result,Th,El>::result result;
  
};



//to dynamic world
template<typename T>
struct to_dynamic {};

template<int n>
struct to_dynamic<int_<n> > {
  static int value() {return n;}
};

//static_if
template<bool cond,typename th,typename el> struct static_if;
template<typename th,typename el> struct static_if<true,th,el> {typedef th result;};
template<typename th,typename el> struct static_if<false,th,el> {typedef el result;};


DECLARE_ENV(e1)
  //直接マクロに渡そうとしたらバグったんだよ
  //(lambda (x y z) x)
  typedef Lambda<LIST3(Symbol<'x'>,Symbol<'y'>,Symbol<'z'>),LIST1(Symbol<'x'>),e1> return_x;
  //(lambda (x y z) y)
  typedef Lambda<LIST3(Symbol<'x'>,Symbol<'y'>,Symbol<'z'>),LIST1(Symbol<'y'>),e1> return_y;
  //(lambda (x y z) m)
  typedef Lambda<LIST3(Symbol<'x'>,Symbol<'y'>,Symbol<'z'>),LIST1(Symbol<'m'>),e1> return_m;
  //(lambda (x y z) m x)
  typedef Lambda<LIST3(Symbol<'x'>,Symbol<'y'>,Symbol<'z'>),LIST2(Symbol<'m'>,Symbol<'x'>),e1> return_mx;
  //(lambda (x then_func else_func) (if (= x 0) (then_func) (else_func)))
  typedef Lambda<
    LIST3(Symbol<'x'>,Symbol<'t'>,Symbol<'e'>),
    LIST1(LIST4(if_tag,LIST3(Symbol<'='>,Symbol<'x'>,int_<0>),LIST1(Symbol<'t'>),LIST1(Symbol<'e'>))),
    e1> if_then_func;
  struct op_eq_impl{ 
    template<typename Args> struct exec;
    template<typename L,typename R> struct exec<Cons<L,Cons<R,nil>>> {
      typedef typename static_if<L::value == R::value,t_tag,nil>::result result;
    };
  };
  struct op_plus_impl {
    template<typename Args>
    struct exec;
    template<int n,typename Rest>
    struct exec<Cons<int_<n>,Rest>> {
      typedef int_<n+exec<Rest>::result::value> result;
    };
    template<int n>
    struct exec<Cons<int_<n>,nil>> {
      typedef int_<n> result;
    };
  };

  BIND_SYMBOL('x',int_<100>);
  BIND_SYMBOL('y',int_<200>);
  BIND_SYMBOL('z',LIST3(int_<200>,int_<100>,int_<300>));
  BIND_SYMBOL('m',int_<1000>);
  BIND_SYMBOL('p', return_x ); 
  BIND_SYMBOL('q', return_y ); 
  BIND_SYMBOL('r', return_m ); 
  BIND_SYMBOL('s', return_mx);
  BIND_SYMBOL('t', if_then_func);
  BIND_SYMBOL('=', PrimitiveProc<op_eq_impl>);
  BIND_SYMBOL('+', PrimitiveProc<op_plus_impl>);
END_ENV()

DECLARE_ENV(e2)
  BIND_SYMBOL('x',int_<111>);
  BIND_SYMBOL('a',int_<999>);
END_ENV()


#include <iostream>
using namespace std;


int _tmain(int argc, _TCHAR* argv[]) {
  typedef e1<nil> env;
  typedef e2<env> env2;
  cout << to_dynamic<Evaluator<Symbol<'x'>,env >::result>::value() << endl; //100
  cout << to_dynamic<Evaluator<Symbol<'x'>,env2 >::result>::value() << endl; //111
  cout << to_dynamic<Evaluator<int_<999>,nil>::result>::value() << endl; //999

  cout << to_dynamic<Evaluator<LIST4(Symbol<'p'>,int_<1>,int_<2>,int_<3>),env>::result>::value() << endl; //1
  cout << to_dynamic<Evaluator<LIST4(Symbol<'q'>,int_<1>,int_<2>,int_<3>),env>::result>::value() << endl; //2
  cout << to_dynamic<Evaluator<LIST4(Symbol<'r'>,int_<1>,int_<2>,int_<3>),env>::result>::value() << endl; //1000
  cout << to_dynamic<Evaluator<LIST4(Symbol<'s'>,int_<1>,int_<2>,int_<3>),env>::result>::value() << endl; //1
  //↓引数の数が不整合だとコンパイルエラー
  //to_dynamic<Evaluator<LIST3(Symbol<'p'>,int_<1>,int_<2>),env>::result>::value();

  typedef Lambda<LIST0(),LIST1(int_<1111>),env> t_func;
  typedef Lambda<LIST0(),LIST1(int_<2222>),env> f_func;
  cout << to_dynamic<Evaluator<LIST4(Symbol<'t'>,int_<0>,t_func,f_func),env>::result>::value() << endl; //1111
  cout << to_dynamic<Evaluator<LIST4(Symbol<'t'>,int_<1>,t_func,f_func),env>::result>::value() << endl; //2222
  
  cout << to_dynamic<Evaluator<LIST4(Symbol<'+'>,int_<1>,int_<2>,int_<3>),env>::result>::value() << endl; //6

}

このダックタイピングでテンプレートマッチングな純粋関数型プログラミング…… た、たまらん！！！！
勿論純粋関数型ですから set! などという不潔なものとは無縁ですし、検証してないけどおそらくは同様な理由によりcontinuationも……いやひょっとしてできるか？要検証。すべての評価過程はひとしく<型>として存在するわけだしな。
どうにかモナド的なものを導入してHaskell並みのテンプレートプログラミングができるといいなー。無理。
D言語だとmixinでスタティックな文字列をスタティックにパースして型を生成するって技が使えそうだ。誰かやってそうだけど。