2017年1月21日土曜日

開発環境

Cを高級アセンブラーとした、Scheme の コンパイラー(ksc)、インタプリター(ksi)の作成で、標準ライブラリの complex ライブラリの手続きのを実装、複素数を扱うライブラリを complex(c11) から GNU MPC に変更。

コード

kscm

number.h

#pragma once
/** \file  */
#include "object.h"
extern fn_obj_of_obj bool_of_obj_ks[];
extern fn_obj_of_obj obj_of_obj_obj_ks[];
extern fn_obj_of_obj obj_of_obj_ks[];

extern mpfr_prec_t prec;

/*  */

/* complex library */
Object number_angle(Object args);
Object number_imag_part(Object args);
Object number_magnitude(Object args);
Object number_make_polar(Object args);
Object number_make_rectangular(Object args);
Object number_real_part(Object args);

void number_init();

number.c

#include "number.h"

/* mpfr_prec_t prec = 53; */
mpfr_prec_t prec = 128;

/*  */

/* complex library */
Object number_angle(Object args) {
  return apply_obj_of_obj(number_angle, args);
}
Object number_imag_part(Object args) {
  return apply_obj_of_obj(number_imag_part, args);
}
Object number_magnitude(Object args) {
  return apply_obj_of_obj(number_magnitude, args);
}
Object number_make_polar(Object args) {
  return apply_obj_of_obj_obj(number_make_polar, args);
}
Object number_make_rectangular(Object args) {
  return apply_obj_of_obj_obj(number_make_rectangular, args);
}
Object number_real_part(Object args) {
  return apply_obj_of_obj(number_real_part, args);
}

/*  */

scm_complex.c

#include "scm_complex.h"

static mpf_t opf1, opf2;
Object complex_new(char const *real, char const *imag, int base) {
  mpf_set_str(opf1, real, base);
  mpf_set_str(opf2, imag, base);
  Object out = {.type = COMPLEX};
  mpc_init2(out.z, prec);
  mpc_set_f_f(out.z, opf1, opf2, MPC_RNDNN);
  return out;
}
static Object copy(Object o) {
  Object out = {.type = COMPLEX};
  mpc_init2(out.z, prec);
  mpc_set(out.z, o.z, MPC_RNDNN);
  return out;
}
static void complex_free(Object *ptr) { mpc_clear(ptr->z); }
/* object.h */
static bool eqv_p(Object o1, Object o2) { return mpc_cmp(o1.z, o2.z) == 0; }
static mpfr_t opfr1, opfr2;
static void write(Object o, FILE *s) {
  if (mpfr_inf_p(mpc_realref(o.z))) {
    fprintf(s, "%cinf.0", mpfr_sgn(mpc_realref(o.z)) > 0 ? '+' : '-');
  } else if (mpfr_nan_p(mpc_realref(o.z))) {
    fprintf(s, "+nan.0");
  } else {
    mpfr_get_f(opf1, mpc_realref(o.z), MPFR_RNDN);
    gmp_fprintf(s, "%.*Fg", prec, opf1);
    mpfr_round(opfr1, mpc_realref(o.z));
    if (mpfr_equal_p(opfr1, mpc_realref(o.z))) {
      fprintf(s, ".0");
    }
  }
  if (!mpfr_zero_p(mpc_imagref(o.z))) {
    if (mpfr_inf_p(mpc_imagref(o.z))) {
      fprintf(s, "%cinf.0", mpfr_sgn(mpc_imagref(o.z)) > 0 ? '+' : '-');
    } else if (mpfr_nan_p(mpc_imagref(o.z))) {
      fprintf(s, "+nan.0");
    } else {
      mpfr_get_f(opf1, mpc_imagref(o.z), MPFR_RNDN);
      gmp_fprintf(s, "%+.*Fg", prec, opf1);
      mpfr_round(opfr1, mpc_imagref(o.z));
      if (mpfr_equal_p(opfr1, mpc_imagref(o.z))) {
        fprintf(s, ".0");
      }
    }
    fprintf(s, "i");
  }
}

