Scheme - C言語による Scheme の interpreter (kscheme) - (被演算子の評価,エブリス末尾再帰に似た最適化)

開発環境

• OS X Yosemite - Apple, Ubuntu (OS)
• Emacs (CUI)、BBEdit - Bare Bones Software, Inc. (GUI) (Text Editor)
• C (プログラミング言語)
• Clang/LLVM (コンパイラ, Xcode - Apple)

Schemeの処理系(解釈系、評価機、レジスタ計算機を翻訳した命令列中心のより、もう少しC言語の特性を使った書き方をしたもの(label, gotoではなく、関数を呼び出すとか))を少しずつ書き進めてめていくことに。

エブリス末尾再帰に似た、最初の被演算子の評価を特別にして、退避を避けた最適化。

参考書籍等

• 計算機プログラムの構造と解釈[第2版]
• Structure and Interpretation of Computer Programs (原書)
• R7RSHomePage – Scheme Working Groups
• Head First C ―頭とからだで覚えるCの基本
• 21st Century C: C Tips from the New School
• プログラミング言語C 第2版 ANSI規格準拠
• プログラミング言語Cアンサー・ブック 第2版
• C実践プログラミング 第3版

kscheme

コード(BBEdit, Emacs)

kscheme.c

#include "kscheme.h"
#include "data.h"
#include "list_operations.h"

#include "expressions.h"
#include "data_structures.h"
#include "running_evaluator.h"

#include "kread.h"
#include <stdio.h>

void ev_appl_operand_first();
void ev_appl_operand_first_last();
void ev_appl_accum_first_arg();
  
extern data_s empty_data;
data_s expr, env, val, cont, proc, argl, unev;
/* 構文の型による場合分け */
void eval_dispatch() {
  if (is_self_evaluating(expr))
    ev_self_eval();
  else if (is_variable(expr))
    ev_variable();
  else if (is_quoted(expr))
    ev_quoted();
  else if (is_assignment(expr))
    ev_assignment();
  else if (is_definition(expr))
    ev_definition();
  else if (is_if(expr))
    ev_if();
  else if (is_lambda(expr))
    ev_lambda();
  else if (is_begin(expr))
    ev_begin();
  else if (is_application(expr))
    ev_application();
  else
    unknown_expression_type();
}

/* 単純式の評価 */
void ev_self_eval() {
  val = expr;
  cont.data.fn();
}

void ev_variable() {
  val = lookup_variable_value(expr, env);
  cont.data.fn();
}

void ev_quoted() {
  val = text_of_quotation(expr);
  cont.data.fn();
}

void ev_lambda() {
  unev = lambda_parameters(expr);
  expr = lambda_body(expr);
  val = make_procedure(unev, expr, env);
  cont.data.fn();
}

/* 手続き作用の評価 */
void ev_application() {
  save(cont);
  save(env);
  unev = operands(expr);
  save(unev);
  expr = operator(expr);
  cont.data.fn = ev_appl_did_operator;
  eval_dispatch();
}

void ev_appl_did_operator() {
  unev = restore();
  env = restore();
  /* argl = empty_arglist(); */
  proc = val;
  if (no_operands(unev)) {
    argl = empty_arglist();
    apply_dispatch();
  } else {
    save(proc);
    ev_appl_operand_first();
    /* ev_appl_operand_loop(); */
  }
}

void ev_appl_operand_first() {
  expr = first_operand(unev);
  if (is_last_operand(unev)) {
    cont.data.fn = ev_appl_operand_first_last;
    eval_dispatch();
  } else {
    save(env);
    save(unev);
    cont.data.fn = ev_appl_accum_first_arg;
    eval_dispatch();
  }
}

void ev_appl_operand_first_last() {
  argl = empty_arglist();
  argl = adjoin_arg(val, argl);
  proc = restore();
  apply_dispatch();
}

void ev_appl_accum_first_arg() {
  unev = restore();
  env = restore();
  argl = empty_arglist();
  argl = adjoin_arg(val, argl);
  unev = rest_operands(unev);
  ev_appl_operand_loop();
}

void ev_appl_operand_loop() {
  save(argl);
  expr = first_operand(unev);
  if (is_last_operand(unev))
    ev_appl_last_arg();
  else {
    save(env);
    save(unev);
    cont.data.fn = ev_appl_accumulate_arg;
    eval_dispatch();
  }
}

void ev_appl_accumulate_arg() {
  unev = restore();
  env = restore();
  argl = restore();
  argl = adjoin_arg(val, argl);
  unev = rest_operands(unev);
  ev_appl_operand_loop();
}

void ev_appl_last_arg() {
  cont.data.fn = ev_appl_accum_last_arg;
  eval_dispatch();
}

void ev_appl_accum_last_arg() {
  argl = restore();
  argl = adjoin_arg(val, argl);
  proc = restore();
  apply_dispatch();
}

/* 手続き作用 */
void apply_dispatch() {
  if (is_primitive_procedure(proc))
    primitive_apply();
  else if (is_compound_procedure(proc))
    compound_apply();
  else
    unknown_procedure_type();
}
void primitive_apply() {
  val = apply_primitive_procedure(proc, argl);
  cont = restore();
  cont.data.fn();
}
void compound_apply() {
  unev = procedure_parameters(proc);
  env = procedure_environment(proc);
  env = extend_environment(unev, argl, env);
  unev = procedure_body(proc);
  ev_sequence();
}

/* 並びの評価 */
void ev_begin() {
  unev = begin_actions(expr);
  save(cont);
  ev_sequence();
}

