Scheme - C言語による Scheme の interpreter (kscheme) - (除算の商(quotient 手続き)と剰余(remainder 手続き), リストの長さ(length 手続き))

開発環境

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

SICPで必要になった, 除算の商を得る quotient 手続き、リストの長さを得る length 手続き、また、除算の剰余を得る remainder 手続き等を追加、実装。(GMPを利用)

参考書籍等

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

number_z.c

#include "number_z.h"
#include <gmp.h>
#include "stopif.h"

data_s number_z_new(char *in) {
  data_s out = {.type = Z};
  Stopif(mpz_init_set_str(out.data.z, in, 10) == -1, exit(1),
         "整数割り当て失敗");
  return out;
}

data_s number_z_copy(data_s in) {
  data_s out = {.type = Z};
  mpz_init_set(out.data.z, in.data.z);
  return out;
}

void number_z_free(data_s in) { mpz_clear(in.data.z); }

void number_z_print(FILE *stream, data_s in) {
  mpz_out_str(stream, 10, in.data.z);
}

bool number_z_eq(data_s in1, data_s in2) {
  return mpz_cmp(in1.data.z, in2.data.z) == 0;
}

data_s number_z_quotient(data_s in1, data_s in2) {
  data_s out = {.type=Z};
  mpz_init(out.data.z);
  mpz_tdiv_q(out.data.z, in1.data.z, in2.data.z);
  return out;
}

prim_number_procedures.c

#include "prim_number_procedures.h"
#include "list_operations.h"
#include <gmp.h>

static data_s number_add(data_s in1, data_s in2);
static data_s number_sub(data_s in1, data_s in2);
static data_s number_mul(data_s in1, data_s in2);
static data_s number_div(data_s in1, data_s in2);
static data_s number_eq(data_s in1, data_s in2);
static data_s number_less_than(data_s in1, data_s in2);

data_s prim_number_add(data_s in) { return number_add(car(in), car(cdr(in))); }
data_s prim_number_sub(data_s in) { return number_sub(car(in), car(cdr(in))); }
data_s prim_number_mul(data_s in) { return number_mul(car(in), car(cdr(in))); }
data_s prim_number_div(data_s in) { return number_div(car(in), car(cdr(in))); }
data_s prim_number_eq(data_s in) { return number_eq(car(in), car(cdr(in))); }
data_s prim_number_less_than(data_s in) {
  return number_less_than(car(in), car(cdr(in)));
}
data_s prim_number_greater_than(data_s in) {
  return number_less_than(car(cdr(in)), car(in));
}

#include "error.h"
static data_s number_add(data_s in1, data_s in2) {
  data_s out;
  if (in1.type == Z) {
    if (in2.type == Z) {
      out.type = Z;
      mpz_init(out.data.z);
      mpz_add(out.data.z, in1.data.z, in2.data.z);
    } else if (in2.type == Q) {
      out.type = Q;
      mpq_init(out.data.q);
      mpq_t x;
      mpq_init(x);
      mpq_set_z(x, in1.data.z);
      mpq_add(out.data.q, x, in2.data.q);
      mpq_clear(x);
    } else if (in2.type == R) {
      out.type = R;
      mpf_init(out.data.r);
      mpf_t x;
      mpf_init(x);
      mpf_set_z(x, in1.data.z);
      mpf_add(out.data.r, x, in2.data.r);
      mpf_clear(x);
    } else {
      out = error_data;
    }
  } else if (in1.type == Q) {
    if (in2.type == Z)
      out = number_add(in2, in1);
    else if (in2.type == Q) {
      out.type = Q;
      mpq_init(out.data.q);
      mpq_add(out.data.q, in1.data.q, in2.data.q);
    } else if (in2.type == R) {
      out.type = R;
      mpf_init(out.data.r);
      mpf_t x;
      mpf_init(x);
      mpf_set_q(x, in1.data.q);
      mpf_add(out.data.r, x, in2.data.r);
      mpf_clear(x);
    } else
      out = error_data;
  } else if (in1.type == R) {
    if (in2.type == Z)
      out = number_add(in2, in1);
    else if (in2.type == Q)
      out = number_add(in2, in1);
    else if (in2.type == R) {
      out.type = R;
      mpf_init(out.data.r);
      mpf_add(out.data.r, in1.data.r, in2.data.r);
    } else
      out = error_data;
  } else
    out = error_data;
  return out;
}

