Merge branch 'master' into analyzer

Conflicts: include/picrin/pair.h src/pair.c
2014-01-23 16:21:10 +09:00
parent c7811f0c39 95c5361197
commit 2e28f604a6
7 changed files with 503 additions and 211 deletions
@@ -4,9 +4,28 @@

 #include <math.h>
 #include <limits.h>
+#include <stdlib.h>

 #include "picrin.h"

+static int
+gcd(int a, int b)
+{
+  if (a > b)
+    return gcd(b, a);
+  if (a < 0)
+    return gcd(-a, b);
+  if (a > 0)
+    return gcd(b % a, a);
+  return b;
+}
+
+static int
+lcm(int a, int b)
+{
+  return abs(a * b) / gcd(a, b);
+}
+
 static pic_value
 pic_number_real_p(pic_state *pic)
 {
@@ -133,6 +152,112 @@ DEFINE_ARITH_CMP(>, gt)
 DEFINE_ARITH_CMP(<=, le)
 DEFINE_ARITH_CMP(>=, ge)

+static pic_value
+pic_number_zero_p(pic_state *pic)
+{
+  double f;
+
+  pic_get_args(pic, "f", &f);
+
+  return pic_bool_value(f == 0);
+}
+
+static pic_value
+pic_number_positive_p(pic_state *pic)
+{
+  double f;
+
+  pic_get_args(pic, "f", &f);
+
+  return pic_bool_value(f > 0);
+}
+
+static pic_value
+pic_number_negative_p(pic_state *pic)
+{
+  double f;
+
+  pic_get_args(pic, "f", &f);
+
+  return pic_bool_value(f < 0);
+}
+
+static pic_value
+pic_number_odd_p(pic_state *pic)
+{
+  int i;
+
+  pic_get_args(pic, "i", &i);
+
+  return pic_bool_value(i % 2 != 0);
+}
+
+static pic_value
+pic_number_even_p(pic_state *pic)
+{
+  int i;
+
+  pic_get_args(pic, "i", &i);
+
+  return pic_bool_value(i % 2 == 0);
+}
+
+static pic_value
+pic_number_max(pic_state *pic)
+{
+  size_t argc;
+  pic_value *argv;
+  int i;
+  double f;
+  bool e = true;
+
+  pic_get_args(pic, "*", &argc, &argv);
+
+  f = -INFINITY;
+  for (i = 0; i < argc; ++i) {
+    if (pic_int_p(argv[i])) {
+      f = fmax(f, pic_int(argv[i]));
+    }
+    else if (pic_float_p(argv[i])) {
+      e = false;
+      f = fmax(f, pic_float(argv[i]));
+    }
+    else {
+      pic_error(pic, "min: number required");
+    }
+  }
+
+  return e ? pic_int_value(f) : pic_float_value(f);
+}
+
+static pic_value
+pic_number_min(pic_state *pic)
+{
+  size_t argc;
+  pic_value *argv;
+  int i;
+  double f;
+  bool e = true;
+
+  pic_get_args(pic, "*", &argc, &argv);
+
+  f = INFINITY;
+  for (i = 0; i < argc; ++i) {
+    if (pic_int_p(argv[i])) {
+      f = fmin(f, pic_int(argv[i]));
+    }
+    else if (pic_float_p(argv[i])) {
+      e = false;
+      f = fmin(f, pic_float(argv[i]));
+    }
+    else {
+      pic_error(pic, "min: number required");
+    }
+  }
+
+  return e ? pic_int_value(f) : pic_float_value(f);
+}
+
 #define DEFINE_ARITH_OP(op, name, unit)                         \
  static pic_value                                              \
  pic_number_##name(pic_state *pic)                             \
@@ -283,6 +408,58 @@ pic_number_trunc_remainder(pic_state *pic)
  }
 }