void ev_sequence() {
  expr = first_expr(unev);
  if (is_last_expr(unev))
    ev_sequence_last_expr();
  else {
    save(unev);
    save(env);
    cont.data.fn = ev_sequence_cont;
    eval_dispatch();
  }
}

void ev_sequence_cont() {
  env = restore();
  unev = restore();
  unev = rest_exprs(unev);
  ev_sequence();
}

void ev_sequence_last_expr() {
  cont = restore();
  eval_dispatch();
}

/* 条件式 */
void ev_if() {
  save(expr);
  save(env);
  save(cont);
  cont.data.fn = ev_if_decide;
  expr = if_predicate(expr);
  eval_dispatch();
}
void ev_if_decide() {
  cont = restore();
  env = restore();
  expr = restore();
  if (val.type != BOOL || val.data.bln != false)
    ev_if_consequent();
  else
    ev_if_alternative();
}

void ev_if_alternative() {
  expr = if_alternative(expr);
  eval_dispatch();
}

void ev_if_consequent() {
  expr = if_consequent(expr);
  eval_dispatch();
}

/* 代入と定義 */
void ev_assignment() {
  unev = assignment_variable(expr);
  save(unev);
  expr = assignment_value(expr);
  save(env);
  save(cont);
  cont.data.fn = ev_assignment1;
  eval_dispatch();
}

void ev_assignment1() {
  cont = restore();
  env = restore();
  unev = restore();
  set_variable_value(unev, val, env);
  cont.data.fn();
}

void ev_definition() {
  unev = definition_variable(expr);
  save(unev);
  expr = definition_value(expr);
  save(env);
  save(cont);
  cont.data.fn = ev_definition1;
  eval_dispatch();
}

void ev_definition1() {
  cont = restore();
  env = restore();
  unev = restore();
  define_variable(unev, val, env);
  val = unev;
  cont.data.fn();
}

/* 評価の実行 */
void read_eval_print_loop() {
  initialize_stack();
  printf("In : ");
  expr = kread(stdin);
  env = get_global_environment();
  cont.data.fn = print_result;
  eval_dispatch();
}

void print_result() {
  printf("Out: ");
  user_print(val);
  read_eval_print_loop();
}

void unknown_expression_type() {
  data_s unknown_expression_type_error =
      symbol_new(";Unknown expression type error");
  val = unknown_expression_type_error;
  signal_error();
}

void unknown_procedure_type() {
  data_s unknown_procedure_type_error =
      symbol_new(";Unknown procedure type error");
  cont = restore();
  val = unknown_procedure_type_error;
  signal_error();
}
void signal_error() {
  user_print(val);
  read_eval_print_loop();
}

extern data_s root; /* garbage collection */
extern data_s stack;
extern data_s procedure;
extern data_s primitive;
extern data_s the_empty_environment;
extern data_s primitive_procedures;
extern data_s the_global_environment;
extern data_s compound_procedure;
extern data_s procedure_env;
int main() {
  expr = env = val = cont = proc = argl = unev = empty_data;
  procedure = symbol_new("procedure");
  primitive = symbol_new("primitive");
  compound_procedure = symbol_new("compound-procedure");
  procedure_env = symbol_new("<procedure-env>");
  the_empty_environment = empty_data;
  primitive_procedures =
    list(23, list(2, symbol_new("car"), (data_s){.type = CAR}),
         list(2, symbol_new("cdr"), (data_s){.type = CDR}),
         list(2, symbol_new("set-car!"), (data_s){.type = SET_CAR}),
         list(2, symbol_new("set-cdr!"), (data_s){.type = SET_CDR}),
         list(2, symbol_new("cons"), (data_s){.type = CONS}),
         list(2, symbol_new("eq?"), (data_s){.type = IS_EQ}),
         list(2, symbol_new("pair?"), (data_s){.type = IS_PAIR}),
         list(2, symbol_new("null?"), (data_s){.type = IS_NULL}),
         list(2, symbol_new("symbol?"), (data_s){.type = IS_SYMBOL}),
         list(2, symbol_new("number?"), (data_s){.type = IS_NUMBER}),
         list(2, symbol_new("char?"), (data_s){.type = IS_CHAR}),
         list(2, symbol_new("string?"), (data_s){.type = IS_STRING}),
         list(2, symbol_new("map"), (data_s){.type = MAP}),
         list(2, symbol_new("list"), (data_s){.type = LIST}),
         list(2, symbol_new("+"), (data_s){.type=NUMBER_ADD}),
         list(2, symbol_new("-"), (data_s){.type=NUMBER_SUB}),
         list(2, symbol_new("*"), (data_s){.type=NUMBER_MUL}),
         list(2, symbol_new("/"), (data_s){.type=NUMBER_DIV}),
         list(2, symbol_new("="), (data_s){.type=NUMBER_EQ}),
         list(2, symbol_new("<"), (data_s){.type=NUMBER_LESS_THAN}),
         list(2, symbol_new("display"), (data_s){.type=DISPLAY}),
         list(2, symbol_new("newline"), (data_s){.type=NEWLINE}),
         list(2, symbol_new("exit"), (data_s){.type=EXIT}));
  the_global_environment = setup_environment();
  read_eval_print_loop();
}

入出力結果(Terminal(gosh), REPL(Read, Eval, Print, Loop))

$ ./kscheme
In : (define factorial
  (lambda (n)
    (if (= n 1)
        1
        (* n (factorial (- n 1))))))
Out: factorial
In : (factorial 10)
Out: 3628800
In : (define fib
  (lambda (n)
    (if (= n 0)
        0
        (if (= n 1)
            1
            (+ (fib (- n 1))
               (fib (- n 2)))))))
Out: fib
In : (fib 20)
Out: 6765
In : (exit)
$