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

initial benz integration

This commit is contained in:
Yuichi Nishiwaki 2014-09-01 09:33:28 +09:00
parent a2e968fe46
commit 83f580bfcf
29 changed files with 12 additions and 11014 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
CMakeLists.txt
View File

@ -26,7 +26,7 @@ else()
add_definitions(-std=c99) # at least c99 is required
endif()
include_directories(include extlib)
include_directories(extlib/benz/include)
# build picrin
include(piclib/CMakeLists.txt)

13
src/CMakeLists.txt
View File

@ -1,7 +1,10 @@
find_package(Perl REQUIRED)
# xfile
set(XFILE_SOURCES extlib/xfile/xfile.c)
# benz
file(GLOB BENZ_SOURCES extlib/benz/*.c)
# srcs
file(GLOB PICRIN_SOURCES src/*.c)
# piclib
set(PICLIB_SOURCE ${PROJECT_SOURCE_DIR}/src/load_piclib.c)
@ -21,12 +24,10 @@ add_custom_command(
WORKING_DIRECTORY ${PROJECT_SOURCE_DIR}
)
# build!
file(GLOB PICRIN_SOURCES ${PROJECT_SOURCE_DIR}/src/*.c)
add_library(picrin SHARED ${PICRIN_SOURCES} ${PICLIB_SOURCE} ${XFILE_SOURCES} ${PICRIN_CONTRIB_SOURCES} ${CONTRIB_INIT})
add_library(picrin SHARED ${BENZ_SOURCES} ${PICRIN_SOURCES} ${PICLIB_SOURCE} ${PICRIN_CONTRIB_SOURCES} ${CONTRIB_INIT})
target_link_libraries(picrin m ${PICRIN_CONTRIB_LIBRARIES})
# install
set(CMAKE_INSTALL_RPATH ${CMAKE_INSTALL_PREFIX}/lib)
install(TARGETS picrin DESTINATION lib)
install(DIRECTORY include/ DESTINATION include FILES_MATCHING PATTERN "*.h")
install(DIRECTORY extlib/benz/include/ DESTINATION include FILES_MATCHING PATTERN "*.h")

196
src/blob.c
View File

@ -1,196 +0,0 @@
/**
* See Copyright Notice in picrin.h
*/
#include <string.h>
#include "picrin.h"
#include "picrin/blob.h"
char *
pic_strndup(pic_state *pic, const char *s, size_t n)
{
char *r;
r = pic_alloc(pic, n + 1);
memcpy(r, s, n);
r[n] = '\0';
return r;
}
char *
pic_strdup(pic_state *pic, const char *s)
{
return pic_strndup(pic, s, strlen(s));
}
struct pic_blob *
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_alloc(pic, len);
bv->len = len;
return bv;
}
static pic_value
pic_blob_bytevector_p(pic_state *pic)
{
pic_value v;
pic_get_args(pic, "o", &v);
return pic_bool_value(pic_blob_p(v));
}
static pic_value
pic_blob_make_bytevector(pic_state *pic)
{
pic_blob *blob;
int k, b = 0, i;
pic_get_args(pic, "i|i", &k, &b);
if (b < 0 || b > 255)
pic_error(pic, "byte out of range");
blob = pic_blob_new(pic, k);
for (i = 0; i < k; ++i) {
blob->data[i] = b;
}
return pic_obj_value(blob);
}
static pic_value
pic_blob_bytevector_length(pic_state *pic)
{
struct pic_blob *bv;
pic_get_args(pic, "b", &bv);
return pic_int_value(bv->len);
}
static pic_value
pic_blob_bytevector_u8_ref(pic_state *pic)
{
struct pic_blob *bv;
int k;
pic_get_args(pic, "bi", &bv, &k);
return pic_int_value(bv->data[k]);
}
static pic_value
pic_blob_bytevector_u8_set(pic_state *pic)
{
struct pic_blob *bv;
int k, v;
pic_get_args(pic, "bii", &bv, &k, &v);
if (v < 0 || v > 255)
pic_error(pic, "byte out of range");
bv->data[k] = v;
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)
{
pic_defun(pic, "bytevector?", pic_blob_bytevector_p);
pic_defun(pic, "make-bytevector", pic_blob_make_bytevector);
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);
}

201
src/bool.c
View File

@ -1,201 +0,0 @@
/**
* See Copyright Notice in picrin.h
*/
#include <string.h>
#include "picrin.h"
#include "picrin/pair.h"
#include "picrin/vector.h"
#include "picrin/blob.h"
#include "picrin/string.h"
static bool
str_equal_p(struct pic_string *str1, struct pic_string *str2)
{
return pic_strcmp(str1, str2) == 0;
}
static bool
blob_equal_p(struct pic_blob *blob1, struct pic_blob *blob2)
{
size_t i;
if (blob1->len != blob2->len) {
return false;
}
for (i = 0; i < blob1->len; ++i) {
if (blob1->data[i] != blob2->data[i])
return false;
}
return true;
}
static bool
internal_equal_p(pic_state *pic, pic_value x, pic_value y, size_t depth, xhash *ht)
{
pic_value local = pic_nil_value();
size_t c;
if (depth > 10) {
if (depth > 200) {
pic_errorf(pic, "Stack overflow in equal\n");
}
if (pic_pair_p(x) || pic_vec_p(x)) {
if (xh_get_ptr(ht, pic_obj_ptr(x)) != NULL) {
return true; /* `x' was seen already. */
} else {
xh_put_ptr(ht, pic_obj_ptr(x), NULL);
}
}
}
c = 0;
LOOP:
if (pic_eqv_p(x, y))
return true;
if (pic_type(x) != pic_type(y))
return false;
switch (pic_type(x)) {
case PIC_TT_STRING:
return str_equal_p(pic_str_ptr(x), pic_str_ptr(y));
case PIC_TT_BLOB:
return blob_equal_p(pic_blob_ptr(x), pic_blob_ptr(y));
case PIC_TT_PAIR: {
if (pic_nil_p(local)) {
local = x;
}
if (internal_equal_p(pic, pic_car(pic, x), pic_car(pic, y), depth + 1, ht)) {
x = pic_cdr(pic, x);
y = pic_cdr(pic, y);
c++;
if (c == 2) {
c = 0;
local = pic_cdr(pic, local);
if (pic_eq_p(local, x)) {
return true;
}
}
goto LOOP;
} else {
return false;
}
}
case PIC_TT_VECTOR: {
size_t i;
struct pic_vector *u, *v;
u = pic_vec_ptr(x);
v = pic_vec_ptr(y);
if (u->len != v->len) {
return false;
}
for (i = 0; i < u->len; ++i) {
if (! internal_equal_p(pic, u->data[i], v->data[i], depth + 1, ht))
return false;
}
return true;
}
default:
return false;
}
}
bool
pic_equal_p(pic_state *pic, pic_value x, pic_value y){
xhash ht;
xh_init_ptr(&ht, 0);
return internal_equal_p(pic, x, y, 0, &ht);
}
static pic_value
pic_bool_eq_p(pic_state *pic)
{
pic_value x, y;
pic_get_args(pic, "oo", &x, &y);
return pic_bool_value(pic_eq_p(x, y));
}
static pic_value
pic_bool_eqv_p(pic_state *pic)
{
pic_value x, y;
pic_get_args(pic, "oo", &x, &y);
return pic_bool_value(pic_eqv_p(x, y));
}
static pic_value
pic_bool_equal_p(pic_state *pic)
{
pic_value x, y;
pic_get_args(pic, "oo", &x, &y);
return pic_bool_value(pic_equal_p(pic, x, y));
}
static pic_value
pic_bool_not(pic_state *pic)
{
pic_value v;
pic_get_args(pic, "o", &v);
return pic_false_p(v) ? pic_true_value() : pic_false_value();
}
static pic_value
pic_bool_boolean_p(pic_state *pic)
{
pic_value v;
pic_get_args(pic, "o", &v);
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)
{
pic_defun(pic, "eq?", pic_bool_eq_p);
pic_defun(pic, "eqv?", pic_bool_eqv_p);
pic_defun(pic, "equal?", pic_bool_equal_p);
pic_defun(pic, "not", pic_bool_not);
pic_defun(pic, "boolean?", pic_bool_boolean_p);
pic_defun(pic, "boolean=?", pic_bool_boolean_eq_p);
}

43
src/char.c
View File

@ -1,43 +0,0 @@
/**
* See Copyright Notice in picrin.h
*/
#include "picrin.h"
static pic_value
pic_char_char_p(pic_state *pic)
{
pic_value v;
pic_get_args(pic, "o", &v);
return pic_char_p(v) ? pic_true_value() : pic_false_value();
}
static pic_value
pic_char_char_to_integer(pic_state *pic)
{
char c;
pic_get_args(pic, "c", &c);
return pic_int_value(c);
}
static pic_value
pic_char_integer_to_char(pic_state *pic)
{
int i;
pic_get_args(pic, "i", &i);
return pic_char_value(i);
}
void
pic_init_char(pic_state *pic)
{
pic_defun(pic, "char?", pic_char_char_p);
pic_defun(pic, "char->integer", pic_char_char_to_integer);
pic_defun(pic, "integer->char", pic_char_integer_to_char);
}

1458
src/codegen.c
View File

File diff suppressed because it is too large Load Diff

371
src/cont.c
View File

@ -1,371 +0,0 @@
/**
* See Copyright Notice in picrin.h
*/
#include <setjmp.h>
#include <string.h>
#include <stdarg.h>
#include "picrin.h"
#include "picrin/proc.h"
#include "picrin/cont.h"
#include "picrin/pair.h"
#include "picrin/error.h"
pic_value
pic_values0(pic_state *pic)
{
return pic_values_by_list(pic, pic_nil_value());
}
pic_value
pic_values1(pic_state *pic, pic_value arg1)
{
return pic_values_by_list(pic, pic_list1(pic, arg1));
}
pic_value
pic_values2(pic_state *pic, pic_value arg1, pic_value arg2)
{
return pic_values_by_list(pic, pic_list2(pic, arg1, arg2));
}
pic_value
pic_values3(pic_state *pic, pic_value arg1, pic_value arg2, pic_value arg3)
{
return pic_values_by_list(pic, pic_list3(pic, arg1, arg2, arg3));
}
pic_value
pic_values4(pic_state *pic, pic_value arg1, pic_value arg2, pic_value arg3, pic_value arg4)
{
return pic_values_by_list(pic, pic_list4(pic, arg1, arg2, arg3, arg4));
}
pic_value
pic_values5(pic_state *pic, pic_value arg1, pic_value arg2, pic_value arg3, pic_value arg4, pic_value arg5)
{
return pic_values_by_list(pic, pic_list5(pic, arg1, arg2, arg3, arg4, arg5));
}
pic_value
pic_values_by_array(pic_state *pic, size_t argc, pic_value *argv)
{
size_t i;
for (i = 0; i < argc; ++i) {
pic->sp[i] = argv[i];
}
pic->ci->retc = argc;
return argc == 0 ? pic_none_value() : pic->sp[0];
}
pic_value
pic_values_by_list(pic_state *pic, pic_value list)
{
pic_value v;
size_t i;
i = 0;
pic_for_each (v, list) {
pic->sp[i++] = v;
}
pic->ci->retc = i;
return pic_nil_p(list) ? pic_none_value() : pic->sp[0];
}
size_t
pic_receive(pic_state *pic, size_t n, pic_value *argv)
{
pic_callinfo *ci;
size_t i, retc;
/* take info from discarded frame */
ci = pic->ci + 1;
retc = ci->retc;
for (i = 0; i < retc && i < n; ++i) {
argv[i] = ci->fp[i];
}
return retc;
}
static void save_cont(pic_state *, struct pic_cont **);
static void restore_cont(pic_state *, struct pic_cont *);
static ptrdiff_t
native_stack_length(pic_state *pic, char **pos)
{
char t;
*pos = (pic->native_stack_start > &t)
? &t
: pic->native_stack_start;
return (pic->native_stack_start > &t)
? pic->native_stack_start - &t
: &t - pic->native_stack_start;
}
static void
save_cont(pic_state *pic, struct pic_cont **c)
{
void pic_vm_tear_off(pic_state *);
struct pic_cont *cont;
char *pos;
pic_vm_tear_off(pic); /* tear off */
cont = *c = (struct pic_cont *)pic_obj_alloc(pic, sizeof(struct pic_cont), PIC_TT_CONT);
cont->blk = pic->blk;
cont->stk_len = native_stack_length(pic, &pos);
cont->stk_pos = pos;
assert(cont->stk_len > 0);
cont->stk_ptr = pic_alloc(pic, cont->stk_len);
memcpy(cont->stk_ptr, cont->stk_pos, cont->stk_len);
cont->sp_offset = pic->sp - pic->stbase;
cont->st_len = pic->stend - pic->stbase;
cont->st_ptr = (pic_value *)pic_alloc(pic, sizeof(pic_value) * cont->st_len);
memcpy(cont->st_ptr, pic->stbase, sizeof(pic_value) * cont->st_len);
cont->ci_offset = pic->ci - pic->cibase;
cont->ci_len = pic->ciend - pic->cibase;
cont->ci_ptr = (pic_callinfo *)pic_alloc(pic, sizeof(pic_callinfo) * cont->ci_len);
memcpy(cont->ci_ptr, pic->cibase, sizeof(pic_callinfo) * cont->ci_len);
cont->ip = pic->ip;
cont->arena_idx = pic->arena_idx;
cont->arena_size = pic->arena_size;
cont->arena = (struct pic_object **)pic_alloc(pic, sizeof(struct pic_object *) * pic->arena_size);
memcpy(cont->arena, pic->arena, sizeof(struct pic_object *) * pic->arena_size);
cont->try_jmp_idx = pic->try_jmp_idx;
cont->try_jmp_size = pic->try_jmp_size;
cont->try_jmps = pic_alloc(pic, sizeof(struct pic_jmpbuf) * pic->try_jmp_size);
memcpy(cont->try_jmps, pic->try_jmps, sizeof(struct pic_jmpbuf) * pic->try_jmp_size);
cont->results = pic_undef_value();
}
static void
native_stack_extend(pic_state *pic, struct pic_cont *cont)
{
volatile pic_value v[1024];
((void)v);
restore_cont(pic, cont);
}
noreturn static void
restore_cont(pic_state *pic, struct pic_cont *cont)
{
char v;
struct pic_cont *tmp = cont;
struct pic_block *blk;
if (&v < pic->native_stack_start) {
if (&v > cont->stk_pos) native_stack_extend(pic, cont);
}
else {
if (&v > cont->stk_pos + cont->stk_len) native_stack_extend(pic, cont);
}
blk = pic->blk;
pic->blk = cont->blk;
pic->stbase = (pic_value *)pic_realloc(pic, pic->stbase, sizeof(pic_value) * cont->st_len);
memcpy(pic->stbase, cont->st_ptr, sizeof(pic_value) * cont->st_len);
pic->sp = pic->stbase + cont->sp_offset;
pic->stend = pic->stbase + cont->st_len;
pic->cibase = (pic_callinfo *)pic_realloc(pic, pic->cibase, sizeof(pic_callinfo) * cont->ci_len);
memcpy(pic->cibase, cont->ci_ptr, sizeof(pic_callinfo) * cont->ci_len);
pic->ci = pic->cibase + cont->ci_offset;
pic->ciend = pic->cibase + cont->ci_len;
pic->ip = cont->ip;
pic->arena = (struct pic_object **)pic_realloc(pic, pic->arena, sizeof(struct pic_object *) * cont->arena_size);
memcpy(pic->arena, cont->arena, sizeof(struct pic_object *) * cont->arena_size);
pic->arena_size = cont->arena_size;
pic->arena_idx = cont->arena_idx;
pic->try_jmps = pic_realloc(pic, pic->try_jmps, sizeof(struct pic_jmpbuf) * cont->try_jmp_size);
memcpy(pic->try_jmps, cont->try_jmps, sizeof(struct pic_jmpbuf) * cont->try_jmp_size);
pic->try_jmp_size = cont->try_jmp_size;
pic->try_jmp_idx = cont->try_jmp_idx;
memcpy(cont->stk_pos, cont->stk_ptr, cont->stk_len);
longjmp(tmp->jmp, 1);
}
static void
walk_to_block(pic_state *pic, struct pic_block *here, struct pic_block *there)
{
if (here == there)
return;
if (here->depth < there->depth) {
walk_to_block(pic, here, there->prev);
pic_apply0(pic, there->in);
}
else {
pic_apply0(pic, there->out);
walk_to_block(pic, here->prev, there);
}
}
static pic_value
pic_dynamic_wind(pic_state *pic, struct pic_proc *in, struct pic_proc *thunk, struct pic_proc *out)
{
struct pic_block *here;
pic_value val;
if (in != NULL) {
pic_apply0(pic, in); /* enter */
}
here = pic->blk;
pic->blk = (struct pic_block *)pic_obj_alloc(pic, sizeof(struct pic_block), PIC_TT_BLK);
pic->blk->prev = here;
pic->blk->depth = here->depth + 1;
pic->blk->in = in;
pic->blk->out = out;
val = pic_apply0(pic, thunk);
pic->blk = here;
if (out != NULL) {
pic_apply0(pic, out); /* exit */
}
return val;
}
noreturn static pic_value
cont_call(pic_state *pic)
{
struct pic_proc *proc;
size_t argc;
pic_value *argv;
struct pic_cont *cont;
proc = pic_get_proc(pic);
pic_get_args(pic, "*", &argc, &argv);
cont = (struct pic_cont *)pic_ptr(pic_attr_ref(pic, proc, "@@cont"));
cont->results = pic_list_by_array(pic, argc, argv);
/* execute guard handlers */
walk_to_block(pic, pic->blk, cont->blk);
restore_cont(pic, cont);
}
pic_value
pic_callcc(pic_state *pic, struct pic_proc *proc)
{
struct pic_cont *cont;
save_cont(pic, &cont);
if (setjmp(cont->jmp)) {
return pic_values_by_list(pic, cont->results);
}
else {
struct pic_proc *c;
c = pic_proc_new(pic, cont_call, "<continuation-procedure>");
/* save the continuation object in proc */
pic_attr_set(pic, c, "@@cont", pic_obj_value(cont));
return pic_apply1(pic, proc, pic_obj_value(c));
}
}
static pic_value
pic_callcc_trampoline(pic_state *pic, struct pic_proc *proc)
{
struct pic_cont *cont;
save_cont(pic, &cont);
if (setjmp(cont->jmp)) {
return pic_values_by_list(pic, cont->results);
}
else {
struct pic_proc *c;
c = pic_proc_new(pic, cont_call, "<continuation-procedure>");
/* save the continuation object in proc */
pic_attr_set(pic, c, "@@cont", pic_obj_value(cont));
return pic_apply_trampoline(pic, proc, pic_list1(pic, pic_obj_value(c)));
}
}
static pic_value
pic_cont_callcc(pic_state *pic)
{
struct pic_proc *cb;
pic_get_args(pic, "l", &cb);
return pic_callcc_trampoline(pic, cb);
}
static pic_value
pic_cont_dynamic_wind(pic_state *pic)
{
struct pic_proc *in, *thunk, *out;
pic_get_args(pic, "lll", &in, &thunk, &out);
return pic_dynamic_wind(pic, in, thunk, out);
}
static pic_value
pic_cont_values(pic_state *pic)
{
size_t argc;
pic_value *argv;
pic_get_args(pic, "*", &argc, &argv);
return pic_values_by_array(pic, argc, argv);
}
static pic_value
pic_cont_call_with_values(pic_state *pic)
{
struct pic_proc *producer, *consumer;
size_t argc;
pic_value args[256];
pic_get_args(pic, "ll", &producer, &consumer);
pic_apply(pic, producer, pic_nil_value());
argc = pic_receive(pic, 256, args);
return pic_apply_trampoline(pic, consumer, pic_list_by_array(pic, argc, args));
}
void
pic_init_cont(pic_state *pic)
{
pic_defun(pic, "call-with-current-continuation", pic_cont_callcc);
pic_defun(pic, "call/cc", pic_cont_callcc);
pic_defun(pic, "dynamic-wind", pic_cont_dynamic_wind);
pic_defun(pic, "values", pic_cont_values);
pic_defun(pic, "call-with-values", pic_cont_call_with_values);
}

15
src/data.c
View File

@ -1,15 +0,0 @@
#include "picrin.h"
#include "picrin/data.h"
struct pic_data *
pic_data_alloc(pic_state *pic, const pic_data_type *type, void *userdata)
{
struct pic_data *data;
data = (struct pic_data *)pic_obj_alloc(pic, sizeof(struct pic_data), PIC_TT_DATA);
data->type = type;
data->data = userdata;
xh_init_str(&data->storage, sizeof(pic_value));
return data;
}

74
src/debug.c
View File

@ -1,74 +0,0 @@
/**
* See Copyright Notice in picrin.h
*/
#include "picrin.h"
#include "picrin/string.h"
#include "picrin/error.h"
#include "picrin/proc.h"
pic_str *
pic_get_backtrace(pic_state *pic)
{
size_t ai = pic_gc_arena_preserve(pic);
pic_callinfo *ci;
pic_str *trace;
trace = pic_str_new(pic, NULL, 0);
for (ci = pic->ci; ci != pic->cibase; --ci) {
struct pic_proc *proc = pic_proc_ptr(ci->fp[0]);
trace = pic_strcat(pic, trace, pic_str_new_cstr(pic, " at "));
trace = pic_strcat(pic, trace, pic_str_new_cstr(pic, pic_symbol_name(pic, pic_proc_name(proc))));
if (pic_proc_func_p(proc)) {
trace = pic_strcat(pic, trace, pic_str_new_cstr(pic, " (native function)\n"));
} else if (pic_proc_irep_p(proc)) {
trace = pic_strcat(pic, trace, pic_str_new_cstr(pic, " (unknown location)\n")); /* TODO */
}
}
pic_gc_arena_restore(pic, ai);
pic_gc_protect(pic, pic_obj_value(trace));
return trace;
}
void
pic_print_backtrace(pic_state *pic, struct pic_error *e)
{
size_t ai = pic_gc_arena_preserve(pic);
pic_str *trace;
assert(pic->err != NULL);
trace = pic_str_new(pic, NULL, 0);
switch (e->type) {
case PIC_ERROR_OTHER:
trace = pic_strcat(pic, trace, pic_str_new_cstr(pic, "error: "));
break;
case PIC_ERROR_FILE:
trace = pic_strcat(pic, trace, pic_str_new_cstr(pic, "file error: "));
break;
case PIC_ERROR_READ:
trace = pic_strcat(pic, trace, pic_str_new_cstr(pic, "read error: "));
break;
case PIC_ERROR_RAISED:
trace = pic_strcat(pic, trace, pic_str_new_cstr(pic, "raised: "));
break;
}
trace = pic_strcat(pic, trace, e->msg);
/* TODO: print error irritants */
trace = pic_strcat(pic, trace, pic_str_new(pic, "\n", 1));
trace = pic_strcat(pic, trace, e->stack);
/* print! */
printf("%s", pic_str_cstr(trace));
pic_gc_arena_restore(pic, ai);
}

169
src/dict.c
View File