static data_s number_sub(data_s in1, data_s in2) {
  data_s out;
  if (in1.type == Z) {
    if (in2.type == Z) {
      out.type = Z;
      mpz_init(out.data.z);
      mpz_sub(out.data.z, in1.data.z, in2.data.z);
    } else if (in2.type == Q) {
      out.type = Q;
      mpq_init(out.data.q);
      mpq_t x;
      mpq_init(x);
      mpq_set_z(x, in1.data.z);
      mpq_sub(out.data.q, x, in2.data.q);
      mpq_clear(x);
    } else if (in2.type == R) {
      out.type = R;
      mpf_init(out.data.r);
      mpf_t x;
      mpf_init(x);
      mpf_set_z(x, in1.data.z);
      mpf_sub(out.data.r, x, in2.data.r);
      mpf_clear(x);
    } else {
      out = error_data;
    }
  } else if (in1.type == Q) {
    if (in2.type == Z) {
      out.type = Q;
      mpq_init(out.data.q);
      mpq_t x;
      mpq_init(x);
      mpq_set_z(x, in2.data.z);
      mpq_sub(out.data.q, in1.data.q, x);
      mpq_clear(x);
    } else if (in2.type == Q) {
      out.type = Q;
      mpq_init(out.data.q);
      mpq_sub(out.data.q, in1.data.q, in2.data.q);
    } else if (in2.type == R) {
      out.type = R;
      mpf_init(out.data.r);
      mpf_t x;
      mpf_init(x);
      mpf_set_q(x, in1.data.q);
      mpf_sub(out.data.r, x, in2.data.r);
      mpf_clear(x);
    } else {
      out = error_data;
    }
  } else if (in1.type == R) {
    out.type = R;
    mpf_init(out.data.r);
    if (in2.type == Z) {
      mpf_t x;
      mpf_init(x);
      mpf_set_z(x, in2.data.z);
      mpf_sub(out.data.r, in1.data.r, x);
      mpf_clear(x);
    } else if (in2.type == Q) {
      mpf_t x;
      mpf_init(x);
      mpf_set_q(x, in2.data.q);
      mpf_sub(out.data.r, in1.data.r, x);
      mpf_clear(x);
    } else if (in2.type == R) {
      mpf_sub(out.data.r, in1.data.r, in2.data.r);
    } else {
      out = error_data;
    }
  } else {
    out = error_data;
  }
  return out;
}

static data_s number_mul(data_s in1, data_s in2) {
  data_s out;
  if (in1.type == Z) {
    if (in2.type == Z) {
      out.type = Z;
      mpz_init(out.data.z);
      mpz_mul(out.data.z, in1.data.z, in2.data.z);
    } else if (in2.type == Q) {
      out.type = Q;
      mpq_init(out.data.q);
      mpq_t x;
      mpq_init(x);
      mpq_set_z(x, in1.data.z);
      mpq_mul(out.data.q, x, in2.data.q);
      mpq_clear(x);
    } else if (in2.type == R) {
      out.type = R;
      mpf_init(out.data.r);
      mpf_t x;
      mpf_init(x);
      mpf_set_z(x, in1.data.z);
      mpf_mul(out.data.r, x, in2.data.r);
      mpf_clear(x);
    } else {
      out = error_data;
    }
  } else if (in1.type == Q) {
    if (in2.type == Z)
      out = number_mul(in2, in1);
    else if (in2.type == Q) {
      out.type = Q;
      mpq_init(out.data.q);
      mpq_mul(out.data.q, in1.data.q, in2.data.q);
    } else if (in2.type == R) {
      out.type = R;
      mpf_init(out.data.r);
      mpf_t x;
      mpf_init(x);
      mpf_set_q(x, in1.data.q);
      mpf_mul(out.data.r, x, in2.data.r);
      mpf_clear(x);
    } else
      out = error_data;
  } else if (in1.type == R) {
    if (in2.type == Z)
      out = number_mul(in2, in1);
    else if (in2.type == Q)
      out = number_mul(in2, in1);
    else if (in2.type == R) {
      out.type = R;
      mpf_init(out.data.r);
      mpf_mul(out.data.r, in1.data.r, in2.data.r);
    } else
      out = error_data;
  } else
    out = error_data;
  return out;
}

