Scheme - C言語による Scheme の interpreter (kscheme) - (lexicaladdressing(文面アドレス)の実装)

開発環境

• 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ではなく、関数を呼び出すとか))を少しずつ書き進めてめていくことに。

入れ子になったlambda式での変数探索の最適化のため、文面アドレスを実装。

参考書籍等

• 計算機プログラムの構造と解釈[第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)

lexical_addressing.h

#pragma once
#include "data.h"

data_s lexical_address_lookup(data_s env, size_t frame_num, size_t disp_num);
data_s lexical_address_set(data_s env, size_t frame_num, size_t disp_num,
                           data_s val);
data_s find_variable(data_s var, data_s env);

lexical_addressing.c

#include "lexical_addressing.h"
#include "list_operations.h"
#include "data_structures.h"

data_s unassigned;
extern data_s error_data;
data_s lexical_address_lookup(data_s env, size_t frame_num, size_t disp_num) {
  data_s out = env;
  for (; frame_num > 0; frame_num--) {
    if (out.type == EMPTY) {
      fprintf(stderr, ";LEXICAL-ADDRESS-LOOKUP frame number: %ld displacement "
                      "number: %ld\n",
              frame_num, disp_num);
      return error_data;
    }
    out = enclosing_environment(out);
  }
  if (out.type == EMPTY) {
    fprintf(stderr, ";LEXICAL-ADDRESS-LOOKUP frame number: %ld displacement "
                    "number: %ld\n",
            frame_num, disp_num);
    return error_data;
  }

  out = first_frame(out);
  out = frame_values(out);
  for (; disp_num > 0; disp_num--)
    out = cdr(out);
  if (out.type == EMPTY) {
    fprintf(stderr, ";LEXICAL-ADDRESS-LOOKUP frame number: %ld displacement "
                    "number: %ld\n",
            frame_num, disp_num);
    return error_data;
  }

  out = car(out);
  return out.type == SYMBOL && out.data.symbol == unassigned.data.symbol
             ? error_data
             : out;
}

data_s lexical_address_set(data_s env, size_t frame_num, size_t disp_num,
                           data_s val) {
  data_s frame = env;
  for (; frame_num > 0; frame_num--) {
    if (frame.type == EMPTY) {
      fprintf(stderr, ";LEXICAL-ADDRESS-SET! frame number: %ld displacement "
                      "number: %ld\n",
              frame_num, disp_num);
      return error_data;
    }
    frame = enclosing_environment(frame);
  }
  if (frame.type == EMPTY) {
    fprintf(stderr, ";LEXICAL-ADDRESS-SET! frame number: %ld displacement "
                    "number: %ld\n",
            frame_num, disp_num);
    return error_data;
  }

  frame = car(frame);
  data_s values = frame_values(frame);
  for (; disp_num > 0; disp_num--) {
    if (values.type == EMPTY) {
      fprintf(stderr, ";LEXICAL-ADDRESS-SET! frame number: %ld displacement "
                      "number: %ld\n",
              frame_num, disp_num);
      return error_data;
    }
    values = cdr(values);
  }
  if (values.type == EMPTY) {
    fprintf(stderr, ";LEXICAL-ADDRESS-SET! frame number: %ld displacement "
                    "number: %ld\n",
            frame_num, disp_num);
    return error_data;
  }
  set_car(values, val);
  return val;
}

data_s not_found;
data_s find_variable(data_s var, data_s env) {
  size_t len = c_length(env);
  data_s frames = env;
  data_s frame;
  for (size_t frame_num = 0; frame_num < len; frame_num++) {
    frame = car(frames);
    frame = cdr(frame);
    size_t frame_len = c_length(frame);
    for (size_t disp_num = 0; disp_num < frame_len; disp_num++) {
      data_s b = is_eq(var, car(frame));
      if (b.type == SYMBOL && b.data.bln == true)
        return cons((data_s){.data.size = frame_num},
                    (data_s){.data.size = disp_num});
    }
  }
  return not_found;
}

kscheme.c

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

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

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

void ev_appl_did_operator1();
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 = find_variable(expr, car(env));
  val = val.type == SYMBOL
            ? lookup_variable_value(expr, cdr(env))
            : lexical_address_lookup(cdr(env), car(val).data.size,
                                     cdr(val).data.size);
  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);
  unev = operands(expr);
  expr = operator(expr);
  if (expr.type == SYMBOL) {
    cont.data.fn = ev_appl_did_operator1;
  } else {
    cont.data.fn = ev_appl_did_operator;
    save(unev);
    save(env);
  }
  eval_dispatch();
}

void ev_appl_did_operator1() {
  proc = val;
  if (no_operands(unev)) {
    argl = empty_arglist();
    apply_dispatch();
  } else {
    save(proc);
    ev_appl_operand_first();
  }
}

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

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 = cons(cons(argl, car(env)),
             extend_environment(unev, argl, cdr(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();
  data_s lexical_address = find_variable(unev, car(env));
  if (lexical_address.type == SYMBOL)
    set_variable_value(unev, val, cdr(env));
  else
    lexical_address_set(cdr(env), car(lexical_address).data.size,
                        cdr(lexical_address).data.size, val);
  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, cdr(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);
  print_statistics();
  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 *cars;
extern data_s *cdrs;
data_s *new_cars;
data_s *new_cdrs;

extern data_s root; /* garbage collection */
extern data_s stack;
extern data_s lambda;
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;

/* lexical_addressing */
extern data_s unassigned;
extern data_s not_found;

int main() {
  cars = malloc(sizeof(data_s) * MEMORY_SIZE);
  cdrs = malloc(sizeof(data_s) * MEMORY_SIZE);
  new_cars = malloc(sizeof(data_s) * MEMORY_SIZE);
  new_cdrs = malloc(sizeof(data_s) * MEMORY_SIZE);

  expr = env = val = cont = proc = argl = unev = empty_data;
  lambda = symbol_new("lambda");
  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;

  unassigned = symbol_new("*unassigned*");
  not_found = symbol_new("*not-found*");
  
  primitive_procedures =
      list(24, list(2, symbol_new("car"), (data_s){.type = CAR}),
           list(2, symbol_new("cdr"), (data_s){.type = CDR}),
           list(2, symbol_new("set!"), (data_s){.type = SET}),
           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 f
  ((lambda (x y)
     (lambda (a b c d e)
            ((lambda (y z) (* x y))
             (* x y)
             (+ x y))))
   1
   2))
Out: f
;(total-pushes = 10 maximum-depth = 7)
In : f
Out: (compound-procedure (a b c d e) (((lambda (y z) (* x y)) (* x y) (+ x y))) <procedure-env>)
;(total-pushes = 0 maximum-depth = 0)
In : (f 1 2 3 4 5)
Out: 2
;(total-pushes = 36 maximum-depth = 8)
In : (exit)
$