/* number.h */
static bool integer_p(Object o) {
  if (mpfr_zero_p(mpc_imagref(o.z))) {
    mpfr_round(opfr1, mpc_realref(o.z));
    return mpfr_equal_p(opfr1, mpc_realref(o.z));
  }
  return false;
}
static bool exact_p(Object o) { return false; }
static bool finite_p(Object o) {
  return !mpfr_inf_p(mpc_realref(o.z)) && !mpfr_inf_p(mpc_imagref(o.z)) &&
         !mpfr_nan_p(mpc_realref(o.z)) && !mpfr_nan_p(mpc_imagref(o.z));
}
static bool infinite_p(Object o) {
  return mpfr_inf_p(mpc_realref(o.z)) || mpfr_inf_p(mpc_imagref(o.z));
}
static bool nan_p(Object o) {
  return mpfr_nan_p(mpc_realref(o.z)) || mpfr_nan_p(mpc_imagref(o.z));
}
static bool lt(Object o1, Object o2) {
  return mpfr_less_p(mpc_realref(o1.z), mpc_realref(o2.z));
}
static Object math_equal(Object o1, Object o2) {
  return mpc_cmp(o1.z, o2.z) == 0 ? boolean_true : boolean_false;
}
static Object add(Object o1, Object o2) {
  Object out = {.type = COMPLEX};
  mpc_init2(out.z, prec);
  mpc_add(out.z, o1.z, o2.z, MPC_RNDNN);
  return out;
}
static Object mul(Object o1, Object o2) {
  Object out = {.type = COMPLEX};
  mpc_init2(out.z, prec);
  mpc_mul(out.z, o1.z, o2.z, MPC_RNDNN);
  return out;
}
static Object sub(Object o1, Object o2) {
  Object out = {.type = COMPLEX};
  mpc_init2(out.z, prec);
  mpc_sub(out.z, o1.z, o2.z, MPC_RNDNN);
  return out;
}
static Object complex_div(Object o1, Object o2) {
  Object out = {.type = COMPLEX};
  mpc_init2(out.z, prec);
  mpc_div(out.z, o1.z, o2.z, MPC_RNDNN);
  return out;
}
static Object complex_floor(Object o) {
  Object out = {.type = COMPLEX};
  mpc_init2(out.z, prec);
  mpfr_floor(opfr1, mpc_realref(o.z));
  mpc_set_fr(out.z, opfr1, MPC_RNDNN);
  return out;
}
static Object ceiling(Object o) {
  Object out = {.type = COMPLEX};
  mpc_init2(out.z, prec);
  mpfr_ceil(opfr1, mpc_realref(o.z));
  mpc_set_fr(out.z, opfr1, MPC_RNDNN);
  return out;
}
static Object truncate(Object o) {
  Object out = {.type = COMPLEX};
  mpc_init2(out.z, prec);
  mpfr_trunc(opfr1, mpc_realref(o.z));
  mpc_set_fr(out.z, opfr1, MPC_RNDNN);
  return out;
}
static Object complex_round(Object o) {
  Object out = {.type = COMPLEX};
  mpc_init2(out.z, prec);
  mpfr_round(opfr1, mpc_realref(o.z));
  mpc_set_fr(out.z, opfr1, MPC_RNDNN);
  return out;
}
static Object complex_sqrt(Object o) {
  Object out = {.type = COMPLEX};
  mpc_init2(out.z, prec);
  mpc_sqrt(out.z, o.z, MPC_RNDNN);
  return out;
}
static Object inexact(Object o) { return copy(o); }

static Object even_p(Object o) {
  mpfr_div_ui(opfr1, mpc_realref(o.z), 2, MPFR_RNDN);
  return mpfr_zero_p(opfr1) ? boolean_true : boolean_false;
}
static Object exact(Object o) {
  Object out = {.type = RATIONAL};
  mpq_init(out.rational);
  mpfr_get_f(opf1, mpc_realref(o.z), MPFR_RNDN);
  mpq_set_f(out.rational, opf1);
  return out;
}
static Object expt(Object o1, Object o2) {
  Object out = {.type = COMPLEX};
  mpc_init2(out.z, prec);
  mpc_pow(out.z, o1.z, o2.z, MPC_RNDNN);
  return out;
}
static Object to_char(Object o) {
  return (Object){.type = CHAR, .ch = mpfr_get_ui(mpc_realref(o.z), MPFR_RNDN)};
}
static Object negative_p(Object o) {
  return mpfr_sgn(mpc_realref(o.z)) < 0 ? boolean_true : boolean_false;
}