+static pic_value
+pic_number_gcd(pic_state *pic)
+{
+  size_t argc;
+  pic_value *args;
+  int r;
+  bool e = true;
+
+  pic_get_args(pic, "*", &argc, &args);
+
+  r = 0;
+  while (argc-- > 0) {
+    if (pic_int_p(args[argc])) {
+      r = gcd(r, pic_int(args[argc]));
+    }
+    else if (pic_float_p(args[argc])) {
+      e = false;
+      r = gcd(r, pic_float(args[argc]));
+    }
+    else {
+      pic_error(pic, "gcd: number required");
+    }
+  }
+  return e ? pic_int_value(r) : pic_float_value(r);
+}
+
+static pic_value
+pic_number_lcm(pic_state *pic)
+{
+  size_t argc;
+  pic_value *args;
+  int r;
+  bool e = true;
+
+  pic_get_args(pic, "*", &argc, &args);
+
+  r = 1;
+  while (argc-- > 0) {
+    if (pic_int_p(args[argc])) {
+      r = lcm(r, pic_int(args[argc]));
+    }
+    else if (pic_float_p(args[argc])) {
+      e = false;
+      r = lcm(r, pic_float(args[argc]));
+    }
+    else {
+      pic_error(pic, "lcm: number required");
+    }
+  }
+  return e ? pic_int_value(r) : pic_float_value(r);
+}
+
 static pic_value
 pic_number_floor(pic_state *pic)
 {
@@ -526,6 +703,17 @@ pic_init_number(pic_state *pic)
  pic_defun(pic, ">=", pic_number_ge);
  pic_gc_arena_restore(pic, ai);

+  pic_defun(pic, "zero?", pic_number_zero_p);
+  pic_defun(pic, "positive?", pic_number_positive_p);
+  pic_defun(pic, "negative?", pic_number_negative_p);
+  pic_defun(pic, "odd?", pic_number_odd_p);
+  pic_defun(pic, "even?", pic_number_even_p);
+  pic_gc_arena_restore(pic, ai);
+
+  pic_defun(pic, "min", pic_number_min);
+  pic_defun(pic, "max", pic_number_max);
+  pic_gc_arena_restore(pic, ai);
+
  pic_defun(pic, "+", pic_number_add);
  pic_defun(pic, "-", pic_number_sub);
  pic_defun(pic, "*", pic_number_mul);
@@ -539,6 +727,10 @@ pic_init_number(pic_state *pic)
  pic_defun(pic, "truncate-remainder", pic_number_trunc_remainder);
  pic_gc_arena_restore(pic, ai);

+  pic_defun(pic, "gcd", pic_number_gcd);
+  pic_defun(pic, "lcm", pic_number_lcm);
+  pic_gc_arena_restore(pic, ai);
+
  pic_defun(pic, "floor", pic_number_floor);
  pic_defun(pic, "ceiling", pic_number_ceil);
  pic_defun(pic, "truncate", pic_number_trunc);
@@ -48,8 +48,9 @@ pic_cdr(pic_state *pic, pic_value obj)
 bool
 pic_list_p(pic_state *pic, pic_value obj)
 {
-  while (pic_pair_p(obj))
+  while (pic_pair_p(obj)) {
    obj = pic_pair_ptr(obj)->cdr;
+  }

  return pic_nil_p(obj);
 }
@@ -84,6 +85,20 @@ pic_list_from_array(pic_state *pic, size_t c, pic_value *vs)
  return pic_reverse(pic, v);
 }

+pic_value
+pic_make_list(pic_state *pic, int k, pic_value fill)
+{
+  pic_value list;
+  int i;
+
+  list = pic_nil_value();
+  for (i = 0; i < k; ++i) {
+    list = pic_cons(pic, fill, list);
+  }
+
+  return list;
+}
+
 int
 pic_length(pic_state *pic, pic_value obj)
 {
@@ -114,6 +129,23 @@ pic_reverse(pic_state *pic, pic_value list)
  return acc;
 }

+pic_value
+pic_append(pic_state *pic, pic_value xs, pic_value ys)
+{
+  int ai = pic_gc_arena_preserve(pic);
+
+  if (pic_nil_p(xs)) {
+    return ys;
+  }
+  else {
+    xs = pic_cons(pic, pic_car(pic, xs), pic_append(pic, pic_cdr(pic, xs), ys));
+  }
+
+  pic_gc_arena_restore(pic, ai);
+  pic_gc_protect(pic, xs);
+  return xs;
+}
+
 pic_value
 pic_assq(pic_state *pic, pic_value key, pic_value assoc)
 {
@@ -181,12 +213,35 @@ pic_cddr(pic_state *pic, pic_value v)
 }

 pic_value
-pic_list_ref(pic_state *pic, pic_value list, int i)
+pic_list_tail(pic_state *pic, pic_value list, int i)
 {
  while (i-- > 0) {
    list = pic_cdr(pic, list);
  }
-  return pic_car(pic, list);
+  return list;
+}
+
+pic_value
+pic_list_ref(pic_state *pic, pic_value list, int i)
+{
+  return pic_car(pic, pic_list_tail(pic, list, i));
+}
+
+void
+pic_list_set(pic_state *pic, pic_value list, int i, pic_value obj)
+{
+  pic_pair_ptr(pic_list_tail(pic, list, i))->car = obj;
+}
+
+pic_value
+pic_list_copy(pic_state *pic, pic_value obj)
+{
+  if (pic_pair_p(obj)) {
+    return pic_cons(pic, pic_car(pic, obj), pic_list_copy(pic, pic_cdr(pic, obj)));
+  }
+  else {
+    return obj;
+  }
 }

 static pic_value