@ -1,169 +0,0 @@
/**
* See Copyright Notice in picrin.h
*/
#include "picrin.h"
#include "picrin/dict.h"
#include "picrin/cont.h"
struct pic_dict *
pic_dict_new(pic_state *pic)
{
struct pic_dict *dict;
dict = (struct pic_dict *)pic_obj_alloc(pic, sizeof(struct pic_dict), PIC_TT_DICT);
xh_init_int(&dict->hash, sizeof(pic_value));
return dict;
}
pic_value
pic_dict_ref(pic_state *pic, struct pic_dict *dict, pic_sym key)
{
xh_entry *e;
e = xh_get_int(&dict->hash, key);
if (! e) {
pic_errorf(pic, "element not found for a key: ~s", pic_sym_value(key));
}
return xh_val(e, pic_value);
}
void
pic_dict_set(pic_state *pic, struct pic_dict *dict, pic_sym key, pic_value val)
{
UNUSED(pic);
xh_put_int(&dict->hash, key, &val);
}
size_t
pic_dict_size(pic_state *pic, struct pic_dict *dict)
{
UNUSED(pic);
return dict->hash.count;
}
bool
pic_dict_has(pic_state *pic, struct pic_dict *dict, pic_sym key)
{
UNUSED(pic);
return xh_get_int(&dict->hash, key) != NULL;
}
void
pic_dict_del(pic_state *pic, struct pic_dict *dict, pic_sym key)
{
if (xh_get_int(&dict->hash, key) == NULL) {
pic_errorf(pic, "no slot named ~s found in dictionary", pic_sym_value(key));
}
xh_del_int(&dict->hash, key);
}
static pic_value
pic_dict_dict(pic_state *pic)
{
struct pic_dict *dict;
pic_get_args(pic, "");
dict = pic_dict_new(pic);
return pic_obj_value(dict);
}
static pic_value
pic_dict_dict_p(pic_state *pic)
{
pic_value obj;
pic_get_args(pic, "o", &obj);
return pic_bool_value(pic_dict_p(obj));
}
static pic_value
pic_dict_dict_ref(pic_state *pic)
{
struct pic_dict *dict;
pic_sym key;
pic_get_args(pic, "dm", &dict, &key);
if (pic_dict_has(pic, dict, key)) {
return pic_values2(pic, pic_dict_ref(pic, dict , key), pic_true_value());
} else {
return pic_values2(pic, pic_none_value(), pic_false_value());
}
}
static pic_value
pic_dict_dict_set(pic_state *pic)
{
struct pic_dict *dict;
pic_sym key;
pic_value val;
pic_get_args(pic, "dmo", &dict, &key, &val);
pic_dict_set(pic, dict, key, val);
return pic_none_value();
}
static pic_value
pic_dict_dict_del(pic_state *pic)
{
struct pic_dict *dict;
pic_sym key;
pic_get_args(pic, "dm", &dict, &key);
pic_dict_del(pic, dict, key);
return pic_none_value();
}
static pic_value
pic_dict_dict_size(pic_state *pic)
{
struct pic_dict *dict;
pic_get_args(pic, "d", &dict);
return pic_int_value(pic_dict_size(pic, dict));
}
static pic_value
pic_dict_dict_for_each(pic_state *pic)
{
struct pic_proc *proc;
struct pic_dict *dict;
xh_iter it;
pic_get_args(pic, "ld", &proc, &dict);
xh_begin(&it, &dict->hash);
while (xh_next(&it)) {
pic_apply2(pic, proc, pic_sym_value(xh_key(it.e, pic_sym)), xh_val(it.e, pic_value));
}
return pic_none_value();
}
void
pic_init_dict(pic_state *pic)
{
pic_deflibrary (pic, "(picrin dictionary)") {
pic_defun(pic, "make-dictionary", pic_dict_dict);
pic_defun(pic, "dictionary?", pic_dict_dict_p);
pic_defun(pic, "dictionary-ref", pic_dict_dict_ref);
pic_defun(pic, "dictionary-set!", pic_dict_dict_set);
pic_defun(pic, "dictionary-delete", pic_dict_dict_del);
pic_defun(pic, "dictionary-size", pic_dict_dict_size);
pic_defun(pic, "dictionary-for-each", pic_dict_dict_for_each);
}
}

286
src/error.c
View File

@ -1,286 +0,0 @@
/**
* See Copyright Notice in picrin.h
*/
#include <stdlib.h>
#include <string.h>
#include <stdarg.h>
#include "picrin.h"
#include "picrin/pair.h"
#include "picrin/string.h"
#include "picrin/error.h"
void
pic_abort(pic_state *pic, const char *msg)
{
UNUSED(pic);
fprintf(stderr, "abort: %s\n", msg);
abort();
}
void
pic_warnf(pic_state *pic, const char *fmt, ...)
{
va_list ap;
pic_value err_line;
va_start(ap, fmt);
err_line = pic_vformat(pic, fmt, ap);
va_end(ap);
fprintf(stderr, "warn: %s\n", pic_str_cstr(pic_str_ptr(pic_car(pic, err_line))));
}
void
pic_push_try(pic_state *pic, struct pic_proc *handler)
{
struct pic_jmpbuf *try_jmp;
if (pic->try_jmp_idx >= pic->try_jmp_size) {
pic->try_jmp_size *= 2;
pic->try_jmps = pic_realloc(pic, pic->try_jmps, sizeof(struct pic_jmpbuf) * pic->try_jmp_size);
}
try_jmp = pic->try_jmps + pic->try_jmp_idx++;
try_jmp->handler = handler;
try_jmp->ci_offset = pic->ci - pic->cibase;
try_jmp->sp_offset = pic->sp - pic->stbase;
try_jmp->ip = pic->ip;
try_jmp->prev_jmp = pic->jmp;
pic->jmp = &try_jmp->here;
}
void
pic_pop_try(pic_state *pic)
{
struct pic_jmpbuf *try_jmp;
try_jmp = pic->try_jmps + --pic->try_jmp_idx;
/* assert(pic->jmp == &try_jmp->here); */
pic->ci = try_jmp->ci_offset + pic->cibase;
pic->sp = try_jmp->sp_offset + pic->stbase;
pic->ip = try_jmp->ip;
pic->jmp = try_jmp->prev_jmp;
}
static struct pic_error *
error_new(pic_state *pic, short type, pic_str *msg, pic_value irrs)
{
struct pic_error *e;
pic_str *stack;
stack = pic_get_backtrace(pic);
e = (struct pic_error *)pic_obj_alloc(pic, sizeof(struct pic_error), PIC_TT_ERROR);
e->type = type;
e->msg = msg;
e->irrs = irrs;
e->stack = stack;
return e;
}
noreturn void
pic_throw_error(pic_state *pic, struct pic_error *e)
{
void pic_vm_tear_off(pic_state *);
pic_vm_tear_off(pic); /* tear off */
pic->err = e;
if (! pic->jmp) {
puts(pic_errmsg(pic));
abort();
}
longjmp(*pic->jmp, 1);
}
noreturn void
pic_throw(pic_state *pic, short type, const char *msg, pic_value irrs)
{
struct pic_error *e;
e = error_new(pic, type, pic_str_new_cstr(pic, msg), irrs);
pic_throw_error(pic, e);
}
const char *
pic_errmsg(pic_state *pic)
{
assert(pic->err != NULL);
return pic_str_cstr(pic->err->msg);
}
void
pic_errorf(pic_state *pic, const char *fmt, ...)
{
va_list ap;
pic_value err_line, irrs;
const char *msg;
va_start(ap, fmt);
err_line = pic_vformat(pic, fmt, ap);
va_end(ap);
msg = pic_str_cstr(pic_str_ptr(pic_car(pic, err_line)));
irrs = pic_cdr(pic, err_line);
pic_throw(pic, PIC_ERROR_OTHER, msg, irrs);
}
static pic_value
pic_error_with_exception_handler(pic_state *pic)
{
struct pic_proc *handler, *thunk;
pic_value v;
pic_get_args(pic, "ll", &handler, &thunk);
pic_try_with_handler(handler) {
v = pic_apply0(pic, thunk);
}
pic_catch {
struct pic_error *e = pic->err;
pic->err = NULL;
if (e->type == PIC_ERROR_RAISED) {
v = pic_list_ref(pic, e->irrs, 0);
} else {
v = pic_obj_value(e);
}
v = pic_apply1(pic, handler, v);
pic_errorf(pic, "error handler returned ~s, by error ~s", v, pic_obj_value(e));
}
return v;
}
noreturn static pic_value
pic_error_raise(pic_state *pic)
{
pic_value v;
pic_get_args(pic, "o", &v);
pic_throw(pic, PIC_ERROR_RAISED, "object is raised", pic_list1(pic, v));
}
static pic_value
pic_error_raise_continuable(pic_state *pic)
{
pic_value v;
pic_get_args(pic, "o", &v);
if (pic->try_jmp_idx == 0) {
pic_errorf(pic, "no exception handler registered");
}
if (pic->try_jmps[pic->try_jmp_idx - 1].handler == NULL) {
pic_errorf(pic, "uncontinuable exception handler is on top");
}
else {
pic->try_jmp_idx--;
v = pic_apply1(pic, pic->try_jmps[pic->try_jmp_idx].handler, v);
++pic->try_jmp_idx;
}
return v;
}
noreturn static pic_value
pic_error_error(pic_state *pic)
{
const char *str;
size_t argc;
pic_value *argv;
pic_get_args(pic, "z*", &str, &argc, &argv);
pic_throw(pic, PIC_ERROR_OTHER, str, pic_list_by_array(pic, argc, argv));
}
static pic_value
pic_error_error_object_p(pic_state *pic)
{
pic_value v;
pic_get_args(pic, "o", &v);
return pic_bool_value(pic_error_p(v));
}
static pic_value
pic_error_error_object_message(pic_state *pic)
{
struct pic_error *e;
pic_get_args(pic, "e", &e);
return pic_obj_value(e->msg);
}
static pic_value
pic_error_error_object_irritants(pic_state *pic)
{
struct pic_error *e;
pic_get_args(pic, "e", &e);
return e->irrs;
}
static pic_value
pic_error_read_error_p(pic_state *pic)
{
pic_value v;
struct pic_error *e;
pic_get_args(pic, "o", &v);
if (! pic_error_p(v)) {
return pic_false_value();
}
e = pic_error_ptr(v);
return pic_bool_value(e->type == PIC_ERROR_READ);
}
static pic_value
pic_error_file_error_p(pic_state *pic)
{
pic_value v;
struct pic_error *e;
pic_get_args(pic, "o", &v);
if (! pic_error_p(v)) {
return pic_false_value();
}
e = pic_error_ptr(v);
return pic_bool_value(e->type == PIC_ERROR_FILE);
}
void
pic_init_error(pic_state *pic)
{
pic_defun(pic, "with-exception-handler", pic_error_with_exception_handler);
pic_defun(pic, "raise", pic_error_raise);
pic_defun(pic, "raise-continuable", pic_error_raise_continuable);
pic_defun(pic, "error", pic_error_error);
pic_defun(pic, "error-object?", pic_error_error_object_p);
pic_defun(pic, "error-object-message", pic_error_error_object_message);
pic_defun(pic, "error-object-irritants", pic_error_error_object_irritants);
pic_defun(pic, "read-error?", pic_error_read_error_p);
pic_defun(pic, "file-error?", pic_error_file_error_p);
}

10
src/eval.c
View File

@ -5,16 +5,6 @@
#include "picrin.h"
#include "picrin/macro.h"
pic_value
pic_eval(pic_state *pic, pic_value program, struct pic_lib *lib)
{
struct pic_proc *proc;
proc = pic_compile(pic, program, lib);
return pic_apply(pic, proc, pic_nil_value());
}
static pic_value
pic_eval_eval(pic_state *pic)
{

872
src/gc.c
View File

@ -1,872 +0,0 @@
/**
* See Copyright Notice in picrin.h
*/
#include <stdlib.h>
#include "picrin.h"
#include "picrin/gc.h"
#include "picrin/pair.h"
#include "picrin/string.h"
#include "picrin/vector.h"
#include "picrin/irep.h"
#include "picrin/proc.h"
#include "picrin/port.h"
#include "picrin/blob.h"
#include "picrin/cont.h"
#include "picrin/error.h"
#include "picrin/macro.h"
#include "picrin/lib.h"
#include "picrin/var.h"
#include "picrin/data.h"
#include "picrin/dict.h"
#include "picrin/record.h"
#include "picrin/read.h"
#if GC_DEBUG
# include <string.h>
#endif
union header {
struct {
union header *ptr;
size_t size;
unsigned int mark : 1;
} s;
long alignment[4];
};
struct heap_page {
union header *basep, *endp;
struct heap_page *next;
};
struct pic_heap {
union header base, *freep;
struct heap_page *pages;
};
static void
heap_init(struct pic_heap *heap)
{
heap->base.s.ptr = &heap->base;
heap->base.s.size = 0; /* not 1, since it must never be used for allocation */
heap->base.s.mark = PIC_GC_UNMARK;
heap->freep = &heap->base;
heap->pages = NULL;
#if GC_DEBUG
printf("freep = %p\n", (void *)heap->freep);
#endif
}
struct pic_heap *
pic_heap_open()
{
struct pic_heap *heap;
heap = (struct pic_heap *)calloc(1, sizeof(struct pic_heap));
heap_init(heap);
return heap;
}
void
pic_heap_close(struct pic_heap *heap)
{
struct heap_page *page;
while (heap->pages) {
page = heap->pages;
heap->pages = heap->pages->next;
free(page);
}
}
static void gc_free(pic_state *, union header *);
static void
add_heap_page(pic_state *pic)
{
union header *up, *np;
struct heap_page *page;
size_t nu;
#if GC_DEBUG
puts("adding heap page!");
#endif
nu = (PIC_HEAP_PAGE_SIZE + sizeof(union header) - 1) / sizeof(union header) + 1;
up = (union header *)pic_calloc(pic, 1 + nu + 1, sizeof(union header));
up->s.size = nu + 1;
up->s.mark = PIC_GC_UNMARK;
gc_free(pic, up);
np = up + 1;
np->s.size = nu;
np->s.ptr = up->s.ptr;
up->s.size = 1;
up->s.ptr = np;
page = (struct heap_page *)pic_alloc(pic, sizeof(struct heap_page));
page->basep = up;
page->endp = up + nu + 1;
page->next = pic->heap->pages;
pic->heap->pages = page;
}
static void *
alloc(void *ptr, size_t size)
{
if (size == 0) {
if (ptr) {
free(ptr);
}
return NULL;
}
if (ptr) {
return realloc(ptr, size);
} else {
return malloc(size);
}
}
void *
pic_alloc(pic_state *pic, size_t size)
{
void *ptr;
ptr = alloc(NULL, size);
if (ptr == NULL && size > 0) {
pic_abort(pic, "memory exhausted");
}
return ptr;
}
void *
pic_realloc(pic_state *pic, void *ptr, size_t size)
{
ptr = alloc(ptr, size);
if (ptr == NULL && size > 0) {
pic_abort(pic, "memory exhausted");
}
return ptr;
}
void *
pic_calloc(pic_state *pic, size_t count, size_t size)
{
void *ptr;
size *= count;
ptr = alloc(NULL, size);
if (ptr == NULL && size > 0) {
pic_abort(pic, "memory exhausted");
}
memset(ptr, 0, size);
return ptr;
}
void
pic_free(pic_state *pic, void *ptr)
{
UNUSED(pic);
free(ptr);
}
static void
gc_protect(pic_state *pic, struct pic_object *obj)
{
if (pic->arena_idx >= pic->arena_size) {
pic->arena_size = pic->arena_size * 2 + 1;
pic->arena = pic_realloc(pic, pic->arena, sizeof(struct pic_object *) * pic->arena_size);
}
pic->arena[pic->arena_idx++] = obj;
}
pic_value
pic_gc_protect(pic_state *pic, pic_value v)
{
struct pic_object *obj;
if (pic_vtype(v) != PIC_VTYPE_HEAP) {
return v;
}
obj = pic_obj_ptr(v);
gc_protect(pic, obj);
return v;
}
size_t
pic_gc_arena_preserve(pic_state *pic)
{
return pic->arena_idx;
}
void
pic_gc_arena_restore(pic_state *pic, size_t state)
{
pic->arena_idx = state;
}
static void *
gc_alloc(pic_state *pic, size_t size)
{
union header *freep, *p, *prevp;
size_t nunits;
#if GC_DEBUG
assert(size > 0);
#endif
nunits = (size + sizeof(union header) - 1) / sizeof(union header) + 1;
prevp = freep = pic->heap->freep;
for (p = prevp->s.ptr; ; prevp = p, p = p->s.ptr) {
if (p->s.size >= nunits)
break;
if (p == freep) {
return NULL;
}
}
#if GC_DEBUG
{
unsigned char *c;
size_t s, i, j;
if (p->s.size == nunits) {
c = (unsigned char *)(p + p->s.size - nunits + 1);
s = nunits - 1;
} else {
c = (unsigned char *)(p + p->s.size - nunits);
s = nunits;
}
for (i = 0; i < s; ++i) {
for (j = 0; j < sizeof(union header); ++j) {
assert(c[i * sizeof(union header) + j] == 0xAA);
}
}
}
#endif
if (p->s.size == nunits) {
prevp->s.ptr = p->s.ptr;
}
else {
p->s.size -= nunits;
p += p->s.size;
p->s.size = nunits;
}
pic->heap->freep = prevp;
p->s.mark = PIC_GC_UNMARK;
#if GC_DEBUG
memset(p+1, 0, sizeof(union header) * (nunits - 1));
p->s.ptr = (union header *)0xcafebabe;
#endif
return (void *)(p + 1);
}
static void
gc_free(pic_state *pic, union header *bp)
{
union header *freep, *p;
#if GC_DEBUG
assert(bp != NULL);
assert(bp->s.size > 1);
#endif
#if GC_DEBUG
memset(bp + 1, 0xAA, (bp->s.size - 1) * sizeof(union header));
#endif
freep = pic->heap->freep;
for (p = freep; ! (bp > p && bp < p->s.ptr); p = p->s.ptr) {
if (p >= p->s.ptr && (bp > p || bp < p->s.ptr)) {
break;
}
}
if (bp + bp->s.size == p->s.ptr) {
bp->s.size += p->s.ptr->s.size;
bp->s.ptr = p->s.ptr->s.ptr;
#if GC_DEBUG
memset(p->s.ptr, 0xAA, sizeof(union header));
#endif
}
else {
bp->s.ptr = p->s.ptr;
}
if (p + p->s.size == bp && p->s.size > 1) {
p->s.size += bp->s.size;
p->s.ptr = bp->s.ptr;
#if GC_DEBUG
memset(bp, 0xAA, sizeof(union header));
#endif
}
else {
p->s.ptr = bp;
}
pic->heap->freep = p;
}
static void gc_mark(pic_state *, pic_value);
static void gc_mark_object(pic_state *pic, struct pic_object *obj);
static bool
gc_is_marked(union header *p)
{
return p->s.mark == PIC_GC_MARK;
}
static void
gc_unmark(union header *p)
{
p->s.mark = PIC_GC_UNMARK;
}
static void
gc_mark_object(pic_state *pic, struct pic_object *obj)
{
union header *p;
p = ((union header *)obj) - 1;
if (gc_is_marked(p))
return;
p->s.mark = PIC_GC_MARK;
switch (obj->tt) {
case PIC_TT_PAIR: {
gc_mark(pic, ((struct pic_pair *)obj)->car);
gc_mark(pic, ((struct pic_pair *)obj)->cdr);
break;
}
case PIC_TT_ENV: {
struct pic_env *env = (struct pic_env *)obj;
int i;
for (i = 0; i < env->regc; ++i) {
gc_mark(pic, env->regs[i]);
}
if (env->up) {
gc_mark_object(pic, (struct pic_object *)env->up);
}
break;
}
case PIC_TT_PROC: {
struct pic_proc *proc = (struct pic_proc *)obj;
if (proc->env) {
gc_mark_object(pic, (struct pic_object *)proc->env);
}
if (proc->attr) {
gc_mark_object(pic, (struct pic_object *)proc->attr);
}
if (pic_proc_irep_p(proc)) {
gc_mark_object(pic, (struct pic_object *)proc->u.irep);
}
break;
}
case PIC_TT_PORT: {
break;
}
case PIC_TT_ERROR: {
struct pic_error *err = (struct pic_error *)obj;
gc_mark_object(pic,(struct pic_object *)err->msg);
gc_mark(pic, err->irrs);
gc_mark_object(pic, (struct pic_object *)err->stack);
break;
}
case PIC_TT_STRING: {
break;
}
case PIC_TT_VECTOR: {
size_t i;
for (i = 0; i < ((struct pic_vector *)obj)->len; ++i) {
gc_mark(pic, ((struct pic_vector *)obj)->data[i]);
}
break;
}
case PIC_TT_BLOB: {
break;
}
case PIC_TT_CONT: {
struct pic_cont *cont = (struct pic_cont *)obj;
pic_value *stack;
pic_callinfo *ci;
size_t i;
/* block */
gc_mark_object(pic, (struct pic_object *)cont->blk);
/* stack */
for (stack = cont->st_ptr; stack != cont->st_ptr + cont->sp_offset; ++stack) {
gc_mark(pic, *stack);
}
/* callinfo */
for (ci = cont->ci_ptr + cont->ci_offset; ci != cont->ci_ptr; --ci) {
if (ci->env) {
gc_mark_object(pic, (struct pic_object *)ci->env);
}
}
/* arena */
for (i = 0; i < (size_t)cont->arena_idx; ++i) {
gc_mark_object(pic, cont->arena[i]);
}
/* error handlers */
for (i = 0; i < cont->try_jmp_idx; ++i) {
if (cont->try_jmps[i].handler) {
gc_mark_object(pic, (struct pic_object *)cont->try_jmps[i].handler);
}
}
/* result values */
gc_mark(pic, cont->results);
break;
}
case PIC_TT_MACRO: {
struct pic_macro *mac = (struct pic_macro *)obj;
if (mac->proc) {
gc_mark_object(pic, (struct pic_object *)mac->proc);
}
if (mac->senv) {
gc_mark_object(pic, (struct pic_object *)mac->senv);
}
break;
}
case PIC_TT_SENV: {
struct pic_senv *senv = (struct pic_senv *)obj;
if (senv->up) {
gc_mark_object(pic, (struct pic_object *)senv->up);
}
break;
}
case PIC_TT_LIB: {
struct pic_lib *lib = (struct pic_lib *)obj;
gc_mark(pic, lib->name);
gc_mark_object(pic, (struct pic_object *)lib->env);
break;
}
case PIC_TT_VAR: {
struct pic_var *var = (struct pic_var *)obj;
gc_mark(pic, var->stack);
if (var->conv) {
gc_mark_object(pic, (struct pic_object *)var->conv);
}
break;
}
case PIC_TT_IREP: {
struct pic_irep *irep = (struct pic_irep *)obj;
size_t i;
for (i = 0; i < irep->ilen; ++i) {
gc_mark_object(pic, (struct pic_object *)irep->irep[i]);
}
for (i = 0; i < irep->plen; ++i) {
gc_mark(pic, irep->pool[i]);
}
break;
}
case PIC_TT_DATA: {
struct pic_data *data = (struct pic_data *)obj;
xh_iter it;
xh_begin(&it, &data->storage);
while (xh_next(&it)) {
gc_mark(pic, xh_val(it.e, pic_value));
}
break;
}
case PIC_TT_DICT: {
struct pic_dict *dict = (struct pic_dict *)obj;
xh_iter it;
xh_begin(&it, &dict->hash);
while (xh_next(&it)) {
gc_mark(pic, xh_val(it.e, pic_value));
}
break;
}
case PIC_TT_RECORD: {
struct pic_record *rec = (struct pic_record *)obj;
xh_iter it;
xh_begin(&it, &rec->hash);
while (xh_next(&it)) {
gc_mark(pic, xh_val(it.e, pic_value));
}
break;
}
case PIC_TT_BLK: {
struct pic_block *blk = (struct pic_block *)obj;
if (blk->prev) {
gc_mark_object(pic, (struct pic_object *)blk->prev);
}
if (blk->in) {
gc_mark_object(pic, (struct pic_object *)blk->in);
}
if (blk->out) {
gc_mark_object(pic, (struct pic_object *)blk->out);
}
break;
}
case PIC_TT_NIL:
case PIC_TT_BOOL:
case PIC_TT_FLOAT:
case PIC_TT_INT:
case PIC_TT_SYMBOL:
case PIC_TT_CHAR:
case PIC_TT_EOF:
case PIC_TT_UNDEF:
pic_abort(pic, "logic flaw");
}
}
static void
gc_mark(pic_state *pic, pic_value v)
{
struct pic_object *obj;
if (pic_vtype(v) != PIC_VTYPE_HEAP)
return;
obj = pic_obj_ptr(v);
gc_mark_object(pic, obj);
}
static void
gc_mark_trie(pic_state *pic, struct pic_trie *trie)
{
size_t i;
for (i = 0; i < sizeof trie->table / sizeof(struct pic_trie *); ++i) {
if (trie->table[i] != NULL) {
gc_mark_trie(pic, trie->table[i]);
}
}
if (trie->proc != NULL) {
gc_mark_object(pic, (struct pic_object *)trie->proc);
}
}
static void
gc_mark_phase(pic_state *pic)
{
pic_value *stack;
pic_callinfo *ci;
size_t i, j;
xh_iter it;
/* block */
if (pic->blk) {
gc_mark_object(pic, (struct pic_object *)pic->blk);
}
/* stack */
for (stack = pic->stbase; stack != pic->sp; ++stack) {
gc_mark(pic, *stack);
}
/* callinfo */
for (ci = pic->ci; ci != pic->cibase; --ci) {
if (ci->env) {
gc_mark_object(pic, (struct pic_object *)ci->env);
}
}
/* error object */
if (pic->err) {
gc_mark_object(pic, (struct pic_object *)pic->err);
}
/* arena */
for (j = 0; j < pic->arena_idx; ++j) {
gc_mark_object(pic, pic->arena[j]);
}
/* global variables */
xh_begin(&it, &pic->globals);
while (xh_next(&it)) {
gc_mark(pic, xh_val(it.e, pic_value));
}
/* macro objects */
xh_begin(&it, &pic->macros);
while (xh_next(&it)) {
gc_mark_object(pic, xh_val(it.e, struct pic_object *));
}
/* error handlers */
for (i = 0; i < pic->try_jmp_idx; ++i) {
if (pic->try_jmps[i].handler) {
gc_mark_object(pic, (struct pic_object *)pic->try_jmps[i].handler);
}
}
/* readers */
gc_mark_trie(pic, pic->reader->trie);
/* library table */
gc_mark(pic, pic->libs);
}
static void
gc_finalize_object(pic_state *pic, struct pic_object *obj)
{
#if GC_DEBUG
printf("* finalizing object: %s", pic_type_repr(pic_type(pic_obj_value(obj))));
// pic_debug(pic, pic_obj_value(obj));
puts("");
#endif
switch (obj->tt) {
case PIC_TT_PAIR: {
break;
}
case PIC_TT_ENV: {
break;
}
case PIC_TT_PROC: {
break;
}
case PIC_TT_VECTOR: {
pic_free(pic, ((struct pic_vector *)obj)->data);
break;
}
case PIC_TT_BLOB: {
pic_free(pic, ((struct pic_blob *)obj)->data);
break;
}
case PIC_TT_STRING: {
XROPE_DECREF(((struct pic_string *)obj)->rope);
break;
}
case PIC_TT_PORT: {
break;
}
case PIC_TT_ERROR: {
break;
}
case PIC_TT_CONT: {
struct pic_cont *cont = (struct pic_cont *)obj;
pic_free(pic, cont->stk_ptr);
pic_free(pic, cont->st_ptr);
pic_free(pic, cont->ci_ptr);
pic_free(pic, cont->arena);
pic_free(pic, cont->try_jmps);
break;
}
case PIC_TT_SENV: {
struct pic_senv *senv = (struct pic_senv *)obj;
xh_destroy(&senv->map);
break;
}
case PIC_TT_MACRO: {
break;
}
case PIC_TT_LIB: {
struct pic_lib *lib = (struct pic_lib *)obj;
xh_destroy(&lib->exports);
break;
}
case PIC_TT_VAR: {
break;
}
case PIC_TT_IREP: {
struct pic_irep *irep = (struct pic_irep *)obj;
pic_free(pic, irep->code);
pic_free(pic, irep->irep);
pic_free(pic, irep->pool);
break;
}
case PIC_TT_DATA: {
struct pic_data *data = (struct pic_data *)obj;
data->type->dtor(pic, data->data);
xh_destroy(&data->storage);
break;
}
case PIC_TT_DICT: {
struct pic_dict *dict = (struct pic_dict *)obj;
xh_destroy(&dict->hash);
break;
}
case PIC_TT_RECORD: {
struct pic_record *rec = (struct pic_record *)obj;
xh_destroy(&rec->hash);
break;
}
case PIC_TT_BLK: {
break;
}
case PIC_TT_NIL:
case PIC_TT_BOOL:
case PIC_TT_FLOAT:
case PIC_TT_INT:
case PIC_TT_SYMBOL:
case PIC_TT_CHAR:
case PIC_TT_EOF:
case PIC_TT_UNDEF:
pic_abort(pic, "logic flaw");
}
}
static void
gc_sweep_page(pic_state *pic, struct heap_page *page)
{
#if GC_DEBUG
static union header *NIL = (union header *)0xdeadbeef;
#else
static union header *NIL = NULL;
#endif
union header *bp, *p, *s = NIL, *t;
#if GC_DEBUG
int c = 0;
#endif
for (bp = page->basep; ; bp = bp->s.ptr) {
for (p = bp + bp->s.size; p != bp->s.ptr; p += p->s.size) {
if (p == page->endp) {
goto escape;
}
if (! gc_is_marked(p)) {
if (s == NIL) {
s = p;
}
else {
t->s.ptr = p;
}
t = p;
t->s.ptr = NIL; /* For dead objects we can safely reuse ptr field */
}
gc_unmark(p);
}
}
escape:
/* free! */
while (s != NIL) {
t = s->s.ptr;
gc_finalize_object(pic, (struct pic_object *)(s + 1));
gc_free(pic, s);
s = t;
#if GC_DEBUG
c++;
#endif
}
#if GC_DEBUG
printf("freed objects count: %d\n", c);
#endif
}
static void
gc_sweep_phase(pic_state *pic)
{
struct heap_page *page = pic->heap->pages;
while (page) {
gc_sweep_page(pic, page);
page = page->next;
}
}
void
pic_gc_run(pic_state *pic)
{
#if GC_DEBUG
struct heap_page *page;
#endif
#if DEBUG
puts("gc run!");
#endif
gc_mark_phase(pic);
gc_sweep_phase(pic);
#if GC_DEBUG
for (page = pic->heap->pages; page; page = page->next) {
union header *bp, *p;
unsigned char *c;
for (bp = page->basep; ; bp = bp->s.ptr) {
for (c = (unsigned char *)(bp+1); c != (unsigned char *)(bp + bp->s.size); ++c) {
assert(*c == 0xAA);
}
for (p = bp + bp->s.size; p != bp->s.ptr; p += p->s.size) {
if (p == page->endp) {
/* if (page->next) */
/* assert(bp->s.ptr == page->next->basep); */
/* else */
/* assert(bp->s.ptr == &pic->heap->base); */
goto escape;
}
assert(! gc_is_marked(p));
}
}
escape:
((void)0);
}
puts("not error on heap found! gc successfully finished");
#endif
}
struct pic_object *
pic_obj_alloc_unsafe(pic_state *pic, size_t size, enum pic_tt tt)
{
struct pic_object *obj;
#if GC_DEBUG
printf("*allocating: %s\n", pic_type_repr(tt));
#endif
#if GC_STRESS
pic_gc_run(pic);
#endif
obj = (struct pic_object *)gc_alloc(pic, size);
if (obj == NULL) {
pic_gc_run(pic);
obj = (struct pic_object *)gc_alloc(pic, size);
if (obj == NULL) {
add_heap_page(pic);
obj = (struct pic_object *)gc_alloc(pic, size);
if (obj == NULL)
pic_abort(pic, "GC memory exhausted");
}
}
obj->tt = tt;
return obj;
}
struct pic_object *
pic_obj_alloc(pic_state *pic, size_t size, enum pic_tt tt)
{
struct pic_object *obj;
obj = pic_obj_alloc_unsafe(pic, size, tt);
gc_protect(pic, obj);
return obj;
}

78
src/init.c
View File

@ -6,10 +6,6 @@
#include "picrin.h"
#include "picrin/pair.h"
#include "picrin/read.h"
#include "picrin/lib.h"
#include "picrin/macro.h"
#include "picrin/error.h"
static pic_value
pic_features(pic_state *pic)
@ -39,87 +35,19 @@ pic_libraries(pic_state *pic)
return libs;
}
void pic_init_bool(pic_state *);
void pic_init_pair(pic_state *);
void pic_init_port(pic_state *);
void pic_init_number(pic_state *);
void pic_init_time(pic_state *);
void pic_init_system(pic_state *);
void pic_init_file(pic_state *);
void pic_init_proc(pic_state *);
void pic_init_symbol(pic_state *);
void pic_init_vector(pic_state *);
void pic_init_blob(pic_state *);
void pic_init_cont(pic_state *);
void pic_init_char(pic_state *);
void pic_init_error(pic_state *);
void pic_init_str(pic_state *);
void pic_init_macro(pic_state *);
void pic_init_var(pic_state *);
void pic_init_load(pic_state *);
void pic_init_write(pic_state *);
void pic_init_read(pic_state *);
void pic_init_dict(pic_state *);
void pic_init_record(pic_state *);
void pic_init_eval(pic_state *);
void pic_init_lib(pic_state *);
void pic_init_contrib(pic_state *);
void pic_load_piclib(pic_state *);
#define DONE pic_gc_arena_restore(pic, ai);
void
pic_init_core(pic_state *pic)
pic_init_misc(pic_state *pic)
{
size_t ai = pic_gc_arena_preserve(pic);
pic_init_reader(pic);
pic_deflibrary (pic, "(picrin base core)") {
pic_define_syntactic_keyword(pic, pic->lib->env, pic->sDEFINE, pic->rDEFINE);
pic_define_syntactic_keyword(pic, pic->lib->env, pic->sSETBANG, pic->rSETBANG);
pic_define_syntactic_keyword(pic, pic->lib->env, pic->sQUOTE, pic->rQUOTE);
pic_define_syntactic_keyword(pic, pic->lib->env, pic->sLAMBDA, pic->rLAMBDA);
pic_define_syntactic_keyword(pic, pic->lib->env, pic->sIF, pic->rIF);
pic_define_syntactic_keyword(pic, pic->lib->env, pic->sBEGIN, pic->rBEGIN);
pic_define_syntactic_keyword(pic, pic->lib->env, pic->sDEFINE_SYNTAX, pic->rDEFINE_SYNTAX);
}
pic_deflibrary (pic, "(picrin library)") {
pic_defun(pic, "libraries", pic_libraries);
}
pic_deflibrary (pic, "(scheme base)") {
pic_defun(pic, "features", pic_features);
pic_init_bool(pic); DONE;
pic_init_pair(pic); DONE;
pic_init_port(pic); DONE;
pic_init_number(pic); DONE;
pic_init_time(pic); DONE;
pic_init_system(pic); DONE;
pic_init_file(pic); DONE;
pic_init_proc(pic); DONE;
pic_init_symbol(pic); DONE;
pic_init_vector(pic); DONE;
pic_init_blob(pic); DONE;
pic_init_cont(pic); DONE;
pic_init_char(pic); DONE;
pic_init_error(pic); DONE;
pic_init_str(pic); DONE;
pic_init_macro(pic); DONE;
pic_init_var(pic); DONE;
pic_init_load(pic); DONE;
pic_init_write(pic); DONE;
pic_init_read(pic); DONE;
pic_init_dict(pic); DONE;
pic_init_record(pic); DONE;
pic_init_eval(pic); DONE;
pic_init_lib(pic); DONE;
pic_init_contrib(pic); DONE;
pic_load_piclib(pic); DONE;
pic_init_contrib(pic);
pic_load_piclib(pic);
}
}