static Object odd_p(Object o) {
  mpfr_div_ui(opfr1, mpc_realref(o.z), 2, MPFR_RNDN);
  return mpfr_zero_p(opfr1) ? boolean_false : boolean_true;
}
static Object positive_p(Object o) {
  return mpfr_sgn(mpc_realref(o.z)) > 0 ? boolean_true : boolean_false;
}
static Object square(Object o) {
  Object out = {.type = COMPLEX};
  mpc_init2(out.z, prec);
  mpc_pow_ui(out.z, o.z, 2, MPC_RNDNN);
  return out;
}
static Object angle(Object o) {
  Object out = {.type = COMPLEX};
  mpc_init2(out.z, prec);
  mpc_arg(opfr1, o.z, MPFR_RNDN);
  mpc_set_fr(out.z, opfr1, MPC_RNDNN);
  return out;
}
static Object imag_part(Object o) {
  Object out = {.type = COMPLEX};
  mpc_init2(out.z, prec);
  mpc_set_fr(out.z, mpc_imagref(o.z), MPC_RNDNN);
  return out;
}
static Object magnitude(Object o) {
  Object out = {.type = COMPLEX};
  mpc_init2(out.z, prec);
  mpc_abs(opfr1, o.z, MPFR_RNDN);
  mpc_set_fr(out.z, opfr1, MPC_RNDNN);
  return out;
}
static Object make_polar(Object o1, Object o2) {
  mpfr_cos(opfr1, mpc_realref(o1.z), MPFR_RNDN);
  mpfr_sin(opfr2, mpc_realref(o2.z), MPFR_RNDN);
  Object out = {.type = COMPLEX};
  mpc_init2(out.z, prec);
  mpc_set_fr_fr(out.z, opfr1, opfr2, MPC_RNDNN);
  return out;
}
static Object make_rectangular(Object o1, Object o2) {
  Object out = {.type = COMPLEX};
  mpc_init2(out.z, prec);
  mpc_set_fr_fr(out.z, mpc_realref(o1.z), mpc_realref(o2.z), MPC_RNDNN);
  return out;
}
static Object real_part(Object o) {
  Object out = {.type = COMPLEX};
  mpc_init2(out.z, prec);
  mpc_set_fr(out.z, mpc_realref(o.z), MPC_RNDNN);
  return out;
}

