diff --git a/piclib/built-in.scm b/piclib/built-in.scm index da9f3974..0a2fbca0 100644 --- a/piclib/built-in.scm +++ b/piclib/built-in.scm @@ -316,24 +316,6 @@ pivot (loop (if (> x (car rest)) x (car rest)) (cdr rest))))) -;;; so ugly code, must rewrite everything as soon as possible... -(define-macro (define-transitive-predicate op) - `(define (,op . args) - (call/cc - (lambda (exit) - (do ((val (car args)) - (nums (cdr args) (cdr nums))) - ((pair? nums) #t) - (if (,op val (car nums)) - (set! val (car nums)) - (exit #f))))))) - -(define-transitive-predicate =) -(define-transitive-predicate <) -(define-transitive-predicate >) -(define-transitive-predicate <=) -(define-transitive-predicate >=) - (define (floor/ n m) (values (floor-quotient n m) (floor-remainder n m))) diff --git a/src/number.c b/src/number.c index f2e1b3e5..841372cf 100644 --- a/src/number.c +++ b/src/number.c @@ -79,6 +79,40 @@ pic_number_nan_p(pic_state *pic) return pic_false_value(); } +#define DEFINE_MATH_PRED(op, name) \ + static pic_value \ + pic_number_##name(pic_state *pic) \ + { \ + int argc, i; \ + pic_value *argv; \ + double f,g; \ + \ + pic_get_args(pic, "ff*", &f, &g, &argc, &argv); \ + \ + if (! (f op g)) \ + return pic_false_value(); \ + \ + for (i = 0; i < argc; ++i) { \ + if (pic_float_p(argv[i])) \ + g = pic_float(argv[i]); \ + else if (pic_int_p(argv[i])) \ + g = pic_int(argv[i]); \ + else \ + pic_error(pic, #op ": number required"); \ + \ + if (! (f op g)) \ + return pic_false_value(); \ + } \ + \ + return pic_true_value(); \ + } + +DEFINE_MATH_PRED(=, eq) +DEFINE_MATH_PRED(<, lt) +DEFINE_MATH_PRED(>, gt) +DEFINE_MATH_PRED(<=, le) +DEFINE_MATH_PRED(>=, ge) + static pic_value pic_number_abs(pic_state *pic) { @@ -399,6 +433,11 @@ pic_init_number(pic_state *pic) pic_defun(pic, "nan?", pic_number_nan_p); pic_gc_arena_restore(pic, ai); + pic_defun(pic, "=", pic_number_eq); + pic_defun(pic, "<", pic_number_lt); + pic_defun(pic, ">", pic_number_gt); + pic_defun(pic, "<=", pic_number_le); + pic_defun(pic, ">=", pic_number_ge); pic_defun(pic, "abs", pic_number_abs); pic_defun(pic, "floor-quotient", pic_number_floor_quotient);