static data_s number_div(data_s in1, data_s in2) {
  data_s out;
  if (in1.type == Z) {
    if (in2.type == Z) {
      out.type = Q;
      mpq_init(out.data.q);
      mpq_t x, y;
      mpq_init(x);
      mpq_init(y);
      mpq_set_z(x, in1.data.z);
      mpq_set_z(y, in2.data.z);
      mpq_div(out.data.q, x, y);
      mpq_clear(x);
      mpq_clear(y);
    } else if (in2.type == Q) {
      out.type = Q;
      mpq_init(out.data.q);
      mpq_t x;
      mpq_init(x);
      mpq_set_z(x, in1.data.z);
      mpq_div(out.data.q, x, in2.data.q);
      mpq_clear(x);
    } else if (in2.type == R) {
      out.type = R;
      mpf_init(out.data.r);
      mpf_t x;
      mpf_init(x);
      mpf_set_z(x, in1.data.z);
      mpf_div(out.data.r, x, in2.data.r);
      mpf_clear(x);
    } else {
      out = error_data;
    }
  } else if (in1.type == Q) {
    if (in2.type == Z) {
      out.type = Q;
      mpq_init(out.data.q);
      mpq_t x;
      mpq_init(x);
      mpq_set_z(x, in2.data.z);
      mpq_div(out.data.q, in1.data.q, x);
      mpq_clear(x);
    } else if (in2.type == Q) {
      out.type = Q;
      mpq_init(out.data.q);
      mpq_div(out.data.q, in1.data.q, in2.data.q);
    } else if (in2.type == R) {
      out.type = R;
      mpf_init(out.data.r);
      mpf_t x;
      mpf_init(x);
      mpf_set_q(x, in1.data.q);
      mpf_div(out.data.r, x, in2.data.r);
      mpf_clear(x);
    } else {
      out = error_data;
    }
  } else if (in1.type == R) {
    out.type = R;
    mpf_init(out.data.r);
    if (in2.type == Z) {
      mpf_t x;
      mpf_init(x);
      mpf_set_z(x, in2.data.z);
      mpf_div(out.data.r, in1.data.r, x);
      mpf_clear(x);
    } else if (in2.type == Q) {
      mpf_t x;
      mpf_init(x);
      mpf_set_q(x, in2.data.q);
      mpf_div(out.data.r, in1.data.r, x);
      mpf_clear(x);
    } else if (in2.type == R) {
      mpf_div(out.data.r, in1.data.r, in2.data.r);
    } else {
      out = error_data;
    }
  } else {
    out = error_data;
  }
  return out;
}

#include "boolean.h"
static data_s number_eq(data_s in1, data_s in2) {
  data_s out;
  if (in1.type == Z) {
    if (in2.type == Z) {
      out = mpz_cmp(in1.data.z, in2.data.z) == 0 ? true_data : false_data;
    } else if (in2.type == Q) {
      mpq_t x;
      mpq_init(x);
      mpq_set_z(x, in1.data.z);
      out = mpq_equal(x, in2.data.q) != 0 ? true_data : false_data;
      mpq_clear(x);
    } else if (in2.type == R) {
      mpf_t x;
      mpf_init(x);
      mpf_set_z(x, in1.data.z);
      out = mpf_cmp(x, in2.data.r) == 0 ? true_data : false_data;
      mpf_clear(x);
    } else {
      out = error_data;
    }
  } else if (in1.type == Q) {
    if (in2.type == Z)
      out = number_eq(in2, in1);
    else if (in2.type == Q) {
      out = mpq_equal(in1.data.q, in2.data.q) != 0 ? true_data : false_data;
    } else if (in2.type == R) {
      mpf_t x;
      mpf_init(x);
      mpf_set_q(x, in1.data.q);
      out = mpf_cmp(x, in2.data.r) == 0 ? true_data : false_data;
      mpf_clear(x);
    } else
      out = error_data;
  } else if (in1.type == R) {
    if (in2.type == Z)
      out = number_eq(in2, in1);
    else if (in2.type == Q)
      out = number_eq(in2, in1);
    else if (in2.type == R) {
      out = mpf_cmp(in1.data.r, in2.data.r) == 0 ? true_data : false_data;
    } else
      out = error_data;
  } else
    out = error_data;
  return out;
}