@@ -199,6 +254,16 @@ pic_pair_pair_p(pic_state *pic)
  return pic_bool_value(pic_pair_p(v));
 }

+static pic_value
+pic_pair_cons(pic_state *pic)
+{
+  pic_value v,w;
+
+  pic_get_args(pic, "oo", &v, &w);
+
+  return pic_cons(pic, v, w);
+}
+
 static pic_value
 pic_pair_car(pic_state *pic)
 {
@@ -220,23 +285,43 @@ pic_pair_cdr(pic_state *pic)
 }

 static pic_value
-pic_pair_null_p(pic_state *pic)
+pic_pair_caar(pic_state *pic)
 {
  pic_value v;

  pic_get_args(pic, "o", &v);

-  return pic_bool_value(pic_nil_p(v));
+  return pic_caar(pic, v);
 }

 static pic_value
-pic_pair_cons(pic_state *pic)
+pic_pair_cadr(pic_state *pic)
 {
-  pic_value v,w;
+  pic_value v;

-  pic_get_args(pic, "oo", &v, &w);
+  pic_get_args(pic, "o", &v);

-  return pic_cons(pic, v, w);
+  return pic_cadr(pic, v);
+}
+
+static pic_value
+pic_pair_cdar(pic_state *pic)
+{
+  pic_value v;
+
+  pic_get_args(pic, "o", &v);
+
+  return pic_cdar(pic, v);
+}
+
+static pic_value
+pic_pair_cddr(pic_state *pic)
+{
+  pic_value v;
+
+  pic_get_args(pic, "o", &v);
+
+  return pic_cddr(pic, v);
 }

 static pic_value
@@ -267,14 +352,151 @@ pic_pair_set_cdr(pic_state *pic)
  return pic_none_value();
 }

+static pic_value
+pic_pair_null_p(pic_state *pic)
+{
+  pic_value v;
+
+  pic_get_args(pic, "o", &v);
+
+  return pic_bool_value(pic_nil_p(v));
+}
+
+static pic_value
+pic_pair_list_p(pic_state *pic)
+{
+  pic_value v;
+
+  pic_get_args(pic, "o", &v);
+
+  return pic_bool_value(pic_list_p(pic, v));
+}
+
+static pic_value
+pic_pair_make_list(pic_state *pic)
+{
+  int i;
+  pic_value fill = pic_none_value();
+
+  pic_get_args(pic, "i|o", &i, &fill);
+
+  return pic_make_list(pic, i, fill);
+}
+
+static pic_value
+pic_pair_list(pic_state *pic)
+{
+  size_t argc;
+  pic_value *argv;
+
+  pic_get_args(pic, "*", &argc, &argv);
+
+  return pic_list_from_array(pic, argc, argv);
+}
+
+static pic_value
+pic_pair_length(pic_state *pic)
+{
+  pic_value list;
+
+  pic_get_args(pic, "o", &list);
+
+  return pic_int_value(pic_length(pic, list));
+}
+
+static pic_value
+pic_pair_append(pic_state *pic)
+{
+  size_t argc;
+  pic_value *args, list;
+
+  pic_get_args(pic, "*", &argc, &args);
+
+  list = args[--argc];
+
+  while (argc-- > 0) {
+    list = pic_append(pic, args[argc], list);
+  }
+  return list;
+}
+
+static pic_value
+pic_pair_reverse(pic_state *pic)
+{
+  pic_value list;
+
+  pic_get_args(pic, "o", &list);
+
+  return pic_reverse(pic, list);
+}
+
+static pic_value
+pic_pair_list_tail(pic_state *pic)
+{
+  pic_value list;
+  int i;
+
+  pic_get_args(pic, "oi", &list, &i);
+
+  return pic_list_tail(pic, list, i);
+}
+
+static pic_value
+pic_pair_list_ref(pic_state *pic)
+{
+  pic_value list;
+  int i;
+
+  pic_get_args(pic, "oi", &list, &i);
+
+  return pic_list_ref(pic, list, i);
+}
+
+static pic_value
+pic_pair_list_set(pic_state *pic)
+{
+  pic_value list, obj;
+  int i;
+
+  pic_get_args(pic, "oio", &list, &i, &obj);
+
+  pic_list_set(pic, list, i, obj);
+
+  return pic_none_value();
+}
+
+static pic_value
+pic_pair_list_copy(pic_state *pic)
+{
+  pic_value obj;
+
+  pic_get_args(pic, "o", &obj);
+
+  return pic_list_copy(pic, obj);
+}
+
 void
 pic_init_pair(pic_state *pic)
 {
  pic_defun(pic, "pair?", pic_pair_pair_p);
+  pic_defun(pic, "cons", pic_pair_cons);
  pic_defun(pic, "car", pic_pair_car);
  pic_defun(pic, "cdr", pic_pair_cdr);
-  pic_defun(pic, "null?", pic_pair_null_p);
-  pic_defun(pic, "cons", pic_pair_cons);
  pic_defun(pic, "set-car!", pic_pair_set_car);
  pic_defun(pic, "set-cdr!", pic_pair_set_cdr);
+  pic_defun(pic, "caar", pic_pair_caar);
+  pic_defun(pic, "cadr", pic_pair_cadr);
+  pic_defun(pic, "cdar", pic_pair_cdar);
+  pic_defun(pic, "cddr", pic_pair_cddr);
+  pic_defun(pic, "null?", pic_pair_null_p);
+  pic_defun(pic, "list?", pic_pair_list_p);
+  pic_defun(pic, "make-list", pic_pair_make_list);
+  pic_defun(pic, "list", pic_pair_list);
+  pic_defun(pic, "length", pic_pair_length);
+  pic_defun(pic, "append", pic_pair_append);
+  pic_defun(pic, "reverse", pic_pair_reverse);
+  pic_defun(pic, "list-tail", pic_pair_list_tail);
+  pic_defun(pic, "list-ref", pic_pair_list_ref);
+  pic_defun(pic, "list-set!", pic_pair_list_set);
+  pic_defun(pic, "list-copy", pic_pair_list_copy);
 }
