Scheme - C言語による Scheme の interpreter (kscheme) - (gcd(greatest common divisor、最大公約数) 手続きを実装)

開発環境

• 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で、合成手続きとして実装した gcd 手続きが、うまく機能しなかったから、とりあえず gcd 手続きを実装。(gmpを利用。Scheme の仕様(r7rs)の gcd 手続きと挙動は異なり、有理数、実数の場合は零に向かって丸めて、整数にして求めるように実装した。)

参考書籍等

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

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));
}

data_s prim_number_sin(data_s in) {
  data_s out = {.type = R};

  return out;
}

data_s prim_number_cos(data_s in) {
  data_s out = {.type = R};

  return out;
}

#include <string.h>
#include <stdlib.h>
data_s prim_number_number2string(data_s in) {
  int base = 10;
  char *s = NULL;
  if (cdr(in).type != EMPTY) {
    base = mpz_get_ui(cadr(in).data.z);
  }
  data_s d = car(in);
  if (d.type == Z) {
    s = mpz_get_str(s, base, d.data.z);
  } else if (d.type == Q) {
    s = mpq_get_str(NULL, base, d.data.q);
  } else if (d.type == R) {
    mp_exp_t e;
    char *t;
    t = mpf_get_str(NULL, &e, base, 0, d.data.r);
    size_t len = strlen(t);
    s = malloc(sizeof(char) * (len + 1));
    size_t i = 0;
    for (; i < len + 1; i++) {
      if (e == 0) {
        s[i] = '.';
        e--;
      } else {
        s[i] = *t;
        t++;
        e--;
      }
    }
  }
  return (data_s){.type = STRING, .data.str = s};
}

#include "number.h"
data_s prim_number_gcd(data_s in) {
  data_s out;
  if (in.type == EMPTY) {
    out = data_s_new(Z, "0");
  } else if (cdr(in).type == EMPTY) {
    out = car(in);
  } else {
    out.type = Z;
    mpz_init(out.data.z);
    data_s in1 = car(in);
    data_s in2 = cadr(in);
    if (in1.type == Z) {
      if (in2.type == Z) {        
        mpz_gcd(out.data.z, in1.data.z, in2.data.z);
      } else if (in2.type == Q) {
        data_s t = {.type=Z};
        mpz_init(t.data.z);
        mpz_set_q(t.data.z, in2.data.q);
        mpz_gcd(out.data.z, in1.data.z, t.data.z);
      } else if (in2.type == R) {
        data_s t = {.type=Z};
        mpz_init(t.data.z);
        mpz_set_f(t.data.z, in2.data.r);
        mpz_gcd(out.data.z, in1.data.z, t.data.z);        
      }
    } else if (in1.type == Q) {
      data_s t = {.type = Z};
      mpz_init(t.data.z);
      mpz_set_q(t.data.z, in1.data.q);      
      if (in2.type == Z) {
        mpz_gcd(out.data.z, t.data.z, in2.data.z);
      } else if (in2.type == Q) {
        data_s t2 = {.type=Z};
        mpz_init(t2.data.z);
        mpz_set_q(t2.data.z, in2.data.q);
        mpz_gcd(out.data.z, t.data.z, t2.data.z);
      } else if (in2.type == R) {
        data_s t2 = {.type=Z};
        mpz_init(t2.data.z);
        mpz_set_f(t2.data.z, in2.data.r);
        mpz_gcd(out.data.z, t.data.z, t2.data.z);        
      }
    } else if (in1.type == R) {
      data_s t = {.type =Z};
      mpz_init(t.data.z);
      mpz_set_f(t.data.z, in1.data.r);
      if (in2.type == Z) {
        mpz_gcd(out.data.z, t.data.z, in2.data.z);
      } else if (in2.type == Q) {
        data_s t2 = {.type=Z};
        mpz_init(t2.data.z);
        mpz_set_q(t2.data.z, in2.data.q);
        mpz_gcd(out.data.z, t.data.z, t2.data.z);        
      } else if (in2.type == R) {
        data_s t2 = {.type=Z};
        mpz_init(t2.data.z);
        mpz_set_f(t2.data.z, in2.data.r);
        mpz_gcd(out.data.z, t.data.z, t2.data.z);        
      }
    }
    data_s t = cddr(in);
    while (t.type != EMPTY) {
      
    }
  }
  return out;
}

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

$ kscheme 
kscm> (gcd 1 2)
1
kscm> (gcd 10 15)
5
kscm> (gcd 10/7 15/7)
1
kscm> (gcd 10 15.5)
5
kscm> (gcd 10.1 15.5)
5
kscm> (gcd 10.1 15.6)
5
kscm> (gcd 10.1 15.9)
5
kscm> (gcd 10.1 16)
2
kscm> (gcd 10.9 16)
2
kscm> $