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

add value.h

This commit is contained in:
Yuichi Nishiwaki 2017-03-29 07:11:27 +09:00
parent f7484c089f
commit b44d69b4da
35 changed files with 775 additions and 575 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
Makefile
View File

@ -17,7 +17,6 @@ LIBPICRIN_SRCS = \
lib/state.c\ lib/state.c\
lib/string.c\ lib/string.c\
lib/symbol.c\ lib/symbol.c\
lib/value.c\
lib/var.c\ lib/var.c\
lib/vector.c\ lib/vector.c\
lib/weak.c\ lib/weak.c\
@ -77,7 +76,7 @@ src/init_contrib.c:
lib/boot.c: piclib/boot.scm lib/boot.c: piclib/boot.scm
bin/picrin-bootstrap tools/mkboot.scm < piclib/boot.scm > lib/boot.c bin/picrin-bootstrap tools/mkboot.scm < piclib/boot.scm > lib/boot.c
$(LIBPICRIN_OBJS) $(PICRIN_OBJS) $(CONTRIB_OBJS): lib/include/picrin.h lib/include/picrin/*.h lib/khash.h lib/object.h lib/state.h lib/vm.h $(LIBPICRIN_OBJS) $(PICRIN_OBJS) $(CONTRIB_OBJS): lib/include/picrin.h lib/include/picrin/*.h lib/khash.h lib/value.h lib/object.h lib/state.h lib/vm.h
doc: docs/*.rst docs/contrib.rst doc: docs/*.rst docs/contrib.rst
$(MAKE) -C docs html $(MAKE) -C docs html

1
contrib/10.callcc/callcc.c
View File

@ -1,4 +1,5 @@
#include "picrin.h" #include "picrin.h"
#include "value.h"
#include "object.h" #include "object.h"
#include "state.h" #include "state.h"

18
contrib/20.r7rs/src/system.c
View File

@ -33,15 +33,10 @@ pic_system_exit(pic_state *pic)
argc = pic_get_args(pic, "|o", &v); argc = pic_get_args(pic, "|o", &v);
if (argc == 1) { if (argc == 1) {
switch (pic_type(pic, v)) { if (pic_float_p(pic, v)) {
case PIC_TYPE_FLOAT:
status = (int)pic_float(pic, v); status = (int)pic_float(pic, v);
break; } else if (pic_int_p(pic, v)) {
case PIC_TYPE_INT:
status = pic_int(pic, v); status = pic_int(pic, v);
break;
default:
break;
} }
} }
@ -58,15 +53,10 @@ pic_system_emergency_exit(pic_state *pic)
argc = pic_get_args(pic, "|o", &v); argc = pic_get_args(pic, "|o", &v);
if (argc == 1) { if (argc == 1) {
switch (pic_type(pic, v)) { if (pic_float_p(pic, v)) {
case PIC_TYPE_FLOAT:
status = (int)pic_float(pic, v); status = (int)pic_float(pic, v);
break; } else if (pic_int_p(pic, v)) {
case PIC_TYPE_INT:
status = pic_int(pic, v); status = pic_int(pic, v);
break;
default:
break;
} }
} }

15
contrib/40.srfi/src/106.c
View File

@ -18,7 +18,7 @@ struct pic_socket_t {
int fd; int fd;
}; };
PIC_INLINE void PIC_STATIC_INLINE void
socket_close(struct pic_socket_t *sock) socket_close(struct pic_socket_t *sock)
{ {
if (sock != NULL && sock->fd != -1) { if (sock != NULL && sock->fd != -1) {
@ -27,7 +27,7 @@ socket_close(struct pic_socket_t *sock)
} }
} }
PIC_INLINE void PIC_STATIC_INLINE void
ensure_socket_is_open(pic_state *pic, struct pic_socket_t *sock) ensure_socket_is_open(pic_state *pic, struct pic_socket_t *sock)
{ {
if (sock != NULL && sock->fd == -1) { if (sock != NULL && sock->fd == -1) {
@ -297,10 +297,17 @@ xf_socket_close(pic_state *PIC_UNUSED(pic), void *PIC_UNUSED(cookie))
static pic_value static pic_value
make_socket_port(pic_state *pic, struct pic_socket_t *sock, const char *mode) make_socket_port(pic_state *pic, struct pic_socket_t *sock, const char *mode)
{ {
static const pic_port_type xf_socket_rd = {
xf_socket_read, 0, xf_socket_seek, xf_socket_close
};
static const pic_port_type xf_socket_wr = {
0, xf_socket_write, xf_socket_seek, xf_socket_close
};
if (*mode == 'r') { if (*mode == 'r') {
return pic_funopen(pic, sock, xf_socket_read, 0, xf_socket_seek, xf_socket_close); return pic_funopen(pic, sock, &xf_socket_rd);
} else { } else {
return pic_funopen(pic, sock, 0, xf_socket_write, xf_socket_seek, xf_socket_close); return pic_funopen(pic, sock, &xf_socket_wr);
} }
} }

1
lib/blob.c
View File

@ -3,6 +3,7 @@
*/ */
#include "picrin.h" #include "picrin.h"
#include "value.h"
#include "object.h" #include "object.h"
pic_value pic_value

27
lib/bool.c
View File