void complex_init() {
  fn_of_obj_ptr of_obj_ptr_ks[] = {object_free, NULL};
  fn_of_obj_ptr of_obj_ptr_vs[] = {complex_free, NULL};
  for (size_t i = 0; of_obj_ptr_ks[i] != NULL; i++) {
    put_of_obj_ptr(of_obj_ptr_ks[i], COMPLEX, of_obj_ptr_vs[i]);
  }
  fn_obj_of_obj ks1[] = {object_eqv_p, object_eq_p, number_lt, NULL};
  fn_bool_of_obj_obj vs1[] = {eqv_p, eqv_p, lt, NULL};
  for (size_t i = 0; ks1[i] != NULL; i++) {
    put_bool_of_obj_obj(ks1[i], COMPLEX, COMPLEX, vs1[i]);
  }
  fn_obj_of_obj of_obj_file_ks[] = {object_write, NULL};
  fn_of_obj_file of_obj_file_vs[] = {write, NULL};
  for (size_t i = 0; of_obj_file_ks[i] != NULL; i++) {
    put_of_obj_file(of_obj_file_ks[i], COMPLEX, of_obj_file_vs[i]);
  }
  /* number.h */
  fn_obj_of_obj bool_of_obj_ks[] = {object_integer_p, number_exact_p,
                                    number_finite_p,  number_infinite_p,
                                    number_nan_p,     NULL};
  fn_bool_of_obj bool_of_obj_vs[] = {integer_p,  exact_p, finite_p,
                                     infinite_p, nan_p,   NULL};
  for (size_t i = 0; bool_of_obj_ks[i] != NULL; i++) {
    put_bool_of_obj(bool_of_obj_ks[i], COMPLEX, bool_of_obj_vs[i]);
  }
  fn_obj_of_obj obj_of_obj_obj_ks[] = {number_math_equal,
                                       number_add,
                                       number_mul,
                                       number_sub,
                                       number_div,
                                       number_expt,
                                       number_make_polar,
                                       number_make_rectangular,
                                       NULL};
  fn_obj_of_obj_obj obj_of_obj_obj_vs[] = {
      math_equal,       add, mul, sub, complex_div, expt, make_polar,
      make_rectangular, NULL};
  for (size_t i = 0; obj_of_obj_obj_ks[i] != NULL; i++) {
    put_obj_of_obj_obj(obj_of_obj_obj_ks[i], COMPLEX, COMPLEX,
                       obj_of_obj_obj_vs[i]);
  }
  fn_obj_of_obj obj_of_obj_ks[] = {object_copy,
                                   number_ceiling,
                                   number_inexact,
                                   number_even_p,
                                   number_exact,
                                   number_floor,
                                   number_to_char,
                                   number_negative_p,
                                   number_odd_p,
                                   number_positive_p,
                                   number_round,
                                   number_square,
                                   number_truncate,
                                   number_sqrt,
                                   number_angle,
                                   number_imag_part,
                                   number_magnitude,
                                   number_real_part,
                                   NULL};
  fn_obj_of_obj obj_of_obj_vs[] = {
      copy,          ceiling,   inexact,    even_p,       exact,
      complex_floor, to_char,   negative_p, odd_p,        positive_p,
      complex_round, square,    truncate,   complex_sqrt, angle,
      imag_part,     magnitude, real_part,  NULL};
  for (size_t i = 0; obj_of_obj_ks[i] != NULL; i++) {
    put_obj_of_obj(obj_of_obj_ks[i], COMPLEX, obj_of_obj_vs[i]);
  }
  mpf_inits(opf1, opf2, NULL);
  mpfr_inits(opfr1, opfr2, NULL);
}

rational.c

#include "rational.h"

Object rational_new(char const *s, int base) {
  Object o = {.type = RATIONAL};
  mpq_init(o.rational);
  mpq_set_str(o.rational, s, base);
  mpq_canonicalize(o.rational);
  return o;
}
static Object copy(Object o) {
  Object out = {.type = RATIONAL};
  mpq_init(out.rational);
  mpq_set(out.rational, o.rational);
  return out;
}
static void rational_free(Object *o_ptr) { mpq_clear(o_ptr->rational); }