273
src/lib.c
View File

@ -1,273 +0,0 @@
/**
* See Copyright Notice in picrin.h
*/
#include "picrin.h"
#include "picrin/lib.h"
#include "picrin/pair.h"
#include "picrin/macro.h"
#include "picrin/error.h"
#include "picrin/dict.h"
#include "picrin/string.h"
struct pic_lib *
pic_make_library(pic_state *pic, pic_value name)
{
struct pic_lib *lib;
struct pic_senv *senv;
if ((lib = pic_find_library(pic, name)) != NULL) {
#if DEBUG
printf("* reopen library: ");
pic_debug(pic, name);
puts("");
#endif
return lib;
}
senv = pic_null_syntactic_environment(pic);
lib = (struct pic_lib *)pic_obj_alloc(pic, sizeof(struct pic_lib), PIC_TT_LIB);
lib->env = senv;
lib->name = name;
xh_init_int(&lib->exports, sizeof(pic_sym));
/* register! */
pic->libs = pic_acons(pic, name, pic_obj_value(lib), pic->libs);
return lib;
}
void
pic_in_library(pic_state *pic, pic_value spec)
{
struct pic_lib *lib;
lib = pic_find_library(pic, spec);
if (! lib) {
pic_errorf(pic, "library not found: ~a", spec);
}
pic->lib = lib;
}
struct pic_lib *
pic_find_library(pic_state *pic, pic_value spec)
{
pic_value v;
v = pic_assoc(pic, spec, pic->libs, NULL);
if (pic_false_p(v)) {
return NULL;
}
return pic_lib_ptr(pic_cdr(pic, v));
}
static struct pic_dict *
import_table(pic_state *pic, pic_value spec)
{
const pic_sym sONLY = pic_intern_cstr(pic, "only");
const pic_sym sRENAME = pic_intern_cstr(pic, "rename");
const pic_sym sPREFIX = pic_intern_cstr(pic, "prefix");
const pic_sym sEXCEPT = pic_intern_cstr(pic, "except");
struct pic_lib *lib;
struct pic_dict *imports, *dict;
pic_value val, id;
xh_iter it;
imports = pic_dict_new(pic);
if (pic_list_p(spec)) {
if (pic_eq_p(pic_car(pic, spec), pic_sym_value(sONLY))) {
dict = import_table(pic, pic_cadr(pic, spec));
pic_for_each (val, pic_cddr(pic, spec)) {
pic_dict_set(pic, imports, pic_sym(val), pic_dict_ref(pic, dict, pic_sym(val)));
}
return imports;
}
if (pic_eq_p(pic_car(pic, spec), pic_sym_value(sRENAME))) {
imports = import_table(pic, pic_cadr(pic, spec));
pic_for_each (val, pic_cddr(pic, spec)) {
id = pic_dict_ref(pic, imports, pic_sym(pic_car(pic, val)));
pic_dict_del(pic, imports, pic_sym(pic_car(pic, val)));
pic_dict_set(pic, imports, pic_sym(pic_cadr(pic, val)), id);
}
return imports;
}
if (pic_eq_p(pic_car(pic, spec), pic_sym_value(sPREFIX))) {
dict = import_table(pic, pic_cadr(pic, spec));
xh_begin(&it, &dict->hash);
while (xh_next(&it)) {
pic_dict_set(pic, imports, pic_intern_cstr(pic, pic_str_cstr(pic_strcat(pic, pic_str_new_cstr(pic, pic_symbol_name(pic, pic_sym(pic_car(pic, pic_cddr(pic, spec))))), pic_str_new_cstr(pic, pic_symbol_name(pic, xh_key(it.e, pic_sym)))))), xh_val(it.e, pic_value));
}
return imports;
}
if (pic_eq_p(pic_car(pic, spec), pic_sym_value(sEXCEPT))) {
imports = import_table(pic, pic_cadr(pic, spec));
pic_for_each (val, pic_cddr(pic, spec)) {
pic_dict_del(pic, imports, pic_sym(val));
}
return imports;
}
}
lib = pic_find_library(pic, spec);
if (! lib) {
pic_errorf(pic, "library not found: ~a", spec);
}
xh_begin(&it, &lib->exports);
while (xh_next(&it)) {
pic_dict_set(pic, imports, xh_key(it.e, pic_sym), pic_sym_value(xh_val(it.e, pic_sym)));
}
return imports;
}
static void
import(pic_state *pic, pic_value spec)
{
struct pic_dict *imports;
xh_iter it;
imports = import_table(pic, spec);
xh_begin(&it, &imports->hash);
while (xh_next(&it)) {
#if DEBUG
printf("* importing %s as %s\n", pic_symbol_name(pic, xh_key(it.e, pic_sym)), pic_symbol_name(pic, pic_sym(xh_val(it.e, pic_value))));
#endif
pic_put_rename(pic, pic->lib->env, xh_key(it.e, pic_sym), pic_sym(xh_val(it.e, pic_value)));
}
}
static void
export(pic_state *pic, pic_value spec)
{
const pic_sym sRENAME = pic_intern_cstr(pic, "rename");
pic_value a, b;
pic_sym rename;
if (pic_sym_p(spec)) { /* (export a) */
a = b = spec;
} else { /* (export (rename a b)) */
if (! pic_list_p(spec))
goto fail;
if (! pic_length(pic, spec) == 3)
goto fail;
if (! pic_eq_p(pic_car(pic, spec), pic_sym_value(sRENAME)))
goto fail;
if (! pic_sym_p(a = pic_list_ref(pic, spec, 1)))
goto fail;
if (! pic_sym_p(b = pic_list_ref(pic, spec, 2)))
goto fail;
}
if (! pic_find_rename(pic, pic->lib->env, pic_sym(a), &rename)) {
pic_errorf(pic, "export: symbol not defined %s", pic_symbol_name(pic, pic_sym(a)));
}
#if DEBUG
printf("* exporting %s as %s\n", pic_symbol_name(pic, pic_sym(b)), pic_symbol_name(pic, rename));
#endif
xh_put_int(&pic->lib->exports, pic_sym(b), &rename);
return;
fail:
pic_errorf(pic, "illegal export spec: ~s", spec);
}
void
pic_import(pic_state *pic, pic_value spec)
{
import(pic, spec);
}
void
pic_export(pic_state *pic, pic_sym sym)
{
export(pic, pic_sym_value(sym));
}
static pic_value
pic_lib_import(pic_state *pic)
{
size_t argc, i;
pic_value *argv;
pic_get_args(pic, "*", &argc, &argv);
for (i = 0; i < argc; ++i) {
import(pic, argv[i]);
}
return pic_none_value();
}
static pic_value
pic_lib_export(pic_state *pic)
{
size_t argc, i;
pic_value *argv;
pic_get_args(pic, "*", &argc, &argv);
for (i = 0; i < argc; ++i) {
export(pic, argv[i]);
}
return pic_none_value();
}
static pic_value
pic_lib_define_library(pic_state *pic)
{
struct pic_lib *prev = pic->lib;
size_t argc, i;
pic_value spec, *argv;
pic_get_args(pic, "o*", &spec, &argc, &argv);
pic_make_library(pic, spec);
pic_try {
pic_in_library(pic, spec);
for (i = 0; i < argc; ++i) {
pic_void(pic_eval(pic, argv[i], pic->lib));
}
pic_in_library(pic, prev->name);
}
pic_catch {
pic_in_library(pic, prev->name); /* restores pic->lib even if an error occurs */
pic_throw_error(pic, pic->err);
}
return pic_none_value();
}
static pic_value
pic_lib_in_library(pic_state *pic)
{
pic_value spec;
pic_get_args(pic, "o", &spec);
pic_in_library(pic, spec);
return pic_none_value();
}
void
pic_init_lib(pic_state *pic)
{
void pic_defmacro(pic_state *, pic_sym, pic_sym, pic_func_t);
pic_defmacro(pic, pic->sIMPORT, pic->rIMPORT, pic_lib_import);
pic_defmacro(pic, pic->sEXPORT, pic->rEXPORT, pic_lib_export);
pic_defmacro(pic, pic->sDEFINE_LIBRARY, pic->rDEFINE_LIBRARY, pic_lib_define_library);
pic_defmacro(pic, pic->sIN_LIBRARY, pic->rIN_LIBRARY, pic_lib_in_library);
}

449
src/macro.c
View File