static data_s number_less_than(data_s in1, data_s in2) {
  data_s out;
  if (in1.type == Z) {
    if (in2.type == Z) {
      out = mpz_cmp(in1.data.z, in2.data.z) < 0 ? true_data : false_data;
    } else if (in2.type == Q) {
      mpq_t x;
      mpq_init(x);
      mpq_set_z(x, in1.data.z);
      out = mpq_cmp(x, in2.data.q) < 0 ? true_data : false_data;
      mpq_clear(x);
    } else if (in2.type == R) {
      mpf_t x;
      mpf_init(x);
      mpf_set_z(x, in1.data.z);
      out = mpf_cmp(x, in2.data.r) < 0 ? true_data : false_data;
      mpf_clear(x);
    } else {
      out = error_data;
    }
  } else if (in1.type == Q) {
    if (in2.type == Z) {
      mpq_t x;
      mpq_init(x);
      mpq_set_z(x, in2.data.z);
      out = mpq_cmp(in1.data.q, x) < 0 ? true_data : false_data;
      mpq_clear(x);
    } else if (in2.type == Q) {
      out = mpq_cmp(in1.data.q, in2.data.q) < 0 ? true_data : false_data;
    } else if (in2.type == R) {
      mpf_t x;
      mpf_init(x);
      mpf_set_q(x, in1.data.q);
      out = mpf_cmp(x, in2.data.r) < 0 ? true_data : false_data;
      mpf_clear(x);
    } else {
      out = error_data;
    }
  } else if (in1.type == R) {
    if (in2.type == Z) {
      mpf_t x;
      mpf_init(x);
      mpf_set_z(x, in2.data.z);
      out = mpf_cmp(in1.data.r, x) < 0 ? true_data : false_data;
      mpf_clear(x);
    } else if (in2.type == Q) {
      mpf_t x;
      mpf_init(x);
      mpf_set_q(x, in2.data.q);
      out = mpf_cmp(in1.data.r, x) < 0 ? true_data : false_data;
      mpf_clear(x);
    } else if (in2.type == R) {
      out = mpf_cmp(in1.data.r, in2.data.r) < 0 ? true_data : false_data;
    } else {
      out = error_data;
    }
  } else {
    out = error_data;
  }
  return out;
}

data_s prim_number_remainder(data_s in) {
  data_s out;
  data_s in1 = car(in);
  data_s in2 = cadr(in);
  if (in2.type == Z) {
    out.type = Z;
    mpz_init(out.data.z);
    mpz_tdiv_r(out.data.z, in1.data.z, in2.data.z);
  }
  return out;
}

#include "boolean.h"
data_s prim_is_number(data_s in) {
  data_s t = car(in);
  return t.type == Z || t.type == Q || t.type == R ? true_data : false_data;
}

#include "number_z.h"
data_s prim_number_quotient(data_s in) {
  return number_z_quotient(car(in), cadr(in));
}

list_operations.c

#include "list_operations.h"

/* const size_t memory_size = 15932; */
/* const size_t memory_size = 32768; */
const size_t memory_size = 50000;

data_s *cars;
data_s *cdrs;
char *markers;
data_s car(data_s in) { return data_s_copy(*(cars + in.data.index)); }
data_s cdr(data_s in) { return data_s_copy(*(cdrs + in.data.index)); }
#include "undef.h"
data_s set_car(data_s in1, data_s in2) {
  data_s_free(*(cars + in1.data.index));
  *(cars + in1.data.index) = data_s_copy(in2);
  return undef_data;
}