static bool eqv_p(Object o1, Object o2) {
  return mpq_equal(o1.rational, o2.rational);
}
static bool exact_p(Object o) { return true; }
static bool integer_p(Object o) {
  return mpz_cmp_ui(mpq_denref(o.rational), 1) == 0;
}
static bool finite_p(Object o) { return true; }
static bool infinite_p(Object o) { return false; }
static bool nan_p(Object o) { return false; }
static Object math_equal(Object o1, Object o2) {
  return mpq_equal(o1.rational, o2.rational) ? boolean_true : boolean_false;
}
static bool lt(Object o1, Object o2) {
  return mpq_cmp(o1.rational, o2.rational) < 0 ? true : false;
}
static Object apply_void_mp_mp_mp(void (*fn)(mpq_ptr, mpq_srcptr, mpq_srcptr),
                                  Object o1, Object o2) {
  Object o = {.type = RATIONAL};
  mpq_init(o.rational);
  fn(o.rational, o1.rational, o2.rational);
  return o;
}
static Object add(Object o1, Object o2) {
  return apply_void_mp_mp_mp(mpq_add, o1, o2);
}
static Object mul(Object o1, Object o2) {
  return apply_void_mp_mp_mp(mpq_mul, o1, o2);
}
static Object sub(Object o1, Object o2) {
  return apply_void_mp_mp_mp(mpq_sub, o1, o2);
}
static Object rational_div(Object o1, Object o2) {
  return apply_void_mp_mp_mp(mpq_div, o1, o2);
}
static Object numerator(Object o) {
  Object out = {.type = RATIONAL};
  mpq_init(out.rational);
  mpq_set_z(out.rational, mpq_numref(o.rational));
  return out;
}
static Object denominator(Object o) {
  Object out = {.type = RATIONAL};
  mpq_init(out.rational);
  mpq_set_z(out.rational, mpq_denref(o.rational));
  return out;
}
static Object rational_floor(Object o) {
  Object out = {.type = RATIONAL};
  mpq_init(out.rational);
  mpz_fdiv_q(mpq_numref(out.rational), mpq_numref(o.rational),
             mpq_denref(o.rational));
  mpz_set_ui(mpq_denref(out.rational), 1);
  return out;
}
static Object ceiling(Object o) {
  Object out = {.type = RATIONAL};
  mpq_init(out.rational);
  mpz_cdiv_q(mpq_numref(out.rational), mpq_numref(o.rational),
             mpq_denref(o.rational));
  mpz_set_ui(mpq_denref(out.rational), 1);
  return out;
}
static Object truncate(Object o) {
  Object out = {.type = RATIONAL};
  mpq_init(out.rational);
  mpz_tdiv_q(mpq_numref(out.rational), mpq_numref(o.rational),
             mpq_denref(o.rational));
  mpz_set_ui(mpq_denref(out.rational), 1);
  return out;
}
static Object to_complex(Object o) {
  Object out = {.type = COMPLEX};
  mpc_init2(out.z, prec);
  mpc_set_q(out.z, o.rational, MPC_RNDNN);
  return out;
}
static Object inexact(Object o) {
  Object out = {.type = COMPLEX};
  mpc_init2(out.z, prec);
  mpc_set_q(out.z, o.rational, MPC_RNDNN);
  return out;
}
static Object rational_sqrt(Object o) {
  if (mpz_perfect_square_p(mpq_numref(o.rational)) &&
      mpz_perfect_square_p(mpq_denref(o.rational))) {
    Object out = {.type = RATIONAL};
    mpq_init(out.rational);
    mpz_sqrt(mpq_numref(out.rational), mpq_numref(o.rational));
    mpz_sqrt(mpq_denref(out.rational), mpq_denref(o.rational));
    return out;
  }
  Object o0 = to_complex(o);
  fn_obj_of_obj fn = get_obj_of_obj(number_sqrt, o0);
  Object out = fn(o0);
  rational_free(&o0);
  return out;
}
static void write(Object o, FILE *port) { mpq_out_str(port, 10, o.rational); }
static Object even_p(Object o) {
  return mpz_even_p(mpq_numref(o.rational)) ? boolean_true : boolean_false;
}
static Object exact(Object o) { return copy(o); }
static mpc_t opc1, opc2;
static Object expt(Object o1, Object o2) {
  Object out = {.type = COMPLEX};
  mpc_init2(out.z, prec);
  mpc_set_q(opc1, o1.rational, MPC_RNDNN);
  mpc_set_q(opc2, o1.rational, MPC_RNDNN);
  mpc_pow(out.z, opc1, opc2, MPC_RNDNN);
  return out;
}
static Object gcd(Object o1, Object o2) {
  Object out = {.type = RATIONAL};
  mpq_init(out.rational);
  mpz_gcd(mpq_numref(out.rational), mpq_numref(o1.rational),
          mpq_numref(o2.rational));
  mpz_set_ui(mpq_denref(out.rational), 1);
  return out;
}
static Object to_char(Object o) {
  return (Object){.type = CHAR, .ch = mpz_get_ui(mpq_numref(o.rational))};
}
static Object lcm(Object o1, Object o2) {
  Object out = {.type = RATIONAL};
  mpq_init(out.rational);
  mpz_lcm(mpq_numref(out.rational), mpq_numref(o1.rational),
          mpq_numref(o2.rational));
  mpz_set_ui(mpq_denref(out.rational), 1);
  return out;
}
static Object negative_p(Object o) {
  return mpq_sgn(o.rational) == -1 ? boolean_true : boolean_false;
}
static Object odd_p(Object o) {
  return mpz_odd_p(mpq_numref(o.rational)) ? boolean_true : boolean_false;
}
static Object positive_p(Object o) {
  return mpq_sgn(o.rational) == 1 ? boolean_true : boolean_false;
}
static mpfr_t opfr1;
static Object rational_round(Object o) {
  Object out = {.type = RATIONAL};
  mpq_init(out.rational);
  mpfr_set_q(opfr1, o.rational, MPFR_RNDN);
  mpfr_get_z(mpq_numref(out.rational), opfr1, MPFR_RNDN);
  mpz_set_ui(mpq_denref(out.rational), 1);
  return out;
}
static Object square(Object o) {
  Object out = {.type = RATIONAL};
  mpq_init(out.rational);
  mpq_mul(out.rational, o.rational, o.rational);
  return out;
}
static Object angle(Object o) {
  Object out = {.type = COMPLEX};
  mpc_init2(out.z, prec);
  if (mpq_sgn(o.rational) >= 0) {
    mpc_set_ui(out.z, 0, MPC_RNDNN);
  } else {
    mpfr_const_pi(opfr1, MPFR_RNDN);
    mpc_set_fr(out.z, opfr1, MPC_RNDNN);
  }
  return out;
}
static Object imag_part(Object o) {
  Object out = {.type = RATIONAL};
  mpq_init(out.rational);
  mpq_set_ui(out.rational, 0, 1);
  return out;
}
static Object magnitude(Object o) {
  Object out = {.type = RATIONAL};
  mpq_init(out.rational);
  mpq_abs(out.rational, o.rational);
  return out;
}
static Object real_part(Object o) { return copy(o); }