@ -3,399 +3,6 @@
*/
#include "picrin.h"
#include "picrin/pair.h"
#include "picrin/string.h"
#include "picrin/proc.h"
#include "picrin/macro.h"
#include "picrin/lib.h"
#include "picrin/error.h"
#include "picrin/dict.h"
#include "picrin/cont.h"
pic_sym
pic_add_rename(pic_state *pic, struct pic_senv *senv, pic_sym sym)
{
pic_sym rename;
rename = pic_gensym(pic, sym);
pic_put_rename(pic, senv, sym, rename);
return rename;
}
void
pic_put_rename(pic_state *pic, struct pic_senv *senv, pic_sym sym, pic_sym rename)
{
UNUSED(pic);
xh_put_int(&senv->map, sym, &rename);
}
bool
pic_find_rename(pic_state *pic, struct pic_senv *senv, pic_sym sym, pic_sym *rename)
{
xh_entry *e;
UNUSED(pic);
if ((e = xh_get_int(&senv->map, sym)) == NULL) {
return false;
}
if (rename != NULL) {
*rename = xh_val(e, pic_sym);
}
return true;
}
static void
define_macro(pic_state *pic, pic_sym rename, struct pic_proc *proc, struct pic_senv *senv)
{
struct pic_macro *mac;
mac = (struct pic_macro *)pic_obj_alloc(pic, sizeof(struct pic_macro), PIC_TT_MACRO);
mac->senv = senv;
mac->proc = proc;
xh_put_int(&pic->macros, rename, &mac);
}
static struct pic_macro *
find_macro(pic_state *pic, pic_sym rename)
{
xh_entry *e;
if ((e = xh_get_int(&pic->macros, rename)) == NULL) {
return NULL;
}
return xh_val(e, struct pic_macro *);
}
static pic_sym
make_identifier(pic_state *pic, pic_sym sym, struct pic_senv *senv)
{
pic_sym rename;
while (true) {
if (pic_find_rename(pic, senv, sym, &rename)) {
return rename;
}
if (! senv->up)
break;
senv = senv->up;
}
if (! pic_interned_p(pic, sym)) {
return sym;
}
else {
return pic_gensym(pic, sym);
}
}
static pic_value macroexpand(pic_state *, pic_value, struct pic_senv *);
static pic_value
macroexpand_symbol(pic_state *pic, pic_sym sym, struct pic_senv *senv)
{
return pic_sym_value(make_identifier(pic, sym, senv));
}
static pic_value
macroexpand_quote(pic_state *pic, pic_value expr)
{
return pic_cons(pic, pic_sym_value(pic->rQUOTE), pic_cdr(pic, expr));
}
static pic_value
macroexpand_list(pic_state *pic, pic_value obj, struct pic_senv *senv)
{
size_t ai = pic_gc_arena_preserve(pic);
pic_value x, head, tail;
if (pic_pair_p(obj)) {
head = macroexpand(pic, pic_car(pic, obj), senv);
tail = macroexpand_list(pic, pic_cdr(pic, obj), senv);
x = pic_cons(pic, head, tail);
} else {
x = macroexpand(pic, obj, senv);
}
pic_gc_arena_restore(pic, ai);
pic_gc_protect(pic, x);
return x;
}
static pic_value
macroexpand_lambda(pic_state *pic, pic_value expr, struct pic_senv *senv)
{
pic_value formal, body;
struct pic_senv *in;
pic_value a;
if (pic_length(pic, expr) < 2) {
pic_error(pic, "syntax error");
}
in = pic_senv_new(pic, senv);
for (a = pic_cadr(pic, expr); pic_pair_p(a); a = pic_cdr(pic, a)) {
pic_value v = pic_car(pic, a);
if (! pic_sym_p(v)) {
pic_error(pic, "syntax error");
}
pic_add_rename(pic, in, pic_sym(v));
}
if (pic_sym_p(a)) {
pic_add_rename(pic, in, pic_sym(a));
}
else if (! pic_nil_p(a)) {
pic_error(pic, "syntax error");
}
formal = macroexpand_list(pic, pic_cadr(pic, expr), in);
body = macroexpand_list(pic, pic_cddr(pic, expr), in);
return pic_cons(pic, pic_sym_value(pic->rLAMBDA), pic_cons(pic, formal, body));
}
static pic_value
macroexpand_define(pic_state *pic, pic_value expr, struct pic_senv *senv)
{
pic_sym sym, rename;
pic_value var, val;
if (pic_length(pic, expr) != 3) {
pic_error(pic, "syntax error");
}
var = pic_cadr(pic, expr);
if (! pic_sym_p(var)) {
pic_error(pic, "binding to non-symbol object");
}
sym = pic_sym(var);
if (! pic_find_rename(pic, senv, sym, &rename)) {
rename = pic_add_rename(pic, senv, sym);
}
val = macroexpand(pic, pic_list_ref(pic, expr, 2), senv);
return pic_list3(pic, pic_sym_value(pic->rDEFINE), pic_sym_value(rename), val);
}
static pic_value
macroexpand_defsyntax(pic_state *pic, pic_value expr, struct pic_senv *senv)
{
pic_value var, val;
pic_sym sym, rename;
if (pic_length(pic, expr) != 3) {
pic_error(pic, "syntax error");
}
var = pic_cadr(pic, expr);
if (! pic_sym_p(var)) {
pic_error(pic, "binding to non-symbol object");
}
sym = pic_sym(var);
if (! pic_find_rename(pic, senv, sym, &rename)) {
rename = pic_add_rename(pic, senv, sym);
} else {
pic_warnf(pic, "redefining syntax variable: ~s", pic_sym_value(sym));
}
val = pic_cadr(pic, pic_cdr(pic, expr));
pic_try {
val = pic_eval(pic, val, pic->lib);
} pic_catch {
pic_errorf(pic, "macroexpand error while definition: %s", pic_errmsg(pic));
}
if (! pic_proc_p(val)) {
pic_errorf(pic, "macro definition \"~s\" evaluates to non-procedure object", var);
}
define_macro(pic, rename, pic_proc_ptr(val), senv);
return pic_none_value();
}
static pic_value
macroexpand_macro(pic_state *pic, struct pic_macro *mac, pic_value expr, struct pic_senv *senv)
{
pic_value v, args;
#if DEBUG
puts("before expand-1:");
pic_debug(pic, expr);
puts("");
#endif
if (mac->senv == NULL) { /* legacy macro */
args = pic_cdr(pic, expr);
} else {
args = pic_list3(pic, expr, pic_obj_value(senv), pic_obj_value(mac->senv));
}
pic_try {
v = pic_apply(pic, mac->proc, args);
} pic_catch {
pic_errorf(pic, "macroexpand error while application: %s", pic_errmsg(pic));
}
#if DEBUG
puts("after expand-1:");
pic_debug(pic, v);
puts("");
#endif
return v;
}
static pic_value
macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv)
{
switch (pic_type(expr)) {
case PIC_TT_SYMBOL: {
return macroexpand_symbol(pic, pic_sym(expr), senv);
}
case PIC_TT_PAIR: {
pic_value car;
struct pic_macro *mac;
if (! pic_list_p(expr)) {
pic_errorf(pic, "cannot macroexpand improper list: ~s", expr);
}
car = macroexpand(pic, pic_car(pic, expr), senv);
if (pic_sym_p(car)) {
pic_sym tag = pic_sym(car);
if (tag == pic->rDEFINE_SYNTAX) {
return macroexpand_defsyntax(pic, expr, senv);
}
else if (tag == pic->rLAMBDA) {
return macroexpand_lambda(pic, expr, senv);
}
else if (tag == pic->rDEFINE) {
return macroexpand_define(pic, expr, senv);
}
else if (tag == pic->rQUOTE) {
return macroexpand_quote(pic, expr);
}
if ((mac = find_macro(pic, tag)) != NULL) {
return macroexpand_node(pic, macroexpand_macro(pic, mac, expr, senv), senv);
}
}
return pic_cons(pic, car, macroexpand_list(pic, pic_cdr(pic, expr), senv));
}
default:
return expr;
}
}
static pic_value
macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv)
{
size_t ai = pic_gc_arena_preserve(pic);
pic_value v;
#if DEBUG
printf("[macroexpand] expanding... ");
pic_debug(pic, expr);
puts("");
#endif
v = macroexpand_node(pic, expr, senv);
pic_gc_arena_restore(pic, ai);
pic_gc_protect(pic, v);
return v;
}
pic_value
pic_macroexpand(pic_state *pic, pic_value expr, struct pic_lib *lib)
{
struct pic_lib *prev;
pic_value v;
#if DEBUG
puts("before expand:");
pic_debug(pic, expr);
puts("");
#endif
/* change library for macro-expansion time processing */
prev = pic->lib;
pic->lib = lib;
v = macroexpand(pic, expr, lib->env);
pic->lib = prev;
#if DEBUG
puts("after expand:");
pic_debug(pic, v);
puts("");
#endif
return v;
}
struct pic_senv *
pic_senv_new(pic_state *pic, struct pic_senv *up)
{
struct pic_senv *senv;
senv = (struct pic_senv *)pic_obj_alloc(pic, sizeof(struct pic_senv), PIC_TT_SENV);
senv->up = up;
xh_init_int(&senv->map, sizeof(pic_sym));
return senv;
}
struct pic_senv *
pic_null_syntactic_environment(pic_state *pic)
{
struct pic_senv *senv;
senv = pic_senv_new(pic, NULL);
pic_define_syntactic_keyword(pic, senv, pic->sDEFINE_LIBRARY, pic->rDEFINE_LIBRARY);
pic_define_syntactic_keyword(pic, senv, pic->sIMPORT, pic->rIMPORT);
pic_define_syntactic_keyword(pic, senv, pic->sEXPORT, pic->rEXPORT);
pic_define_syntactic_keyword(pic, senv, pic->sIN_LIBRARY, pic->rIN_LIBRARY);
return senv;
}
void
pic_define_syntactic_keyword(pic_state *pic, struct pic_senv *senv, pic_sym sym, pic_sym rsym)
{
pic_put_rename(pic, senv, sym, rsym);
if (pic->lib && pic->lib->env == senv) {
pic_export(pic, sym);
}
}
void
pic_defmacro(pic_state *pic, pic_sym name, pic_sym id, pic_func_t func)
{
pic_put_rename(pic, pic->lib->env, name, id);
/* symbol registration */
define_macro(pic, id, pic_proc_new(pic, func, pic_symbol_name(pic, name)), NULL);
/* auto export! */
pic_export(pic, name);
}
bool
pic_identifier_p(pic_state *pic, pic_value obj)
{
return pic_sym_p(obj) && ! pic_interned_p(pic, pic_sym(obj));
}
static pic_value
pic_macro_gensym(pic_state *pic)
@ -429,66 +36,12 @@ pic_macro_macroexpand(pic_state *pic)
return pic_macroexpand(pic, expr, pic->lib);
}
static pic_value
pic_macro_macroexpand_1(pic_state *pic)
{
struct pic_senv *senv = pic->lib->env;
struct pic_macro *mac;
pic_value expr;
pic_sym sym;
pic_get_args(pic, "o", &expr);
if (pic_sym_p(expr)) {
if (pic_interned_p(pic, pic_sym(expr))) {
return pic_values2(pic, macroexpand_symbol(pic, pic_sym(expr), senv), pic_true_value());
}
}
if (pic_pair_p(expr) && pic_sym_p(pic_car(pic, expr))) {
sym = make_identifier(pic, pic_sym(pic_car(pic, expr)), senv);
if ((mac = find_macro(pic, sym)) != NULL) {
return pic_values2(pic, macroexpand_macro(pic, mac, expr, senv), pic_true_value());
}
}
return pic_values2(pic, expr, pic_false_value()); /* no expansion occurred */
}
static pic_value
pic_macro_identifier_p(pic_state *pic)
{
pic_value obj;
pic_get_args(pic, "o", &obj);
return pic_bool_value(pic_identifier_p(pic, obj));
}
static pic_value
pic_macro_make_identifier(pic_state *pic)
{
pic_value obj;
pic_sym sym;
pic_get_args(pic, "mo", &sym, &obj);
pic_assert_type(pic, obj, senv);
return pic_sym_value(make_identifier(pic, sym, pic_senv_ptr(obj)));
}
void
pic_init_macro(pic_state *pic)
pic_init_macro2(pic_state *pic)
{
pic_deflibrary (pic, "(picrin base macro)") {
pic_defun(pic, "identifier?", pic_macro_identifier_p);
pic_defun(pic, "make-identifier", pic_macro_make_identifier);
}
pic_deflibrary (pic, "(picrin macro)") {
pic_defun(pic, "gensym", pic_macro_gensym);
pic_defun(pic, "ungensym", pic_macro_ungensym);
pic_defun(pic, "macroexpand", pic_macro_macroexpand);
pic_defun(pic, "macroexpand-1", pic_macro_macroexpand_1);
}
}

944
src/number.c
View File

@ -1,944 +0,0 @@
/**
* See Copyright Notice in picrin.h
*/
#include <math.h>
#include <limits.h>
#include <stdlib.h>
#include "picrin.h"
#include "picrin/string.h"
#include "picrin/cont.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 double
lcm(int a, int b)
{
return fabs((double)a * b) / gcd(a, b);
}
/**
* Returns the length of string representing val.
* radix is between 2 and 36 (inclusive).
* No error checks are performed in this function.
*/
static int
number_string_length(int val, int radix)
{
long long v = val; /* in case val == INT_MIN */
int count = 0;
if (val == 0) {
return 1;
}
if (val < 0) {
v = - v;
count = 1;
}
while (v > 0) {
++count;
v /= radix;
}
return count;
}
/**
* Returns the string representing val.
* radix is between 2 and 36 (inclusive).
* This function overwrites buffer and stores the result.
* No error checks are performed in this function. It is caller's responsibility to avoid buffer-overrun.
*/
static void
number_string(int val, int radix, int length, char *buffer) {
const char digits[37] = "0123456789abcdefghijklmnopqrstuvwxyz";
long long v = val;
int i;
if (val == 0) {
buffer[0] = '0';
buffer[1] = '\0';
return;
}
if (val < 0) {
buffer[0] = '-';
v = -v;
}
for(i = length - 1; v > 0; --i) {
buffer[i] = digits[v % radix];
v /= radix;
}
buffer[length] = '\0';
return;
}
static pic_value
pic_number_real_p(pic_state *pic)
{
pic_value v;
pic_get_args(pic, "o", &v);
return pic_bool_value(pic_float_p(v) || pic_int_p(v));
}
static pic_value
pic_number_integer_p(pic_state *pic)
{
pic_value v;
pic_get_args(pic, "o", &v);
if (pic_int_p(v)) {
return pic_true_value();
}
if (pic_float_p(v)) {
double f = pic_float(v);
if (isinf(f)) {
return pic_false_value();
}
if (f == round(f)) {
return pic_true_value();
}
}
return pic_false_value();
}
static pic_value
pic_number_exact_p(pic_state *pic)
{
pic_value v;
pic_get_args(pic, "o", &v);
return pic_bool_value(pic_int_p(v));
}
static pic_value
pic_number_inexact_p(pic_state *pic)
{
pic_value v;
pic_get_args(pic, "o", &v);
return pic_bool_value(pic_float_p(v));
}
static pic_value
pic_number_finite_p(pic_state *pic)
{
pic_value v;
pic_get_args(pic, "o", &v);
if (pic_int_p(v))
return pic_true_value();
if (pic_float_p(v) && ! (isinf(pic_float(v)) || isnan(pic_float(v))))
return pic_true_value();
else
return pic_false_value();
}
static pic_value
pic_number_infinite_p(pic_state *pic)
{
pic_value v;
pic_get_args(pic, "o", &v);
if (pic_float_p(v) && isinf(pic_float(v)))
return pic_true_value();
else
return pic_false_value();
}
static pic_value
pic_number_nan_p(pic_state *pic)
{
pic_value v;
pic_get_args(pic, "o", &v);
if (pic_float_p(v) && isnan(pic_float(v)))
return pic_true_value();
else
return pic_false_value();
}
#define DEFINE_ARITH_CMP(op, name) \
static pic_value \
pic_number_##name(pic_state *pic) \
{ \
size_t argc; \
pic_value *argv; \
size_t i; \
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) { \
f = g; \
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_ARITH_CMP(==, eq)
DEFINE_ARITH_CMP(<, lt)
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;
size_t 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, "max: 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;
size_t 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) \
{ \
size_t argc; \
pic_value *argv; \
size_t i; \
double f; \
bool e = true; \
\
pic_get_args(pic, "*", &argc, &argv); \
\
f = unit; \
for (i = 0; i < argc; ++i) { \
if (pic_int_p(argv[i])) { \
f op##= pic_int(argv[i]); \
} \
else if (pic_float_p(argv[i])) { \
e = false; \
f op##= pic_float(argv[i]); \
} \
else { \
pic_error(pic, #op ": number required"); \
} \
} \
\
return e ? pic_int_value((int)f) : pic_float_value(f); \
}
DEFINE_ARITH_OP(+, add, 0)
DEFINE_ARITH_OP(*, mul, 1)
#define DEFINE_ARITH_INV_OP(op, name, unit, exact) \
static pic_value \
pic_number_##name(pic_state *pic) \
{ \
size_t argc; \
pic_value *argv; \
size_t i; \
double f; \
bool e; \
\
pic_get_args(pic, "F*", &f, &e, &argc, &argv); \
\
e = e && exact; \
\
if (argc == 0) { \
f = unit op f; \
} \
for (i = 0; i < argc; ++i) { \
if (pic_int_p(argv[i])) { \
f op##= pic_int(argv[i]); \
} \
else if (pic_float_p(argv[i])) { \
e = false; \
f op##= pic_float(argv[i]); \
} \
else { \
pic_error(pic, #op ": number required"); \
} \
} \
\
return e ? pic_int_value((int)f) : pic_float_value(f); \
}
DEFINE_ARITH_INV_OP(-, sub, 0, true)
DEFINE_ARITH_INV_OP(/, div, 1, false)
static pic_value
pic_number_abs(pic_state *pic)
{
double f;
bool e;
pic_get_args(pic, "F", &f, &e);
if (e) {
return pic_int_value(fabs(f));
}
else {
return pic_float_value(fabs(f));
}
}
static pic_value
pic_number_floor_quotient(pic_state *pic)
{
int i,j;
bool e1, e2;
pic_get_args(pic, "II", &i, &e1, &j, &e2);
if (e1 && e2) {
return pic_int_value((int)floor((double)i/j));
}
else {
return pic_float_value(floor((double)i/j));
}
}
static pic_value
pic_number_floor_remainder(pic_state *pic)
{
int i,j,q;
bool e1, e2;
pic_get_args(pic, "II", &i, &e1, &j, &e2);
q = (int)floor((double)i/j);
if (e1 && e2) {
return pic_int_value(i - j * q);
}
else {
return pic_float_value(i - j * q);
}
}
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)
{
int i,j;
bool e1, e2;
pic_get_args(pic, "II", &i, &e1, &j, &e2);
if (e1 && e2) {
return pic_int_value((int)trunc((double)i/j));
}
else {
return pic_float_value(trunc((double)i/j));
}
}
static pic_value
pic_number_trunc_remainder(pic_state *pic)
{
int i,j,q;
bool e1, e2;
pic_get_args(pic, "II", &i, &e1, &j, &e2);
q = (int)trunc((double)i/j);
if (e1 && e2) {
return pic_int_value(i - j * q);
}
else {
return pic_float_value(i - j * q);
}
}
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)
{
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;
double 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_valid_int(r) ? pic_int_value(r) : pic_float_value(r);
}
static pic_value
pic_number_floor(pic_state *pic)
{
double f;
bool e;
pic_get_args(pic, "F", &f, &e);
if (e) {
return pic_int_value((int)f);
}
else {
return pic_float_value(floor(f));
}
}
static pic_value
pic_number_ceil(pic_state *pic)
{
double f;
bool e;
pic_get_args(pic, "F", &f, &e);
if (e) {
return pic_int_value((int)f);
}
else {
return pic_float_value(ceil(f));
}
}
static pic_value
pic_number_trunc(pic_state *pic)
{
double f;
bool e;
pic_get_args(pic, "F", &f, &e);
if (e) {
return pic_int_value((int)f);
}
else {
return pic_float_value(trunc(f));
}
}
static pic_value
pic_number_round(pic_state *pic)
{
double f;
bool e;
pic_get_args(pic, "F", &f, &e);
if (e) {
return pic_int_value((int)f);
}
else {
return pic_float_value(round(f));
}
}
static pic_value
pic_number_exp(pic_state *pic)
{
double f;
pic_get_args(pic, "f", &f);
return pic_float_value(exp(f));
}
static pic_value
pic_number_log(pic_state *pic)
{
double f,g;
int argc;
argc = pic_get_args(pic, "f|f", &f, &g);
if (argc == 1) {
return pic_float_value(log(f));
}
else {
return pic_float_value(log(f) / log(g));
}
}
static pic_value
pic_number_sin(pic_state *pic)
{
double f;
pic_get_args(pic, "f", &f);
f = sin(f);
return pic_float_value(f);
}
static pic_value
pic_number_cos(pic_state *pic)
{
double f;
pic_get_args(pic, "f", &f);
f = cos(f);
return pic_float_value(f);
}
static pic_value
pic_number_tan(pic_state *pic)
{
double f;
pic_get_args(pic, "f", &f);
f = tan(f);
return pic_float_value(f);
}
static pic_value
pic_number_acos(pic_state *pic)
{
double f;
pic_get_args(pic, "f", &f);
f = acos(f);
return pic_float_value(f);
}
static pic_value
pic_number_asin(pic_state *pic)
{
double f;
pic_get_args(pic, "f", &f);
f = asin(f);
return pic_float_value(f);
}
static pic_value
pic_number_atan(pic_state *pic)
{
double f,g;
int argc;
argc = pic_get_args(pic, "f|f", &f, &g);
if (argc == 1) {
f = atan(f);
return pic_float_value(f);
}
else {
return pic_float_value(atan2(f,g));
}
}
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)
{
double f;
bool e;
pic_get_args(pic, "F", &f, &e);
if (e) {
long long i = (long long)f;
if (i * i <= INT_MAX) {
return pic_int_value(i * i);
}
}
return pic_float_value(f * f);
}
static pic_value
pic_number_sqrt(pic_state *pic)
{
double f;
pic_get_args(pic, "f", &f);
return pic_float_value(sqrt(f));
}
static pic_value
pic_number_expt(pic_state *pic)
{
double f, g, h;
bool e1, e2;
pic_get_args(pic, "FF", &f, &e1, &g, &e2);
h = pow(f, g);
if (e1 && e2) {
if (h <= INT_MAX) {
return pic_int_value((int)h);
}
}
return pic_float_value(h);
}
static pic_value
pic_number_inexact(pic_state *pic)
{
double f;
pic_get_args(pic, "f", &f);
return pic_float_value(f);
}
static pic_value
pic_number_exact(pic_state *pic)
{
double f;
pic_get_args(pic, "f", &f);
return pic_int_value((int)round(f));
}
static pic_value
pic_number_number_to_string(pic_state *pic)
{
double f;
bool e;
int radix = 10;
pic_get_args(pic, "F|i", &f, &e, &radix);
if (radix < 2 || radix > 36) {
pic_errorf(pic, "number->string: invalid radix %d (between 2 and 36, inclusive)", radix);
}
if (e) {
int ival = (int) f;
int ilen = number_string_length(ival, radix);
char buf[ilen + 1];
number_string(ival, radix, ilen, buf);
return pic_obj_value(pic_str_new(pic, buf, sizeof buf - 1));
}
else {
char buf[snprintf(NULL, 0, "%a", f) + 1];
snprintf(buf, sizeof buf, "%a", f);
return pic_obj_value(pic_str_new(pic, buf, sizeof buf - 1));
}
}
static pic_value
pic_number_string_to_number(pic_state *pic)
{
const char *str;
int radix = 10;
long num;
char *eptr;
double flo;
pic_get_args(pic, "z|i", &str, &radix);
num = strtol(str, &eptr, radix);
if (*eptr == '\0') {
return pic_valid_int(num)
? pic_int_value(num)
: pic_float_value(num);
}
flo = strtod(str, &eptr);
if (*eptr == '\0') {
return pic_float_value(flo);
}
pic_errorf(pic, "invalid string given: %s", str);
}
void
pic_init_number(pic_state *pic)
{
size_t ai = pic_gc_arena_preserve(pic);
pic_defun(pic, "number?", pic_number_real_p);
pic_defun(pic, "complex?", pic_number_real_p);
pic_defun(pic, "real?", pic_number_real_p);
pic_defun(pic, "rational?", pic_number_real_p);
pic_defun(pic, "integer?", pic_number_integer_p);
pic_gc_arena_restore(pic, ai);
pic_defun(pic, "exact?", pic_number_exact_p);
pic_defun(pic, "inexact?", pic_number_inexact_p);
pic_defun(pic, "exact-integer?", pic_number_exact_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_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);
pic_defun(pic, "/", pic_number_div);
pic_gc_arena_restore(pic, ai);
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);
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);
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);
pic_defun(pic, "inexact", pic_number_inexact);
pic_defun(pic, "exact", pic_number_exact);
pic_gc_arena_restore(pic, ai);
pic_defun(pic, "number->string", pic_number_number_to_string);
pic_defun(pic, "string->number", pic_number_string_to_number);
pic_gc_arena_restore(pic, ai);
pic_deflibrary (pic, "(scheme inexact)") {
pic_defun(pic, "finite?", pic_number_finite_p);
pic_defun(pic, "infinite?", pic_number_infinite_p);
pic_defun(pic, "nan?", pic_number_nan_p);
pic_defun(pic, "exp", pic_number_exp);
pic_defun(pic, "log", pic_number_log);
pic_defun(pic, "sin", pic_number_sin);
pic_defun(pic, "cos", pic_number_cos);
pic_defun(pic, "tan", pic_number_tan);
pic_defun(pic, "acos", pic_number_acos);
pic_defun(pic, "asin", pic_number_asin);
pic_defun(pic, "atan", pic_number_atan);
pic_defun(pic, "sqrt", pic_number_sqrt);
}
}

767
src/pair.c
View File