@ -3,6 +3,7 @@
*/ */
#include "picrin.h" #include "picrin.h"
#include "value.h"
#include "object.h" #include "object.h"
#if PIC_NAN_BOXING #if PIC_NAN_BOXING
@ -10,13 +11,13 @@
bool bool
pic_eq_p(pic_state *PIC_UNUSED(pic), pic_value x, pic_value y) pic_eq_p(pic_state *PIC_UNUSED(pic), pic_value x, pic_value y)
{ {
return x == y; return x.v == y.v;
} }
bool bool
pic_eqv_p(pic_state *PIC_UNUSED(pic), pic_value x, pic_value y) pic_eqv_p(pic_state *PIC_UNUSED(pic), pic_value x, pic_value y)
{ {
return x == y; return x.v == y.v;
} }
#else #else
@ -24,36 +25,36 @@ pic_eqv_p(pic_state *PIC_UNUSED(pic), pic_value x, pic_value y)
bool bool
pic_eq_p(pic_state *PIC_UNUSED(pic), pic_value x, pic_value y) pic_eq_p(pic_state *PIC_UNUSED(pic), pic_value x, pic_value y)
{ {
if (pic_type(pic, x) != pic_type(pic, y)) if (value_type(pic, x) != value_type(pic, y))
return false; return false;
switch (pic_type(pic, x)) { switch (value_type(pic, x)) {
case PIC_TYPE_NIL: case PIC_TYPE_NIL:
return true; return true;
case PIC_TYPE_TRUE: case PIC_TYPE_FALSE: case PIC_TYPE_TRUE: case PIC_TYPE_FALSE:
return pic_type(pic, x) == pic_type(pic, y); return value_type(pic, x) == value_type(pic, y);
default: default:
return pic_obj_ptr(x) == pic_obj_ptr(y); return obj_ptr(x) == obj_ptr(y);
} }
} }
bool bool
pic_eqv_p(pic_state *PIC_UNUSED(pic), pic_value x, pic_value y) pic_eqv_p(pic_state *PIC_UNUSED(pic), pic_value x, pic_value y)
{ {
if (pic_type(pic, x) != pic_type(pic, y)) if (value_type(pic, x) != value_type(pic, y))
return false; return false;
switch (pic_type(pic, x)) { switch (value_type(pic, x)) {
case PIC_TYPE_NIL: case PIC_TYPE_NIL:
return true; return true;
case PIC_TYPE_TRUE: case PIC_TYPE_FALSE: case PIC_TYPE_TRUE: case PIC_TYPE_FALSE:
return pic_type(pic, x) == pic_type(pic, y); return value_type(pic, x) == value_type(pic, y);
case PIC_TYPE_FLOAT: case PIC_TYPE_FLOAT:
return pic_float(pic, x) == pic_float(pic, y); return pic_float(pic, x) == pic_float(pic, y);
case PIC_TYPE_INT: case PIC_TYPE_INT:
return pic_int(pic, x) == pic_int(pic, y); return pic_int(pic, x) == pic_int(pic, y);
default: default:
return pic_obj_ptr(x) == pic_obj_ptr(y); return obj_ptr(x) == obj_ptr(y);
} }
} }
@ -76,7 +77,7 @@ internal_equal_p(pic_state *pic, pic_value x, pic_value y, int depth, khash_t(m)
} }
if (pic_pair_p(pic, x) || pic_vec_p(pic, x)) { if (pic_pair_p(pic, x) || pic_vec_p(pic, x)) {
int ret; int ret;
kh_put(m, h, pic_obj_ptr(x), &ret); kh_put(m, h, obj_ptr(x), &ret);
if (ret != 0) { if (ret != 0) {
return true; /* `x' was seen already. */ return true; /* `x' was seen already. */
} }
@ -88,11 +89,11 @@ internal_equal_p(pic_state *pic, pic_value x, pic_value y, int depth, khash_t(m)
if (pic_eqv_p(pic, x, y)) { if (pic_eqv_p(pic, x, y)) {
return true; return true;
} }
if (pic_type(pic, x) != pic_type(pic, y)) { if (value_type(pic, x) != value_type(pic, y)) {
return false; return false;
} }
switch (pic_type(pic, x)) { switch (value_type(pic, x)) {
case PIC_TYPE_ID: { case PIC_TYPE_ID: {
struct identifier *id1, *id2; struct identifier *id1, *id2;
pic_value s1, s2; pic_value s1, s2;

1
lib/char.c
View File

@ -3,6 +3,7 @@
*/ */
#include "picrin.h" #include "picrin.h"
#include "value.h"
#include "object.h" #include "object.h"
static pic_value static pic_value

1
lib/cont.c
View File

@ -3,6 +3,7 @@
*/ */
#include "picrin.h" #include "picrin.h"
#include "value.h"
#include "object.h" #include "object.h"
#include "state.h" #include "state.h"

3
lib/data.c
View File

@ -3,12 +3,13 @@
*/ */
#include "picrin.h" #include "picrin.h"
#include "value.h"
#include "object.h" #include "object.h"
bool bool
pic_data_p(pic_state *pic, pic_value obj, const pic_data_type *type) pic_data_p(pic_state *pic, pic_value obj, const pic_data_type *type)
{ {
if (pic_type(pic, obj) != PIC_TYPE_DATA) { if (value_type(pic, obj) != PIC_TYPE_DATA) {
return false; return false;
} }
return type == NULL || pic_data_ptr(pic, obj)->type == type; return type == NULL || pic_data_ptr(pic, obj)->type == type;

1
lib/debug.c
View File

@ -3,6 +3,7 @@
*/ */
#include "picrin.h" #include "picrin.h"
#include "value.h"
#include "object.h" #include "object.h"
#include "state.h" #include "state.h"

1
lib/dict.c
View File

@ -3,6 +3,7 @@
*/ */
#include "picrin.h" #include "picrin.h"
#include "value.h"
#include "object.h" #include "object.h"
KHASH_DEFINE(dict, symbol *, pic_value, kh_ptr_hash_func, kh_ptr_hash_equal) KHASH_DEFINE(dict, symbol *, pic_value, kh_ptr_hash_func, kh_ptr_hash_equal)

3
lib/error.c
View File

@ -3,6 +3,7 @@
*/ */
#include "picrin.h" #include "picrin.h"
#include "value.h"
#include "object.h" #include "object.h"
#include "state.h" #include "state.h"
@ -101,7 +102,7 @@ pic_start_try(pic_state *pic, PIC_JMPBUF *jmp)
void void
pic_end_try(pic_state *pic, pic_value cookie) pic_end_try(pic_state *pic, pic_value cookie)
{ {
struct checkpoint *here = (struct checkpoint *)pic_obj_ptr(pic_car(pic, cookie)); struct checkpoint *here = pic_cp_ptr(pic, pic_car(pic, cookie));
pic_value out = pic_cdr(pic, cookie); pic_value out = pic_cdr(pic, cookie);
pic->cp = here; pic->cp = here;

11
lib/ext/eval.c
View File

@ -4,6 +4,7 @@
#include "picrin.h" #include "picrin.h"
#include "picrin/extra.h" #include "picrin/extra.h"
#include "value.h"
#include "object.h" #include "object.h"
#include "state.h" #include "state.h"
#include "vm.h" #include "vm.h"
@ -172,7 +173,7 @@ expand_defmacro(pic_state *pic, pic_value expr, pic_value env)
static pic_value static pic_value
expand_node(pic_state *pic, pic_value expr, pic_value env, pic_value deferred) expand_node(pic_state *pic, pic_value expr, pic_value env, pic_value deferred)
{ {
switch (pic_type(pic, expr)) { switch (value_type(pic, expr)) {
case PIC_TYPE_ID: case PIC_TYPE_ID:
case PIC_TYPE_SYMBOL: { case PIC_TYPE_SYMBOL: {
return expand_var(pic, expr, env, deferred); return expand_var(pic, expr, env, deferred);
@ -497,7 +498,7 @@ analyze_call(pic_state *pic, analyze_scope *scope, pic_value obj)
static pic_value static pic_value
analyze_node(pic_state *pic, analyze_scope *scope, pic_value obj) analyze_node(pic_state *pic, analyze_scope *scope, pic_value obj)
{ {
switch (pic_type(pic, obj)) { switch (value_type(pic, obj)) {
case PIC_TYPE_SYMBOL: { case PIC_TYPE_SYMBOL: {
return analyze_var(pic, scope, obj); return analyze_var(pic, scope, obj);
} }
@ -946,7 +947,7 @@ codegen_quote(pic_state *pic, codegen_context *cxt, pic_value obj, bool tailpos)
int pidx; int pidx;
obj = pic_list_ref(pic, obj, 1); obj = pic_list_ref(pic, obj, 1);
switch (pic_type(pic, obj)) { switch (value_type(pic, obj)) {
case PIC_TYPE_UNDEF: case PIC_TYPE_UNDEF:
emit_n(pic, cxt, OP_PUSHUNDEF); emit_n(pic, cxt, OP_PUSHUNDEF);
break; break;
@ -981,10 +982,10 @@ codegen_quote(pic_state *pic, codegen_context *cxt, pic_value obj, bool tailpos)
emit_i(pic, cxt, OP_PUSHCHAR, pidx); emit_i(pic, cxt, OP_PUSHCHAR, pidx);
break; break;
default: default:
assert(pic_obj_p(pic,obj)); assert(obj_p(pic,obj));
check_pool_size(pic, cxt); check_pool_size(pic, cxt);
pidx = (int)cxt->plen++; pidx = (int)cxt->plen++;
cxt->pool[pidx] = pic_obj_ptr(obj); cxt->pool[pidx] = obj_ptr(obj);
emit_i(pic, cxt, OP_PUSHCONST, pidx); emit_i(pic, cxt, OP_PUSHCONST, pidx);
break; break;
} }

1
lib/ext/lib.c
View File

@ -4,6 +4,7 @@
#include "picrin.h" #include "picrin.h"
#include "picrin/extra.h" #include "picrin/extra.h"
#include "value.h"
#include "object.h" #include "object.h"
#include "state.h" #include "state.h"

1
lib/ext/read.c
View File

@ -4,6 +4,7 @@
#include "picrin.h" #include "picrin.h"
#include "picrin/extra.h" #include "picrin/extra.h"
#include "value.h"
#include "object.h" #include "object.h"
#undef EOF #undef EOF

68
lib/ext/write.c
View File

@ -4,6 +4,7 @@
#include "picrin.h" #include "picrin.h"
#include "picrin/extra.h" #include "picrin/extra.h"
#include "value.h"
#include "object.h" #include "object.h"
struct writer_control { struct writer_control {
@ -169,7 +170,7 @@ traverse(pic_state *pic, pic_value obj, struct writer_control *p)
return; return;
} }
switch (pic_type(pic, obj)) { switch (value_type(pic, obj)) {
case PIC_TYPE_PAIR: case PIC_TYPE_PAIR:
case PIC_TYPE_VECTOR: case PIC_TYPE_VECTOR:
case PIC_TYPE_DICT: { case PIC_TYPE_DICT: {
@ -217,7 +218,7 @@ static bool
is_shared_object(pic_state *pic, pic_value obj, struct writer_control *p) { is_shared_object(pic_state *pic, pic_value obj, struct writer_control *p) {
pic_value shared = p->shared; pic_value shared = p->shared;
if (! pic_obj_p(pic, obj)) { if (! obj_p(pic, obj)) {
return false; return false;
} }
if (! pic_weak_has(pic, shared, obj)) { if (! pic_weak_has(pic, shared, obj)) {
@ -409,6 +410,65 @@ write_dict(pic_state *pic, pic_value dict, pic_value port, struct writer_control
pic_fprintf(pic, port, ")"); pic_fprintf(pic, port, ")");
} }
static const char *
typename(pic_state *pic, pic_value obj)
{
switch (value_type(pic, obj)) {
case PIC_TYPE_NIL:
return "null";
case PIC_TYPE_TRUE:
case PIC_TYPE_FALSE:
return "boolean";
case PIC_TYPE_FLOAT:
return "float";
case PIC_TYPE_INT:
return "int";
case PIC_TYPE_SYMBOL:
return "symbol";
case PIC_TYPE_CHAR:
return "char";
case PIC_TYPE_EOF:
return "eof-object";
case PIC_TYPE_UNDEF:
return "undefined";
case PIC_TYPE_INVALID:
return "invalid";
case PIC_TYPE_PAIR:
return "pair";
case PIC_TYPE_STRING:
return "string";
case PIC_TYPE_VECTOR:
return "vector";
case PIC_TYPE_BLOB:
return "bytevector";
case PIC_TYPE_PORT:
return "port";
case PIC_TYPE_ERROR:
return "error";
case PIC_TYPE_ID:
return "identifier";
case PIC_TYPE_CXT:
return "context";
case PIC_TYPE_FUNC:
case PIC_TYPE_IREP:
return "procedure";
case PIC_TYPE_ENV:
return "environment";
case PIC_TYPE_DATA:
return "data";
case PIC_TYPE_DICT:
return "dictionary";
case PIC_TYPE_WEAK:
return "ephemeron";
case PIC_TYPE_RECORD:
return "record";
case PIC_TYPE_CP:
return "checkpoint";
default:
pic_error(pic, "typename: invalid type given", 1, obj);
}
}
static void static void
write_core(pic_state *pic, pic_value obj, pic_value port, struct writer_control *p) write_core(pic_state *pic, pic_value obj, pic_value port, struct writer_control *p)
{ {
@ -426,7 +486,7 @@ write_core(pic_state *pic, pic_value obj, pic_value port, struct writer_control
pic_weak_set(pic, labels, obj, pic_int_value(pic, i)); pic_weak_set(pic, labels, obj, pic_int_value(pic, i));
} }
switch (pic_type(pic, obj)) { switch (value_type(pic, obj)) {
case PIC_TYPE_UNDEF: case PIC_TYPE_UNDEF:
pic_fprintf(pic, port, "#undefined"); pic_fprintf(pic, port, "#undefined");
break; break;
@ -473,7 +533,7 @@ write_core(pic_state *pic, pic_value obj, pic_value port, struct writer_control
write_dict(pic, obj, port, p); write_dict(pic, obj, port, p);
break; break;
default: default:
pic_fprintf(pic, port, "#<%s %p>", pic_typename(pic, pic_type(pic, obj)), pic_obj_ptr(obj)); pic_fprintf(pic, port, "#<%s %p>", typename(pic, obj), obj_ptr(obj));
break; break;
} }

19
lib/gc.c
View File

@ -3,6 +3,7 @@
*/ */
#include "picrin.h" #include "picrin.h"
#include "value.h"
#include "object.h" #include "object.h"
#include "state.h" #include "state.h"
@ -168,10 +169,10 @@ gc_protect(pic_state *pic, struct object *obj)
pic_value pic_value
pic_protect(pic_state *pic, pic_value v) pic_protect(pic_state *pic, pic_value v)
{ {
if (! pic_obj_p(pic, v)) if (! obj_p(pic, v))
return v; return v;
gc_protect(pic, pic_obj_ptr(v)); gc_protect(pic, obj_ptr(v));
return v; return v;
} }
@ -305,10 +306,10 @@ static void gc_mark_object(pic_state *, struct object *);
static void static void
gc_mark(pic_state *pic, pic_value v) gc_mark(pic_state *pic, pic_value v)
{ {
if (! pic_obj_p(pic, v)) if (! obj_p(pic, v))
return; return;
gc_mark_object(pic, pic_obj_ptr(v)); gc_mark_object(pic, obj_ptr(v));
} }
static void static void
@ -326,8 +327,8 @@ gc_mark_object(pic_state *pic, struct object *obj)
switch (obj->u.basic.tt) { switch (obj->u.basic.tt) {
case PIC_TYPE_PAIR: { case PIC_TYPE_PAIR: {
gc_mark(pic, obj->u.pair.car); gc_mark(pic, obj->u.pair.car);
if (pic_obj_p(pic, obj->u.pair.cdr)) { if (obj_p(pic, obj->u.pair.cdr)) {
LOOP(pic_obj_ptr(obj->u.pair.cdr)); LOOP(obj_ptr(obj->u.pair.cdr));
} }
break; break;
} }
@ -416,8 +417,8 @@ gc_mark_object(pic_state *pic, struct object *obj)
} }
case PIC_TYPE_RECORD: { case PIC_TYPE_RECORD: {
gc_mark(pic, obj->u.rec.type); gc_mark(pic, obj->u.rec.type);
if (pic_obj_p(pic, obj->u.rec.datum)) { if (obj_p(pic, obj->u.rec.datum)) {
LOOP(pic_obj_ptr(obj->u.rec.datum)); LOOP(obj_ptr(obj->u.rec.datum));
} }
break; break;
} }
@ -531,7 +532,7 @@ gc_mark_phase(pic_state *pic)
key = kh_key(h, it); key = kh_key(h, it);
val = kh_val(h, it); val = kh_val(h, it);
if (is_marked(pic, key)) { if (is_marked(pic, key)) {
if (pic_obj_p(pic, val) && ! is_marked(pic, pic_obj_ptr(val))) { if (obj_p(pic, val) && ! is_marked(pic, obj_ptr(val))) {
gc_mark(pic, val); gc_mark(pic, val);
++j; ++j;
} }

355
lib/include/picrin.h
View File

@ -36,80 +36,103 @@ extern "C" {
typedef struct pic_state pic_state; typedef struct pic_state pic_state;
#if PIC_NAN_BOXING
# include <stdint.h>
typedef uint64_t pic_value;
#else
typedef struct { typedef struct {
unsigned char type; #if PIC_NAN_BOXING
uint64_t v;
#else
union { union {
void *data; void *data;
double f; double f;
int i; int i;
char c; char c;
} u; } u;
} pic_value; unsigned char type;
#endif #endif
} pic_value;
/*
* state manipulation
*/
typedef void *(*pic_allocf)(void *userdata, void *ptr, size_t n); typedef void *(*pic_allocf)(void *userdata, void *ptr, size_t n);
pic_state *pic_open(pic_allocf f, void *userdata); pic_state *pic_open(pic_allocf f, void *userdata);
void pic_close(pic_state *); void pic_close(pic_state *);
void pic_add_feature(pic_state *, const char *feature);
/*
* memory management
*/
void *pic_malloc(pic_state *, size_t); void *pic_malloc(pic_state *, size_t);
void *pic_realloc(pic_state *, void *, size_t); void *pic_realloc(pic_state *, void *, size_t);
void *pic_calloc(pic_state *, size_t, size_t); void *pic_calloc(pic_state *, size_t, size_t);
void pic_free(pic_state *, void *); void pic_free(pic_state *, void *);
/* for managed area: */
typedef pic_value (*pic_func_t)(pic_state *);
void *pic_alloca(pic_state *, size_t);
size_t pic_enter(pic_state *); size_t pic_enter(pic_state *);
void pic_leave(pic_state *, size_t); void pic_leave(pic_state *, size_t);
pic_value pic_protect(pic_state *, pic_value); pic_value pic_protect(pic_state *, pic_value);
void *pic_alloca(pic_state *, size_t);
void pic_gc(pic_state *); void pic_gc(pic_state *);
int pic_get_args(pic_state *, const char *fmt, ...);
void pic_defun(pic_state *, const char *name, pic_func_t f); /*
void pic_defvar(pic_state *, const char *name, pic_value v); * comparison
void pic_define(pic_state *, const char *lib, const char *name, pic_value v); */
pic_value pic_ref(pic_state *, const char *lib, const char *name);
void pic_set(pic_state *, const char *lib, const char *name, pic_value v);
pic_value pic_closure_ref(pic_state *, int i);
void pic_closure_set(pic_state *, int i, pic_value v);
pic_value pic_funcall(pic_state *, const char *lib, const char *name, int n, ...);
pic_value pic_make_var(pic_state *, pic_value init, pic_value conv);
pic_value pic_return(pic_state *, int n, ...); bool pic_eq_p(pic_state *, pic_value, pic_value);
pic_value pic_vreturn(pic_state *, int n, va_list); bool pic_eqv_p(pic_state *, pic_value, pic_value);
pic_value pic_valuesk(pic_state *, int n, pic_value *retv); bool pic_equal_p(pic_state *, pic_value, pic_value);
int pic_receive(pic_state *, int n, pic_value *retv);
void pic_make_library(pic_state *, const char *lib);
void pic_in_library(pic_state *, const char *lib);
bool pic_find_library(pic_state *, const char *lib);
const char *pic_current_library(pic_state *);
void pic_import(pic_state *, const char *lib);
void pic_export(pic_state *, pic_value sym);
typedef void (*pic_panicf)(pic_state *, const char *msg); /*
* number, boolean, character, string, bytevector, and userdata
*/
pic_panicf pic_atpanic(pic_state *, pic_panicf f); typedef struct {
PIC_NORETURN void pic_panic(pic_state *, const char *msg); const char *type_name;
PIC_NORETURN void pic_error(pic_state *, const char *msg, int n, ...); void (*dtor)(pic_state *, void *);
PIC_NORETURN void pic_raise(pic_state *, pic_value v); void (*mark)(pic_state *, void *, void (*)(pic_state *, pic_value));
pic_value pic_make_error(pic_state *, const char *type, const char *msg, pic_value irrs); } pic_data_type;
pic_value pic_lambda(pic_state *, pic_func_t f, int n, ...); typedef struct {
pic_value pic_vlambda(pic_state *, pic_func_t f, int n, va_list); int (*read)(pic_state *, void *, char *, int);
pic_value pic_call(pic_state *, pic_value proc, int, ...); int (*write)(pic_state *, void *, const char *, int);
pic_value pic_vcall(pic_state *, pic_value proc, int, va_list); long (*seek)(pic_state *, void *, long, int);
pic_value pic_apply(pic_state *, pic_value proc, int n, pic_value *argv); int (*close)(pic_state *, void *);
pic_value pic_applyk(pic_state *, pic_value proc, int n, pic_value *argv); } pic_port_type;
typedef pic_value (*pic_func_t)(pic_state *);
#include "value.h"
#include "object.h"
bool pic_undef_p(pic_state *, pic_value); /* deprecated */
bool pic_int_p(pic_state *, pic_value);
bool pic_float_p(pic_state *, pic_value);
bool pic_char_p(pic_state *, pic_value);
bool pic_true_p(pic_state *, pic_value);
bool pic_false_p(pic_state *, pic_value);
bool pic_bool_p(pic_state *, pic_value);
bool pic_str_p(pic_state *, pic_value);
bool pic_blob_p(pic_state *, pic_value);
bool pic_data_p(pic_state *, pic_value, const pic_data_type *);
/* constructors */
pic_value pic_undef_value(pic_state *);
pic_value pic_int_value(pic_state *, int);
pic_value pic_float_value(pic_state *, double);
pic_value pic_char_value(pic_state *, char);
pic_value pic_bool_value(pic_state *, bool);
pic_value pic_true_value(pic_state *);
pic_value pic_false_value(pic_state *);
pic_value pic_str_value(pic_state *, const char *str, int len);
#define pic_cstr_value(pic, cstr) pic_str_value(pic, (cstr), strlen(cstr))
#define pic_lit_value(pic, lit) pic_str_value(pic, "" lit, -((int)sizeof lit - 1))
pic_value pic_strf_value(pic_state *, const char *fmt, ...);
pic_value pic_vstrf_value(pic_state *, const char *fmt, va_list ap);
pic_value pic_blob_value(pic_state *, const unsigned char *buf, int len);
pic_value pic_data_value(pic_state *, void *ptr, const pic_data_type *type);
/* destructors */
int pic_int(pic_state *, pic_value i); int pic_int(pic_state *, pic_value i);
double pic_float(pic_state *, pic_value f); double pic_float(pic_state *, pic_value f);
char pic_char(pic_state *, pic_value c); char pic_char(pic_state *, pic_value c);
@ -118,90 +141,12 @@ const char *pic_str(pic_state *, pic_value str, int *len);
unsigned char *pic_blob(pic_state *, pic_value blob, int *len); unsigned char *pic_blob(pic_state *, pic_value blob, int *len);
void *pic_data(pic_state *, pic_value data); void *pic_data(pic_state *, pic_value data);
typedef struct {
const char *type_name;
void (*dtor)(pic_state *, void *);
void (*mark)(pic_state *, void *, void (*)(pic_state *, pic_value));
} pic_data_type;
pic_value pic_invalid_value(pic_state *); /*
pic_value pic_undef_value(pic_state *); * pair
pic_value pic_int_value(pic_state *, int); */
pic_value pic_float_value(pic_state *, double);
pic_value pic_char_value(pic_state *, char);
pic_value pic_true_value(pic_state *);
pic_value pic_false_value(pic_state *);
#define pic_bool_value(pic, b) ((b) ? pic_true_value(pic) : pic_false_value(pic))
pic_value pic_eof_object(pic_state *);
pic_value pic_str_value(pic_state *, const char *str, int len);
#define pic_cstr_value(pic, cstr) pic_str_value(pic, (cstr), strlen(cstr))
#define pic_lit_value(pic, lit) pic_str_value(pic, "" lit, -((int)sizeof lit - 1))
pic_value pic_strf_value(pic_state *, const char *fmt, ...);
pic_value pic_vstrf_value(pic_state *, const char *fmt, va_list ap);
pic_value pic_blob_value(pic_state *, const unsigned char *buf, int len);
pic_value pic_data_value(pic_state *, void *ptr, const pic_data_type *type);
enum { bool pic_pair_p(pic_state *, pic_value);
PIC_TYPE_INVALID = 1,
PIC_TYPE_FLOAT = 2,
PIC_TYPE_INT = 3,
PIC_TYPE_CHAR = 4,
PIC_TYPE_EOF = 5,
PIC_TYPE_UNDEF = 6,
PIC_TYPE_TRUE = 8,
PIC_TYPE_NIL = 7,
PIC_TYPE_FALSE = 9,
PIC_IVAL_END = 10,
/* -------------------- */
PIC_TYPE_STRING = 16,
PIC_TYPE_VECTOR = 17,
PIC_TYPE_BLOB = 18,
PIC_TYPE_PORT = 20,
PIC_TYPE_ERROR = 21,
PIC_TYPE_ID = 22,
PIC_TYPE_ENV = 23,
PIC_TYPE_DATA = 24,
PIC_TYPE_DICT = 25,
PIC_TYPE_WEAK = 26,
PIC_TYPE_RECORD = 27,
PIC_TYPE_SYMBOL = 28,
PIC_TYPE_PAIR = 29,
PIC_TYPE_CXT = 30,
PIC_TYPE_CP = 31,
PIC_TYPE_FUNC = 32,
PIC_TYPE_IREP = 33
};
#define pic_invalid_p(pic,v) (pic_type(pic,v) == PIC_TYPE_INVALID)
#define pic_undef_p(pic,v) (pic_type(pic,v) == PIC_TYPE_UNDEF)
#define pic_int_p(pic,v) (pic_type(pic,v) == PIC_TYPE_INT)
#define pic_float_p(pic,v) (pic_type(pic,v) == PIC_TYPE_FLOAT)
#define pic_char_p(pic,v) (pic_type(pic,v) == PIC_TYPE_CHAR)
#define pic_eof_p(pic, v) (pic_type(pic, v) == PIC_TYPE_EOF)
#define pic_bool_p(pic,v) (pic_type(pic,v) == PIC_TYPE_TRUE || pic_type(pic,v) == PIC_TYPE_FALSE)
#define pic_true_p(pic,v) (pic_type(pic,v) == PIC_TYPE_TRUE)
#define pic_false_p(pic,v) (pic_type(pic,v) == PIC_TYPE_FALSE)
#define pic_id_p(pic, v) (pic_type(pic, v) == PIC_TYPE_ID || pic_type(pic, v) == PIC_TYPE_SYMBOL)
#define pic_str_p(pic,v) (pic_type(pic,v) == PIC_TYPE_STRING)
#define pic_blob_p(pic,v) (pic_type(pic,v) == PIC_TYPE_BLOB)
#define pic_proc_p(pic,v) (pic_type(pic,v) == PIC_TYPE_FUNC || pic_type(pic, v) == PIC_TYPE_IREP)
#define pic_nil_p(pic,v) (pic_type(pic,v) == PIC_TYPE_NIL)
#define pic_pair_p(pic,v) (pic_type(pic,v) == PIC_TYPE_PAIR)
#define pic_vec_p(pic,v) (pic_type(pic,v) == PIC_TYPE_VECTOR)
#define pic_dict_p(pic,v) (pic_type(pic,v) == PIC_TYPE_DICT)
#define pic_weak_p(pic,v) (pic_type(pic,v) == PIC_TYPE_WEAK)
#define pic_port_p(pic, v) (pic_type(pic, v) == PIC_TYPE_PORT)
#define pic_sym_p(pic,v) (pic_type(pic,v) == PIC_TYPE_SYMBOL)
bool pic_data_p(pic_state *, pic_value, const pic_data_type *);
int pic_type(pic_state *, pic_value);
const char *pic_typename(pic_state *, int);
bool pic_eq_p(pic_state *, pic_value, pic_value);
bool pic_eqv_p(pic_state *, pic_value, pic_value);
bool pic_equal_p(pic_state *, pic_value, pic_value);
/* pair */
pic_value pic_cons(pic_state *, pic_value car, pic_value cdr); pic_value pic_cons(pic_state *, pic_value car, pic_value cdr);
pic_value pic_car(pic_state *, pic_value pair); pic_value pic_car(pic_state *, pic_value pair);
pic_value pic_cdr(pic_state *, pic_value pair); pic_value pic_cdr(pic_state *, pic_value pair);
@ -212,9 +157,14 @@ pic_value pic_cadr(pic_state *, pic_value);
pic_value pic_cdar(pic_state *, pic_value); pic_value pic_cdar(pic_state *, pic_value);
pic_value pic_cddr(pic_state *, pic_value); pic_value pic_cddr(pic_state *, pic_value);
/* list */
pic_value pic_nil_value(pic_state *); /*
* list
*/
bool pic_nil_p(pic_state *, pic_value);
bool pic_list_p(pic_state *, pic_value); bool pic_list_p(pic_state *, pic_value);
pic_value pic_nil_value(pic_state *);
pic_value pic_make_list(pic_state *, int n, pic_value *argv); pic_value pic_make_list(pic_state *, int n, pic_value *argv);
pic_value pic_list(pic_state *, int n, ...); pic_value pic_list(pic_state *, int n, ...);
pic_value pic_vlist(pic_state *, int n, va_list); pic_value pic_vlist(pic_state *, int n, va_list);
@ -225,13 +175,23 @@ int pic_length(pic_state *, pic_value list);
pic_value pic_reverse(pic_state *, pic_value list); pic_value pic_reverse(pic_state *, pic_value list);
pic_value pic_append(pic_state *, pic_value xs, pic_value ys); pic_value pic_append(pic_state *, pic_value xs, pic_value ys);
/* vector */
/*
* vector
*/
bool pic_vec_p(pic_state *, pic_value);
pic_value pic_make_vec(pic_state *, int n, pic_value *argv); pic_value pic_make_vec(pic_state *, int n, pic_value *argv);
pic_value pic_vec_ref(pic_state *, pic_value vec, int i); pic_value pic_vec_ref(pic_state *, pic_value vec, int i);
void pic_vec_set(pic_state *, pic_value vec, int i, pic_value v); void pic_vec_set(pic_state *, pic_value vec, int i, pic_value v);
int pic_vec_len(pic_state *, pic_value vec); int pic_vec_len(pic_state *, pic_value vec);
/* dictionary */
/*
* dictionary
*/
bool pic_dict_p(pic_state *, pic_value);
pic_value pic_make_dict(pic_state *); pic_value pic_make_dict(pic_state *);
pic_value pic_dict_ref(pic_state *, pic_value dict, pic_value key); pic_value pic_dict_ref(pic_state *, pic_value dict, pic_value key);
void pic_dict_set(pic_state *, pic_value dict, pic_value key, pic_value); void pic_dict_set(pic_state *, pic_value dict, pic_value key, pic_value);
@ -240,21 +200,23 @@ bool pic_dict_has(pic_state *, pic_value dict, pic_value key);
int pic_dict_size(pic_state *, pic_value dict); int pic_dict_size(pic_state *, pic_value dict);
bool pic_dict_next(pic_state *, pic_value dict, int *iter, pic_value *key, pic_value *val); bool pic_dict_next(pic_state *, pic_value dict, int *iter, pic_value *key, pic_value *val);
/* ephemeron */
/*
* ephemeron
*/
bool pic_weak_p(pic_state *, pic_value);
pic_value pic_make_weak(pic_state *); pic_value pic_make_weak(pic_state *);
pic_value pic_weak_ref(pic_state *, pic_value weak, pic_value key); pic_value pic_weak_ref(pic_state *, pic_value weak, pic_value key);
void pic_weak_set(pic_state *, pic_value weak, pic_value key, pic_value val); void pic_weak_set(pic_state *, pic_value weak, pic_value key, pic_value val);
void pic_weak_del(pic_state *, pic_value weak, pic_value key); void pic_weak_del(pic_state *, pic_value weak, pic_value key);
bool pic_weak_has(pic_state *, pic_value weak, pic_value key); bool pic_weak_has(pic_state *, pic_value weak, pic_value key);
/* symbol */
pic_value pic_intern(pic_state *, pic_value str);
#define pic_intern_str(pic,s,i) pic_intern(pic, pic_str_value(pic, (s), (i)))
#define pic_intern_cstr(pic,s) pic_intern(pic, pic_cstr_value(pic, (s)))
#define pic_intern_lit(pic,lit) pic_intern(pic, pic_lit_value(pic, lit))
pic_value pic_sym_name(pic_state *, pic_value sym);
/* string */ /*
* string
*/
int pic_str_len(pic_state *, pic_value str); int pic_str_len(pic_state *, pic_value str);
char pic_str_ref(pic_state *, pic_value str, int i); char pic_str_ref(pic_state *, pic_value str, int i);
pic_value pic_str_cat(pic_state *, pic_value str1, pic_value str2); pic_value pic_str_cat(pic_state *, pic_value str1, pic_value str2);
@ -263,8 +225,37 @@ int pic_str_cmp(pic_state *, pic_value str1, pic_value str2);
int pic_str_hash(pic_state *, pic_value str); int pic_str_hash(pic_state *, pic_value str);
/*
* symbol
*/
/* External I/O */ bool pic_sym_p(pic_state *, pic_value);
pic_value pic_intern(pic_state *, pic_value str);
#define pic_intern_str(pic,s,i) pic_intern(pic, pic_str_value(pic, (s), (i)))
#define pic_intern_cstr(pic,s) pic_intern(pic, pic_cstr_value(pic, (s)))
#define pic_intern_lit(pic,lit) pic_intern(pic, pic_lit_value(pic, lit))
pic_value pic_sym_name(pic_state *, pic_value sym);
/*
* procedure
*/
bool pic_proc_p(pic_state *, pic_value);
pic_value pic_lambda(pic_state *, pic_func_t f, int n, ...);
pic_value pic_vlambda(pic_state *, pic_func_t f, int n, va_list);
int pic_get_args(pic_state *, const char *fmt, ...);
pic_value pic_closure_ref(pic_state *, int i);
void pic_closure_set(pic_state *, int i, pic_value v);
pic_value pic_call(pic_state *, pic_value proc, int, ...);
pic_value pic_vcall(pic_state *, pic_value proc, int, va_list);
pic_value pic_apply(pic_state *, pic_value proc, int n, pic_value *argv);
pic_value pic_applyk(pic_state *, pic_value proc, int n, pic_value *argv);
/*
* port
*/
#define PIC_SEEK_CUR 0 #define PIC_SEEK_CUR 0
#define PIC_SEEK_END 1 #define PIC_SEEK_END 1
@ -273,39 +264,105 @@ int pic_str_hash(pic_state *, pic_value str);
#define pic_stdin(pic) pic_funcall(pic, "picrin.base", "current-input-port", 0) #define pic_stdin(pic) pic_funcall(pic, "picrin.base", "current-input-port", 0)
#define pic_stdout(pic) pic_funcall(pic, "picrin.base", "current-output-port", 0) #define pic_stdout(pic) pic_funcall(pic, "picrin.base", "current-output-port", 0)
#define pic_stderr(pic) pic_funcall(pic, "picrin.base", "current-error-port", 0) #define pic_stderr(pic) pic_funcall(pic, "picrin.base", "current-error-port", 0)
bool pic_eof_p(pic_state *, pic_value);
pic_value pic_funopen(pic_state *, void *cookie, int (*read)(pic_state *, void *, char *, int), int (*write)(pic_state *, void *, const char *, int), long (*seek)(pic_state *, void *, long, int), int (*close)(pic_state *, void *)); pic_value pic_eof_object(pic_state *);
bool pic_port_p(pic_state *, pic_value, const pic_port_type *type);
pic_value pic_funopen(pic_state *, void *cookie, const pic_port_type *type);
size_t pic_fread(pic_state *, void *ptr, size_t size, size_t count, pic_value port); size_t pic_fread(pic_state *, void *ptr, size_t size, size_t count, pic_value port);
size_t pic_fwrite(pic_state *, const void *ptr, size_t size, size_t count, pic_value port); size_t pic_fwrite(pic_state *, const void *ptr, size_t size, size_t count, pic_value port);
long pic_fseek(pic_state *, pic_value port, long offset, int whence); long pic_fseek(pic_state *, pic_value port, long offset, int whence);
int pic_fclose(pic_state *, pic_value port); int pic_fclose(pic_state *, pic_value port);
/* error */
void pic_clearerr(pic_state *, pic_value port); void pic_clearerr(pic_state *, pic_value port);
int pic_feof(pic_state *, pic_value port); int pic_feof(pic_state *, pic_value port);
int pic_ferror(pic_state *, pic_value port); int pic_ferror(pic_state *, pic_value port);
/* basic I/O */
int pic_fputc(pic_state *, int c, pic_value port); int pic_fputc(pic_state *, int c, pic_value port);
int pic_fgetc(pic_state *, pic_value port); int pic_fgetc(pic_state *, pic_value port);
int pic_fputs(pic_state *, const char *s, pic_value port); int pic_fputs(pic_state *, const char *s, pic_value port);
char *pic_fgets(pic_state *, char *s, int size, pic_value port); char *pic_fgets(pic_state *, char *s, int size, pic_value port);
int pic_ungetc(pic_state *, int c, pic_value port); int pic_ungetc(pic_state *, int c, pic_value port);
int pic_fflush(pic_state *, pic_value port); int pic_fflush(pic_state *, pic_value port);
/* formatted output */
int pic_printf(pic_state *, const char *fmt, ...); int pic_printf(pic_state *, const char *fmt, ...);
int pic_fprintf(pic_state *, pic_value port, const char *fmt, ...); int pic_fprintf(pic_state *, pic_value port, const char *fmt, ...);
int pic_vfprintf(pic_state *, pic_value port, const char *fmt, va_list ap); int pic_vfprintf(pic_state *, pic_value port, const char *fmt, va_list ap);
/* string buffer */
pic_value pic_fmemopen(pic_state *, const char *buf, int len, const char *mode); /* deprecated */ pic_value pic_fmemopen(pic_state *, const char *buf, int len, const char *mode); /* deprecated */
int pic_fgetbuf(pic_state *, pic_value port, const char **buf, int *len); /* deprecated */ int pic_fgetbuf(pic_state *, pic_value port, const char **buf, int *len); /* deprecated */
/* debug */ /*
void pic_warnf(pic_state *, const char *, ...); * error handling
pic_value pic_get_backtrace(pic_state *); */
typedef void (*pic_panicf)(pic_state *, const char *msg);
pic_panicf pic_atpanic(pic_state *, pic_panicf f);
PIC_NORETURN void pic_panic(pic_state *, const char *msg);
PIC_NORETURN void pic_error(pic_state *, const char *msg, int n, ...);
PIC_NORETURN void pic_raise(pic_state *, pic_value v);
pic_value pic_make_error(pic_state *, const char *type, const char *msg, pic_value irrs); /* deprecated */
pic_value pic_get_backtrace(pic_state *); /* deprecated */
#define pic_try pic_try_(PIC_GENSYM(cont), PIC_GENSYM(jmp))
#define pic_try_(cont, jmp) \
do { \
extern pic_value pic_start_try(pic_state *, PIC_JMPBUF *); \
extern void pic_end_try(pic_state *, pic_value); \
extern pic_value pic_err(pic_state *); \
PIC_JMPBUF jmp; \
if (PIC_SETJMP(pic, jmp) == 0) { \
pic_value pic_try_cookie_ = pic_start_try(pic, &jmp);
#define pic_catch(e) pic_catch_(e, PIC_GENSYM(label))
#define pic_catch_(e, label) \
pic_end_try(pic, pic_try_cookie_); \
} else { \
e = pic_err(pic); \
goto label; \
} \
} while (0); \
if (0) \
label:
/*
* library
*/
/* utility macros */ void pic_make_library(pic_state *, const char *lib);
void pic_in_library(pic_state *, const char *lib);
bool pic_find_library(pic_state *, const char *lib);
const char *pic_current_library(pic_state *);
void pic_import(pic_state *, const char *lib);
void pic_export(pic_state *, pic_value sym);
#define pic_deflibrary(pic, lib) do { \
if (! pic_find_library(pic, lib)) { \
pic_make_library(pic, lib); \
} \
pic_in_library(pic, lib); \
} while (0)
/*
* core language features
*/
void pic_add_feature(pic_state *, const char *feature);
void pic_define(pic_state *, const char *lib, const char *name, pic_value v);
pic_value pic_ref(pic_state *, const char *lib, const char *name);
void pic_set(pic_state *, const char *lib, const char *name, pic_value v);
pic_value pic_make_var(pic_state *, pic_value init, pic_value conv);
void pic_defun(pic_state *, const char *name, pic_func_t f);
void pic_defvar(pic_state *, const char *name, pic_value v);
pic_value pic_funcall(pic_state *, const char *lib, const char *name, int n, ...);
pic_value pic_return(pic_state *, int n, ...);
pic_value pic_vreturn(pic_state *, int n, va_list);
pic_value pic_valuesk(pic_state *, int n, pic_value *retv);
int pic_receive(pic_state *, int n, pic_value *retv);
/*
* utility macros
*/
#define pic_for_each(var, list, it) \ #define pic_for_each(var, list, it) \
for (it = (list); ! pic_nil_p(pic, it); it = pic_cdr(pic, it)) \ for (it = (list); ! pic_nil_p(pic, it); it = pic_cdr(pic, it)) \

26
lib/include/picrin/extra.h
View File

@ -27,32 +27,6 @@ void pic_load_cstr(pic_state *, const char *);
pic_value pic_fopen(pic_state *, FILE *, const char *mode); pic_value pic_fopen(pic_state *, FILE *, const char *mode);
#endif #endif
#define pic_deflibrary(pic, lib) do { \
if (! pic_find_library(pic, lib)) { \
pic_make_library(pic, lib); \
} \
pic_in_library(pic, lib); \
} while (0)
#define pic_try pic_try_(PIC_GENSYM(cont), PIC_GENSYM(jmp))
#define pic_try_(cont, jmp) \
do { \
extern pic_value pic_start_try(pic_state *, PIC_JMPBUF *); \
extern void pic_end_try(pic_state *, pic_value); \
extern pic_value pic_err(pic_state *); \
PIC_JMPBUF jmp; \
if (PIC_SETJMP(pic, jmp) == 0) { \
pic_value pic_try_cookie_ = pic_start_try(pic, &jmp);
#define pic_catch(e) pic_catch_(e, PIC_GENSYM(label))
#define pic_catch_(e, label) \
pic_end_try(pic, pic_try_cookie_); \
} else { \
e = pic_err(pic); \
goto label; \
} \
} while (0); \
if (0) \
label:
/* for debug */ /* for debug */

56
lib/include/picrin/setup.h
View File

@ -117,12 +117,32 @@ typedef unsigned long uint32_t;
# define PIC_NORETURN # define PIC_NORETURN
#endif #endif
/*
* normalize inline keyword; PIC_*_INLINE macros have the same semantics as c99
*/
#if __STDC_VERSION__ >= 199901L #if __STDC_VERSION__ >= 199901L
# define PIC_INLINE static inline # define PIC_STATIC_INLINE static inline
#elif __GNUC__ || __clang__ #elif __GNUC__ || __clang__
# define PIC_INLINE static __inline__ # define PIC_STATIC_INLINE static __inline__
#else #else
# define PIC_INLINE static # define PIC_STATIC_INLINE static
#endif
#if defined __GNUC__ && !defined __GNUC_STDC_INLINE__ && !defined __GNUC_GNU_INLINE__
# define __GNUC_GNU_INLINE__ 1
#endif
/* PIC_INLINE does not necessarily unify identical definitions */
#if defined __GNUC_GNU_INLINE__
# define PIC_EXTERN_INLINE inline
# define PIC_INLINE extern inline
#elif __STDC_VERSION__ >= 199901L
# define PIC_EXTERN_INLINE extern inline
# define PIC_INLINE inline
#else
# define PIC_EXTERN_INLINE
# define PIC_INLINE static
#endif #endif
#if defined(__cplusplus) #if defined(__cplusplus)
@ -173,25 +193,25 @@ typedef unsigned long uint32_t;
# define assert(v) (void)0 # define assert(v) (void)0
PIC_INLINE int PIC_STATIC_INLINE int
isspace(int c) isspace(int c)
{ {
return c == ' ' || c == '\t' || c == '\r' || c == '\v' || c == '\f' || c == '\n'; return c == ' ' || c == '\t' || c == '\r' || c == '\v' || c == '\f' || c == '\n';
} }
PIC_INLINE int PIC_STATIC_INLINE int
tolower(int c) tolower(int c)
{ {
return ('A' <= c && c <= 'Z') ? c - 'A' + 'a' : c; return ('A' <= c && c <= 'Z') ? c - 'A' + 'a' : c;
} }
PIC_INLINE int PIC_STATIC_INLINE int
isdigit(int c) isdigit(int c)
{ {
return '0' <= c && c <= '9'; return '0' <= c && c <= '9';
} }
PIC_INLINE char * PIC_STATIC_INLINE char *
strchr(const char *s, int c) strchr(const char *s, int c)
{ {
do { do {
@ -201,7 +221,7 @@ strchr(const char *s, int c)
return NULL; return NULL;
} }
PIC_INLINE size_t PIC_STATIC_INLINE size_t
strlen(const char *s) strlen(const char *s)
{ {
size_t l = 0; size_t l = 0;
@ -212,7 +232,7 @@ strlen(const char *s)
return l; return l;
} }
PIC_INLINE int PIC_STATIC_INLINE int
strcmp(const char *s1, const char *s2) strcmp(const char *s1, const char *s2)
{ {
while (*s1 && *s1 == *s2) { while (*s1 && *s1 == *s2) {
@ -222,7 +242,7 @@ strcmp(const char *s1, const char *s2)
return (unsigned)*s1 - (unsigned)*s2; return (unsigned)*s1 - (unsigned)*s2;
} }
PIC_INLINE long PIC_STATIC_INLINE long
strtol(const char *nptr, char **endptr, int base) strtol(const char *nptr, char **endptr, int base)
{ {
long l = 0; long l = 0;
@ -252,7 +272,7 @@ strtol(const char *nptr, char **endptr, int base)
return l; return l;
} }
PIC_INLINE void * PIC_STATIC_INLINE void *
memset(void *s, int n, size_t c) memset(void *s, int n, size_t c)
{ {
char *p = s; char *p = s;
@ -263,7 +283,7 @@ memset(void *s, int n, size_t c)
return s; return s;
} }
PIC_INLINE void * PIC_STATIC_INLINE void *
memcpy(void *dst, const void *src, size_t n) memcpy(void *dst, const void *src, size_t n)
{ {
const char *s = src; const char *s = src;
@ -275,7 +295,7 @@ memcpy(void *dst, const void *src, size_t n)
return d; return d;
} }
PIC_INLINE void * PIC_STATIC_INLINE void *
memmove(void *dst, const void *src, size_t n) memmove(void *dst, const void *src, size_t n)
{ {
const char *s = src; const char *s = src;
@ -293,7 +313,7 @@ memmove(void *dst, const void *src, size_t n)
return d; return d;
} }
PIC_INLINE int PIC_STATIC_INLINE int
memcmp(const void *b1, const void *b2, size_t n) memcmp(const void *b1, const void *b2, size_t n)
{ {
const char *s1 = b1, *s2 = b2; const char *s1 = b1, *s2 = b2;
@ -305,7 +325,7 @@ memcmp(const void *b1, const void *b2, size_t n)
return (unsigned)*s1 - (unsigned)*s2; return (unsigned)*s1 - (unsigned)*s2;
} }
PIC_INLINE char * PIC_STATIC_INLINE char *
strcpy(char *dst, const char *src) strcpy(char *dst, const char *src)
{ {
char *d = dst; char *d = dst;
@ -315,7 +335,7 @@ strcpy(char *dst, const char *src)
return d; return d;
} }
PIC_INLINE double PIC_STATIC_INLINE double
atof(const char *nptr) atof(const char *nptr)
{ {
int c; int c;
@ -384,7 +404,7 @@ atof(const char *nptr)
#if PIC_USE_STDIO #if PIC_USE_STDIO
# include <stdio.h> # include <stdio.h>
PIC_INLINE void PIC_STATIC_INLINE void
pic_dtoa(double dval, char *buf) pic_dtoa(double dval, char *buf)
{ {
sprintf(buf, "%g", dval); sprintf(buf, "%g", dval);
@ -392,7 +412,7 @@ pic_dtoa(double dval, char *buf)
#else #else
PIC_INLINE void PIC_STATIC_INLINE void
pic_dtoa(double dval, char *buf) pic_dtoa(double dval, char *buf)
{ {
# define fabs(x) ((x) >= 0 ? (x) : -(x)) # define fabs(x) ((x) >= 0 ? (x) : -(x))

2
lib/khash.h
View File

@ -201,7 +201,7 @@
#define kh_ptr_hash_equal(a, b) ((a) == (b)) #define kh_ptr_hash_equal(a, b) ((a) == (b))
#define kh_int_hash_func(key) (int)(key) #define kh_int_hash_func(key) (int)(key)
#define kh_int_hash_equal(a, b) ((a) == (b)) #define kh_int_hash_equal(a, b) ((a) == (b))
PIC_INLINE int kh_str_hash_func(const char *s) { PIC_STATIC_INLINE int kh_str_hash_func(const char *s) {
int h = 0; int h = 0;
while (*s) { while (*s) {
h = (h << 5) - h + *s++; h = (h << 5) - h + *s++;

2
lib/number.c
View File

@ -3,6 +3,8 @@
*/ */
#include "picrin.h" #include "picrin.h"
#include "value.h"
#include "object.h"
static pic_value static pic_value
pic_number_number_p(pic_state *pic) pic_number_number_p(pic_state *pic)

66
lib/object.h
View File

@ -145,13 +145,8 @@ struct port {
char *ptr; /* next character position */ char *ptr; /* next character position */
char *base; /* location of the buffer */ char *base; /* location of the buffer */
/* operators */ /* operators */
struct { void *cookie;
void *cookie; const pic_port_type *vtable;
int (*read)(pic_state *, void *, char *, int);
int (*write)(pic_state *, void *, const char *, int);
long (*seek)(pic_state *, void *, long, int);
int (*close)(pic_state *, void *);
} vtable;
int flag; /* mode of the file access */ int flag; /* mode of the file access */
} file; } file;
}; };
@ -164,31 +159,6 @@ struct checkpoint {
struct checkpoint *prev; struct checkpoint *prev;
}; };
struct object *pic_obj_ptr(pic_value);
#define pic_id_ptr(pic, o) (assert(pic_id_p(pic, o)), (struct identifier *)pic_obj_ptr(o))
#define pic_sym_ptr(pic, o) (assert(pic_sym_p(pic, o)), (symbol *)pic_obj_ptr(o))
#define pic_str_ptr(pic, o) (assert(pic_str_p(pic, o)), (struct string *)pic_obj_ptr(o))
#define pic_blob_ptr(pic, o) (assert(pic_blob_p(pic, o)), (struct blob *)pic_obj_ptr(o))
#define pic_pair_ptr(pic, o) (assert(pic_pair_p(pic, o)), (struct pair *)pic_obj_ptr(o))
#define pic_vec_ptr(pic, o) (assert(pic_vec_p(pic, o)), (struct vector *)pic_obj_ptr(o))
#define pic_dict_ptr(pic, o) (assert(pic_dict_p(pic, o)), (struct dict *)pic_obj_ptr(o))
#define pic_weak_ptr(pic, o) (assert(pic_weak_p(pic, o)), (struct weak *)pic_obj_ptr(o))
#define pic_data_ptr(pic, o) (assert(pic_data_p(pic, o, NULL)), (struct data *)pic_obj_ptr(o))
#define pic_proc_ptr(pic, o) (assert(pic_proc_p(pic, o)), (struct proc *)pic_obj_ptr(o))
#define pic_env_ptr(pic, o) (assert(pic_env_p(pic, o)), (struct env *)pic_obj_ptr(o))
#define pic_port_ptr(pic, o) (assert(pic_port_p(pic, o)), (struct port *)pic_obj_ptr(o))
#define pic_error_ptr(pic, o) (assert(pic_error_p(pic, o)), (struct error *)pic_obj_ptr(o))
#define pic_rec_ptr(pic, o) (assert(pic_rec_p(pic, o)), (struct record *)pic_obj_ptr(o))
#define pic_obj_p(pic,v) (pic_type(pic,v) > PIC_IVAL_END)
#define pic_env_p(pic, v) (pic_type(pic, v) == PIC_TYPE_ENV)
#define pic_error_p(pic, v) (pic_type(pic, v) == PIC_TYPE_ERROR)
#define pic_rec_p(pic, v) (pic_type(pic, v) == PIC_TYPE_RECORD)
pic_value pic_obj_value(void *ptr);
struct object *pic_obj_alloc(pic_state *, size_t, int type);
#define TYPENAME_int "integer" #define TYPENAME_int "integer"
#define TYPENAME_blob "bytevector" #define TYPENAME_blob "bytevector"
#define TYPENAME_char "character" #define TYPENAME_char "character"
@ -218,6 +188,35 @@ struct object *pic_obj_alloc(pic_state *, size_t, int type);
if (tolen - at < e - s) pic_error(pic, "invalid range", 0); \ if (tolen - at < e - s) pic_error(pic, "invalid range", 0); \
} while (0) } while (0)
PIC_STATIC_INLINE struct object *obj_ptr(pic_value); /* defined in value.h */
PIC_STATIC_INLINE int obj_tt(void *ptr) {
return ((struct basic *)ptr)->tt;
}
#define DEFPTR(name,type) \
PIC_STATIC_INLINE type *name(pic_state *PIC_UNUSED(pic), pic_value o) { \
return (type *) obj_ptr(o); \
}
DEFPTR(pic_id_ptr, struct identifier)
DEFPTR(pic_sym_ptr, symbol)
DEFPTR(pic_str_ptr, struct string)
DEFPTR(pic_blob_ptr, struct blob)
DEFPTR(pic_pair_ptr, struct pair)
DEFPTR(pic_vec_ptr, struct vector)
DEFPTR(pic_dict_ptr, struct dict)
DEFPTR(pic_weak_ptr, struct weak)
DEFPTR(pic_data_ptr, struct data)
DEFPTR(pic_proc_ptr, struct proc)
DEFPTR(pic_env_ptr, struct env)
DEFPTR(pic_port_ptr, struct port)
DEFPTR(pic_error_ptr, struct error)
DEFPTR(pic_rec_ptr, struct record)
DEFPTR(pic_cp_ptr, struct checkpoint)
struct object *pic_obj_alloc(pic_state *, size_t, int type);
pic_value pic_make_identifier(pic_state *, pic_value id, pic_value env); pic_value pic_make_identifier(pic_state *, pic_value id, pic_value env);
pic_value pic_make_proc(pic_state *, pic_func_t, int, pic_value *); pic_value pic_make_proc(pic_state *, pic_func_t, int, pic_value *);
pic_value pic_make_proc_irep(pic_state *, struct irep *, struct context *); pic_value pic_make_proc_irep(pic_state *, struct irep *, struct context *);
@ -232,9 +231,6 @@ pic_value pic_id_name(pic_state *, pic_value id);
struct rope *pic_rope_incref(struct rope *); struct rope *pic_rope_incref(struct rope *);
void pic_rope_decref(pic_state *, struct rope *); void pic_rope_decref(pic_state *, struct rope *);
#define pic_func_p(pic, proc) (pic_type(pic, proc) == PIC_TYPE_FUNC)
#define pic_irep_p(pic, proc) (pic_type(pic, proc) == PIC_TYPE_IREP)
struct cont *pic_alloca_cont(pic_state *); struct cont *pic_alloca_cont(pic_state *);
pic_value pic_make_cont(pic_state *, struct cont *); pic_value pic_make_cont(pic_state *, struct cont *);
void pic_save_point(pic_state *, struct cont *, PIC_JMPBUF *); void pic_save_point(pic_state *, struct cont *, PIC_JMPBUF *);

1
lib/pair.c
View File

@ -3,6 +3,7 @@
*/ */
#include "picrin.h" #include "picrin.h"
#include "value.h"
#include "object.h" #include "object.h"
pic_value pic_value

75
lib/port.c
View File

@ -3,6 +3,7 @@
*/ */
#include "picrin.h" #include "picrin.h"
#include "value.h"
#include "object.h" #include "object.h"
#include "state.h" #include "state.h"
@ -10,20 +11,26 @@
# define EOF (-1) # define EOF (-1)
#endif #endif
bool
pic_port_p(pic_state *pic, pic_value obj, const pic_port_type *type)
{
if (value_type(pic, obj) != PIC_TYPE_PORT) {
return false;
}
return type == NULL || pic_port_ptr(pic, obj)->file.vtable == type;
}
pic_value pic_value
pic_funopen(pic_state *pic, void *cookie, int (*read)(pic_state *, void *, char *, int), int (*write)(pic_state *, void *, const char *, int), long (*seek)(pic_state *, void *, long, int), int (*close)(pic_state *, void *)) pic_funopen(pic_state *pic, void *cookie, const pic_port_type *type)
{ {
struct port *port; struct port *port;
port = (struct port *)pic_obj_alloc(pic, sizeof(struct port), PIC_TYPE_PORT); port = (struct port *)pic_obj_alloc(pic, sizeof(struct port), PIC_TYPE_PORT);
port->file.cnt = 0; port->file.cnt = 0;
port->file.base = NULL; port->file.base = NULL;
port->file.flag = read? FILE_READ : FILE_WRITE; port->file.flag = type->read ? FILE_READ : FILE_WRITE;
port->file.vtable.cookie = cookie; port->file.cookie = cookie;
port->file.vtable.read = read; port->file.vtable = type;
port->file.vtable.write = write;
port->file.vtable.seek = seek;
port->file.vtable.close = close;
return pic_obj_value(port); return pic_obj_value(port);
} }
@ -39,7 +46,7 @@ pic_fclose(pic_state *pic, pic_value port)
fp->flag = 0; fp->flag = 0;
if (fp->base != fp->buf) if (fp->base != fp->buf)
pic_free(pic, fp->base); pic_free(pic, fp->base);
return fp->vtable.close(pic, fp->vtable.cookie); return fp->vtable->close(pic, fp->cookie);
} }
void void
@ -88,7 +95,7 @@ fillbuf(pic_state *pic, struct file *fp)
bufsize = (fp->flag & FILE_UNBUF) ? sizeof(fp->buf) : PIC_BUFSIZ; bufsize = (fp->flag & FILE_UNBUF) ? sizeof(fp->buf) : PIC_BUFSIZ;
fp->ptr = fp->base; fp->ptr = fp->base;
fp->cnt = fp->vtable.read(pic, fp->vtable.cookie, fp->ptr, bufsize); fp->cnt = fp->vtable->read(pic, fp->cookie, fp->ptr, bufsize);
if (--fp->cnt < 0) { if (--fp->cnt < 0) {
if (fp->cnt == -1) if (fp->cnt == -1)
@ -126,7 +133,7 @@ flushbuf(pic_state *pic, int x, struct file *fp)
fp->cnt = 0; fp->cnt = 0;
if (x == EOF) if (x == EOF)
return EOF; return EOF;
num_written = fp->vtable.write(pic, fp->vtable.cookie, (const char *) &c, 1); num_written = fp->vtable->write(pic, fp->cookie, (const char *) &c, 1);
bufsize = 1; bufsize = 1;
} else { } else {
/* buffered write */ /* buffered write */
@ -137,7 +144,7 @@ flushbuf(pic_state *pic, int x, struct file *fp)
bufsize = (int)(fp->ptr - fp->base); bufsize = (int)(fp->ptr - fp->base);
while(bufsize - num_written > 0) { while(bufsize - num_written > 0) {
int t; int t;
t = fp->vtable.write(pic, fp->vtable.cookie, fp->base + num_written, bufsize - num_written); t = fp->vtable->write(pic, fp->cookie, fp->base + num_written, bufsize - num_written);
if (t < 0) if (t < 0)
break; break;
num_written += t; num_written += t;
@ -304,7 +311,7 @@ pic_fseek(pic_state *pic, pic_value port, long offset, int whence)
fp->ptr = fp->base; fp->ptr = fp->base;
fp->cnt = 0; fp->cnt = 0;
if ((s = fp->vtable.seek(pic, fp->vtable.cookie, offset, whence)) != 0) if ((s = fp->vtable->seek(pic, fp->cookie, offset, whence)) != 0)
return s; return s;
fp->flag &= ~FILE_EOF; fp->flag &= ~FILE_EOF;
return 0; return 0;
@ -366,12 +373,19 @@ file_close(pic_state *PIC_UNUSED(pic), void *cookie) {
return fclose(cookie); return fclose(cookie);
} }
static const pic_port_type file_rd = {
file_read, 0, file_seek, file_close
};
static const pic_port_type file_wr = {
0, file_write, file_seek, file_close
};
pic_value pic_value
pic_fopen(pic_state *pic, FILE *fp, const char *mode) { pic_fopen(pic_state *pic, FILE *fp, const char *mode) {
if (*mode == 'r') { if (*mode == 'r') {
return pic_funopen(pic, fp, file_read, 0, file_seek, file_close); return pic_funopen(pic, fp, &file_rd);
} else { } else {
return pic_funopen(pic, fp, 0, file_write, file_seek, file_close); return pic_funopen(pic, fp, &file_wr);
} }
} }
@ -397,14 +411,22 @@ null_close(pic_state *PIC_UNUSED(pic), void *PIC_UNUSED(cookie)) {
return 0; return 0;
} }
static const pic_port_type null_rd = {
null_read, 0, null_seek, null_close
};
static const pic_port_type null_wr = {
0, null_write, null_seek, null_close
};
static pic_value static pic_value
pic_fopen_null(pic_state *PIC_UNUSED(pic), const char *mode) pic_fopen_null(pic_state *PIC_UNUSED(pic), const char *mode)
{ {
switch (*mode) { switch (*mode) {
case 'r': case 'r':
return pic_funopen(pic, 0, null_read, 0, null_seek, null_close); return pic_funopen(pic, 0, &null_rd);
default: default:
return pic_funopen(pic, 0, 0, null_write, null_seek, null_close); return pic_funopen(pic, 0, &null_wr);
} }
} }
@ -470,6 +492,13 @@ string_close(pic_state *pic, void *cookie)
return 0; return 0;
} }
static const pic_port_type string_rd = {
string_read, 0, string_seek, string_close
};
static const pic_port_type string_wr = {
0, string_write, string_seek, string_close
};
pic_value pic_value
pic_fmemopen(pic_state *pic, const char *data, int size, const char *mode) pic_fmemopen(pic_state *pic, const char *data, int size, const char *mode)
{ {
@ -483,9 +512,9 @@ pic_fmemopen(pic_state *pic, const char *data, int size, const char *mode)
if (*mode == 'r') { if (*mode == 'r') {
memcpy(m->buf, data, size); memcpy(m->buf, data, size);
return pic_funopen(pic, m, string_read, NULL, string_seek, string_close); return pic_funopen(pic, m, &string_rd);
} else { } else {
return pic_funopen(pic, m, NULL, string_write, string_seek, string_close); return pic_funopen(pic, m, &string_wr);
} }
} }
@ -497,10 +526,10 @@ pic_fgetbuf(pic_state *pic, pic_value port, const char **buf, int *len)
pic_fflush(pic, port); pic_fflush(pic, port);
if (fp->vtable.write != string_write) { if (fp->vtable->write != string_write) {
return -1; return -1;
} }
s = fp->vtable.cookie; s = fp->cookie;
*len = s->end; *len = s->end;
*buf = s->buf; *buf = s->buf;
return 0; return 0;
@ -513,7 +542,7 @@ pic_port_input_port_p(pic_state *pic)
pic_get_args(pic, "o", &v); pic_get_args(pic, "o", &v);
if (pic_port_p(pic, v) && (pic_port_ptr(pic, v)->file.flag & FILE_READ) != 0) { if (pic_port_p(pic, v, NULL) && (pic_port_ptr(pic, v)->file.flag & FILE_READ) != 0) {
return pic_true_value(pic); return pic_true_value(pic);
} else { } else {
return pic_false_value(pic); return pic_false_value(pic);
@ -527,7 +556,7 @@ pic_port_output_port_p(pic_state *pic)
pic_get_args(pic, "o", &v); pic_get_args(pic, "o", &v);
if (pic_port_p(pic, v) && (pic_port_ptr(pic, v)->file.flag & FILE_WRITE) != 0) { if (pic_port_p(pic, v, NULL) && (pic_port_ptr(pic, v)->file.flag & FILE_WRITE) != 0) {
return pic_true_value(pic); return pic_true_value(pic);
} }
else { else {
@ -542,7 +571,7 @@ pic_port_port_p(pic_state *pic)
pic_get_args(pic, "o", &v); pic_get_args(pic, "o", &v);
return pic_bool_value(pic, pic_port_p(pic, v)); return pic_bool_value(pic, pic_port_p(pic, v, NULL));
} }
static pic_value static pic_value

8
lib/proc.c
View File

@ -3,6 +3,7 @@
*/ */
#include "picrin.h" #include "picrin.h"
#include "value.h"
#include "object.h" #include "object.h"
#include "state.h" #include "state.h"
#include "vm.h" #include "vm.h"
@ -41,7 +42,6 @@ arg_error(pic_state *pic, int actual, bool varg, int expected)
pic_error(pic, msg, 0); pic_error(pic, msg, 0);
} }
#define MIN(x,y) ((x) < (y) ? (x) : (y))
#define GET_PROC(pic) (pic->ci->fp[0]) #define GET_PROC(pic) (pic->ci->fp[0])
#define GET_ARG(pic,n) (pic->ci->fp[(n)+1]) #define GET_ARG(pic,n) (pic->ci->fp[(n)+1])
@ -126,7 +126,7 @@ pic_get_args(pic_state *pic, const char *format, ...)
*proc = GET_PROC(pic); *proc = GET_PROC(pic);
format++; /* skip '&' */ format++; /* skip '&' */
} }
for (i = 0; i < MIN(paramc + optc, argc); ++i) { for (i = 0; i < argc && i < paramc + optc; ++i) {
c = *format++; c = *format++;
if (c == '|') { if (c == '|') {
@ -189,7 +189,7 @@ pic_get_args(pic_state *pic, const char *format, ...)
e = (c == c2 ? va_arg(ap, bool *) : &dummy); \ e = (c == c2 ? va_arg(ap, bool *) : &dummy); \
\ \
v = GET_ARG(pic, i); \ v = GET_ARG(pic, i); \
switch (pic_type(pic, v)) { \ switch (value_type(pic, v)) { \
case PIC_TYPE_FLOAT: \ case PIC_TYPE_FLOAT: \
*n = pic_float(pic, v); \ *n = pic_float(pic, v); \
*e = false; \ *e = false; \
@ -233,7 +233,9 @@ pic_get_args(pic_state *pic, const char *format, ...)
OBJ_CASE('l', proc) OBJ_CASE('l', proc)
OBJ_CASE('v', vec) OBJ_CASE('v', vec)
OBJ_CASE('d', dict) OBJ_CASE('d', dict)
#define pic_port_p(pic,v) pic_port_p(pic,v,NULL)
OBJ_CASE('p', port) OBJ_CASE('p', port)
#undef pic_port_p
OBJ_CASE('r', rec) OBJ_CASE('r', rec)
default: default:

1
lib/record.c
View File

@ -3,6 +3,7 @@
*/ */
#include "picrin.h" #include "picrin.h"
#include "value.h"
#include "object.h" #include "object.h"
pic_value pic_value

2
lib/state.c
View File

@ -3,7 +3,7 @@
*/ */
#include "picrin.h" #include "picrin.h"
#include "picrin/extra.h" #include "value.h"
#include "object.h" #include "object.h"
#include "state.h" #include "state.h"

1
lib/string.c
View File

@ -3,6 +3,7 @@
*/ */
#include "picrin.h" #include "picrin.h"
#include "value.h"
#include "object.h" #include "object.h"
struct rope { struct rope {

1
lib/symbol.c
View File

@ -3,6 +3,7 @@
*/ */
#include "picrin.h" #include "picrin.h"
#include "value.h"
#include "object.h" #include "object.h"
#include "state.h" #include "state.h"

261
lib/value.c
View File

@ -1,261 +0,0 @@
/**
* See Copyright Notice in picrin.h
*/
#include "picrin.h"
#include "object.h"
#if PIC_NAN_BOXING
/**
* value representation by nan-boxing:
* float : FFFFFFFFFFFFFFFF FFFFFFFFFFFFFFFF FFFFFFFFFFFFFFFF FFFFFFFFFFFFFFFF
* ptr : 111111111111TTTT PPPPPPPPPPPPPPPP PPPPPPPPPPPPPPPP PPPPPPPPPPPPPPPP
* int : 111111111111TTTT 0000000000000000 IIIIIIIIIIIIIIII IIIIIIIIIIIIIIII
* char : 111111111111TTTT 0000000000000000 CCCCCCCCCCCCCCCC CCCCCCCCCCCCCCCC
*/
#define pic_init_value(v,vtype) (v = (0xfff0000000000000ul | ((uint64_t)(vtype) << 48)))
int
pic_vtype(pic_state *PIC_UNUSED(pic), pic_value v)
{
return 0xfff0 >= (v >> 48) ? PIC_TYPE_FLOAT : ((v >> 48) & 0xf);
}
double
pic_float(pic_state *PIC_UNUSED(pic), pic_value v)
{
union { double f; uint64_t i; } u;
u.i = v;
return u.f;
}
int
pic_int(pic_state *PIC_UNUSED(pic), pic_value v)
{
union { int i; unsigned u; } u;
u.u = v & 0xfffffffful;
return u.i;
}
char
pic_char(pic_state *PIC_UNUSED(pic), pic_value v)
{
return v & 0xfffffffful;
}
struct object *
pic_obj_ptr(pic_value v)
{
return (struct object *)(0xfffffffffffful & v);
}
#else
#define pic_init_value(v,vtype) ((v).type = (vtype), (v).u.data = NULL)
int
pic_vtype(pic_state *PIC_UNUSED(pic), pic_value v)
{
return (int)(v.type);
}
double
pic_float(pic_state *PIC_UNUSED(pic), pic_value v)
{
return v.u.f;
}
int
pic_int(pic_state *PIC_UNUSED(pic), pic_value v)
{
return v.u.i;
}
char
pic_char(pic_state *PIC_UNUSED(pic), pic_value v)
{
return v.u.c;
}
struct object *
pic_obj_ptr(pic_value v)
{
return (struct object *)(v.u.data);
}
#endif
#if PIC_NAN_BOXING
pic_value
pic_obj_value(void *ptr)
{
pic_value v;
pic_init_value(v, PIC_IVAL_END);
v |= 0xfffffffffffful & (uint64_t)ptr;
return v;
}
pic_value
pic_float_value(pic_state *PIC_UNUSED(pic), double f)
{
union { double f; uint64_t i; } u;
if (f != f) {
return 0x7ff8000000000000ul;
} else {
u.f = f;
return u.i;
}
}
pic_value
pic_int_value(pic_state *PIC_UNUSED(pic), int i)
{
pic_value v;
pic_init_value(v, PIC_TYPE_INT);
v |= (unsigned)i;
return v;
}
pic_value
pic_char_value(pic_state *PIC_UNUSED(pic), char c)
{
pic_value v;
pic_init_value(v, PIC_TYPE_CHAR);
v |= (unsigned char)c;
return v;
}
#else
pic_value
pic_obj_value(void *ptr)
{
pic_value v;
pic_init_value(v, PIC_IVAL_END);
v.u.data = ptr;
return v;
}
pic_value
pic_float_value(pic_state *PIC_UNUSED(pic), double f)
{
pic_value v;
pic_init_value(v, PIC_TYPE_FLOAT);
v.u.f = f;
return v;
}
pic_value
pic_int_value(pic_state *PIC_UNUSED(pic), int i)
{
pic_value v;
pic_init_value(v, PIC_TYPE_INT);
v.u.i = i;
return v;
}
pic_value
pic_char_value(pic_state *PIC_UNUSED(pic), char c)
{
pic_value v;
pic_init_value(v, PIC_TYPE_CHAR);
v.u.c = c;
return v;
}
#endif
#define DEFVAL(name, type) \
pic_value name(pic_state *PIC_UNUSED(pic)) { \
pic_value v; \
pic_init_value(v, type); \
return v; \
}
DEFVAL(pic_nil_value, PIC_TYPE_NIL)
DEFVAL(pic_eof_object, PIC_TYPE_EOF)
DEFVAL(pic_true_value, PIC_TYPE_TRUE)
DEFVAL(pic_false_value, PIC_TYPE_FALSE)
DEFVAL(pic_undef_value, PIC_TYPE_UNDEF)
DEFVAL(pic_invalid_value, PIC_TYPE_INVALID)
int
pic_type(pic_state *PIC_UNUSED(pic), pic_value v)
{
int tt = pic_vtype(pic, v);
if (tt < PIC_IVAL_END) {
return tt;
}
return ((struct basic *)pic_obj_ptr(v))->tt;
}
const char *
pic_typename(pic_state *pic, int type)
{
switch (type) {
case PIC_TYPE_NIL:
return "null";
case PIC_TYPE_TRUE:
case PIC_TYPE_FALSE:
return "boolean";
case PIC_TYPE_FLOAT:
return "float";
case PIC_TYPE_INT:
return "int";
case PIC_TYPE_SYMBOL:
return "symbol";
case PIC_TYPE_CHAR:
return "char";
case PIC_TYPE_EOF:
return "eof-object";
case PIC_TYPE_UNDEF:
return "undefined";
case PIC_TYPE_INVALID:
return "invalid";
case PIC_TYPE_PAIR:
return "pair";
case PIC_TYPE_STRING:
return "string";
case PIC_TYPE_VECTOR:
return "vector";
case PIC_TYPE_BLOB:
return "bytevector";
case PIC_TYPE_PORT:
return "port";
case PIC_TYPE_ERROR:
return "error";
case PIC_TYPE_ID:
return "identifier";
case PIC_TYPE_CXT:
return "context";
case PIC_TYPE_FUNC:
case PIC_TYPE_IREP:
return "procedure";
case PIC_TYPE_ENV:
return "environment";
case PIC_TYPE_DATA:
return "data";
case PIC_TYPE_DICT:
return "dictionary";
case PIC_TYPE_WEAK:
return "ephemeron";
case PIC_TYPE_RECORD:
return "record";
case PIC_TYPE_CP:
return "checkpoint";
default:
pic_error(pic, "pic_typename: invalid type given", 1, pic_int_value(pic, type));
}
}

305
lib/value.h Normal file
View File

@ -0,0 +1,305 @@
/**
* See Copyright Notice in picrin.h
*/
#ifndef PICRIN_VALUE_H
#define PICRIN_VALUE_H
#if defined(__cplusplus)
extern "C" {
#endif
#ifndef INLINE
# if GENERATE_EXTERNAL_DEFINITION
# define INLINE
# else
# define INLINE
# endif
#endif
#define INLINE PIC_STATIC_INLINE
enum {
PIC_TYPE_INVALID = 1,
PIC_TYPE_FLOAT = 2,
PIC_TYPE_INT = 3,
PIC_TYPE_CHAR = 4,
PIC_TYPE_EOF = 5,
PIC_TYPE_UNDEF = 6,
PIC_TYPE_TRUE = 8,
PIC_TYPE_NIL = 7,
PIC_TYPE_FALSE = 9,
PIC_IVAL_END = 10,
/* -------------------- */
PIC_TYPE_STRING = 16,
PIC_TYPE_VECTOR = 17,
PIC_TYPE_BLOB = 18,
PIC_TYPE_PORT = 20,
PIC_TYPE_ERROR = 21,
PIC_TYPE_ID = 22,
PIC_TYPE_ENV = 23,
PIC_TYPE_DATA = 24,
PIC_TYPE_DICT = 25,
PIC_TYPE_WEAK = 26,
PIC_TYPE_RECORD = 27,
PIC_TYPE_SYMBOL = 28,
PIC_TYPE_PAIR = 29,
PIC_TYPE_CXT = 30,
PIC_TYPE_CP = 31,
PIC_TYPE_FUNC = 32,
PIC_TYPE_IREP = 33
};
PIC_STATIC_INLINE int obj_tt(void *); /* defined in object.h */
#if !PIC_NAN_BOXING
PIC_STATIC_INLINE pic_value
make_value(int type)
{
pic_value v;
v.type = type;
v.u.data = NULL;
return v;
}
PIC_STATIC_INLINE struct object *
obj_ptr(pic_value v)
{
return (struct object *)(v.u.data);
}
PIC_STATIC_INLINE bool
obj_p(pic_state *PIC_UNUSED(pic), pic_value v)
{
return v.type > PIC_IVAL_END;
}
PIC_STATIC_INLINE pic_value
pic_obj_value(void *ptr)
{
pic_value v = make_value(obj_tt(ptr));
v.u.data = ptr;
return v;
}
PIC_STATIC_INLINE int
value_type(pic_state *PIC_UNUSED(pic), pic_value v)
{
return (int)(v.type);
}
INLINE int
pic_int(pic_state *PIC_UNUSED(pic), pic_value v)
{
return v.u.i;
}
INLINE double
pic_float(pic_state *PIC_UNUSED(pic), pic_value v)
{
return v.u.f;
}
INLINE char
pic_char(pic_state *PIC_UNUSED(pic), pic_value v)
{
return v.u.c;
}
INLINE pic_value
pic_int_value(pic_state *PIC_UNUSED(pic), int i)
{
pic_value v = make_value(PIC_TYPE_INT);
v.u.i = i;
return v;
}
INLINE pic_value
pic_float_value(pic_state *PIC_UNUSED(pic), double f)
{
pic_value v = make_value(PIC_TYPE_FLOAT);
v.u.f = f;
return v;
}
INLINE pic_value
pic_char_value(pic_state *PIC_UNUSED(pic), char c)
{
pic_value v = make_value(PIC_TYPE_CHAR);
v.u.c = c;
return v;
}
#else /* NAN_BOXING */
/**
* value representation by nan-boxing:
* float : FFFFFFFFFFFFFFFF FFFFFFFFFFFFFFFF FFFFFFFFFFFFFFFF FFFFFFFFFFFFFFFF
* ptr : 111111111111TTTT PPPPPPPPPPPPPPPP PPPPPPPPPPPPPPPP PPPPPPPPPPPPPPPP
* int : 111111111111TTTT 0000000000000000 IIIIIIIIIIIIIIII IIIIIIIIIIIIIIII
* char : 111111111111TTTT 0000000000000000 CCCCCCCCCCCCCCCC CCCCCCCCCCCCCCCC
*/
PIC_STATIC_INLINE pic_value
make_value(int type)
{
pic_value v;
v.v = 0xfff0000000000000ul | ((uint64_t)(type) << 48);
return v;
}
PIC_STATIC_INLINE struct object *
obj_ptr(pic_value v)
{
return (struct object *)(0xfffffffffffful & v.v);
}
PIC_STATIC_INLINE bool
obj_p(pic_state *PIC_UNUSED(pic), pic_value v)
{
return v.v > ((0xfff0ul + (0xf & PIC_IVAL_END)) << 48);
}
PIC_STATIC_INLINE pic_value
pic_obj_value(void *ptr)
{
pic_value v = make_value(PIC_IVAL_END);
v.v |= 0xfffffffffffful & (uint64_t)ptr;
return v;
}
PIC_STATIC_INLINE int
value_type(pic_state *PIC_UNUSED(pic), pic_value v)
{
int tt = 0xfff0 >= (v.v >> 48) ? PIC_TYPE_FLOAT : ((v.v >> 48) & 0xf);
if (tt == PIC_IVAL_END) {
return obj_tt(obj_ptr(v));
}
return tt;
}
INLINE int
pic_int(pic_state *PIC_UNUSED(pic), pic_value v)
{
union { int i; unsigned u; } u;
u.u = v.v & 0xfffffffful;
return u.i;
}
INLINE double
pic_float(pic_state *PIC_UNUSED(pic), pic_value v)
{
union { double f; uint64_t i; } u;
u.i = v.v;
return u.f;
}
INLINE char
pic_char(pic_state *PIC_UNUSED(pic), pic_value v)
{
return v.v & 0xfffffffful;
}
INLINE pic_value
pic_int_value(pic_state *PIC_UNUSED(pic), int i)
{
pic_value v = make_value(PIC_TYPE_INT);
v.v |= (unsigned)i;
return v;
}
INLINE pic_value
pic_float_value(pic_state *PIC_UNUSED(pic), double f)
{
union { double f; uint64_t i; } u;
pic_value v;
if (f != f) {
v.v = 0x7ff8000000000000ul;
} else {
u.f = f;
v.v = u.i;
}
return v;
}
INLINE pic_value
pic_char_value(pic_state *PIC_UNUSED(pic), char c)
{
pic_value v = make_value(PIC_TYPE_CHAR);
v.v |= (unsigned char)c;
return v;
}
#endif /* NAN_BOXING end */
#define DEFVAL(name, type) \
INLINE pic_value name(pic_state *PIC_UNUSED(pic)) { \
return make_value(type); \
}
DEFVAL(pic_nil_value, PIC_TYPE_NIL)
DEFVAL(pic_eof_object, PIC_TYPE_EOF)
DEFVAL(pic_true_value, PIC_TYPE_TRUE)
DEFVAL(pic_false_value, PIC_TYPE_FALSE)
DEFVAL(pic_undef_value, PIC_TYPE_UNDEF)
DEFVAL(pic_invalid_value, PIC_TYPE_INVALID)
INLINE pic_value
pic_bool_value(pic_state *PIC_UNUSED(pic), bool b)
{
return make_value(b ? PIC_TYPE_TRUE : PIC_TYPE_FALSE);
}
#define DEFPRED(name, type) \
INLINE bool name(pic_state *pic, pic_value obj) { \
return value_type(pic, obj) == type; \
}
DEFPRED(pic_invalid_p, PIC_TYPE_INVALID)
DEFPRED(pic_float_p, PIC_TYPE_FLOAT)
DEFPRED(pic_int_p, PIC_TYPE_INT)
DEFPRED(pic_char_p, PIC_TYPE_CHAR)
DEFPRED(pic_eof_p, PIC_TYPE_EOF)
DEFPRED(pic_undef_p, PIC_TYPE_UNDEF)
DEFPRED(pic_true_p, PIC_TYPE_TRUE)
DEFPRED(pic_nil_p, PIC_TYPE_NIL)
DEFPRED(pic_false_p, PIC_TYPE_FALSE)
DEFPRED(pic_str_p, PIC_TYPE_STRING)
DEFPRED(pic_vec_p, PIC_TYPE_VECTOR)
DEFPRED(pic_blob_p, PIC_TYPE_BLOB)
DEFPRED(pic_error_p, PIC_TYPE_ERROR)
DEFPRED(pic_dict_p, PIC_TYPE_DICT)
DEFPRED(pic_weak_p, PIC_TYPE_WEAK)
DEFPRED(pic_env_p, PIC_TYPE_ENV)
DEFPRED(pic_rec_p, PIC_TYPE_RECORD)
DEFPRED(pic_sym_p, PIC_TYPE_SYMBOL)
DEFPRED(pic_pair_p, PIC_TYPE_PAIR)
DEFPRED(pic_cp_p, PIC_TYPE_CP)
DEFPRED(pic_func_p, PIC_TYPE_FUNC)
DEFPRED(pic_irep_p, PIC_TYPE_IREP)
INLINE bool
pic_bool_p(pic_state *pic, pic_value obj)
{
return pic_true_p(pic, obj) || pic_false_p(pic, obj);
}
INLINE bool
pic_proc_p(pic_state *pic, pic_value o)
{
return pic_func_p(pic, o) || pic_irep_p(pic, o);
}
INLINE bool
pic_id_p(pic_state *pic, pic_value o)
{
return value_type(pic, o) == PIC_TYPE_ID || pic_sym_p(pic, o);
}
#if defined(__cplusplus)
}
#endif
#endif

1
lib/var.c
View File

@ -3,6 +3,7 @@
*/ */
#include "picrin.h" #include "picrin.h"
#include "value.h"
#include "object.h" #include "object.h"
#include "state.h" #include "state.h"

1
lib/vector.c
View File

@ -3,6 +3,7 @@
*/ */
#include "picrin.h" #include "picrin.h"
#include "value.h"
#include "object.h" #include "object.h"
pic_value pic_value

11
lib/weak.c
View File

@ -3,6 +3,7 @@
*/ */
#include "picrin.h" #include "picrin.h"
#include "value.h"
#include "object.h" #include "object.h"
KHASH_DEFINE(weak, struct object *, pic_value, kh_ptr_hash_func, kh_ptr_hash_equal) KHASH_DEFINE(weak, struct object *, pic_value, kh_ptr_hash_func, kh_ptr_hash_equal)
@ -25,7 +26,7 @@ pic_weak_ref(pic_state *pic, pic_value weak, pic_value key)
khash_t(weak) *h = &pic_weak_ptr(pic, weak)->hash; khash_t(weak) *h = &pic_weak_ptr(pic, weak)->hash;
int it; int it;
it = kh_get(weak, h, pic_obj_ptr(key)); it = kh_get(weak, h, obj_ptr(key));
if (it == kh_end(h)) { if (it == kh_end(h)) {
pic_error(pic, "element not found for given key", 1, key); pic_error(pic, "element not found for given key", 1, key);
} }
@ -39,7 +40,7 @@ pic_weak_set(pic_state *pic, pic_value weak, pic_value key, pic_value val)
int ret; int ret;
int it; int it;
it = kh_put(weak, h, pic_obj_ptr(key), &ret); it = kh_put(weak, h, obj_ptr(key), &ret);
kh_val(h, it) = val; kh_val(h, it) = val;
} }
@ -48,7 +49,7 @@ pic_weak_has(pic_state *pic, pic_value weak, pic_value key)
{ {
khash_t(weak) *h = &pic_weak_ptr(pic, weak)->hash; khash_t(weak) *h = &pic_weak_ptr(pic, weak)->hash;
return kh_get(weak, h, pic_obj_ptr(key)) != kh_end(h); return kh_get(weak, h, obj_ptr(key)) != kh_end(h);
} }
void void
@ -57,7 +58,7 @@ pic_weak_del(pic_state *pic, pic_value weak, pic_value key)
khash_t(weak) *h = &pic_weak_ptr(pic, weak)->hash; khash_t(weak) *h = &pic_weak_ptr(pic, weak)->hash;
int it; int it;
it = kh_get(weak, h, pic_obj_ptr(key)); it = kh_get(weak, h, obj_ptr(key));
if (it == kh_end(h)) { if (it == kh_end(h)) {
pic_error(pic, "element not found for given key", 1, key); pic_error(pic, "element not found for given key", 1, key);
} }
@ -73,7 +74,7 @@ weak_call(pic_state *pic)
n = pic_get_args(pic, "o|o", &key, &val); n = pic_get_args(pic, "o|o", &key, &val);
if (! pic_obj_p(pic, key)) { if (! obj_p(pic, key)) {
pic_error(pic, "attempted to set a non-object key", 1, key); pic_error(pic, "attempted to set a non-object key", 1, key);
} }