data_s set_cdr(data_s in1, data_s in2) {
  data_s_free(*(cdrs + in1.data.index));
  *(cdrs + in1.data.index) = data_s_copy(in2);
  return undef_data;
}

#include "garbage_collector.h"
size_t marker_count = 0;
size_t free_index = 0;
data_s cons(data_s in1, data_s in2) {
  *(markers + free_index) += 1;
  marker_count++;
  data_s out = {.type = PAIR, .data.index = free_index};
  *(cars + free_index) = data_s_copy(in1);
  *(cdrs + free_index) = data_s_copy(in2);

  if (marker_count == memory_size)
    begin_garbage_collection();

  free_index++;
  while (1) {
    if (free_index == memory_size)
      free_index = 0;
    if (*(markers + free_index) == 0)
      break;
    free_index++;
  }
  return out;
}

#include "undef.h"
data_s set(data_s *in1, data_s in2) {
  data_s_free(*in1);
  *in1 = data_s_copy(in2);
  return undef_data;
}

#include "empty.h"
data_s list(int args, ...) {
  data_s data_array[args];
  data_s out = empty_data;
  va_list ap;
  va_start(ap, args);
  for (int i = 0; i < args; i++)
    *(data_array + i) = va_arg(ap, data_s);
  va_end(ap);
  for (int i = args; i > 0; i--) {
    out = cons(*(data_array + i - 1), out);
  }
  return out;
}

data_s append(data_s in1, data_s in2) {
  if (in1.type == EMPTY)
    return in2;
  return cons(car(in1), append(cdr(in1), in2));
}

data_s reverse(data_s in) {
  data_s out = empty_data;
  while (in.type != EMPTY) {
    out = cons(car(in), out);
    in = cdr(in);
  }
  return out;
}

#include "number_z.h"
data_s length(data_s in) {
  data_s out = number_z_new("0");  
  while (in.type != EMPTY) {
    data_s t = number_z_copy(out);
    mpz_add_ui(out.data.z, t.data.z, 1);
    number_z_free(t);
    in = cdr(in);
  }
  return out;
}

data_s caar(data_s in) { return car(car(in)); }
data_s cadr(data_s in) { return car(cdr(in)); }
data_s cdar(data_s in) { return cdr(car(in)); }
data_s cddr(data_s in) { return cdr(cdr(in)); }
data_s caaar(data_s in) { return car(car(car(in))); }
data_s caadr(data_s in) { return car(car(cdr(in))); }
data_s cadar(data_s in) { return car(cdr(car(in))); }
data_s caddr(data_s in) { return car(cdr(cdr(in))); }
data_s cdaar(data_s in) { return cdr(car(car(in))); }
data_s cdadr(data_s in) { return cdr(car(cdr(in))); }
data_s cddar(data_s in) { return cdr(cdr(car(in))); }
data_s cdddr(data_s in) { return cdr(cdr(cdr(in))); }
data_s caaaar(data_s in) { return car(car(car(car(in)))); }
data_s caaadr(data_s in) { return car(car(car(cdr(in)))); }
data_s caadar(data_s in) { return car(car(cdr(car(in)))); }
data_s caaddr(data_s in) { return car(car(cdr(cdr(in)))); }
data_s cadaar(data_s in) { return car(cdr(car(car(in)))); }
data_s cadadr(data_s in) { return car(cdr(car(cdr(in)))); }
data_s caddar(data_s in) { return car(cdr(cdr(car(in)))); }
data_s cadddr(data_s in) { return car(cdr(cdr(cdr(in)))); }
data_s cdaaar(data_s in) { return cdr(car(car(car(in)))); }
data_s cdaadr(data_s in) { return cdr(car(car(cdr(in)))); }
data_s cdadar(data_s in) { return cdr(car(cdr(car(in)))); }
data_s cdaddr(data_s in) { return cdr(car(cdr(cdr(in)))); }
data_s cddaar(data_s in) { return cdr(cdr(car(car(in)))); }
data_s cddadr(data_s in) { return cdr(cdr(car(cdr(in)))); }
data_s cdddar(data_s in) { return cdr(cdr(cdr(car(in)))); }
data_s cddddr(data_s in) { return cdr(cdr(cdr(cdr(in)))); }