@ -1,767 +0,0 @@
/**
* See Copyright Notice in picrin.h
*/
#include <stdarg.h>
#include "picrin.h"
#include "picrin/pair.h"
pic_value
pic_cons(pic_state *pic, pic_value car, pic_value cdr)
{
struct pic_pair *pair;
pair = (struct pic_pair *)pic_obj_alloc(pic, sizeof(struct pic_pair), PIC_TT_PAIR);
pair->car = car;
pair->cdr = cdr;
return pic_obj_value(pair);
}
pic_value
pic_car(pic_state *pic, pic_value obj)
{
struct pic_pair *pair;
if (! pic_pair_p(obj)) {
pic_errorf(pic, "pair required, but got ~s", obj);
}
pair = pic_pair_ptr(obj);
return pair->car;
}
pic_value
pic_cdr(pic_state *pic, pic_value obj)
{
struct pic_pair *pair;
if (! pic_pair_p(obj)) {
pic_errorf(pic, "pair required, but got ~s", obj);
}
pair = pic_pair_ptr(obj);
return pair->cdr;
}
void
pic_set_car(pic_state *pic, pic_value obj, pic_value val)
{
struct pic_pair *pair;
if (! pic_pair_p(obj)) {
pic_error(pic, "pair required");
}
pair = pic_pair_ptr(obj);
pair->car = val;
}
void
pic_set_cdr(pic_state *pic, pic_value obj, pic_value val)
{
struct pic_pair *pair;
if (! pic_pair_p(obj)) {
pic_error(pic, "pair required");
}
pair = pic_pair_ptr(obj);
pair->cdr = val;
}
bool
pic_list_p(pic_value obj)
{
pic_value local, rapid;
int i;
/* Floyd's cycle-finding algorithm. */
local = rapid = obj;
while (true) {
/* advance rapid fast-forward; runs 2x faster than local */
for (i = 0; i < 2; ++i) {
if (pic_pair_p(rapid)) {
rapid = pic_pair_ptr(rapid)->cdr;
}
else {
return pic_nil_p(rapid);
}
}
/* advance local */
local = pic_pair_ptr(local)->cdr;
if (pic_eq_p(local, rapid)) {
return false;
}
}
}
pic_value
pic_list1(pic_state *pic, pic_value obj1)
{
return pic_cons(pic, obj1, pic_nil_value());
}
pic_value
pic_list2(pic_state *pic, pic_value obj1, pic_value obj2)
{
size_t ai = pic_gc_arena_preserve(pic);
pic_value val;
val = pic_cons(pic, obj1, pic_list1(pic, obj2));
pic_gc_arena_restore(pic, ai);
pic_gc_protect(pic, val);
return val;
}
pic_value
pic_list3(pic_state *pic, pic_value obj1, pic_value obj2, pic_value obj3)
{
size_t ai = pic_gc_arena_preserve(pic);
pic_value val;
val = pic_cons(pic, obj1, pic_list2(pic, obj2, obj3));
pic_gc_arena_restore(pic, ai);
pic_gc_protect(pic, val);
return val;
}
pic_value
pic_list4(pic_state *pic, pic_value obj1, pic_value obj2, pic_value obj3, pic_value obj4)
{
size_t ai = pic_gc_arena_preserve(pic);
pic_value val;
val = pic_cons(pic, obj1, pic_list3(pic, obj2, obj3, obj4));
pic_gc_arena_restore(pic, ai);
pic_gc_protect(pic, val);
return val;
}
pic_value
pic_list5(pic_state *pic, pic_value obj1, pic_value obj2, pic_value obj3, pic_value obj4, pic_value obj5)
{
size_t ai = pic_gc_arena_preserve(pic);
pic_value val;
val = pic_cons(pic, obj1, pic_list4(pic, obj2, obj3, obj4, obj5));
pic_gc_arena_restore(pic, ai);
pic_gc_protect(pic, val);
return val;
}
pic_value
pic_list6(pic_state *pic, pic_value obj1, pic_value obj2, pic_value obj3, pic_value obj4, pic_value obj5, pic_value obj6)
{
size_t ai = pic_gc_arena_preserve(pic);
pic_value val;
val = pic_cons(pic, obj1, pic_list5(pic, obj2, obj3, obj4, obj5, obj6));
pic_gc_arena_restore(pic, ai);
pic_gc_protect(pic, val);
return val;
}
pic_value
pic_list7(pic_state *pic, pic_value obj1, pic_value obj2, pic_value obj3, pic_value obj4, pic_value obj5, pic_value obj6, pic_value obj7)
{
size_t ai = pic_gc_arena_preserve(pic);
pic_value val;
val = pic_cons(pic, obj1, pic_list6(pic, obj2, obj3, obj4, obj5, obj6, obj7));
pic_gc_arena_restore(pic, ai);
pic_gc_protect(pic, val);
return val;
}
pic_value
pic_list_by_array(pic_state *pic, size_t c, pic_value *vs)
{
pic_value v;
v = pic_nil_value();
while (c--) {
v = pic_cons(pic, vs[c], v);
}
return 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)
{
int c = 0;
if (! pic_list_p(obj)) {
pic_errorf(pic, "length: expected list, but got ~s", obj);
}
while (! pic_nil_p(obj)) {
obj = pic_cdr(pic, obj);
++c;
}
return c;
}
pic_value
pic_reverse(pic_state *pic, pic_value list)
{
size_t ai = pic_gc_arena_preserve(pic);
pic_value v, acc;
acc = pic_nil_value();
pic_for_each(v, list) {
acc = pic_cons(pic, v, acc);
pic_gc_arena_restore(pic, ai);
pic_gc_protect(pic, acc);
}
return acc;
}
pic_value
pic_append(pic_state *pic, pic_value xs, pic_value ys)
{
size_t ai = pic_gc_arena_preserve(pic);
pic_value x;
xs = pic_reverse(pic, xs);
pic_for_each (x, xs) {
ys = pic_cons(pic, x, ys);
pic_gc_arena_restore(pic, ai);
pic_gc_protect(pic, xs);
pic_gc_protect(pic, ys);
}
return ys;
}
pic_value
pic_memq(pic_state *pic, pic_value key, pic_value list)
{
enter:
if (pic_nil_p(list))
return pic_false_value();
if (pic_eq_p(key, pic_car(pic, list)))
return list;
list = pic_cdr(pic, list);
goto enter;
}
pic_value
pic_memv(pic_state *pic, pic_value key, pic_value list)
{
enter:
if (pic_nil_p(list))
return pic_false_value();
if (pic_eqv_p(key, pic_car(pic, list)))
return list;
list = pic_cdr(pic, 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)
{
pic_value cell;
enter:
if (pic_nil_p(assoc))
return pic_false_value();
cell = pic_car(pic, assoc);
if (pic_eq_p(key, pic_car(pic, cell)))
return cell;
assoc = pic_cdr(pic, assoc);
goto enter;
}
pic_value
pic_assv(pic_state *pic, pic_value key, pic_value assoc)
{
pic_value cell;
enter:
if (pic_nil_p(assoc))
return pic_false_value();
cell = pic_car(pic, assoc);
if (pic_eqv_p(key, pic_car(pic, cell)))
return cell;
assoc = pic_cdr(pic, assoc);
goto enter;
}
pic_value
pic_assoc(pic_state *pic, pic_value key, pic_value assoc, struct pic_proc *compar)
{
pic_value cell;
enter:
if (pic_nil_p(assoc))
return pic_false_value();
cell = pic_car(pic, assoc);
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;
}
pic_value
pic_acons(pic_state *pic, pic_value key, pic_value val, pic_value assoc)
{
return pic_cons(pic, pic_cons(pic, key, val), assoc);
}
pic_value
pic_caar(pic_state *pic, pic_value v)
{
return pic_car(pic, pic_car(pic, v));
}
pic_value
pic_cadr(pic_state *pic, pic_value v)
{
return pic_car(pic, pic_cdr(pic, v));
}
pic_value
pic_cdar(pic_state *pic, pic_value v)
{
return pic_cdr(pic, pic_car(pic, v));
}
pic_value
pic_cddr(pic_state *pic, pic_value v)
{
return pic_cdr(pic, pic_cdr(pic, v));
}
pic_value
pic_list_tail(pic_state *pic, pic_value list, int i)
{
while (i-- > 0) {
list = pic_cdr(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
pic_pair_pair_p(pic_state *pic)
{
pic_value v;
pic_get_args(pic, "o", &v);
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)
{
pic_value v;
pic_get_args(pic, "o", &v);
return pic_car(pic, v);
}
static pic_value
pic_pair_cdr(pic_state *pic)
{
pic_value v;
pic_get_args(pic, "o", &v);
return pic_cdr(pic, v);
}
static pic_value
pic_pair_caar(pic_state *pic)
{
pic_value v;
pic_get_args(pic, "o", &v);
return pic_caar(pic, v);
}
static pic_value
pic_pair_cadr(pic_state *pic)
{
pic_value v;
pic_get_args(pic, "o", &v);
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
pic_pair_set_car(pic_state *pic)
{
pic_value v,w;
pic_get_args(pic, "oo", &v, &w);
if (! pic_pair_p(v))
pic_error(pic, "pair expected");
pic_pair_ptr(v)->car = w;
return pic_none_value();
}
static pic_value
pic_pair_set_cdr(pic_state *pic)
{
pic_value v,w;
pic_get_args(pic, "oo", &v, &w);
if (! pic_pair_p(v))
pic_error(pic, "pair expected");
pic_pair_ptr(v)->cdr = w;
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(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_by_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);
if (argc == 0) {
return pic_nil_value();
}
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);
}
static pic_value
pic_pair_memq(pic_state *pic)
{
pic_value key, list;
pic_get_args(pic, "oo", &key, &list);
return pic_memq(pic, key, list);
}
static pic_value
pic_pair_memv(pic_state *pic)
{
pic_value key, list;
pic_get_args(pic, "oo", &key, &list);
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)
{
pic_value key, list;
pic_get_args(pic, "oo", &key, &list);
return pic_assq(pic, key, list);
}
static pic_value
pic_pair_assv(pic_state *pic)
{
pic_value key, list;
pic_get_args(pic, "oo", &key, &list);
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)
{
pic_deflibrary (pic, "(picrin base list)") {
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, "set-car!", pic_pair_set_car);
pic_defun(pic, "set-cdr!", pic_pair_set_cdr);
pic_defun(pic, "null?", pic_pair_null_p);
}
pic_deflibrary (pic, "(picrin list)") {
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, "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);
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);
}
}

749
src/port.c
View File

@ -1,749 +0,0 @@
/**
* See Copyright Notice in picrin.h
*/
#include <stdlib.h>
#include <string.h>
#include <limits.h>
#include "picrin.h"
#include "picrin/proc.h"
#include "picrin/port.h"
#include "picrin/string.h"
#include "picrin/blob.h"
#include "picrin/var.h"
pic_value
pic_eof_object()
{
pic_value v;
pic_init_value(v, PIC_VTYPE_EOF);
return v;
}
struct pic_port *
pic_stdin(pic_state *pic)
{
struct pic_proc *proc;
proc = pic_proc_ptr(pic_ref(pic, "current-input-port"));
return pic_port_ptr(pic_apply(pic, proc, pic_nil_value()));
}
struct pic_port *
pic_stdout(pic_state *pic)
{
struct pic_proc *proc;
proc = pic_proc_ptr(pic_ref(pic, "current-output-port"));
return pic_port_ptr(pic_apply(pic, proc, pic_nil_value()));
}
static struct pic_port *
port_new_stdport(pic_state *pic, xFILE *file, short dir)
{
struct pic_port *port;
port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port), PIC_TT_PORT);
port->file = file;
port->flags = dir | PIC_PORT_TEXT;
port->status = PIC_PORT_OPEN;
return port;
}
struct pic_port *
pic_open_input_string(pic_state *pic, const char *str)
{
struct pic_port *port;
port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port *), PIC_TT_PORT);
port->file = xmopen();
port->flags = PIC_PORT_IN | PIC_PORT_TEXT;
port->status = PIC_PORT_OPEN;
xfputs(str, port->file);
xfflush(port->file);
xrewind(port->file);
return port;
}
struct pic_port *
pic_open_output_string(pic_state *pic)
{
struct pic_port *port;
port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port *), PIC_TT_PORT);
port->file = xmopen();
port->flags = PIC_PORT_OUT | PIC_PORT_TEXT;
port->status = PIC_PORT_OPEN;
return port;
}
struct pic_string *
pic_get_output_string(pic_state *pic, struct pic_port *port)
{
long size;
char *buf;
/* get endpos */
xfflush(port->file);
size = xftell(port->file);
xrewind(port->file);
/* copy to buf */
buf = (char *)pic_alloc(pic, size + 1);
buf[size] = 0;
xfread(buf, size, 1, port->file);
return pic_str_new(pic, buf, size);
}
void
pic_close_port(pic_state *pic, struct pic_port *port)
{
if (xfclose(port->file) == EOF) {
pic_error(pic, "close-port: failure");
}
port->status = PIC_PORT_CLOSE;
}
static pic_value
pic_port_input_port_p(pic_state *pic)
{
pic_value v;
pic_get_args(pic, "o", &v);
if (pic_port_p(v) && (pic_port_ptr(v)->flags & PIC_PORT_IN) != 0) {
return pic_true_value();
}
else {
return pic_false_value();
}
}
static pic_value
pic_port_output_port_p(pic_state *pic)
{
pic_value v;
pic_get_args(pic, "o", &v);
if (pic_port_p(v) && (pic_port_ptr(v)->flags & PIC_PORT_OUT) != 0) {
return pic_true_value();
}
else {
return pic_false_value();
}
}
static pic_value
pic_port_textual_port_p(pic_state *pic)
{
pic_value v;
pic_get_args(pic, "o", &v);
if (pic_port_p(v) && (pic_port_ptr(v)->flags & PIC_PORT_TEXT) != 0) {
return pic_true_value();
}
else {
return pic_false_value();
}
}
static pic_value
pic_port_binary_port_p(pic_state *pic)
{
pic_value v;
pic_get_args(pic, "o", &v);
if (pic_port_p(v) && (pic_port_ptr(v)->flags & PIC_PORT_BINARY) != 0) {
return pic_true_value();
}
else {
return pic_false_value();
}
}
static pic_value
pic_port_port_p(pic_state *pic)
{
pic_value v;
pic_get_args(pic, "o", &v);
return pic_bool_value(pic_port_p(v));
}
static pic_value
pic_port_input_port_open_p(pic_state *pic)
{
pic_value v;
struct pic_port *port;
pic_get_args(pic, "o", &v);
if (! pic_port_p(v))
return pic_false_value();
port = pic_port_ptr(v);
if ((port->flags & PIC_PORT_IN) == 0)
return pic_false_value();
return pic_bool_value(port->status == PIC_PORT_OPEN);
}
static pic_value
pic_port_output_port_open_p(pic_state *pic)
{
pic_value v;
struct pic_port *port;
pic_get_args(pic, "o", &v);
if (! pic_port_p(v))
return pic_false_value();
port = pic_port_ptr(v);
if ((port->flags & PIC_PORT_OUT) == 0)
return pic_false_value();
return pic_bool_value(port->status == PIC_PORT_OPEN);
}
static pic_value
pic_port_eof_object_p(pic_state *pic)
{
pic_value v;
pic_get_args(pic, "o", &v);
if (pic_vtype(v) == PIC_VTYPE_EOF) {
return pic_true_value();
}
else {
return pic_false_value();
}
}
static pic_value
pic_port_eof_object(pic_state *pic)
{
pic_get_args(pic, "");
return pic_eof_object();
}
static pic_value
pic_port_close_port(pic_state *pic)
{
struct pic_port *port;
pic_get_args(pic, "p", &port);
pic_close_port(pic, port);
return pic_none_value();
}
#define assert_port_profile(port, flgs, stat, caller) do { \
if ((port->flags & (flgs)) != (flgs)) { \
switch (flgs) { \
case PIC_PORT_IN: \
pic_error(pic, caller ": expected output port"); \
case PIC_PORT_OUT: \
pic_error(pic, caller ": expected input port"); \
case PIC_PORT_IN | PIC_PORT_TEXT: \
pic_error(pic, caller ": expected input/textual port"); \
case PIC_PORT_IN | PIC_PORT_BINARY: \
pic_error(pic, caller ": expected input/binary port"); \
case PIC_PORT_OUT | PIC_PORT_TEXT: \
pic_error(pic, caller ": expected output/textual port"); \
case PIC_PORT_OUT | PIC_PORT_BINARY: \
pic_error(pic, caller ": expected output/binary port"); \
} \
} \
if (port->status != stat) { \
switch (stat) { \
case PIC_PORT_OPEN: \
pic_error(pic, caller ": expected open port"); \
case PIC_PORT_CLOSE: \
pic_error(pic, caller ": expected close port"); \
} \
} \
} while (0)
static pic_value
pic_port_open_input_string(pic_state *pic)
{
struct pic_port *port;
char *str;
pic_get_args(pic, "z", &str);
port = pic_open_input_string(pic, str);
return pic_obj_value(port);
}
static pic_value
pic_port_open_output_string(pic_state *pic)
{
struct pic_port *port;
pic_get_args(pic, "");
port = pic_open_output_string(pic);
return pic_obj_value(port);
}
static pic_value
pic_port_get_output_string(pic_state *pic)
{
struct pic_port *port = pic_stdout(pic);
pic_get_args(pic, "|p", &port);
assert_port_profile(port, PIC_PORT_OUT | PIC_PORT_TEXT, PIC_PORT_OPEN, "get-output-string");
return pic_obj_value(pic_get_output_string(pic, port));
}
static pic_value
pic_port_open_input_blob(pic_state *pic)
{
struct pic_port *port;
struct pic_blob *blob;
pic_get_args(pic, "b", &blob);
port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port *), PIC_TT_PORT);
port->file = xmopen();
port->flags = PIC_PORT_IN | PIC_PORT_BINARY;
port->status = PIC_PORT_OPEN;
xfwrite(blob->data, 1, blob->len, port->file);
xfflush(port->file);
xrewind(port->file);
return pic_obj_value(port);
}
static pic_value
pic_port_open_output_bytevector(pic_state *pic)
{
struct pic_port *port;
pic_get_args(pic, "");
port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port *), PIC_TT_PORT);
port->file = xmopen();
port->flags = PIC_PORT_OUT | PIC_PORT_BINARY;
port->status = PIC_PORT_OPEN;
return pic_obj_value(port);
}
static pic_value
pic_port_get_output_bytevector(pic_state *pic)
{
struct pic_port *port = pic_stdout(pic);
pic_blob *blob;
long endpos;
pic_get_args(pic, "|p", &port);
assert_port_profile(port, PIC_PORT_OUT | PIC_PORT_BINARY, PIC_PORT_OPEN, "get-output-bytevector");
/* get endpos */
xfflush(port->file);
endpos = xftell(port->file);
xrewind(port->file);
/* copy to buf */
blob = pic_blob_new(pic, endpos);
xfread(blob->data, 1, endpos, port->file);
return pic_obj_value(blob);
}
static pic_value
pic_port_read_char(pic_state *pic)
{
int c;
struct pic_port *port = pic_stdin(pic);
pic_get_args(pic, "|p", &port);
assert_port_profile(port, PIC_PORT_IN | PIC_PORT_TEXT, PIC_PORT_OPEN, "read-char");
if ((c = xfgetc(port->file)) == EOF) {
return pic_eof_object();
}
else {
return pic_char_value((char)c);
}
}
static pic_value
pic_port_peek_char(pic_state *pic)
{
int c;
struct pic_port *port = pic_stdin(pic);
pic_get_args(pic, "|p", &port);
assert_port_profile(port, PIC_PORT_IN | PIC_PORT_TEXT, PIC_PORT_OPEN, "peek-char");
if ((c = xfgetc(port->file)) == EOF) {
return pic_eof_object();
}
else {
xungetc(c, port->file);
return pic_char_value((char)c);
}
}
static pic_value
pic_port_read_line(pic_state *pic)
{
int c;
struct pic_port *port = pic_stdin(pic), *buf;
struct pic_string *str;
pic_get_args(pic, "|p", &port);
assert_port_profile(port, PIC_PORT_IN | PIC_PORT_TEXT, PIC_PORT_OPEN, "read-line");
buf = pic_open_output_string(pic);
while ((c = xfgetc(port->file)) != EOF && c != '\n') {
xfputc(c, buf->file);
}
str = pic_get_output_string(pic, buf);
if (pic_strlen(str) == 0 && c == EOF) {
return pic_eof_object();
}
else {
return pic_obj_value(str);
}
}
static pic_value
pic_port_char_ready_p(pic_state *pic)
{
struct pic_port *port = pic_stdin(pic);
assert_port_profile(port, PIC_PORT_IN | PIC_PORT_TEXT, PIC_PORT_OPEN, "char-ready?");
pic_get_args(pic, "|p", &port);
return pic_true_value(); /* FIXME: always returns #t */
}
static pic_value
pic_port_read_string(pic_state *pic){
struct pic_port *port = pic_stdin(pic), *buf;
pic_str *str;
int k, i;
int c;
pic_get_args(pic, "i|p", &k, &port);
assert_port_profile(port, PIC_PORT_IN | PIC_PORT_TEXT, PIC_PORT_OPEN, "read-stritg");
c = EOF;
buf = pic_open_output_string(pic);
for(i = 0; i < k; ++i) {
if((c = xfgetc(port->file)) == EOF){
break;
}
xfputc(c, buf->file);
}
str = pic_get_output_string(pic, buf);
if (pic_strlen(str) == 0 && c == EOF) {
return pic_eof_object();
}
else {
return pic_obj_value(str);
}
}
static pic_value
pic_port_read_byte(pic_state *pic){
struct pic_port *port = pic_stdin(pic);
int c;
pic_get_args(pic, "|p", &port);
assert_port_profile(port, PIC_PORT_IN | PIC_PORT_BINARY, PIC_PORT_OPEN, "read-u8");
if ((c = xfgetc(port->file)) == EOF) {
return pic_eof_object();
}
return pic_int_value(c);
}
static pic_value
pic_port_peek_byte(pic_state *pic)
{
int c;
struct pic_port *port = pic_stdin(pic);
pic_get_args(pic, "|p", &port);
assert_port_profile(port, PIC_PORT_IN | PIC_PORT_BINARY, PIC_PORT_OPEN, "peek-u8");
c = xfgetc(port->file);
if (c == EOF) {
return pic_eof_object();
}
else {
xungetc(c, port->file);
return pic_int_value(c);
}
}
static pic_value
pic_port_byte_ready_p(pic_state *pic)
{
struct pic_port *port = pic_stdin(pic);
pic_get_args(pic, "|p", &port);
assert_port_profile(port, PIC_PORT_IN | PIC_PORT_BINARY, PIC_PORT_OPEN, "u8-ready?");
return pic_true_value(); /* FIXME: always returns #t */
}
static pic_value
pic_port_read_blob(pic_state *pic)
{
struct pic_port *port = pic_stdin(pic);
pic_blob *blob;
int k, i;
pic_get_args(pic, "i|p", &k, &port);
assert_port_profile(port, PIC_PORT_IN | PIC_PORT_BINARY, PIC_PORT_OPEN, "read-bytevector");
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, blob->data, i);
blob->len = i;
return pic_obj_value(blob);
}
}
static pic_value
pic_port_read_blob_ip(pic_state *pic)
{
struct pic_port *port;
struct pic_blob *bv;
int i, n, start, end, len;
char *buf;
n = pic_get_args(pic, "b|pii", &bv, &port, &start, &end);
switch (n) {
case 1:
port = pic_stdin(pic);
case 2:
start = 0;
case 3:
end = bv->len;
}
assert_port_profile(port, PIC_PORT_IN | PIC_PORT_BINARY, PIC_PORT_OPEN, "read-bytevector!");
len = end - start;
buf = pic_calloc(pic, len, sizeof(char));
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();
}
else {
return pic_int_value(i);
}
}
static pic_value
pic_port_newline(pic_state *pic)
{
struct pic_port *port = pic_stdout(pic);
pic_get_args(pic, "|p", &port);
assert_port_profile(port, PIC_PORT_OUT | PIC_PORT_TEXT, PIC_PORT_OPEN, "newline");
xfputs("\n", port->file);
return pic_none_value();
}
static pic_value
pic_port_write_char(pic_state *pic)
{
char c;
struct pic_port *port = pic_stdout(pic);
pic_get_args(pic, "c|p", &c, &port);
assert_port_profile(port, PIC_PORT_OUT | PIC_PORT_TEXT, PIC_PORT_OPEN, "write-char");
xfputc(c, port->file);
return pic_none_value();
}
static pic_value
pic_port_write_string(pic_state *pic)
{
char *str;
struct pic_port *port;
int start, end, n, i;
n = pic_get_args(pic, "z|pii", &str, &port, &start, &end);
switch (n) {
case 1:
port = pic_stdout(pic);
case 2:
start = 0;
case 3:
end = INT_MAX;
}
assert_port_profile(port, PIC_PORT_OUT | PIC_PORT_TEXT, PIC_PORT_OPEN, "write-string");
for (i = start; i < end && str[i] != '\0'; ++i) {
xfputc(str[i], port->file);
}
return pic_none_value();
}
static pic_value
pic_port_write_byte(pic_state *pic)
{
int i;
struct pic_port *port = pic_stdout(pic);
pic_get_args(pic, "i|p", &i, &port);
assert_port_profile(port, PIC_PORT_OUT | PIC_PORT_BINARY, PIC_PORT_OPEN, "write-u8");
xfputc(i, port->file);
return pic_none_value();
}
static pic_value
pic_port_write_blob(pic_state *pic)
{
struct pic_blob *blob;
struct pic_port *port;
int start, end, n, i;
n = pic_get_args(pic, "b|pii", &blob, &port, &start, &end);
switch (n) {
case 1:
port = pic_stdout(pic);
case 2:
start = 0;
case 3:
end = blob->len;
}
assert_port_profile(port, PIC_PORT_OUT | PIC_PORT_BINARY, PIC_PORT_OPEN, "write-bytevector");
for (i = start; i < end; ++i) {
xfputc(blob->data[i], port->file);
}
return pic_none_value();
}
static pic_value
pic_port_flush(pic_state *pic)
{
struct pic_port *port = pic_stdout(pic);
pic_get_args(pic, "|p", &port);
assert_port_profile(port, PIC_PORT_OUT, PIC_PORT_OPEN, "flush-output-port");
xfflush(port->file);
return pic_none_value();
}
void
pic_init_port(pic_state *pic)
{
struct pic_port *STDIN, *STDOUT, *STDERR;
STDIN = port_new_stdport(pic, xstdin, PIC_PORT_IN);
STDOUT = port_new_stdport(pic, xstdout, PIC_PORT_OUT);
STDERR = port_new_stdport(pic, xstderr, PIC_PORT_OUT);
pic_deflibrary (pic, "(picrin port)") {
pic_define(pic, "standard-input-port", pic_obj_value(STDIN));
pic_define(pic, "standard-output-port", pic_obj_value(STDOUT));
pic_define(pic, "standard-error-port", pic_obj_value(STDERR));
}
pic_define(pic, "current-input-port", pic_obj_value(pic_var_new(pic, pic_obj_value(STDIN), NULL)));
pic_define(pic, "current-output-port", pic_obj_value(pic_var_new(pic, pic_obj_value(STDOUT), NULL)));
pic_define(pic, "current-error-port", pic_obj_value(pic_var_new(pic, pic_obj_value(STDERR), NULL)));
pic_defun(pic, "input-port?", pic_port_input_port_p);
pic_defun(pic, "output-port?", pic_port_output_port_p);
pic_defun(pic, "textual-port?", pic_port_textual_port_p);
pic_defun(pic, "binary-port?", pic_port_binary_port_p);
pic_defun(pic, "port?", pic_port_port_p);
pic_defun(pic, "input-port-open?", pic_port_input_port_open_p);
pic_defun(pic, "output-port-open?", pic_port_output_port_open_p);
pic_defun(pic, "close-port", pic_port_close_port);
pic_defun(pic, "close-input-port", pic_port_close_port);
pic_defun(pic, "close-output-port", pic_port_close_port);
/* string I/O */
pic_defun(pic, "open-input-string", pic_port_open_input_string);
pic_defun(pic, "open-output-string", pic_port_open_output_string);
pic_defun(pic, "get-output-string", pic_port_get_output_string);
pic_defun(pic, "open-input-bytevector", pic_port_open_input_blob);
pic_defun(pic, "open-output-bytevector", pic_port_open_output_bytevector);
pic_defun(pic, "get-output-bytevector", pic_port_get_output_bytevector);
/* input */
pic_defun(pic, "read-char", pic_port_read_char);
pic_defun(pic, "peek-char", pic_port_peek_char);
pic_defun(pic, "read-line", pic_port_read_line);
pic_defun(pic, "eof-object?", pic_port_eof_object_p);
pic_defun(pic, "eof-object", pic_port_eof_object);
pic_defun(pic, "char-ready?", pic_port_char_ready_p);
pic_defun(pic, "read-string", pic_port_read_string);
pic_defun(pic, "read-u8", pic_port_read_byte);
pic_defun(pic, "peek-u8", pic_port_peek_byte);
pic_defun(pic, "u8-ready?", pic_port_byte_ready_p);
pic_defun(pic, "read-bytevector", pic_port_read_blob);
pic_defun(pic, "read-bytevector!", pic_port_read_blob_ip);
/* output */
pic_defun(pic, "newline", pic_port_newline);
pic_defun(pic, "write-char", pic_port_write_char);
pic_defun(pic, "write-string", pic_port_write_string);
pic_defun(pic, "write-u8", pic_port_write_byte);
pic_defun(pic, "write-bytevector", pic_port_write_blob);
pic_defun(pic, "flush-output-port", pic_port_flush);
}

