diff --git a/include/picrin/blob.h b/include/picrin/blob.h index 6b52d9e3..f61f588d 100644 --- a/include/picrin/blob.h +++ b/include/picrin/blob.h @@ -18,7 +18,7 @@ struct pic_blob { #define pic_blob_p(v) (pic_type(v) == PIC_TT_BLOB) #define pic_blob_ptr(v) ((struct pic_blob *)pic_ptr(v)) -struct pic_blob *pic_blob_new(pic_state *, char *, size_t len); +struct pic_blob *pic_blob_new(pic_state *, size_t); #if defined(__cplusplus) } diff --git a/include/picrin/pair.h b/include/picrin/pair.h index c7319e25..49de01cc 100644 --- a/include/picrin/pair.h +++ b/include/picrin/pair.h @@ -51,10 +51,11 @@ pic_value pic_append(pic_state *, pic_value, pic_value); pic_value pic_memq(pic_state *, pic_value key, pic_value list); pic_value pic_memv(pic_state *, pic_value key, pic_value list); +pic_value pic_member(pic_state *, pic_value key, pic_value list, struct pic_proc * /* = NULL */); pic_value pic_assq(pic_state *, pic_value key, pic_value assoc); pic_value pic_assv(pic_state *, pic_value key, pic_value assoc); -pic_value pic_assoc(pic_state *, pic_value key, pic_value assoc); +pic_value pic_assoc(pic_state *, pic_value key, pic_value assoc, struct pic_proc * /* = NULL */); pic_value pic_acons(pic_state *, pic_value key, pic_value val, pic_value assoc); 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/picrin/test.scm b/piclib/picrin/test.scm index f786ba58..1e938e11 100644 --- a/piclib/picrin/test.scm +++ b/piclib/picrin/test.scm @@ -69,9 +69,7 @@ (define-syntax test-values (syntax-rules () ((_ expect expr) - (test-values #f expect expr)) - ((_ name expect expr) - (test name (call-with-values (lambda () expect) (lambda results results)) + (test (call-with-values (lambda () expect) (lambda results results)) (call-with-values (lambda () expr) (lambda results results)))))) diff --git a/piclib/prelude.scm b/piclib/prelude.scm index 7049c2f0..d31363a2 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) @@ -276,12 +260,34 @@ (lambda (form r c) `(,(r 'letrec-syntax) ,@(cdr form))))) + (import (scheme read) (scheme file)) + + (define-syntax include + (letrec ((read-file + (lambda (filename) + (let ((port (open-input-file filename))) + (dynamic-wind + (lambda () #f) + (lambda () + (let loop ((expr (read port)) (exprs '())) + (if (eof-object? expr) + (reverse exprs) + (loop (read port) (cons expr exprs))))) + (lambda () + (close-port port))))))) + (er-macro-transformer + (lambda (form rename compare) + (let ((filenames (cdr form))) + (let ((exprs (apply append (map read-file filenames)))) + `(,(rename 'begin) ,@exprs))))))) + (export let let* letrec letrec* quasiquote unquote unquote-splicing and or cond case else => do when unless let-syntax letrec-syntax + include _ ... syntax-error)) (import (picrin core-syntax)) @@ -292,6 +298,7 @@ cond case else => do when unless let-syntax letrec-syntax + include _ ... syntax-error) ;;; multiple value @@ -315,13 +322,6 @@ (lambda (form r c) `(,(r 'let*-values) ,@(cdr form))))) - (define (vector-map proc vect) - (do ((i 0 (+ i 1)) - (u (make-vector (vector-length vect)))) - ((= i (vector-length vect)) - u) - (vector-set! u i (proc (vector-ref vect i))))) - (define (walk proc expr) (cond ((null? expr) @@ -330,7 +330,7 @@ (cons (proc (car expr)) (walk proc (cdr expr)))) ((vector? expr) - (vector-map proc expr)) + (list->vector (map proc (vector->list expr)))) (else (proc expr)))) @@ -593,79 +593,11 @@ (export define-record-type) -(define (every pred list) - (if (null? list) - #t - (if (pred (car list)) - (every pred (cdr list)) - #f))) - (define (fold f s xs) (if (null? xs) 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) - (let ((compare (if (null? opts) equal? (car opts)))) - (if (null? list) - #f - (if (compare obj (car list)) - list - (member obj (cdr list) compare))))) - -(define (assoc obj list . opts) - (let ((compare (if (null? opts) equal? (car opts)))) - (if (null? list) - #f - (if (compare obj (caar list)) - (car list) - (assoc obj (cdr list) compare))))) - -(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,70 +646,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))) - -(define (vector-append . vs) - (define (vector-append-2-inv w v) - (let ((res (make-vector (+ (vector-length v) (vector-length w))))) - (vector-copy! res 0 v) - (vector-copy! res (vector-length v) w) - 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)))) + (list->vector objs)) (define (vector->string . args) (list->string (apply vector->list args))) @@ -785,10 +654,7 @@ (define (string->vector . args) (list->vector (apply string->list args))) -(export vector vector->list list->vector - vector-copy! vector-copy - vector-append vector-fill! - vector->string string->vector) +(export vector vector->string string->vector) ;;; 6.9 bytevector @@ -801,39 +667,6 @@ v) (bytevector-u8-set! v i (car l)))))) -(define (bytevector-copy! to at from . opts) - (let* ((start (if (pair? opts) (car opts) 0)) - (end (if (>= (length opts) 2) - (cadr opts) - (bytevector-length from))) - (vs #f)) - (if (eq? from to) - (begin - (set! vs (make-bytevector (- end start))) - (bytevector-copy! vs 0 from start end) - (bytevector-copy! to at vs)) - (do ((i at (+ i 1)) - (j start (+ j 1))) - ((= j end)) - (bytevector-u8-set! to i (bytevector-u8-ref from j)))))) - -(define (bytevector-copy v . opts) - (let ((start (if (pair? opts) (car opts) 0)) - (end (if (>= (length opts) 2) - (cadr opts) - (bytevector-length v)))) - (let ((res (make-bytevector (- end start)))) - (bytevector-copy! res 0 v start end) - res))) - -(define (bytevector-append . vs) - (define (bytevector-append-2-inv w v) - (let ((res (make-bytevector (+ (bytevector-length v) (bytevector-length w))))) - (bytevector-copy! res 0 v) - (bytevector-copy! res (bytevector-length v) w) - res)) - (fold bytevector-append-2-inv #u8() vs)) - (define (bytevector->list v start end) (do ((i start (+ i 1)) (res '())) @@ -859,9 +692,8 @@ (list->bytevector (map char->integer (string->list s start end))))) (export bytevector - bytevector-copy! - bytevector-copy - bytevector-append + bytevector->list + list->bytevector utf8->string string->utf8) @@ -928,28 +760,6 @@ (export call-with-port) -;;; include syntax - -(import (scheme read) - (scheme file)) - -(define (read-many filename) - (call-with-port (open-input-file filename) - (lambda (port) - (let loop ((expr (read port)) (exprs '())) - (if (eof-object? expr) - (reverse exprs) - (loop (read port) (cons expr exprs))))))) - -(define-syntax include - (er-macro-transformer - (lambda (form rename compare) - (let ((filenames (cdr form))) - (let ((exprs (apply append (map read-many filenames)))) - `(,(rename 'begin) ,@exprs)))))) - -(export include) - ;;; syntax-rules (define-library (picrin syntax-rules) (import (scheme base) diff --git a/src/blob.c b/src/blob.c index 384858aa..0bb28713 100644 --- a/src/blob.c +++ b/src/blob.c @@ -25,12 +25,12 @@ pic_strdup(pic_state *pic, const char *s) } struct pic_blob * -pic_blob_new(pic_state *pic, char *dat, size_t len) +pic_blob_new(pic_state *pic, size_t len) { struct pic_blob *bv; bv = (struct pic_blob *)pic_obj_alloc(pic, sizeof(struct pic_blob), PIC_TT_BLOB); - bv->data = pic_strndup(pic, dat, len); + bv->data = pic_alloc(pic, len); bv->len = len; return bv; } @@ -48,20 +48,20 @@ pic_blob_bytevector_p(pic_state *pic) static pic_value pic_blob_make_bytevector(pic_state *pic) { + pic_blob *blob; int k, b = 0, i; - char *dat; pic_get_args(pic, "i|i", &k, &b); if (b < 0 || b > 255) pic_error(pic, "byte out of range"); - dat = pic_alloc(pic, k); + blob = pic_blob_new(pic, k); for (i = 0; i < k; ++i) { - dat[i] = b; + blob->data[i] = b; } - return pic_obj_value(pic_blob_new(pic, dat, k)); + return pic_obj_value(blob); } static pic_value @@ -100,6 +100,88 @@ pic_blob_bytevector_u8_set(pic_state *pic) return pic_none_value(); } +static pic_value +pic_blob_bytevector_copy_i(pic_state *pic) +{ + pic_blob *to, *from; + int n, at, start, end; + + n = pic_get_args(pic, "bib|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_blob_bytevector_copy(pic_state *pic) +{ + pic_blob *from, *to; + int n, start, end, i = 0; + + n = pic_get_args(pic, "b|ii", &from, &start, &end); + + switch (n) { + case 1: + start = 0; + case 2: + end = from->len; + } + + to = pic_blob_new(pic, end - start); + while (start < end) { + to->data[i++] = from->data[start++]; + } + + return pic_obj_value(to); +} + +static pic_value +pic_blob_bytevector_append(pic_state *pic) +{ + size_t argc, i, j, len; + pic_value *argv; + pic_blob *blob; + + pic_get_args(pic, "*", &argc, &argv); + + len = 0; + for (i = 0; i < argc; ++i) { + pic_assert_type(pic, argv[i], blob); + len += pic_blob_ptr(argv[i])->len; + } + + blob = pic_blob_new(pic, len); + + len = 0; + for (i = 0; i < argc; ++i) { + for (j = 0; j < pic_blob_ptr(argv[i])->len; ++j) { + blob->data[len + j] = pic_blob_ptr(argv[i])->data[j]; + } + len += pic_blob_ptr(argv[i])->len; + } + + return pic_obj_value(blob); +} + void pic_init_blob(pic_state *pic) { @@ -108,4 +190,7 @@ pic_init_blob(pic_state *pic) pic_defun(pic, "bytevector-length", pic_blob_bytevector_length); pic_defun(pic, "bytevector-u8-ref", pic_blob_bytevector_u8_ref); pic_defun(pic, "bytevector-u8-set!", pic_blob_bytevector_u8_set); + pic_defun(pic, "bytevector-copy!", pic_blob_bytevector_copy_i); + pic_defun(pic, "bytevector-copy", pic_blob_bytevector_copy); + pic_defun(pic, "bytevector-append", pic_blob_bytevector_append); } 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/cont.c b/src/cont.c index de076874..11b5a3f6 100644 --- a/src/cont.c +++ b/src/cont.c @@ -210,6 +210,37 @@ walk_to_block(pic_state *pic, pic_block *here, pic_block *there) } } +static pic_value +pic_dynamic_wind(pic_state *pic, struct pic_proc *in, struct pic_proc *thunk, struct pic_proc *out) +{ + pic_block *here; + pic_value val; + + if (in != NULL) { + pic_apply0(pic, in); /* enter */ + } + + here = pic->blk; + pic->blk = (pic_block *)pic_alloc(pic, sizeof(pic_block)); + pic->blk->prev = here; + pic->blk->depth = here->depth + 1; + pic->blk->in = in; + pic->blk->out = out; + pic->blk->refcnt = 1; + PIC_BLK_INCREF(pic, here); + + val = pic_apply0(pic, thunk); + + PIC_BLK_DECREF(pic, pic->blk); + pic->blk = here; + + if (out != NULL) { + pic_apply0(pic, out); /* exit */ + } + + return val; +} + noreturn static pic_value cont_call(pic_state *pic) { @@ -286,33 +317,10 @@ static pic_value pic_cont_dynamic_wind(pic_state *pic) { struct pic_proc *in, *thunk, *out; - pic_value v; pic_get_args(pic, "lll", &in, &thunk, &out); - /* enter */ - pic_apply0(pic, in); - { - pic_block *here; - - here = pic->blk; - pic->blk = (pic_block *)pic_alloc(pic, sizeof(pic_block)); - pic->blk->prev = here; - pic->blk->depth = here->depth + 1; - pic->blk->in = in; - pic->blk->out = out; - pic->blk->refcnt = 1; - PIC_BLK_INCREF(pic, here); - - v = pic_apply0(pic, thunk); - - PIC_BLK_DECREF(pic, pic->blk); - pic->blk = here; - } - /* exit */ - pic_apply0(pic, out); - - return v; + return pic_dynamic_wind(pic, in, thunk, out); } static pic_value diff --git a/src/lib.c b/src/lib.c index 5ac5336a..7a197c87 100644 --- a/src/lib.c +++ b/src/lib.c @@ -54,7 +54,7 @@ pic_find_library(pic_state *pic, pic_value spec) { pic_value v; - v = pic_assoc(pic, spec, pic->lib_tbl); + v = pic_assoc(pic, spec, pic->lib_tbl, NULL); if (pic_false_p(v)) { return NULL; } 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/pair.c b/src/pair.c index 2c80f363..f2960adb 100644 --- a/src/pair.c +++ b/src/pair.c @@ -291,6 +291,26 @@ pic_memv(pic_state *pic, pic_value key, pic_value list) goto enter; } +pic_value +pic_member(pic_state *pic, pic_value key, pic_value list, struct pic_proc *compar) +{ + enter: + + if (pic_nil_p(list)) + return pic_false_value(); + + if (compar == NULL) { + if (pic_equal_p(pic, key, pic_car(pic, list))) + return list; + } else { + if (pic_test(pic_apply2(pic, compar, key, pic_car(pic, list)))) + return list; + } + + list = pic_cdr(pic, list); + goto enter; +} + pic_value pic_assq(pic_state *pic, pic_value key, pic_value assoc) { @@ -328,7 +348,7 @@ pic_assv(pic_state *pic, pic_value key, pic_value assoc) } pic_value -pic_assoc(pic_state *pic, pic_value key, pic_value assoc) +pic_assoc(pic_state *pic, pic_value key, pic_value assoc, struct pic_proc *compar) { pic_value cell; @@ -338,8 +358,13 @@ pic_assoc(pic_state *pic, pic_value key, pic_value assoc) return pic_false_value(); cell = pic_car(pic, assoc); - if (pic_equal_p(pic, key, pic_car(pic, cell))) - return cell; + if (compar == NULL) { + if (pic_equal_p(pic, key, pic_car(pic, cell))) + return cell; + } else { + if (pic_test(pic_apply2(pic, compar, key, pic_car(pic, cell)))) + return cell; + } assoc = pic_cdr(pic, assoc); goto enter; @@ -662,6 +687,17 @@ pic_pair_memv(pic_state *pic) return pic_memv(pic, key, list); } +static pic_value +pic_pair_member(pic_state *pic) +{ + struct pic_proc *proc = NULL; + pic_value key, list; + + pic_get_args(pic, "oo|l", &key, &list, &proc); + + return pic_member(pic, key, list, proc); +} + static pic_value pic_pair_assq(pic_state *pic) { @@ -682,6 +718,17 @@ pic_pair_assv(pic_state *pic) return pic_assv(pic, key, list); } +static pic_value +pic_pair_assoc(pic_state *pic) +{ + struct pic_proc *proc = NULL; + pic_value key, list; + + pic_get_args(pic, "oo|l", &key, &list, &proc); + + return pic_assoc(pic, key, list, proc); +} + void pic_init_pair(pic_state *pic) { @@ -708,6 +755,8 @@ pic_init_pair(pic_state *pic) pic_defun(pic, "list-copy", pic_pair_list_copy); pic_defun(pic, "memq", pic_pair_memq); pic_defun(pic, "memv", pic_pair_memv); + pic_defun(pic, "member", pic_pair_member); pic_defun(pic, "assq", pic_pair_assq); pic_defun(pic, "assv", pic_pair_assv); + pic_defun(pic, "assoc", pic_pair_assoc); } diff --git a/src/port.c b/src/port.c index 8a3534bc..6f9b6673 100644 --- a/src/port.c +++ b/src/port.c @@ -354,8 +354,8 @@ static pic_value pic_port_get_output_bytevector(pic_state *pic) { struct pic_port *port = pic_stdout(pic); + pic_blob *blob; long endpos; - char *buf; pic_get_args(pic, "|p", &port); @@ -367,10 +367,10 @@ pic_port_get_output_bytevector(pic_state *pic) xrewind(port->file); /* copy to buf */ - buf = (char *)pic_alloc(pic, endpos); - xfread(buf, 1, endpos, port->file); + blob = pic_blob_new(pic, endpos); + xfread(blob->data, 1, endpos, port->file); - return pic_obj_value(pic_blob_new(pic, buf, endpos)); + return pic_obj_value(blob); } static pic_value @@ -524,28 +524,32 @@ pic_port_byte_ready_p(pic_state *pic) static pic_value -pic_port_read_blob(pic_state *pic){ +pic_port_read_blob(pic_state *pic) +{ struct pic_port *port = pic_stdin(pic); + pic_blob *blob; int k, i; - char *buf; pic_get_args(pic, "i|p", &k, &port); assert_port_profile(port, PIC_PORT_IN | PIC_PORT_BINARY, PIC_PORT_OPEN, "read-bytevector"); - buf = pic_calloc(pic, k, sizeof(char)); - i = xfread(buf, sizeof(char), k, port->file); + blob = pic_blob_new(pic, k); + + i = xfread(blob->data, sizeof(char), k, port->file); if ( i == 0 ) { return pic_eof_object(); } else { - pic_realloc(pic, buf, i); - return pic_obj_value(pic_blob_new(pic, buf, i)); + pic_realloc(pic, blob->data, i); + blob->len = i; + return pic_obj_value(blob); } } static pic_value -pic_port_read_blob_ip(pic_state *pic){ +pic_port_read_blob_ip(pic_state *pic) +{ struct pic_port *port; struct pic_blob *bv; int i, n, start, end, len; @@ -568,7 +572,7 @@ pic_port_read_blob_ip(pic_state *pic){ i = xfread(buf, sizeof(char), len, port->file); memcpy(bv->data + start, buf, i); pic_free(pic, buf); - + if ( i == 0) { return pic_eof_object(); } diff --git a/src/read.c b/src/read.c index 62467ece..d7726471 100644 --- a/src/read.c +++ b/src/read.c @@ -438,7 +438,7 @@ static pic_value read_unsigned_blob(pic_state *pic, struct pic_port *port, char c) { int nbits, n; - size_t len; + size_t len, i; char *dat, buf[256]; pic_blob *blob; @@ -471,7 +471,11 @@ read_unsigned_blob(pic_state *pic, struct pic_port *port, char c) c = next(port); } - blob = pic_blob_new(pic, dat, len); + blob = pic_blob_new(pic, len); + for (i = 0; i < len; ++i) { + blob->data[i] = dat[i]; + } + pic_free(pic, dat); return pic_obj_value(blob); } 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..d57214e7 100644 --- a/src/vector.c +++ b/src/vector.c @@ -119,6 +119,153 @@ 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_append(pic_state *pic) +{ + size_t argc, i, j, len; + pic_value *argv; + pic_vec *vec; + + pic_get_args(pic, "*", &argc, &argv); + + len = 0; + for (i = 0; i < argc; ++i) { + pic_assert_type(pic, argv[i], vec); + len += pic_vec_ptr(argv[i])->len; + } + + vec = pic_vec_new(pic, len); + + len = 0; + for (i = 0; i < argc; ++i) { + for (j = 0; j < pic_vec_ptr(argv[i])->len; ++j) { + vec->data[len + j] = pic_vec_ptr(argv[i])->data[j]; + } + len += pic_vec_ptr(argv[i])->len; + } + + return pic_obj_value(vec); +} + +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 +274,10 @@ 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-append", pic_vec_vector_append); + 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); } diff --git a/t/r7rs-tests.scm b/t/r7rs-tests.scm index 1cf0cb0a..c02b0c9d 100644 --- a/t/r7rs-tests.scm +++ b/t/r7rs-tests.scm @@ -763,15 +763,15 @@ (test 7 (abs -7)) (test 7 (abs 7)) -;; (test-values (values 2 1) (floor/ 5 2)) -;; (test-values (values -3 1) (floor/ -5 2)) -;; (test-values (values -3 -1) (floor/ 5 -2)) -;; (test-values (values 2 -1) (floor/ -5 -2)) -;; (test-values (values 2 1) (truncate/ 5 2)) -;; (test-values (values -2 -1) (truncate/ -5 2)) -;; (test-values (values -2 1) (truncate/ 5 -2)) -;; (test-values (values 2 -1) (truncate/ -5 -2)) -;; (test-values (values 2.0 -1.0) (truncate/ -5.0 -2)) +(test-values (values 2 1) (floor/ 5 2)) +(test-values (values -3 1) (floor/ -5 2)) +(test-values (values -3 -1) (floor/ 5 -2)) +(test-values (values 2 -1) (floor/ -5 -2)) +(test-values (values 2 1) (truncate/ 5 2)) +(test-values (values -2 -1) (truncate/ -5 2)) +(test-values (values -2 1) (truncate/ 5 -2)) +(test-values (values 2 -1) (truncate/ -5 -2)) +(test-values (values 2.0 -1.0) (truncate/ -5.0 -2)) (test 1 (modulo 13 4)) (test 1 (remainder 13 4))