void rational_init() {
  fn_obj_of_obj ks1[] = {object_eqv_p, object_eq_p, number_lt, NULL};
  fn_bool_of_obj_obj vs1[] = {eqv_p, eqv_p, lt, NULL};
  for (size_t i = 0; ks1[i] != NULL; i++) {
    put_bool_of_obj_obj(ks1[i], RATIONAL, RATIONAL, vs1[i]);
  }

  fn_obj_of_obj bool_of_obj_ks[] = {object_integer_p, number_exact_p,
                                    number_finite_p,  number_infinite_p,
                                    number_nan_p,     NULL};

  fn_bool_of_obj bool_of_obj_vs[] = {integer_p,  exact_p, finite_p,
                                     infinite_p, nan_p,   NULL};
  for (size_t i = 0; bool_of_obj_ks[i] != NULL; i++) {
    put_bool_of_obj(bool_of_obj_ks[i], RATIONAL, bool_of_obj_vs[i]);
  }
  fn_obj_of_obj obj_of_obj_obj_ks[] = {
      number_math_equal, number_add, number_mul, number_sub, number_div,
      number_expt,       number_gcd, number_lcm, NULL};
  fn_obj_of_obj_obj obj_of_obj_obj_vs[] = {
      math_equal, add, mul, sub, rational_div, expt, gcd, lcm, NULL};
  for (size_t i = 0; obj_of_obj_obj_ks[i] != NULL; i++) {
    put_obj_of_obj_obj(obj_of_obj_obj_ks[i], RATIONAL, RATIONAL,
                       obj_of_obj_obj_vs[i]);
  }
  fn_obj_of_obj of_obj_file_ks[] = {object_write, NULL};
  fn_of_obj_file of_obj_file_vs[] = {write, NULL};
  for (size_t i = 0; of_obj_file_ks[i] != NULL; i++) {
    put_of_obj_file(of_obj_file_ks[i], RATIONAL, of_obj_file_vs[i]);
  }
  fn_obj_of_obj obj_of_obj_ks[] = {
      object_copy,       number_denominator, number_ceiling,
      number_sqrt,       number_inexact,     number_even_p,
      number_exact,      number_floor,       number_to_char,
      number_negative_p, number_numerator,   number_odd_p,
      number_positive_p, number_round,       number_square,
      number_truncate,   number_angle,       number_imag_part,
      number_magnitude,  number_real_part,   NULL};
  fn_obj_of_obj obj_of_obj_vs[] = {
      copy,       denominator,    ceiling, rational_sqrt, inexact,   even_p,
      exact,      rational_floor, to_char, negative_p,    numerator, odd_p,
      positive_p, rational_round, square,  truncate,      angle,     imag_part,
      magnitude,  real_part,      NULL};
  for (size_t i = 0; obj_of_obj_ks[i] != NULL; i++) {
    put_obj_of_obj(obj_of_obj_ks[i], RATIONAL, obj_of_obj_vs[i]);
  }
  fn_of_obj_ptr of_obj_ptr_ks[] = {object_free, NULL};
  fn_of_obj_ptr of_obj_ptr_vs[] = {rational_free, NULL};
  for (size_t i = 0; of_obj_ptr_ks[i] != NULL; i++) {
    put_of_obj_ptr(of_obj_ptr_ks[i], RATIONAL, of_obj_ptr_vs[i]);
  }
  mpfr_init(opfr1);
  mpc_init2(opc1, prec);
  mpc_init2(opc2, prec);
}