183
src/proc.c
View File

@ -1,183 +0,0 @@
/**
* See Copyright Notice in picrin.h
*/
#include "picrin.h"
#include "picrin/pair.h"
#include "picrin/proc.h"
#include "picrin/irep.h"
#include "picrin/dict.h"
struct pic_proc *
pic_proc_new(pic_state *pic, pic_func_t func, const char *name)
{
struct pic_proc *proc;
assert(name != NULL);
proc = (struct pic_proc *)pic_obj_alloc(pic, sizeof(struct pic_proc), PIC_TT_PROC);
proc->kind = PIC_PROC_KIND_FUNC;
proc->u.func.f = func;
proc->u.func.name = pic_intern_cstr(pic, name);
proc->env = NULL;
proc->attr = NULL;
return proc;
}
struct pic_proc *
pic_proc_new_irep(pic_state *pic, struct pic_irep *irep, struct pic_env *env)
{
struct pic_proc *proc;
proc = (struct pic_proc *)pic_obj_alloc(pic, sizeof(struct pic_proc), PIC_TT_PROC);
proc->kind = PIC_PROC_KIND_IREP;
proc->u.irep = irep;
proc->env = env;
proc->attr = NULL;
return proc;
}
pic_sym
pic_proc_name(struct pic_proc *proc)
{
switch (proc->kind) {
case PIC_PROC_KIND_FUNC:
return proc->u.func.name;
case PIC_PROC_KIND_IREP:
return proc->u.irep->name;
}
UNREACHABLE();
}
struct pic_dict *
pic_attr(pic_state *pic, struct pic_proc *proc)
{
if (proc->attr == NULL) {
proc->attr = pic_dict_new(pic);
}
return proc->attr;
}
pic_value
pic_attr_ref(pic_state *pic, struct pic_proc *proc, const char *key)
{
return pic_dict_ref(pic, pic_attr(pic, proc), pic_intern_cstr(pic, key));
}
void
pic_attr_set(pic_state *pic, struct pic_proc *proc, const char *key, pic_value v)
{
pic_dict_set(pic, pic_attr(pic, proc), pic_intern_cstr(pic, key), v);
}
static pic_value
pic_proc_proc_p(pic_state *pic)
{
pic_value v;
pic_get_args(pic, "o", &v);
return pic_bool_value(pic_proc_p(v));
}
static pic_value
pic_proc_apply(pic_state *pic)
{
struct pic_proc *proc;
pic_value *args;
size_t argc;
pic_value arg_list;
pic_get_args(pic, "l*", &proc, &argc, &args);
if (argc == 0) {
pic_error(pic, "apply: wrong number of arguments");
}
arg_list = args[--argc];
while (argc--) {
arg_list = pic_cons(pic, args[argc], arg_list);
}
return pic_apply_trampoline(pic, proc, arg_list);
}
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();
}
static pic_value
pic_proc_attribute(pic_state *pic)
{
struct pic_proc *proc;
pic_get_args(pic, "l", &proc);
return pic_obj_value(pic_attr(pic, proc));
}
void
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);
pic_deflibrary (pic, "(picrin attribute)") {
pic_defun(pic, "attribute", pic_proc_attribute);
}
}

976
src/read.c
View File

@ -1,976 +0,0 @@
/**
* See Copyright Notice in picrin.h
*/
#include <ctype.h>
#include <math.h>
#include <stdlib.h>
#include "picrin.h"
#include "picrin/read.h"
#include "picrin/error.h"
#include "picrin/pair.h"
#include "picrin/string.h"
#include "picrin/vector.h"
#include "picrin/blob.h"
#include "picrin/port.h"
#include "picrin/proc.h"
static pic_value read(pic_state *pic, struct pic_port *port, int c);
static pic_value read_nullable(pic_state *pic, struct pic_port *port, int c);
static noreturn void
read_error(pic_state *pic, const char *msg)
{
pic_throw(pic, PIC_ERROR_READ, msg, pic_nil_value());
}
static int
skip(struct pic_port *port, int c)
{
while (isspace(c)) {
c = xfgetc(port->file);
}
return c;
}
static int
next(struct pic_port *port)
{
return xfgetc(port->file);
}
static int
peek(struct pic_port *port)
{
int c;
xungetc((c = xfgetc(port->file)), port->file);
return c;
}
static bool
expect(struct pic_port *port, const char *str)
{
int c;
while ((c = (int)*str++) != 0) {
if (c != peek(port))
return false;
next(port);
}
return true;
}
static bool
isdelim(int c)
{
return c == EOF || strchr("();,|\" \t\n\r", c) != NULL; /* ignores "#", "'" */
}
static bool
strcaseeq(const char *s1, const char *s2)
{
char a, b;
while ((a = *s1++) * (b = *s2++)) {
if (tolower(a) != tolower(b))
return false;
}
return a == b;
}
static pic_value
read_comment(pic_state *pic, struct pic_port *port, const char *str)
{
int c;
UNUSED(pic);
UNUSED(str);
do {
c = next(port);
} while (! (c == EOF || c == '\n'));
return pic_undef_value();
}
static pic_value
read_block_comment(pic_state *pic, struct pic_port *port, const char *str)
{
int x, y;
int i = 1;
UNUSED(pic);
UNUSED(str);
y = next(port);
while (y != EOF && i > 0) {
x = y;
y = next(port);
if (x == '|' && y == '#') {
i--;
}
if (x == '#' && y == '|') {
i++;
}
}
return pic_undef_value();
}
static pic_value
read_datum_comment(pic_state *pic, struct pic_port *port, const char *str)
{
UNUSED(str);
read(pic, port, next(port));
return pic_undef_value();
}
static pic_value
read_directive(pic_state *pic, struct pic_port *port, const char *str)
{
switch (peek(port)) {
case 'n':
if (expect(port, "no-fold-case")) {
pic->reader->typecase = PIC_CASE_DEFAULT;
return pic_undef_value();
}
break;
case 'f':
if (expect(port, "fold-case")) {
pic->reader->typecase = PIC_CASE_FOLD;
return pic_undef_value();
}
break;
}
return read_comment(pic, port, str);
}
static pic_value
read_eval(pic_state *pic, struct pic_port *port, const char *str)
{
pic_value form;
UNUSED(str);
form = read(pic, port, next(port));
return pic_eval(pic, form, pic->lib);
}
static pic_value
read_quote(pic_state *pic, struct pic_port *port, const char *str)
{
UNUSED(str);
return pic_list2(pic, pic_sym_value(pic->sQUOTE), read(pic, port, next(port)));
}
static pic_value
read_quasiquote(pic_state *pic, struct pic_port *port, const char *str)
{
UNUSED(str);
return pic_list2(pic, pic_sym_value(pic->sQUASIQUOTE), read(pic, port, next(port)));
}
static pic_value
read_unquote(pic_state *pic, struct pic_port *port, const char *str)
{
UNUSED(str);
return pic_list2(pic, pic_sym_value(pic->sUNQUOTE), read(pic, port, next(port)));
}
static pic_value
read_unquote_splicing(pic_state *pic, struct pic_port *port, const char *str)
{
UNUSED(str);
return pic_list2(pic, pic_sym_value(pic->sUNQUOTE_SPLICING), read(pic, port, next(port)));
}
static pic_value
read_symbol(pic_state *pic, struct pic_port *port, const char *str)
{
size_t len, i;
char *buf;
pic_sym sym;
int c;
len = strlen(str);
buf = pic_calloc(pic, 1, len + 1);
for (i = 0; i < len; ++i) {
if (pic->reader->typecase == PIC_CASE_FOLD) {
buf[i] = tolower(str[i]);
} else {
buf[i] = str[i];
}
}
while (! isdelim(peek(port))) {
c = next(port);
if (pic->reader->typecase == PIC_CASE_FOLD) {
c = tolower(c);
}
len += 1;
buf = pic_realloc(pic, buf, len + 1);
buf[len - 1] = c;
}
sym = pic_intern(pic, buf, len);
pic_free(pic, buf);
return pic_sym_value(sym);
}
static size_t
read_uinteger(pic_state *pic, struct pic_port *port, int c, char buf[])
{
size_t i = 0;
if (! isdigit(c)) {
read_error(pic, "expected one or more digits");
}
buf[i++] = c;
while (isdigit(c = peek(port))) {
buf[i++] = next(port);
}
buf[i] = '\0';
return i;
}
static size_t
read_suffix(pic_state *pic, struct pic_port *port, char buf[])
{
size_t i = 0;
int c;
c = peek(port);
if (c != 'e' && c != 'E') {
return i;
}
buf[i++] = next(port);
switch ((c = next(port))) {
case '-':
case '+':
buf[i++] = c;
c = next(port);
default:
return i + read_uinteger(pic, port, c, buf + i);
}
}
static pic_value
read_unsigned(pic_state *pic, struct pic_port *port, int c)
{
char buf[256];
size_t i;
i = read_uinteger(pic, port, c, buf);
switch (peek(port)) {
case '.':
buf[i++] = next(port);
i += read_uinteger(pic, port, next(port), buf + i);
read_suffix(pic, port, buf + i);
return pic_float_value(atof(buf));
default:
read_suffix(pic, port, buf + i);
return pic_int_value((int)atof(buf));
}
}
static pic_value
read_number(pic_state *pic, struct pic_port *port, const char *str)
{
return read_unsigned(pic, port, str[0]);
}
static pic_value
negate(pic_value n)
{
if (pic_int_p(n)) {
return pic_int_value(-pic_int(n));
} else {
return pic_float_value(-pic_float(n));
}
}
static pic_value
read_minus(pic_state *pic, struct pic_port *port, const char *str)
{
pic_value sym;
if (isdigit(peek(port))) {
return negate(read_unsigned(pic, port, next(port)));
}
else {
sym = read_symbol(pic, port, str);
if (strcaseeq(pic_symbol_name(pic, pic_sym(sym)), "-inf.0")) {
return pic_float_value(-INFINITY);
}
if (strcaseeq(pic_symbol_name(pic, pic_sym(sym)), "-nan.0")) {
return pic_float_value(-NAN);
}
return sym;
}
}
static pic_value
read_plus(pic_state *pic, struct pic_port *port, const char *str)
{
pic_value sym;
if (isdigit(peek(port))) {
return read_unsigned(pic, port, next(port));
}
else {
sym = read_symbol(pic, port, str);
if (strcaseeq(pic_symbol_name(pic, pic_sym(sym)), "+inf.0")) {
return pic_float_value(INFINITY);
}
if (strcaseeq(pic_symbol_name(pic, pic_sym(sym)), "+nan.0")) {
return pic_float_value(NAN);
}
return sym;
}
}
static pic_value
read_true(pic_state *pic, struct pic_port *port, const char *str)
{
UNUSED(pic);
UNUSED(port);
UNUSED(str);
return pic_true_value();
}
static pic_value
read_false(pic_state *pic, struct pic_port *port, const char *str)
{
UNUSED(pic);
UNUSED(port);
UNUSED(str);
return pic_false_value();
}
static pic_value
read_char(pic_state *pic, struct pic_port *port, const char *str)
{
int c;
UNUSED(str);
c = next(port);
if (! isdelim(peek(port))) {
switch (c) {
default: read_error(pic, "unexpected character after char literal");
case 'a': c = '\a'; if (! expect(port, "lerm")) goto fail; break;
case 'b': c = '\b'; if (! expect(port, "ackspace")) goto fail; break;
case 'd': c = 0x7F; if (! expect(port, "elete")) goto fail; break;
case 'e': c = 0x1B; if (! expect(port, "scape")) goto fail; break;
case 'n':
if ((c = peek(port)) == 'e') {
c = '\n';
if (! expect(port, "ewline"))
goto fail;
} else {
c = '\0';
if (! expect(port, "ull"))
goto fail;
}
break;
case 'r': c = '\r'; if (! expect(port, "eturn")) goto fail; break;
case 's': c = ' '; if (! expect(port, "pace")) goto fail; break;
case 't': c = '\t'; if (! expect(port, "ab")) goto fail; break;
}
}
return pic_char_value(c);
fail:
read_error(pic, "unexpected character while reading character literal");
}
static pic_value
read_string(pic_state *pic, struct pic_port *port, const char *name)
{
int c;
char *buf;
size_t size, cnt;
pic_str *str;
UNUSED(name);
size = 256;
buf = pic_alloc(pic, size);
cnt = 0;
/* TODO: intraline whitespaces */
while ((c = next(port)) != '"') {
if (c == '\\') {
switch (c = next(port)) {
case 'a': c = '\a'; break;
case 'b': c = '\b'; break;
case 't': c = '\t'; break;
case 'n': c = '\n'; break;
case 'r': c = '\r'; break;
}
}
buf[cnt++] = c;
if (cnt >= size) {
buf = pic_realloc(pic, buf, size *= 2);
}
}
buf[cnt] = '\0';
str = pic_str_new(pic, buf, cnt);
pic_free(pic, buf);
return pic_obj_value(str);
}
static pic_value
read_pipe(pic_state *pic, struct pic_port *port, const char *str)
{
char *buf;
size_t size, cnt;
pic_sym sym;
/* Currently supports only ascii chars */
char HEX_BUF[3];
size_t i = 0;
int c;
UNUSED(str);
size = 256;
buf = pic_alloc(pic, size);
cnt = 0;
while ((c = next(port)) != '|') {
if (c == '\\') {
switch ((c = next(port))) {
case 'a': c = '\a'; break;
case 'b': c = '\b'; break;
case 't': c = '\t'; break;
case 'n': c = '\n'; break;
case 'r': c = '\r'; break;
case 'x':
i = 0;
while ((HEX_BUF[i++] = next(port)) != ';') {
if (i >= sizeof HEX_BUF)
read_error(pic, "expected ';'");
}
c = strtol(HEX_BUF, NULL, 16);
break;
}
}
buf[cnt++] = c;
if (cnt >= size) {
buf = pic_realloc(pic, buf, size *= 2);
}
}
buf[cnt] = '\0';
sym = pic_intern_cstr(pic, buf);
pic_free(pic, buf);
return pic_sym_value(sym);
}
static pic_value
read_blob(pic_state *pic, struct pic_port *port, const char *str)
{
int nbits, n, c;
size_t len, i;
char *dat, buf[256];
pic_blob *blob;
UNUSED(str);
nbits = 0;
while (isdigit(c = next(port))) {
nbits = 10 * nbits + c - '0';
}
if (nbits != 8) {
read_error(pic, "unsupported bytevector bit width");
}
if (c != '(') {
read_error(pic, "expected '(' character");
}
len = 0;
dat = NULL;
c = next(port);
while ((c = skip(port, c)) != ')') {
read_uinteger(pic, port, c, buf);
n = atoi(buf);
if (n < 0 || (1 << nbits) <= n) {
read_error(pic, "invalid element in bytevector literal");
}
len += 1;
dat = pic_realloc(pic, dat, len);
dat[len - 1] = n;
c = next(port);
}
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);
}
static pic_value
read_pair(pic_state *pic, struct pic_port *port, const char *str)
{
const int tCLOSE = (str[0] == '(') ? ')' : ']';
pic_value car, cdr;
int c;
retry:
c = skip(port, ' ');
if (c == tCLOSE) {
return pic_nil_value();
}
if (c == '.' && isdelim(peek(port))) {
cdr = read(pic, port, next(port));
closing:
if ((c = skip(port, ' ')) != tCLOSE) {
if (pic_undef_p(read_nullable(pic, port, c))) {
goto closing;
}
read_error(pic, "unmatched parenthesis");
}
return cdr;
}
else {
car = read_nullable(pic, port, c);
if (pic_undef_p(car)) {
goto retry;
}
cdr = read_pair(pic, port, str);
return pic_cons(pic, car, cdr);
}
}
static pic_value
read_vector(pic_state *pic, struct pic_port *port, const char *str)
{
pic_value list;
list = read(pic, port, str[1]);
return pic_obj_value(pic_vec_new_from_list(pic, list));
}
static pic_value
read_label_set(pic_state *pic, struct pic_port *port, int i)
{
pic_value val;
int c;
switch ((c = skip(port, ' '))) {
case '(': case '[':
{
pic_value tmp;
val = pic_cons(pic, pic_none_value(), pic_none_value());
xh_put_int(&pic->reader->labels, i, &val);
tmp = read(pic, port, c);
pic_pair_ptr(val)->car = pic_car(pic, tmp);
pic_pair_ptr(val)->cdr = pic_cdr(pic, tmp);
return val;
}
case '#':
{
bool vect;
if (peek(port) == '(') {
vect = true;
} else {
vect = false;
}
if (vect) {
pic_vec *tmp;
val = pic_obj_value(pic_vec_new(pic, 0));
xh_put_int(&pic->reader->labels, i, &val);
tmp = pic_vec_ptr(read(pic, port, c));
SWAP(pic_value *, tmp->data, pic_vec_ptr(val)->data);
SWAP(size_t, tmp->len, pic_vec_ptr(val)->len);
return val;
}
FALLTHROUGH;
}
default:
{
val = read(pic, port, c);
xh_put_int(&pic->reader->labels, i, &val);
return val;
}
}
}
static pic_value
read_label_ref(pic_state *pic, struct pic_port *port, int i)
{
xh_entry *e;
UNUSED(port);
e = xh_get_int(&pic->reader->labels, i);
if (! e) {
read_error(pic, "label of given index not defined");
}
return xh_val(e, pic_value);
}
static pic_value
read_label(pic_state *pic, struct pic_port *port, const char *str)
{
int i, c;
i = 0;
c = str[1]; /* initial index letter */
do {
i = i * 10 + c;
} while (isdigit(c = next(port)));
if (c == '=') {
return read_label_set(pic, port, i);
}
if (c == '#') {
return read_label_ref(pic, port, i);
}
read_error(pic, "broken label expression");
}
static pic_value
read_unmatch(pic_state *pic, struct pic_port *port, const char *str)
{
UNUSED(port);
UNUSED(str);
read_error(pic, "unmatched parenthesis");
}
static pic_value
read_nullable(pic_state *pic, struct pic_port *port, int c)
{
struct pic_trie *trie = pic->reader->trie;
char buf[128];
size_t i = 0;
pic_str *str;
c = skip(port, c);
if (c == EOF) {
read_error(pic, "unexpected EOF");
}
if (trie->table[c] == NULL) {
read_error(pic, "invalid character at the seeker head");
}
buf[i++] = c;
while (i < sizeof buf) {
trie = trie->table[c];
if ((c = peek(port)) == EOF) {
break;
}
if (trie->table[c] == NULL) {
break;
}
buf[i++] = next(port);
}
if (i == sizeof buf) {
read_error(pic, "too long dispatch string");
}
if (trie->proc == NULL) {
read_error(pic, "no reader registered for current string");
}
str = pic_str_new(pic, buf, i);
return pic_apply2(pic, trie->proc, pic_obj_value(port), pic_obj_value(str));
}
static pic_value
read(pic_state *pic, struct pic_port *port, int c)
{
pic_value val;
retry:
val = read_nullable(pic, port, c);
if (pic_undef_p(val)) {
c = next(port);
goto retry;
}
return val;
}
struct pic_trie *
pic_trie_new(pic_state *pic)
{
struct pic_trie *trie;
trie = pic_alloc(pic, sizeof(struct pic_trie));
trie->proc = NULL;
memset(trie->table, 0, sizeof trie->table);
return trie;
}
void
pic_trie_delete(pic_state *pic, struct pic_trie *trie)
{
size_t i;
for (i = 0; i < sizeof trie->table / sizeof(struct pic_trie *); ++i) {
if (trie->table[i] != NULL) {
pic_trie_delete(pic, trie->table[i]);
}
}
pic_free(pic, trie);
}
void
pic_define_reader(pic_state *pic, const char *str, pic_func_t reader)
{
struct pic_trie *trie = pic->reader->trie;
int c;
while ((c = *str++)) {
if (trie->table[c] == NULL) {
trie->table[c] = pic_trie_new(pic);
}
trie = trie->table[c];
}
trie->proc = pic_proc_new(pic, reader, "reader");
}
#define DEFINE_READER(name) \
static pic_value \
pic_##name(pic_state *pic) \
{ \
struct pic_port *port; \
const char *str; \
\
pic_get_args(pic, "pz", &port, &str); \
\
return name(pic, port, str); \
}
DEFINE_READER(read_unmatch)
DEFINE_READER(read_comment)
DEFINE_READER(read_quote)
DEFINE_READER(read_quasiquote)
DEFINE_READER(read_unquote)
DEFINE_READER(read_unquote_splicing)
DEFINE_READER(read_string)
DEFINE_READER(read_pipe)
DEFINE_READER(read_plus)
DEFINE_READER(read_minus)
DEFINE_READER(read_pair)
DEFINE_READER(read_directive)
DEFINE_READER(read_block_comment)
DEFINE_READER(read_datum_comment)
DEFINE_READER(read_true)
DEFINE_READER(read_false)
DEFINE_READER(read_char)
DEFINE_READER(read_vector)
DEFINE_READER(read_blob)
DEFINE_READER(read_eval)
DEFINE_READER(read_symbol)
DEFINE_READER(read_number)
DEFINE_READER(read_label)
void
pic_init_reader(pic_state *pic)
{
static const char INIT[] = "!$%&*./:<=>?@^_~";
char buf[3] = { 0 };
size_t i;
pic_define_reader(pic, ")", pic_read_unmatch);
pic_define_reader(pic, ";", pic_read_comment);
pic_define_reader(pic, "'", pic_read_quote);
pic_define_reader(pic, "`", pic_read_quasiquote);
pic_define_reader(pic, ",", pic_read_unquote);
pic_define_reader(pic, ",@", pic_read_unquote_splicing);
pic_define_reader(pic, "\"", pic_read_string);
pic_define_reader(pic, "|", pic_read_pipe);
pic_define_reader(pic, "+", pic_read_plus);
pic_define_reader(pic, "-", pic_read_minus);
pic_define_reader(pic, "(", pic_read_pair);
pic_define_reader(pic, "[", pic_read_pair);
pic_define_reader(pic, "#!", pic_read_directive);
pic_define_reader(pic, "#|", pic_read_block_comment);
pic_define_reader(pic, "#;", pic_read_datum_comment);
pic_define_reader(pic, "#t", pic_read_true);
pic_define_reader(pic, "#true", pic_read_true);
pic_define_reader(pic, "#f", pic_read_false);
pic_define_reader(pic, "#false", pic_read_false);
pic_define_reader(pic, "#\\", pic_read_char);
pic_define_reader(pic, "#(", pic_read_vector);
pic_define_reader(pic, "#u", pic_read_blob);
pic_define_reader(pic, "#.", pic_read_eval);
/* read number */
for (buf[0] = '0'; buf[0] <= '9'; ++buf[0]) {
pic_define_reader(pic, buf, pic_read_number);
}
/* read symbol */
for (buf[0] = 'a'; buf[0] <= 'z'; ++buf[0]) {
pic_define_reader(pic, buf, pic_read_symbol);
}
for (buf[0] = 'A'; buf[0] <= 'Z'; ++buf[0]) {
pic_define_reader(pic, buf, pic_read_symbol);
}
for (i = 0; i < sizeof INIT; ++i) {
buf[0] = INIT[i];
pic_define_reader(pic, buf, pic_read_symbol);
}
/* read label */
buf[0] = '#';
for (buf[1] = '0'; buf[1] <= '9'; ++buf[1]) {
pic_define_reader(pic, buf, pic_read_label);
}
}
pic_value
pic_read(pic_state *pic, struct pic_port *port)
{
pic_value val;
int c = next(port);
retry:
c = skip(port, c);
if (c == EOF) {
return pic_eof_object();
}
val = read_nullable(pic, port, c);
if (pic_undef_p(val)) {
c = next(port);
goto retry;
}
return val;
}
pic_value
pic_read_cstr(pic_state *pic, const char *str)
{
struct pic_port *port;
port = pic_open_input_string(pic, str);
return pic_read(pic, port);
}
static pic_value
pic_parse(pic_state *pic, struct pic_port *port)
{
pic_value val, acc;
pic_try {
acc = pic_nil_value();
while (! pic_eof_p(val = pic_read(pic, port))) {
pic_push(pic, val, acc);
}
}
pic_catch {
return pic_undef_value();
}
return pic_reverse(pic, acc);
}
pic_list
pic_parse_file(pic_state *pic, FILE *file)
{
struct pic_port *port;
port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port *), PIC_TT_PORT);
port->file = xfpopen(file);
port->flags = PIC_PORT_OUT | PIC_PORT_TEXT;
port->status = PIC_PORT_OPEN;
return pic_parse(pic, port);
}
pic_list
pic_parse_cstr(pic_state *pic, const char *str)
{
struct pic_port *port;
port = pic_open_input_string(pic, str);
return pic_parse(pic, port);
}
static pic_value
pic_read_read(pic_state *pic)
{
struct pic_port *port = pic_stdin(pic);
pic_get_args(pic, "|p", &port);
return pic_read(pic, port);
}
void
pic_init_read(pic_state *pic)
{
pic_deflibrary (pic, "(scheme read)") {
pic_defun(pic, "read", pic_read_read);
}
}

