diff --git a/piclib/picrin/macro.scm b/piclib/picrin/macro.scm index 2f9fe7e0..5682d8ca 100644 --- a/piclib/picrin/macro.scm +++ b/piclib/picrin/macro.scm @@ -6,24 +6,6 @@ ;; assumes no derived expressions are provided yet - (define (list->vector list) - (define vector (make-vector (length list))) - (define (go list i) - (if (null? list) - vector - (begin - (vector-set! vector i (car list)) - (go (cdr list) (+ i 1))))) - (go list 0)) - - (define (vector->list vector) - (define (go i) - (if (= i (vector-length vector)) - '() - (cons (vector-ref vector i) - (go (+ i 1))))) - (go 0)) - (define (walk proc expr) "walk on symbols" (if (null? expr) diff --git a/piclib/prelude.scm b/piclib/prelude.scm index 7049c2f0..af357cdb 100644 --- a/piclib/prelude.scm +++ b/piclib/prelude.scm @@ -91,22 +91,6 @@ (r 'it) (cons (r 'or) (cdr exprs)))))))))) - (define (list->vector list) - (let ((vector (make-vector (length list)))) - (let loop ((list list) (i 0)) - (if (null? list) - vector - (begin - (vector-set! vector i (car list)) - (loop (cdr list) (+ i 1))))))) - - (define (vector->list vector) - (let ((length (vector-length vector))) - (let loop ((list '()) (i 0)) - (if (= i length) - (reverse list) - (loop (cons (vector-ref vector i) list) (+ i 1)))))) - (define-syntax quasiquote (ir-macro-transformer (lambda (form inject compare) @@ -605,34 +589,6 @@ s (fold f (f (car xs) s) (cdr xs)))) -;;; 6.2. Numbers - -(define (floor/ n m) - (values (floor-quotient n m) - (floor-remainder n m))) - -(define (truncate/ n m) - (values (truncate-quotient n m) - (truncate-remainder n m))) - -; (import (only (scheme inexact) sqrt)) -(import (scheme inexact)) - -(define (exact-integer-sqrt k) - (let ((n (exact (floor (sqrt k))))) - (values n (- k (square n))))) - -(export floor/ truncate/ - exact-integer-sqrt) - -;;; 6.3 Booleans - -(define (boolean=? . objs) - (or (every (lambda (x) (eq? x #t)) objs) - (every (lambda (x) (eq? x #f)) objs))) - -(export boolean=?) - ;;; 6.4 Pairs and lists (define (member obj list . opts) @@ -653,19 +609,6 @@ (export member assoc) -;;; 6.5. Symbols - -(define (symbol=? . objs) - (let ((sym (car objs))) - (if (symbol? sym) - (every (lambda (x) - (and (symbol? x) - (eq? x sym))) - (cdr objs)) - #f))) - -(export symbol=?) - ;;; 6.6 Characters (define-macro (define-char-transitive-predicate name op) @@ -714,52 +657,7 @@ ;;; 6.8. Vector (define (vector . objs) - (let ((len (length objs))) - (let ((v (make-vector len))) - (do ((i 0 (+ i 1)) - (l objs (cdr l))) - ((= i len) - v) - (vector-set! v i (car l)))))) - -(define (vector->list vector . opts) - (let ((start (if (pair? opts) (car opts) 0)) - (end (if (>= (length opts) 2) - (cadr opts) - (vector-length vector)))) - (do ((i start (+ i 1)) - (res '())) - ((= i end) - (reverse res)) - (set! res (cons (vector-ref vector i) res))))) - -(define (list->vector list) - (apply vector list)) - -(define (vector-copy! to at from . opts) - (let* ((start (if (pair? opts) (car opts) 0)) - (end (if (>= (length opts) 2) - (cadr opts) - (vector-length from))) - (vs #f)) - (if (eq? from to) - (begin - (set! vs (make-vector (- end start))) - (vector-copy! vs 0 from start end) - (vector-copy! to at vs)) - (do ((i at (+ i 1)) - (j start (+ j 1))) - ((= j end)) - (vector-set! to i (vector-ref from j)))))) - -(define (vector-copy v . opts) - (let ((start (if (pair? opts) (car opts) 0)) - (end (if (>= (length opts) 2) - (cadr opts) - (vector-length v)))) - (let ((res (make-vector (- end start)))) - (vector-copy! res 0 v start end) - res))) + (list->vector objs)) (define (vector-append . vs) (define (vector-append-2-inv w v) @@ -769,24 +667,13 @@ res)) (fold vector-append-2-inv #() vs)) -(define (vector-fill! v fill . opts) - (let ((start (if (pair? opts) (car opts) 0)) - (end (if (>= (length opts) 2) - (cadr opts) - (vector-length v)))) - (do ((i start (+ i 1))) - ((= i end) - #f) - (vector-set! v i fill)))) - (define (vector->string . args) (list->string (apply vector->list args))) (define (string->vector . args) (list->vector (apply string->list args))) -(export vector vector->list list->vector - vector-copy! vector-copy +(export vector vector-copy! vector-copy vector-append vector-fill! vector->string string->vector) diff --git a/src/bool.c b/src/bool.c index a985c625..74018c63 100644 --- a/src/bool.c +++ b/src/bool.c @@ -169,6 +169,25 @@ pic_bool_boolean_p(pic_state *pic) return (pic_true_p(v) || pic_false_p(v)) ? pic_true_value() : pic_false_value(); } +static pic_value +pic_bool_boolean_eq_p(pic_state *pic) +{ + size_t argc, i; + pic_value *argv; + + pic_get_args(pic, "*", &argc, &argv); + + for (i = 0; i < argc; ++i) { + if (! (pic_true_p(argv[i]) || pic_false_p(argv[i]))) { + return pic_false_value(); + } + if (! pic_eq_p(argv[i], argv[0])) { + return pic_false_value(); + } + } + return pic_true_value(); +} + void pic_init_bool(pic_state *pic) { @@ -178,4 +197,5 @@ pic_init_bool(pic_state *pic) pic_defun(pic, "not", pic_bool_not); pic_defun(pic, "boolean?", pic_bool_boolean_p); + pic_defun(pic, "boolean=?", pic_bool_boolean_eq_p); } diff --git a/src/number.c b/src/number.c index be3eabce..8e15860a 100644 --- a/src/number.c +++ b/src/number.c @@ -8,6 +8,7 @@ #include "picrin.h" #include "picrin/string.h" +#include "picrin/cont.h" static int gcd(int a, int b) @@ -381,6 +382,26 @@ pic_number_floor_remainder(pic_state *pic) } } +static pic_value +pic_number_floor2(pic_state *pic) +{ + int i, j; + bool e1, e2; + double q, r; + + pic_get_args(pic, "II", &i, &e1, &j, &e2); + + q = floor((double)i/j); + r = i - j * q; + + if (e1 && e2) { + return pic_values2(pic, pic_int_value(q), pic_int_value(r)); + } + else { + return pic_values2(pic, pic_float_value(q), pic_float_value(r)); + } +} + static pic_value pic_number_trunc_quotient(pic_state *pic) { @@ -414,6 +435,26 @@ pic_number_trunc_remainder(pic_state *pic) } } +static pic_value +pic_number_trunc2(pic_state *pic) +{ + int i, j; + bool e1, e2; + double q, r; + + pic_get_args(pic, "II", &i, &e1, &j, &e2); + + q = trunc((double)i/j); + r = i - j * q; + + if (e1 && e2) { + return pic_values2(pic, pic_int_value(q), pic_int_value(r)); + } + else { + return pic_values2(pic, pic_float_value(q), pic_float_value(r)); + } +} + static pic_value pic_number_gcd(pic_state *pic) { @@ -620,6 +661,19 @@ pic_number_atan(pic_state *pic) } } +static pic_value +pic_number_exact_integer_sqrt(pic_state *pic) +{ + int k, n, m; + + pic_get_args(pic, "i", &k); + + n = sqrt(k); + m = k - n * n; + + return pic_values2(pic, pic_int_value(n), pic_int_value(m)); +} + static pic_value pic_number_square(pic_state *pic) { @@ -780,8 +834,10 @@ pic_init_number(pic_state *pic) pic_defun(pic, "abs", pic_number_abs); pic_defun(pic, "floor-quotient", pic_number_floor_quotient); pic_defun(pic, "floor-remainder", pic_number_floor_remainder); + pic_defun(pic, "floor/", pic_number_floor2); pic_defun(pic, "truncate-quotient", pic_number_trunc_quotient); pic_defun(pic, "truncate-remainder", pic_number_trunc_remainder); + pic_defun(pic, "truncate/", pic_number_trunc2); pic_defun(pic, "modulo", pic_number_floor_remainder); pic_defun(pic, "quotient", pic_number_trunc_quotient); pic_defun(pic, "remainder", pic_number_trunc_remainder); @@ -797,6 +853,7 @@ pic_init_number(pic_state *pic) pic_defun(pic, "round", pic_number_round); pic_gc_arena_restore(pic, ai); + pic_defun(pic, "exact-integer-sqrt", pic_number_exact_integer_sqrt); pic_defun(pic, "square", pic_number_square); pic_defun(pic, "expt", pic_number_expt); pic_gc_arena_restore(pic, ai); diff --git a/src/symbol.c b/src/symbol.c index 863e41f3..1ebbdc3d 100644 --- a/src/symbol.c +++ b/src/symbol.c @@ -77,6 +77,25 @@ pic_symbol_symbol_p(pic_state *pic) return pic_bool_value(pic_sym_p(v)); } +static pic_value +pic_symbol_symbol_eq_p(pic_state *pic) +{ + size_t argc, i; + pic_value *argv; + + pic_get_args(pic, "*", &argc, &argv); + + for (i = 0; i < argc; ++i) { + if (! pic_sym_p(argv[i])) { + return pic_false_value(); + } + if (! pic_eq_p(argv[i], argv[0])) { + return pic_false_value(); + } + } + return pic_true_value(); +} + static pic_value pic_symbol_symbol_to_string(pic_state *pic) { @@ -109,6 +128,7 @@ void pic_init_symbol(pic_state *pic) { pic_defun(pic, "symbol?", pic_symbol_symbol_p); + pic_defun(pic, "symbol=?", pic_symbol_symbol_eq_p); pic_defun(pic, "symbol->string", pic_symbol_symbol_to_string); pic_defun(pic, "string->symbol", pic_symbol_string_to_symbol); } diff --git a/src/vector.c b/src/vector.c index 917f0878..8fe9392c 100644 --- a/src/vector.c +++ b/src/vector.c @@ -119,6 +119,125 @@ pic_vec_vector_set(pic_state *pic) return pic_none_value(); } +static pic_value +pic_vec_vector_copy_i(pic_state *pic) +{ + pic_vec *to, *from; + int n, at, start, end; + + n = pic_get_args(pic, "viv|ii", &to, &at, &from, &start, &end); + + switch (n) { + case 3: + start = 0; + case 4: + end = from->len; + } + + if (to == from && (start <= at && at < end)) { + /* copy in reversed order */ + at += end - start; + while (start < end) { + to->data[--at] = from->data[--end]; + } + return pic_none_value(); + } + + while (start < end) { + to->data[at++] = from->data[start++]; + } + + return pic_none_value(); +} + +static pic_value +pic_vec_vector_copy(pic_state *pic) +{ + pic_vec *vec, *to; + int n, start, end, i = 0; + + n = pic_get_args(pic, "v|ii", &vec, &start, &end); + + switch (n) { + case 1: + start = 0; + case 2: + end = vec->len; + } + + to = pic_vec_new(pic, end - start); + while (start < end) { + to->data[i++] = vec->data[start++]; + } + + return pic_obj_value(to); +} + +static pic_value +pic_vec_vector_fill_i(pic_state *pic) +{ + pic_vec *vec; + pic_value obj; + int n, start, end; + + n = pic_get_args(pic, "vo|ii", &vec, &obj, &start, &end); + + switch (n) { + case 2: + start = 0; + case 3: + end = vec->len; + } + + while (start < end) { + vec->data[start++] = obj; + } + + return pic_none_value(); +} + +static pic_value +pic_vec_list_to_vector(pic_state *pic) +{ + struct pic_vector *vec; + pic_value list, e, *data; + + pic_get_args(pic, "o", &list); + + vec = pic_vec_new(pic, pic_length(pic, list)); + + data = vec->data; + + pic_for_each (e, list) { + *data++ = e; + } + return pic_obj_value(vec); +} + +static pic_value +pic_vec_vector_to_list(pic_state *pic) +{ + struct pic_vector *vec; + pic_value list; + int n, start, end, i; + + n = pic_get_args(pic, "v|ii", &vec, &start, &end); + + switch (n) { + case 1: + start = 0; + case 2: + end = vec->len; + } + + list = pic_nil_value(); + + for (i = start; i < end; ++i) { + pic_push(pic, vec->data[i], list); + } + return pic_reverse(pic, list); +} + void pic_init_vector(pic_state *pic) { @@ -127,4 +246,9 @@ pic_init_vector(pic_state *pic) pic_defun(pic, "vector-length", pic_vec_vector_length); pic_defun(pic, "vector-ref", pic_vec_vector_ref); pic_defun(pic, "vector-set!", pic_vec_vector_set); + pic_defun(pic, "vector-copy!", pic_vec_vector_copy_i); + pic_defun(pic, "vector-copy", pic_vec_vector_copy); + pic_defun(pic, "vector-fill!", pic_vec_vector_fill_i); + pic_defun(pic, "list->vector", pic_vec_list_to_vector); + pic_defun(pic, "vector->list", pic_vec_vector_to_list); }