@@ -85,21 +85,73 @@ static pic_value
 pic_proc_apply(pic_state *pic)
 {
  struct pic_proc *proc;
-  pic_value *args, v;
+  pic_value *args;
  size_t argc;
-  int i;

  pic_get_args(pic, "l*", &proc, &argc, &args);

  if (argc == 0) {
    pic_error(pic, "apply: wrong number of arguments");
  }
-  v = args[argc - 1];
-  for (i = argc - 2; i >= 0; --i) {
-    v = pic_cons(pic, args[i], v);
-  }

-  return pic_apply(pic, proc, v);
+  return pic_apply(pic, proc, pic_list_from_array(pic, argc, args));
+}
+
+static pic_value
+pic_proc_map(pic_state *pic)
+{
+  struct pic_proc *proc;
+  size_t argc;
+  pic_value *args;
+  int i;
+  pic_value cars, ret;
+
+  pic_get_args(pic, "l*", &proc, &argc, &args);
+
+  ret = pic_nil_value();
+  do {
+    cars = pic_nil_value();
+    for (i = argc - 1; i >= 0; --i) {
+      if (! pic_pair_p(args[i])) {
+        break;
+      }
+      cars = pic_cons(pic, pic_car(pic, args[i]), cars);
+      args[i] = pic_cdr(pic, args[i]);
+    }
+    if (i >= 0)
+      break;
+    ret = pic_cons(pic, pic_apply(pic, proc, cars), ret);
+  } while (1);
+
+  return pic_reverse(pic, ret);
+}
+
+static pic_value
+pic_proc_for_each(pic_state *pic)
+{
+  struct pic_proc *proc;
+  size_t argc;
+  pic_value *args;
+  int i;
+  pic_value cars;
+
+  pic_get_args(pic, "l*", &proc, &argc, &args);
+
+  do {
+    cars = pic_nil_value();
+    for (i = argc - 1; i >= 0; --i) {
+      if (! pic_pair_p(args[i])) {
+        break;
+      }
+      cars = pic_cons(pic, pic_car(pic, args[i]), cars);
+      args[i] = pic_cdr(pic, args[i]);
+    }
+    if (i >= 0)
+      break;
+    pic_apply(pic, proc, cars);
+  } while (1);
+
+  return pic_none_value();
 }

 void
@@ -107,4 +159,6 @@ pic_init_proc(pic_state *pic)
 {
  pic_defun(pic, "procedure?", pic_proc_proc_p);
  pic_defun(pic, "apply", pic_proc_apply);
+  pic_defun(pic, "map", pic_proc_map);
+  pic_defun(pic, "for-each", pic_proc_for_each);
 }