115
src/record.c
View File

@ -1,115 +0,0 @@
/**
* See Copyright Notice in picrin.h
*/
#include "picrin.h"
#include "picrin/record.h"
struct pic_record *
pic_record_new(pic_state *pic, pic_value rectype)
{
struct pic_record *rec;
rec = (struct pic_record *)pic_obj_alloc(pic, sizeof(struct pic_record), PIC_TT_RECORD);
xh_init_int(&rec->hash, sizeof(pic_value));
pic_record_set(pic, rec, pic_intern_cstr(pic, "@@type"), rectype);
return rec;
}
pic_value
pic_record_type(pic_state *pic, struct pic_record *rec)
{
return pic_record_ref(pic, rec, pic_intern_cstr(pic, "@@type"));
}
pic_value
pic_record_ref(pic_state *pic, struct pic_record *rec, pic_sym slot)
{
xh_entry *e;
e = xh_get_int(&rec->hash, slot);
if (! e) {
pic_errorf(pic, "slot named ~s is not found for record: ~s", pic_sym_value(slot), rec);
}
return xh_val(e, pic_value);
}
void
pic_record_set(pic_state *pic, struct pic_record *rec, pic_sym slot, pic_value val)
{
UNUSED(pic);
xh_put_int(&rec->hash, slot, &val);
}
static pic_value
pic_record_make_record(pic_state *pic)
{
struct pic_record * rec;
pic_value rectype;
pic_get_args(pic, "o", &rectype);
rec = pic_record_new(pic, rectype);
return pic_obj_value(rec);
}
static pic_value
pic_record_record_p(pic_state *pic)
{
pic_value rec;
pic_get_args(pic, "o", &rec);
return pic_bool_value(pic_record_p(rec));
}
static pic_value
pic_record_record_type(pic_state *pic)
{
struct pic_record *rec;
pic_get_args(pic, "r", &rec);
return pic_record_type(pic, rec);
}
static pic_value
pic_record_record_ref(pic_state *pic)
{
struct pic_record *rec;
pic_sym slot;
pic_get_args(pic, "rm", &rec, &slot);
return pic_record_ref(pic, rec, slot);
}
static pic_value
pic_record_record_set(pic_state *pic)
{
struct pic_record *rec;
pic_sym slot;
pic_value val;
pic_get_args(pic, "rmo", &rec, &slot, &val);
pic_record_set(pic, rec, slot, val);
return pic_none_value();
}
void
pic_init_record(pic_state *pic)
{
pic_deflibrary (pic, "(picrin record)") {
pic_defun(pic, "make-record", pic_record_make_record);
pic_defun(pic, "record?", pic_record_record_p);
pic_defun(pic, "record-type", pic_record_record_type);
pic_defun(pic, "record-ref", pic_record_record_ref);
pic_defun(pic, "record-set!", pic_record_record_set);
}
}

205
src/state.c
View File

@ -1,205 +0,0 @@
/**
* See Copyright Notice in picrin.h
*/
#include <stdlib.h>
#include "picrin.h"
#include "picrin/gc.h"
#include "picrin/read.h"
#include "picrin/proc.h"
#include "picrin/macro.h"
#include "picrin/cont.h"
#include "picrin/error.h"
void pic_init_core(pic_state *);
pic_state *
pic_open(int argc, char *argv[], char **envp)
{
char t;
pic_state *pic;
size_t ai;
pic = malloc(sizeof(pic_state));
/* root block */
pic->blk = NULL;
/* command line */
pic->argc = argc;
pic->argv = argv;
pic->envp = envp;
/* prepare VM stack */
pic->stbase = pic->sp = calloc(PIC_STACK_SIZE, sizeof(pic_value));
pic->stend = pic->stbase + PIC_STACK_SIZE;
/* callinfo */
pic->cibase = pic->ci = calloc(PIC_STACK_SIZE, sizeof(pic_callinfo));
pic->ciend = pic->cibase + PIC_STACK_SIZE;
/* memory heap */
pic->heap = pic_heap_open();
/* symbol table */
xh_init_str(&pic->syms, sizeof(pic_sym));
xh_init_int(&pic->sym_names, sizeof(const char *));
pic->sym_cnt = 0;
pic->uniq_sym_cnt = 0;
/* global variables */
xh_init_int(&pic->globals, sizeof(pic_value));
/* macros */
xh_init_int(&pic->macros, sizeof(struct pic_macro *));
/* libraries */
pic->libs = pic_nil_value();
pic->lib = NULL;
/* reader */
pic->reader = malloc(sizeof(struct pic_reader));
pic->reader->typecase = PIC_CASE_DEFAULT;
pic->reader->trie = pic_trie_new(pic);
xh_init_int(&pic->reader->labels, sizeof(pic_value));
/* error handling */
pic->jmp = NULL;
pic->err = NULL;
pic->try_jmps = calloc(PIC_RESCUE_SIZE, sizeof(struct pic_jmpbuf));
pic->try_jmp_idx = 0;
pic->try_jmp_size = PIC_RESCUE_SIZE;
/* GC arena */
pic->arena = calloc(PIC_ARENA_SIZE, sizeof(struct pic_object **));
pic->arena_size = PIC_ARENA_SIZE;
pic->arena_idx = 0;
/* native stack marker */
pic->native_stack_start = &t;
#define register_core_symbol(pic,slot,name) do { \
pic->slot = pic_intern_cstr(pic, name); \
} while (0)
ai = pic_gc_arena_preserve(pic);
register_core_symbol(pic, sDEFINE, "define");
register_core_symbol(pic, sLAMBDA, "lambda");
register_core_symbol(pic, sIF, "if");
register_core_symbol(pic, sBEGIN, "begin");
register_core_symbol(pic, sSETBANG, "set!");
register_core_symbol(pic, sQUOTE, "quote");
register_core_symbol(pic, sQUASIQUOTE, "quasiquote");
register_core_symbol(pic, sUNQUOTE, "unquote");
register_core_symbol(pic, sUNQUOTE_SPLICING, "unquote-splicing");
register_core_symbol(pic, sDEFINE_SYNTAX, "define-syntax");
register_core_symbol(pic, sIMPORT, "import");
register_core_symbol(pic, sEXPORT, "export");
register_core_symbol(pic, sDEFINE_LIBRARY, "define-library");
register_core_symbol(pic, sIN_LIBRARY, "in-library");
register_core_symbol(pic, sCONS, "cons");
register_core_symbol(pic, sCAR, "car");
register_core_symbol(pic, sCDR, "cdr");
register_core_symbol(pic, sNILP, "null?");
register_core_symbol(pic, sADD, "+");
register_core_symbol(pic, sSUB, "-");
register_core_symbol(pic, sMUL, "*");
register_core_symbol(pic, sDIV, "/");
register_core_symbol(pic, sMINUS, "minus");
register_core_symbol(pic, sEQ, "=");
register_core_symbol(pic, sLT, "<");
register_core_symbol(pic, sLE, "<=");
register_core_symbol(pic, sGT, ">");
register_core_symbol(pic, sGE, ">=");
register_core_symbol(pic, sNOT, "not");
pic_gc_arena_restore(pic, ai);
#define register_renamed_symbol(pic,slot,name) do { \
pic->slot = pic_gensym(pic, pic_intern_cstr(pic, name)); \
} while (0)
ai = pic_gc_arena_preserve(pic);
register_renamed_symbol(pic, rDEFINE, "define");
register_renamed_symbol(pic, rLAMBDA, "lambda");
register_renamed_symbol(pic, rIF, "if");
register_renamed_symbol(pic, rBEGIN, "begin");
register_renamed_symbol(pic, rSETBANG, "set!");
register_renamed_symbol(pic, rQUOTE, "quote");
register_renamed_symbol(pic, rDEFINE_SYNTAX, "define-syntax");
register_renamed_symbol(pic, rIMPORT, "import");
register_renamed_symbol(pic, rEXPORT, "export");
register_renamed_symbol(pic, rDEFINE_LIBRARY, "define-library");
register_renamed_symbol(pic, rIN_LIBRARY, "in-library");
pic_gc_arena_restore(pic, ai);
/* root block */
pic->blk = (struct pic_block *)pic_obj_alloc(pic, sizeof(struct pic_block), PIC_TT_BLK);
pic->blk->prev = NULL;
pic->blk->depth = 0;
pic->blk->in = pic->blk->out = NULL;
pic_init_core(pic);
/* set library */
pic_make_library(pic, pic_read_cstr(pic, "(picrin user)"));
pic_in_library(pic, pic_read_cstr(pic, "(picrin user)"));
return pic;
}
void
pic_close(pic_state *pic)
{
xh_iter it;
/* invoke exit handlers */
while (pic->blk) {
if (pic->blk->out) {
pic_apply0(pic, pic->blk->out);
}
pic->blk = pic->blk->prev;
}
/* clear out root objects */
pic->sp = pic->stbase;
pic->ci = pic->cibase;
pic->arena_idx = 0;
pic->err = NULL;
xh_clear(&pic->macros);
pic->libs = pic_nil_value();
/* free all heap objects */
pic_gc_run(pic);
/* free heaps */
pic_heap_close(pic->heap);
/* free runtime context */
free(pic->stbase);
free(pic->cibase);
/* free reader struct */
xh_destroy(&pic->reader->labels);
pic_trie_delete(pic, pic->reader->trie);
free(pic->reader);
/* free global stacks */
free(pic->try_jmps);
xh_destroy(&pic->syms);
xh_destroy(&pic->globals);
xh_destroy(&pic->macros);
/* free GC arena */
free(pic->arena);
/* free symbol names */
xh_begin(&it, &pic->sym_names);
while (xh_next(&it)) {
free(xh_val(it.e, char *));
}
xh_destroy(&pic->sym_names);
free(pic);
}

424
src/string.c
View File

@ -1,424 +0,0 @@
/**
* See Copyright Notice in picrin.h
*/
#include <string.h>
#include "picrin.h"
#include "picrin/string.h"
#include "picrin/pair.h"
#include "picrin/port.h"
static pic_str *
str_new_rope(pic_state *pic, xrope *rope)
{
pic_str *str;
str = (pic_str *)pic_obj_alloc(pic, sizeof(pic_str), PIC_TT_STRING);
str->rope = rope; /* delegate ownership */
return str;
}
pic_str *
pic_str_new(pic_state *pic, const char *imbed, size_t len)
{
if (imbed == NULL && len > 0) {
pic_errorf(pic, "zero length specified against NULL ptr");
}
return str_new_rope(pic, xr_new_copy(imbed, len));
}
pic_str *
pic_str_new_cstr(pic_state *pic, const char *cstr)
{
return pic_str_new(pic, cstr, strlen(cstr));
}
pic_str *
pic_str_new_fill(pic_state *pic, size_t len, char fill)
{
size_t i;
char *cstr;
pic_str *str;
cstr = (char *)pic_alloc(pic, len + 1);
cstr[len] = '\0';
for (i = 0; i < len; ++i) {
cstr[i] = fill;
}
str = pic_str_new(pic, cstr, len);
pic_free(pic, cstr);
return str;
}
size_t
pic_strlen(pic_str *str)
{
return xr_len(str->rope);
}
char
pic_str_ref(pic_state *pic, pic_str *str, size_t i)
{
int c;
c = xr_at(str->rope, i);
if (c == -1) {
pic_errorf(pic, "index out of range %d", i);
}
return (char)c;
}
static xrope *
xr_put(xrope *rope, size_t i, char c)
{
xrope *x, *y, *z;
char buf[2];
if (xr_len(rope) <= i) {
return NULL;
}
buf[0] = c;
buf[1] = '\0';
x = xr_sub(rope, 0, i);
y = xr_new_copy(buf, 1);
z = xr_cat(x, y);
XROPE_DECREF(x);
XROPE_DECREF(y);
x = z;
y = xr_sub(rope, i + 1, xr_len(rope));
z = xr_cat(z, y);
XROPE_DECREF(x);
XROPE_DECREF(y);
return z;
}
void
pic_str_set(pic_state *pic, pic_str *str, size_t i, char c)
{
xrope *x;
x = xr_put(str->rope, i, c);
if (x == NULL) {
pic_errorf(pic, "index out of range %d", i);
}
XROPE_DECREF(str->rope);
str->rope = x;
}
pic_str *
pic_strcat(pic_state *pic, pic_str *a, pic_str *b)
{
return str_new_rope(pic, xr_cat(a->rope, b->rope));
}
pic_str *
pic_substr(pic_state *pic, pic_str *str, size_t s, size_t e)
{
return str_new_rope(pic, xr_sub(str->rope, s, e));
}
int
pic_strcmp(pic_str *str1, pic_str *str2)
{
return strcmp(xr_cstr(str1->rope), xr_cstr(str2->rope));
}
const char *
pic_str_cstr(pic_str *str)
{
return xr_cstr(str->rope);
}
pic_value
pic_vfformat(pic_state *pic, xFILE *file, const char *fmt, va_list ap)
{
char c;
pic_value irrs = pic_nil_value();
while ((c = *fmt++)) {
switch (c) {
default:
xfputc(c, file);
break;
case '%':
c = *fmt++;
if (! c)
goto exit;
switch (c) {
default:
xfputc(c, file);
break;
case '%':
xfputc('%', file);
break;
case 'c':
xfprintf(file, "%c", va_arg(ap, int));
break;
case 's':
xfprintf(file, "%s", va_arg(ap, const char *));
break;
case 'd':
xfprintf(file, "%d", va_arg(ap, int));
break;
case 'p':
xfprintf(file, "%p", va_arg(ap, void *));
break;
case 'f':
xfprintf(file, "%f", va_arg(ap, double));
break;
}
break;
case '~':
c = *fmt++;
if (! c)
goto exit;
switch (c) {
default:
xfputc(c, file);
break;
case '~':
xfputc('~', file);
break;
case '%':
xfputc('\n', file);
break;
case 'a':
irrs = pic_cons(pic, pic_fdisplay(pic, va_arg(ap, pic_value), file), irrs);
break;
case 's':
irrs = pic_cons(pic, pic_fwrite(pic, va_arg(ap, pic_value), file), irrs);
break;
}
break;
}
}
exit:
return pic_reverse(pic, irrs);
}
pic_value
pic_vformat(pic_state *pic, const char *fmt, va_list ap)
{
struct pic_port *port;
pic_value irrs;
port = pic_open_output_string(pic);
irrs = pic_vfformat(pic, port->file, fmt, ap);
irrs = pic_cons(pic, pic_obj_value(pic_get_output_string(pic, port)), irrs);
pic_close_port(pic, port);
return irrs;
}
pic_value
pic_format(pic_state *pic, const char *fmt, ...)
{
va_list ap;
pic_value objs;
va_start(ap, fmt);
objs = pic_vformat(pic, fmt, ap);
va_end(ap);
return objs;
}
static pic_value
pic_str_string_p(pic_state *pic)
{
pic_value v;
pic_get_args(pic, "o", &v);
return pic_bool_value(pic_str_p(v));
}
static pic_value
pic_str_make_string(pic_state *pic)
{
int len;
char c = ' ';
pic_get_args(pic, "i|c", &len, &c);
return pic_obj_value(pic_str_new_fill(pic, len, c));
}
static pic_value
pic_str_string_length(pic_state *pic)
{
pic_str *str;
pic_get_args(pic, "s", &str);
return pic_int_value(pic_strlen(str));
}
static pic_value
pic_str_string_ref(pic_state *pic)
{
pic_str *str;
int k;
pic_get_args(pic, "si", &str, &k);
return pic_char_value(pic_str_ref(pic, str, k));
}
static pic_value
pic_str_string_set(pic_state *pic)
{
pic_str *str;
char c;
int k;
pic_get_args(pic, "sic", &str, &k, &c);
pic_str_set(pic, str, k, c);
return pic_none_value();
}
#define DEFINE_STRING_CMP(name, op) \
static pic_value \
pic_str_string_##name(pic_state *pic) \
{ \
size_t argc; \
pic_value *argv; \
size_t i; \
\
pic_get_args(pic, "*", &argc, &argv); \
\
if (argc < 1 || ! pic_str_p(argv[0])) { \
return pic_false_value(); \
} \
\
for (i = 1; i < argc; ++i) { \
if (! pic_str_p(argv[i])) { \
return pic_false_value(); \
} \
if (! (pic_strcmp(pic_str_ptr(argv[i-1]), pic_str_ptr(argv[i])) op 0)) { \
return pic_false_value(); \
} \
} \
return pic_true_value(); \
}
DEFINE_STRING_CMP(eq, ==)
DEFINE_STRING_CMP(lt, <)
DEFINE_STRING_CMP(gt, >)
DEFINE_STRING_CMP(le, <=)
DEFINE_STRING_CMP(ge, >=)
static pic_value
pic_str_string_copy(pic_state *pic)
{
pic_str *str;
int n, start, end;
n = pic_get_args(pic, "s|ii", &str, &start, &end);
switch (n) {
case 1:
start = 0;
case 2:
end = pic_strlen(str);
}
return pic_obj_value(pic_substr(pic, str, start, end));
}
static pic_value
pic_str_string_copy_ip(pic_state *pic)
{
pic_str *to, *from;
int n, at, start, end;
n = pic_get_args(pic, "sis|ii", &to, &at, &from, &start, &end);
switch (n) {
case 3:
start = 0;
case 4:
end = pic_strlen(from);
}
if (to == from) {
from = pic_substr(pic, from, 0, end);
}
while (start < end) {
pic_str_set(pic, to, at++, pic_str_ref(pic, from, start++));
}
return pic_none_value();
}
static pic_value
pic_str_string_append(pic_state *pic)
{
size_t argc, i;
pic_value *argv;
pic_str *str;
pic_get_args(pic, "*", &argc, &argv);
str = pic_str_new(pic, NULL, 0);
for (i = 0; i < argc; ++i) {
if (! pic_str_p(argv[i])) {
pic_error(pic, "type error");
}
str = pic_strcat(pic, str, pic_str_ptr(argv[i]));
}
return pic_obj_value(str);
}
static pic_value
pic_str_string_fill_ip(pic_state *pic)
{
pic_str *str;
char c;
int n, start, end;
n = pic_get_args(pic, "sc|ii", &str, &c, &start, &end);
switch (n) {
case 2:
start = 0;
case 3:
end = pic_strlen(str);
}
while (start < end) {
pic_str_set(pic, str, start++, c);
}
return pic_none_value();
}
void
pic_init_str(pic_state *pic)
{
pic_defun(pic, "string?", pic_str_string_p);
pic_defun(pic, "make-string", pic_str_make_string);
pic_defun(pic, "string-length", pic_str_string_length);
pic_defun(pic, "string-ref", pic_str_string_ref);
pic_defun(pic, "string-set!", pic_str_string_set);
pic_defun(pic, "string=?", pic_str_string_eq);
pic_defun(pic, "string<?", pic_str_string_lt);
pic_defun(pic, "string>?", pic_str_string_gt);
pic_defun(pic, "string<=?", pic_str_string_le);
pic_defun(pic, "string>=?", pic_str_string_ge);
pic_defun(pic, "string-copy", pic_str_string_copy);
pic_defun(pic, "string-copy!", pic_str_string_copy_ip);
pic_defun(pic, "string-append", pic_str_string_append);
pic_defun(pic, "string-fill!", pic_str_string_fill_ip);
pic_defun(pic, "substring", pic_str_string_copy);
}