ksi.scm

(begin
  ;; 
  (define (primitive-procedure? proc) (tagged-list? proc 'primitive))
  (define (primitive-implementation proc) (car (cdr proc)))
  (load "./lib/stdlib/base/primitive_procedures.scm")
  (load "./lib/stdlib/char/primitive_procedures.scm")
  (load "./lib/stdlib/complex/primitive_procedures.scm")
  (define primitive-procedures
    (list ;; complex
          (c-cons 'angle angle)
          (c-cons 'imag-part imag-part)
          (c-cons 'magnitude magnitude)
          (c-cons 'make-polar make-polar)
          (c-cons 'make-rectangular make-rectangular)
          (c-cons 'real-part real-part)
          ))
  ;; 
  )

lib/stdlib/complex/primitive_procedures.scm

(begin
  (define (angle . args)
    (if (c-= (c-length args) 1)
        (if (c-number? (c-car args))
            (c-angle (c-car args))
            (error '|(angle) wrong type of argument --| args))
        (error '|(angle) wrong number of arguments --| args)))
  (define (imag-part . args)
    (if (c-= (c-length args) 1)
        (if (c-number? (c-car args))
            (c-imag-part (c-car args))
            (error '|(imag-part) wrong type of argument --| args))
        (error '|(imag-part) wrong number of arguments --| args)))
  (define (magnitude . args)
    (if (c-= (c-length args) 1)
        (if (c-number? (c-car args))
            (c-magnitude (c-car args))
            (error '|(magnitude) wrong type of argument --| args))
        (error '|(magnitude) wrong number of arguments --| args)))

  (define (make-polar . args)
    (if (c-= (c-length args) 2)
        (begin
          (define x1 (c-car args))
          (define x2 (c-cadr args))
          (if (and (c-real? x1) (c-real? x2))
              (c-make-polar (c-inexact x1) (c-inexact x2))
              (error '|(make-polar) wrong type of argument --| args)))
        (error '|(make-polar) wrong number of arguments --| args)))

  (define (make-rectangular . args)
    (if (c-= (c-length args) 2)
        (begin
          (define x1 (c-car args))
          (define x2 (c-cadr args))
          (if (and (c-real? x1) (c-real? x2))
              (c-make-rectangular (c-inexact x1) (c-inexact x2))
              (error '|(make-rectangular) wrong type of argument --| args)))
        (error '|(make-rectangular) wrong number of arguments --| args)))
  
  (define (real-part . args)
    (if (c-= (c-length args) 1)
        (if (c-number? (c-car args))
            (c-real-part (c-car args))
            (error '|(real-part) wrong type of argument --| args))
        (error '|(real-part) wrong number of arguments --| args)))
  )

0 コメント:

コメントを投稿

Comments on Google+: