conservatory
/
picrin
4
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Merge branch 'master' into refactor-contrib

This commit is contained in:
Sunrim KIM (keen) 2014-07-22 21:01:01 +09:00
parent 973f8156ea 4d108ac299
commit ec92cabfdc
16 changed files with 489 additions and 298 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
include/picrin/blob.h
View File

@ -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)
}

3
include/picrin/pair.h
View File

@ -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);

18
piclib/picrin/macro.scm
View File

@ -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)

4
piclib/picrin/test.scm
View File

@ -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))))))

246
piclib/prelude.scm
View File

@ -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)

97
src/blob.c
View File

@ -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);
}

20
src/bool.c
View File

@ -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);
}

56
src/cont.c
View File

@ -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

2
src/lib.c
View File

@ -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;
}

57
src/number.c
View File

@ -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);

55
src/pair.c
View File

@ -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);
}

28
src/port.c
View File

@ -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();
}

8
src/read.c
View File

@ -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);
}

20
src/symbol.c
View File

@ -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);
}

153
src/vector.c
View File

@ -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);
}

18
t/r7rs-tests.scm
View File

@ -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))