161
src/symbol.c
View File

@ -1,161 +0,0 @@
/**
* See Copyright Notice in picrin.h
*/
#include <string.h>
#include <stdlib.h>
#include <math.h>
#include "picrin.h"
#include "picrin/string.h"
pic_sym
pic_intern(pic_state *pic, const char *str, size_t len)
{
char *cstr;
xh_entry *e;
pic_sym id;
cstr = (char *)pic_malloc(pic, len + 1);
cstr[len] = '\0';
memcpy(cstr, str, len);
e = xh_get_str(&pic->syms, cstr);
if (e) {
return xh_val(e, pic_sym);
}
id = pic->sym_cnt++;
xh_put_str(&pic->syms, cstr, &id);
xh_put_int(&pic->sym_names, id, &cstr);
return id;
}
pic_sym
pic_intern_cstr(pic_state *pic, const char *str)
{
return pic_intern(pic, str, strlen(str));
}
pic_sym
pic_gensym(pic_state *pic, pic_sym base)
{
int uid = pic->uniq_sym_cnt++, len;
char *str, mark;
pic_sym uniq;
if (pic_interned_p(pic, base)) {
mark = '@';
} else {
mark = '.';
}
len = snprintf(NULL, 0, "%s%c%d", pic_symbol_name(pic, base), mark, uid);
str = pic_alloc(pic, len + 1);
sprintf(str, "%s%c%d", pic_symbol_name(pic, base), mark, uid);
/* don't put the symbol to pic->syms to keep it uninterned */
uniq = pic->sym_cnt++;
xh_put_int(&pic->sym_names, uniq, &str);
return uniq;
}
pic_sym
pic_ungensym(pic_state *pic, pic_sym base)
{
const char *name, *occr;
if (pic_interned_p(pic, base)) {
return base;
}
name = pic_symbol_name(pic, base);
if ((occr = strrchr(name, '@')) == NULL) {
pic_abort(pic, "logic flaw");
}
return pic_intern(pic, name, occr - name);
}
bool
pic_interned_p(pic_state *pic, pic_sym sym)
{
return sym == pic_intern_cstr(pic, pic_symbol_name(pic, sym));
}
const char *
pic_symbol_name(pic_state *pic, pic_sym sym)
{
return xh_val(xh_get_int(&pic->sym_names, sym), const char *);
}
static pic_value
pic_symbol_symbol_p(pic_state *pic)
{
pic_value v;
pic_get_args(pic, "o", &v);
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)
{
pic_value v;
pic_get_args(pic, "o", &v);
if (! pic_sym_p(v)) {
pic_error(pic, "symbol->string: expected symbol");
}
return pic_obj_value(pic_str_new_cstr(pic, pic_symbol_name(pic, pic_sym(v))));
}
static pic_value
pic_symbol_string_to_symbol(pic_state *pic)
{
pic_value v;
pic_get_args(pic, "o", &v);
if (! pic_str_p(v)) {
pic_error(pic, "string->symbol: expected string");
}
return pic_symbol_value(pic_intern_cstr(pic, pic_str_cstr(pic_str_ptr(v))));
}
void
pic_init_symbol(pic_state *pic)
{
pic_deflibrary (pic, "(picrin base symbol)") {
pic_defun(pic, "symbol?", pic_symbol_symbol_p);
pic_defun(pic, "symbol->string", pic_symbol_symbol_to_string);
pic_defun(pic, "string->symbol", pic_symbol_string_to_symbol);
}
pic_deflibrary (pic, "(picrin symbol)") {
pic_defun(pic, "symbol=?", pic_symbol_symbol_eq_p);
}
}

134
src/var.c
View File

@ -1,134 +0,0 @@
/**
* See Copyright Notice in picrin.h
*/
#include "picrin.h"
#include "picrin/var.h"
#include "picrin/pair.h"
struct pic_var *
pic_var_new(pic_state *pic, pic_value init, struct pic_proc *conv)
{
struct pic_var *var;
var = (struct pic_var *)pic_obj_alloc(pic, sizeof(struct pic_var), PIC_TT_VAR);
var->stack = pic_nil_value();
var->conv = conv;
pic_var_push(pic, var, init);
return var;
}
pic_value
pic_var_ref(pic_state *pic, struct pic_var *var)
{
return pic_car(pic, var->stack);
}
void
pic_var_set(pic_state *pic, struct pic_var *var, pic_value value)
{
if (var->conv != NULL) {
value = pic_apply1(pic, var->conv, value);
}
pic_set_car(pic, var->stack, value);
}
void
pic_var_push(pic_state *pic, struct pic_var *var, pic_value value)
{
if (var->conv != NULL) {
value = pic_apply1(pic, var->conv, value);
}
var->stack = pic_cons(pic, value, var->stack);
}
void
pic_var_pop(pic_state *pic, struct pic_var *var)
{
var->stack = pic_cdr(pic, var->stack);
}
static pic_value
pic_var_make_parameter(pic_state *pic)
{
struct pic_proc *conv = NULL;
pic_value init;
pic_get_args(pic, "o|l", &init, &conv);
return pic_obj_value(pic_var_new(pic, init, conv));
}
static pic_value
pic_var_parameter_ref(pic_state *pic)
{
struct pic_var *var;
pic_value v;
pic_get_args(pic, "o", &v);
pic_assert_type(pic, v, var);
var = pic_var_ptr(v);
return pic_var_ref(pic, var);
}
static pic_value
pic_var_parameter_set(pic_state *pic)
{
struct pic_var *var;
pic_value v, val;
pic_get_args(pic, "oo", &v, &val);
pic_assert_type(pic, v, var);
var = pic_var_ptr(v);
pic_var_set(pic, var, val);
return pic_none_value();
}
static pic_value
pic_var_parameter_push(pic_state *pic)
{
struct pic_var *var;
pic_value v, val;
pic_get_args(pic, "oo", &v, &val);
pic_assert_type(pic, v, var);
var = pic_var_ptr(v);
pic_var_push(pic, var, val);
return pic_none_value();
}
static pic_value
pic_var_parameter_pop(pic_state *pic)
{
struct pic_var *var;
pic_value v;
pic_get_args(pic, "o", &v);
pic_assert_type(pic, v, var);
var = pic_var_ptr(v);
pic_var_pop(pic, var);
return pic_none_value();
}
void
pic_init_var(pic_state *pic)
{
pic_deflibrary (pic, "(picrin parameter)") {
pic_defun(pic, "make-parameter", pic_var_make_parameter);
pic_defun(pic, "parameter-ref", pic_var_parameter_ref);
pic_defun(pic, "parameter-set!", pic_var_parameter_set);
pic_defun(pic, "parameter-push!", pic_var_parameter_push);
pic_defun(pic, "parameter-pop!", pic_var_parameter_pop);
}
}

283
src/vector.c
View File

@ -1,283 +0,0 @@
/**
* See Copyright Notice in picrin.h
*/
#include "picrin.h"
#include "picrin/vector.h"
#include "picrin/pair.h"
struct pic_vector *
pic_vec_new(pic_state *pic, size_t len)
{
struct pic_vector *vec;
size_t i;
vec = (struct pic_vector *)pic_obj_alloc(pic, sizeof(struct pic_vector), PIC_TT_VECTOR);
vec->len = len;
vec->data = (pic_value *)pic_alloc(pic, sizeof(pic_value) * len);
for (i = 0; i < len; ++i) {
vec->data[i] = pic_none_value();
}
return vec;
}
struct pic_vector *
pic_vec_new_from_list(pic_state *pic, pic_value data)
{
struct pic_vector *vec;
size_t i, len;
len = pic_length(pic, data);
vec = pic_vec_new(pic, len);
for (i = 0; i < len; ++i) {
vec->data[i] = pic_car(pic, data);
data = pic_cdr(pic, data);
}
return vec;
}
void
pic_vec_extend_ip(pic_state *pic, struct pic_vector *vec, size_t size)
{
size_t len, i;
len = vec->len;
vec->len = size;
vec->data = (pic_value *)pic_realloc(pic, vec->data, sizeof(pic_value) * size);
for (i = len; i < size; ++i) {
vec->data[i] = pic_none_value();
}
}
static pic_value
pic_vec_vector_p(pic_state *pic)
{
pic_value v;
pic_get_args(pic, "o", &v);
return pic_bool_value(pic_vec_p(v));
}
static pic_value
pic_vec_make_vector(pic_state *pic)
{
pic_value v;
int n, k;
size_t i;
struct pic_vector *vec;
n = pic_get_args(pic, "i|o", &k, &v);
vec = pic_vec_new(pic, k);
if (n == 2) {
for (i = 0; i < (size_t)k; ++i) {
vec->data[i] = v;
}
}
return pic_obj_value(vec);
}
static pic_value
pic_vec_vector_length(pic_state *pic)
{
struct pic_vector *v;
pic_get_args(pic, "v", &v);
return pic_int_value(v->len);
}
static pic_value
pic_vec_vector_ref(pic_state *pic)
{
struct pic_vector *v;
int k;
pic_get_args(pic, "vi", &v, &k);
if (k < 0 || v->len <= (size_t)k) {
pic_error(pic, "vector-ref: index out of range");
}
return v->data[k];
}
static pic_value
pic_vec_vector_set(pic_state *pic)
{
struct pic_vector *v;
int k;
pic_value o;
pic_get_args(pic, "vio", &v, &k, &o);
if (k < 0 || v->len <= (size_t)k) {
pic_error(pic, "vector-set!: index out of range");
}
v->data[k] = o;
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)
{
pic_defun(pic, "vector?", pic_vec_vector_p);
pic_defun(pic, "make-vector", pic_vec_make_vector);
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);
}

1069
src/vm.c
View File

File diff suppressed because it is too large Load Diff

506
src/write.c
View File

@ -1,506 +0,0 @@
/**
* See Copyright Notice in picrin.h
*/
#include <math.h>
#include "picrin.h"
#include "picrin/port.h"
#include "picrin/pair.h"
#include "picrin/string.h"
#include "picrin/vector.h"
#include "picrin/blob.h"
#include "picrin/dict.h"
#include "picrin/record.h"
#include "picrin/proc.h"
static bool
is_tagged(pic_state *pic, pic_sym tag, pic_value pair)
{
return pic_pair_p(pic_cdr(pic, pair))
&& pic_nil_p(pic_cddr(pic, pair))
&& pic_eq_p(pic_car(pic, pair), pic_symbol_value(tag));
}
static bool
is_quote(pic_state *pic, pic_value pair)
{
return is_tagged(pic, pic->sQUOTE, pair);
}
static bool
is_unquote(pic_state *pic, pic_value pair)
{
return is_tagged(pic, pic->sUNQUOTE, pair);
}
static bool
is_unquote_splicing(pic_state *pic, pic_value pair)
{
return is_tagged(pic, pic->sUNQUOTE_SPLICING, pair);
}
static bool
is_quasiquote(pic_state *pic, pic_value pair)
{
return is_tagged(pic, pic->sQUASIQUOTE, pair);
}
struct writer_control {
pic_state *pic;
xFILE *file;
int mode;
xhash labels; /* object -> int */
xhash visited; /* object -> int */
int cnt;
};
#define WRITE_MODE 1
#define DISPLAY_MODE 2
static void
writer_control_init(struct writer_control *p, pic_state *pic, xFILE *file, int mode)
{
p->pic = pic;
p->file = file;
p->mode = mode;
p->cnt = 0;
xh_init_ptr(&p->labels, sizeof(int));
xh_init_ptr(&p->visited, sizeof(int));
}
static void
writer_control_destroy(struct writer_control *p)
{
xh_destroy(&p->labels);
xh_destroy(&p->visited);
}
static void
traverse_shared(struct writer_control *p, pic_value obj)
{
xh_entry *e;
size_t i;
int c;
switch (pic_type(obj)) {
case PIC_TT_PAIR:
case PIC_TT_VECTOR:
e = xh_get_ptr(&p->labels, pic_obj_ptr(obj));
if (e == NULL) {
c = -1;
xh_put_ptr(&p->labels, pic_obj_ptr(obj), &c);
}
else if (xh_val(e, int) == -1) {
c = p->cnt++;
xh_put_ptr(&p->labels, pic_obj_ptr(obj), &c);
break;
}
else {
break;
}
if (pic_pair_p(obj)) {
traverse_shared(p, pic_car(p->pic, obj));
traverse_shared(p, pic_cdr(p->pic, obj));
}
else {
for (i = 0; i < pic_vec_ptr(obj)->len; ++i) {
traverse_shared(p, pic_vec_ptr(obj)->data[i]);
}
}
break;
default:
/* pass */
break;
}
}
static void write_core(struct writer_control *p, pic_value);
static void
write_pair(struct writer_control *p, struct pic_pair *pair)
{
xh_entry *e;
int c;
write_core(p, pair->car);
if (pic_nil_p(pair->cdr)) {
return;
}
else if (pic_pair_p(pair->cdr)) {
/* shared objects */
if ((e = xh_get_ptr(&p->labels, pic_obj_ptr(pair->cdr))) && xh_val(e, int) != -1) {
xfprintf(p->file, " . ");
if ((xh_get_ptr(&p->visited, pic_obj_ptr(pair->cdr)))) {
xfprintf(p->file, "#%d#", xh_val(e, int));
return;
}
else {
xfprintf(p->file, "#%d=", xh_val(e, int));
c = 1;
xh_put_ptr(&p->visited, pic_obj_ptr(pair->cdr), &c);
}
}
else {
xfprintf(p->file, " ");
}
write_pair(p, pic_pair_ptr(pair->cdr));
return;
}
else {
xfprintf(p->file, " . ");
write_core(p, pair->cdr);
}
}
static void
write_str(pic_state *pic, struct pic_string *str, xFILE *file)
{
size_t i;
const char *cstr = pic_str_cstr(str);
UNUSED(pic);
for (i = 0; i < pic_strlen(str); ++i) {
if (cstr[i] == '"' || cstr[i] == '\\') {
xfputc('\\', file);
}
xfputc(cstr[i], file);
}
}
static void
write_record(pic_state *pic, struct pic_record *rec, xFILE *file)
{
const pic_sym sWRITER = pic_intern_cstr(pic, "writer");
pic_value type, writer, str;
#if DEBUG
xfprintf(file, "#<record %p>", rec);
#else
type = pic_record_type(pic, rec);
if (! pic_record_p(type)) {
pic_errorf(pic, "\"@@type\" property of record object is not of record type");
}
writer = pic_record_ref(pic, pic_record_ptr(type), sWRITER);
if (! pic_proc_p(writer)) {
pic_errorf(pic, "\"writer\" property of record type object is not a procedure");
}
str = pic_apply1(pic, pic_proc_ptr(writer), pic_obj_value(rec));
if (! pic_str_p(str)) {
pic_errorf(pic, "return value from writer procedure is not of string type");
}
xfprintf(file, "%s", pic_str_cstr(pic_str_ptr(str)));
#endif
}
static void
write_core(struct writer_control *p, pic_value obj)
{
pic_state *pic = p->pic;
xFILE *file = p->file;
size_t i;
xh_entry *e;
xh_iter it;
int c;
float f;
/* shared objects */
if (pic_vtype(obj) == PIC_VTYPE_HEAP
&& (e = xh_get_ptr(&p->labels, pic_obj_ptr(obj)))
&& xh_val(e, int) != -1) {
if ((xh_get_ptr(&p->visited, pic_obj_ptr(obj)))) {
xfprintf(file, "#%d#", xh_val(e, int));
return;
}
else {
xfprintf(file, "#%d=", xh_val(e, int));
c = 1;
xh_put_ptr(&p->visited, pic_obj_ptr(obj), &c);
}
}
switch (pic_type(obj)) {
case PIC_TT_UNDEF:
xfprintf(file, "#<undef>");
break;
case PIC_TT_NIL:
xfprintf(file, "()");
break;
case PIC_TT_BOOL:
if (pic_true_p(obj))
xfprintf(file, "#t");
else
xfprintf(file, "#f");
break;
case PIC_TT_PAIR:
if (is_quote(pic, obj)) {
xfprintf(file, "'");
write_core(p, pic_list_ref(pic, obj, 1));
break;
}
else if (is_unquote(pic, obj)) {
xfprintf(file, ",");
write_core(p, pic_list_ref(pic, obj, 1));
break;
}
else if (is_unquote_splicing(pic, obj)) {
xfprintf(file, ",@");
write_core(p, pic_list_ref(pic, obj, 1));
break;
}
else if (is_quasiquote(pic, obj)) {
xfprintf(file, "`");
write_core(p, pic_list_ref(pic, obj, 1));
break;
}
xfprintf(file, "(");
write_pair(p, pic_pair_ptr(obj));
xfprintf(file, ")");
break;
case PIC_TT_SYMBOL:
xfprintf(file, "%s", pic_symbol_name(pic, pic_sym(obj)));
break;
case PIC_TT_CHAR:
if (p->mode == DISPLAY_MODE) {
xfputc(pic_char(obj), file);
break;
}
switch (pic_char(obj)) {
default: xfprintf(file, "#\\%c", pic_char(obj)); break;
case '\a': xfprintf(file, "#\\alarm"); break;
case '\b': xfprintf(file, "#\\backspace"); break;
case 0x7f: xfprintf(file, "#\\delete"); break;
case 0x1b: xfprintf(file, "#\\escape"); break;
case '\n': xfprintf(file, "#\\newline"); break;
case '\r': xfprintf(file, "#\\return"); break;
case ' ': xfprintf(file, "#\\space"); break;
case '\t': xfprintf(file, "#\\tab"); break;
}
break;
case PIC_TT_FLOAT:
f = pic_float(obj);
if (isnan(f)) {
xfprintf(file, signbit(f) ? "-nan.0" : "+nan.0");
} else if (isinf(f)) {
xfprintf(file, signbit(f) ? "-inf.0" : "+inf.0");
} else {
xfprintf(file, "%f", pic_float(obj));
}
break;
case PIC_TT_INT:
xfprintf(file, "%d", pic_int(obj));
break;
case PIC_TT_EOF:
xfprintf(file, "#.(eof-object)");
break;
case PIC_TT_STRING:
if (p->mode == DISPLAY_MODE) {
xfprintf(file, "%s", pic_str_cstr(pic_str_ptr(obj)));
break;
}
xfprintf(file, "\"");
write_str(pic, pic_str_ptr(obj), file);
xfprintf(file, "\"");
break;
case PIC_TT_VECTOR:
xfprintf(file, "#(");
for (i = 0; i < pic_vec_ptr(obj)->len; ++i) {
write_core(p, pic_vec_ptr(obj)->data[i]);
if (i + 1 < pic_vec_ptr(obj)->len) {
xfprintf(file, " ");
}
}
xfprintf(file, ")");
break;
case PIC_TT_BLOB:
xfprintf(file, "#u8(");
for (i = 0; i < pic_blob_ptr(obj)->len; ++i) {
xfprintf(file, "%d", pic_blob_ptr(obj)->data[i]);
if (i + 1 < pic_blob_ptr(obj)->len) {
xfprintf(file, " ");
}
}
xfprintf(file, ")");
break;
case PIC_TT_DICT:
xfprintf(file, "#.(dictionary");
xh_begin(&it, &pic_dict_ptr(obj)->hash);
while (xh_next(&it)) {
xfprintf(file, " '%s ", pic_symbol_name(pic, xh_key(it.e, pic_sym)));
write_core(p, xh_val(it.e, pic_value));
}
xfprintf(file, ")");
break;
case PIC_TT_RECORD:
write_record(pic, pic_record_ptr(obj), file);
break;
default:
xfprintf(file, "#<%s %p>", pic_type_repr(pic_type(obj)), pic_ptr(obj));
break;
}
}
static void
write(pic_state *pic, pic_value obj, xFILE *file)
{
struct writer_control p;
writer_control_init(&p, pic, file, WRITE_MODE);
traverse_shared(&p, obj); /* FIXME */
write_core(&p, obj);
writer_control_destroy(&p);
}
static void
write_simple(pic_state *pic, pic_value obj, xFILE *file)
{
struct writer_control p;
writer_control_init(&p, pic, file, WRITE_MODE);
/* no traverse here! */
write_core(&p, obj);
writer_control_destroy(&p);
}
static void
write_shared(pic_state *pic, pic_value obj, xFILE *file)
{
struct writer_control p;
writer_control_init(&p, pic, file, WRITE_MODE);
traverse_shared(&p, obj);
write_core(&p, obj);
writer_control_destroy(&p);
}
static void
display(pic_state *pic, pic_value obj, xFILE *file)
{
struct writer_control p;
writer_control_init(&p, pic, file, DISPLAY_MODE);
traverse_shared(&p, obj); /* FIXME */
write_core(&p, obj);
writer_control_destroy(&p);
}
pic_value
pic_write(pic_state *pic, pic_value obj)
{
return pic_fwrite(pic, obj, xstdout);
}
pic_value
pic_fwrite(pic_state *pic, pic_value obj, xFILE *file)
{
write(pic, obj, file);
xfflush(file);
return obj;
}
pic_value
pic_display(pic_state *pic, pic_value obj)
{
return pic_fdisplay(pic, obj, xstdout);
}
pic_value
pic_fdisplay(pic_state *pic, pic_value obj, xFILE *file)
{
display(pic, obj, file);
xfflush(file);
return obj;
}
void
pic_printf(pic_state *pic, const char *fmt, ...)
{
va_list ap;
pic_str *str;
va_start(ap, fmt);
str = pic_str_ptr(pic_car(pic, pic_vformat(pic, fmt, ap)));
va_end(ap);
xprintf("%s", pic_str_cstr(str));
xfflush(xstdout);
}
static pic_value
pic_write_write(pic_state *pic)
{
pic_value v;
struct pic_port *port = pic_stdout(pic);
pic_get_args(pic, "o|p", &v, &port);
write(pic, v, port->file);
return pic_none_value();
}
static pic_value
pic_write_write_simple(pic_state *pic)
{
pic_value v;
struct pic_port *port = pic_stdout(pic);
pic_get_args(pic, "o|p", &v, &port);
write_simple(pic, v, port->file);
return pic_none_value();
}
static pic_value
pic_write_write_shared(pic_state *pic)
{
pic_value v;
struct pic_port *port = pic_stdout(pic);
pic_get_args(pic, "o|p", &v, &port);
write_shared(pic, v, port->file);
return pic_none_value();
}
static pic_value
pic_write_display(pic_state *pic)
{
pic_value v;
struct pic_port *port = pic_stdout(pic);
pic_get_args(pic, "o|p", &v, &port);
display(pic, v, port->file);
return pic_none_value();
}
void
pic_init_write(pic_state *pic)
{
pic_deflibrary (pic, "(scheme write)") {
pic_defun(pic, "write", pic_write_write);
pic_defun(pic, "write-simple", pic_write_write_simple);
pic_defun(pic, "write-shared", pic_write_write_shared);
pic_defun(pic, "display", pic_write_display);
}
}