diff --git a/.gitmodules b/.gitmodules index e676f24f..25d3e4f0 100644 --- a/.gitmodules +++ b/.gitmodules @@ -1,12 +1,3 @@ -[submodule "extlib/xhash"] - path = extlib/xhash - url = git://github.com/wasabiz/xhash.git -[submodule "extlib/xfile"] - path = extlib/xfile - url = git://github.com/wasabiz/xfile.git -[submodule "extlib/xrope"] - path = extlib/xrope - url = git://github.com/wasabiz/xrope.git -[submodule "extlib/xvect"] - path = extlib/xvect - url = git://github.com/wasabiz/xvect.git +[submodule "extlib/benz"] + path = extlib/benz + url = git://github.com/picrin-scheme/benz.git diff --git a/CMakeLists.txt b/CMakeLists.txt index 2ee8e462..a46c0557 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -26,13 +26,12 @@ 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) include(contrib/CMakeLists.txt) include(src/CMakeLists.txt) -include(tools/CMakeLists.txt) # ---- diff --git a/extlib/benz b/extlib/benz new file mode 160000 index 00000000..a0687e29 --- /dev/null +++ b/extlib/benz @@ -0,0 +1 @@ +Subproject commit a0687e29e00c5e0389c7ed65415edca5e2a0dd75 diff --git a/extlib/xfile b/extlib/xfile deleted file mode 160000 index e9d634ff..00000000 --- a/extlib/xfile +++ /dev/null @@ -1 +0,0 @@ -Subproject commit e9d634ff99d1a954af3fa80dc2f2ccb1227b4a2b diff --git a/extlib/xhash b/extlib/xhash deleted file mode 160000 index 0b5f935a..00000000 --- a/extlib/xhash +++ /dev/null @@ -1 +0,0 @@ -Subproject commit 0b5f935aa7a236f1ef1787f81dce7f5ba679e95b diff --git a/extlib/xrope b/extlib/xrope deleted file mode 160000 index 32d99fae..00000000 --- a/extlib/xrope +++ /dev/null @@ -1 +0,0 @@ -Subproject commit 32d99fae069c1ec7bf0fc31345bfc27cae84b47a diff --git a/extlib/xvect b/extlib/xvect deleted file mode 160000 index 973b9f3d..00000000 --- a/extlib/xvect +++ /dev/null @@ -1 +0,0 @@ -Subproject commit 973b9f3d89ff4669d08f1bc28e205bd9834bef10 diff --git a/include/picrin.h b/include/picrin.h deleted file mode 100644 index e58d5a61..00000000 --- a/include/picrin.h +++ /dev/null @@ -1,223 +0,0 @@ -/** - * Copyright (c) 2013-2014 Yuichi Nishiwaki and other picrin contributors. - * - * Permission is hereby granted, free of charge, to any person obtaining - * a copy of this software and associated documentation files (the - * "Software"), to deal in the Software without restriction, including - * without limitation the rights to use, copy, modify, merge, publish, - * distribute, sublicense, and/or sell copies of the Software, and to - * permit persons to whom the Software is furnished to do so, subject to - * the following conditions: - * - * The above copyright notice and this permission notice shall be - * included in all copies or substantial portions of the Software. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - * IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY - * CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, - * TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE - * SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - */ - -#ifndef PICRIN_H__ -#define PICRIN_H__ - -#if defined(__cplusplus) -extern "C" { -#endif - -#include -#include -#include -#include -#include -#include -#include - -#include "xvect/xvect.h" -#include "xhash/xhash.h" -#include "xfile/xfile.h" -#include "xrope/xrope.h" - -#include "picrin/config.h" -#include "picrin/util.h" -#include "picrin/value.h" - -typedef struct pic_code pic_code; - -typedef struct { - int argc, retc; - pic_code *ip; - pic_value *fp; - struct pic_env *env; - int regc; - pic_value *regs; - struct pic_env *up; -} pic_callinfo; - -typedef struct { - int argc; - char **argv, **envp; - - struct pic_block *blk; - - pic_value *sp; - pic_value *stbase, *stend; - - pic_callinfo *ci; - pic_callinfo *cibase, *ciend; - - pic_code *ip; - - struct pic_lib *lib; - - pic_sym sDEFINE, sLAMBDA, sIF, sBEGIN, sQUOTE, sSETBANG; - pic_sym sQUASIQUOTE, sUNQUOTE, sUNQUOTE_SPLICING; - pic_sym sDEFINE_SYNTAX, sIMPORT, sEXPORT; - pic_sym sDEFINE_LIBRARY, sIN_LIBRARY; - pic_sym sCONS, sCAR, sCDR, sNILP; - pic_sym sADD, sSUB, sMUL, sDIV, sMINUS; - pic_sym sEQ, sLT, sLE, sGT, sGE, sNOT; - - pic_sym rDEFINE, rLAMBDA, rIF, rBEGIN, rQUOTE, rSETBANG; - pic_sym rDEFINE_SYNTAX, rIMPORT, rEXPORT; - pic_sym rDEFINE_LIBRARY, rIN_LIBRARY; - - xhash syms; /* name to symbol */ - xhash sym_names; /* symbol to name */ - int sym_cnt; - int uniq_sym_cnt; - - xhash globals; - xhash macros; - pic_value libs; - - struct pic_reader *reader; - - jmp_buf *jmp; - struct pic_error *err; - struct pic_jmpbuf *try_jmps; - size_t try_jmp_size, try_jmp_idx; - - struct pic_heap *heap; - struct pic_object **arena; - size_t arena_size, arena_idx; - - char *native_stack_start; -} pic_state; - -typedef pic_value (*pic_func_t)(pic_state *); - -void *pic_alloc(pic_state *, size_t); -#define pic_malloc(pic,size) pic_alloc(pic,size) /* obsoleted */ -void *pic_realloc(pic_state *, void *, size_t); -void *pic_calloc(pic_state *, size_t, size_t); -struct pic_object *pic_obj_alloc(pic_state *, size_t, enum pic_tt); -struct pic_object *pic_obj_alloc_unsafe(pic_state *, size_t, enum pic_tt); -void pic_free(pic_state *, void *); - -void pic_gc_run(pic_state *); -pic_value pic_gc_protect(pic_state *, pic_value); -size_t pic_gc_arena_preserve(pic_state *); -void pic_gc_arena_restore(pic_state *, size_t); -#define pic_void(exec) \ - pic_void_(GENSYM(ai), exec) -#define pic_void_(ai,exec) do { \ - size_t ai = pic_gc_arena_preserve(pic); \ - exec; \ - pic_gc_arena_restore(pic, ai); \ - } while (0) - -pic_state *pic_open(int argc, char *argv[], char **envp); -void pic_close(pic_state *); - -void pic_define(pic_state *, const char *, pic_value); /* automatic export */ -pic_value pic_ref(pic_state *, const char *); -void pic_set(pic_state *, const char *, pic_value); - -pic_value pic_funcall(pic_state *pic, const char *name, pic_list args); - -struct pic_proc *pic_get_proc(pic_state *); -int pic_get_args(pic_state *, const char *, ...); -void pic_defun(pic_state *, const char *, pic_func_t); - -bool pic_equal_p(pic_state *, pic_value, pic_value); - -pic_sym pic_intern(pic_state *, const char *, size_t); -pic_sym pic_intern_cstr(pic_state *, const char *); -const char *pic_symbol_name(pic_state *, pic_sym); -pic_sym pic_gensym(pic_state *, pic_sym); -pic_sym pic_ungensym(pic_state *, pic_sym); -bool pic_interned_p(pic_state *, pic_sym); - -char *pic_strdup(pic_state *, const char *); -char *pic_strndup(pic_state *, const char *, size_t); - -pic_value pic_read(pic_state *, struct pic_port *); -pic_value pic_read_cstr(pic_state *, const char *); -pic_list pic_parse_file(pic_state *, FILE *); /* #f for incomplete input */ -pic_list pic_parse_cstr(pic_state *, const char *); - -pic_value pic_load(pic_state *, const char *); -pic_value pic_load_cstr(pic_state *, const char *); - -pic_value pic_apply(pic_state *, struct pic_proc *, pic_value); -pic_value pic_apply0(pic_state *, struct pic_proc *); -pic_value pic_apply1(pic_state *, struct pic_proc *, pic_value); -pic_value pic_apply2(pic_state *, struct pic_proc *, pic_value, pic_value); -pic_value pic_apply3(pic_state *, struct pic_proc *, pic_value, pic_value, pic_value); -pic_value pic_apply4(pic_state *, struct pic_proc *, pic_value, pic_value, pic_value, pic_value); -pic_value pic_apply5(pic_state *, struct pic_proc *, pic_value, pic_value, pic_value, pic_value, pic_value); -pic_value pic_apply_trampoline(pic_state *, struct pic_proc *, pic_value); -pic_value pic_eval(pic_state *, pic_value, struct pic_lib *); -struct pic_proc *pic_compile(pic_state *, pic_value, struct pic_lib *); -pic_value pic_macroexpand(pic_state *, pic_value, struct pic_lib *); - -void pic_in_library(pic_state *, pic_value); -struct pic_lib *pic_make_library(pic_state *, pic_value); -struct pic_lib *pic_find_library(pic_state *, pic_value); - -#define pic_deflibrary(pic, spec) \ - pic_deflibrary_helper__(pic, GENSYM(i), GENSYM(prev_lib), spec) -#define pic_deflibrary_helper__(pic, i, prev_lib, spec) \ - for (int i = 0; ! i; ) \ - for (struct pic_lib *prev_lib; ! i; ) \ - for ((prev_lib = pic->lib), pic_make_library(pic, pic_read_cstr(pic, spec)), pic_in_library(pic, pic_read_cstr(pic, spec)); ! i++; pic->lib = prev_lib) - -void pic_import(pic_state *, pic_value); -void pic_export(pic_state *, pic_sym); - -noreturn void pic_abort(pic_state *, const char *); -noreturn void pic_errorf(pic_state *, const char *, ...); -void pic_warnf(pic_state *, const char *, ...); -pic_str *pic_get_backtrace(pic_state *); -void pic_print_backtrace(pic_state *, struct pic_error *); - -/* obsoleted */ -noreturn static inline void pic_error(pic_state *pic, const char *msg) -{ - pic_errorf(pic, msg); -} -static inline void pic_warn(pic_state *pic, const char *msg) -{ - pic_warnf(pic, msg); -} - -const char *pic_errmsg(pic_state *); - -pic_value pic_write(pic_state *, pic_value); /* returns given obj */ -pic_value pic_fwrite(pic_state *, pic_value, xFILE *); -void pic_printf(pic_state *, const char *, ...); -pic_value pic_display(pic_state *, pic_value); -pic_value pic_fdisplay(pic_state *, pic_value, xFILE *); -/* obsoleted macros */ -#define pic_debug(pic,obj) pic_write(pic,obj) -#define pic_fdebug(pic,obj,file) pic_fwrite(pic,obj,file) - -#if defined(__cplusplus) -} -#endif - -#endif diff --git a/include/picrin/blob.h b/include/picrin/blob.h deleted file mode 100644 index f61f588d..00000000 --- a/include/picrin/blob.h +++ /dev/null @@ -1,27 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#ifndef PICRIN_BLOB_H__ -#define PICRIN_BLOB_H__ - -#if defined(__cplusplus) -extern "C" { -#endif - -struct pic_blob { - PIC_OBJECT_HEADER - char *data; - size_t len; -}; - -#define pic_blob_p(v) (pic_type(v) == PIC_TT_BLOB) -#define pic_blob_ptr(v) ((struct pic_blob *)pic_ptr(v)) - -struct pic_blob *pic_blob_new(pic_state *, size_t); - -#if defined(__cplusplus) -} -#endif - -#endif diff --git a/include/picrin/config.h b/include/picrin/config.h deleted file mode 100644 index 79b8fc3c..00000000 --- a/include/picrin/config.h +++ /dev/null @@ -1,115 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -/** contribution libraries */ -/* #define PIC_CONTRIB_INITS */ - -/** switch normal VM and direct threaded VM */ -/* #define PIC_DIRECT_THREADED_VM 1 */ - -/** switch internal value representation */ -/* #define PIC_NAN_BOXING 1 */ - -/** enable readline module */ -/* #define PIC_ENABLE_READLINE 1 */ - -/** treat false value as none */ -/* #define PIC_NONE_IS_FALSE 1 */ - -/** initial memory size (to be dynamically extended if necessary) */ -/* #define PIC_ARENA_SIZE 1000 */ - -/* #define PIC_HEAP_PAGE_SIZE 10000 */ - -/* #define PIC_STACK_SIZE 1024 */ - -/* #define PIC_RESCUE_SIZE 30 */ - -/* #define PIC_SYM_POOL_SIZE 128 */ - -/* #define PIC_IREP_SIZE 8 */ - -/* #define PIC_POOL_SIZE 8 */ - -/* #define PIC_ISEQ_SIZE 1024 */ - -/** enable all debug flags */ -/* #define DEBUG 1 */ - -/** auxiliary debug flags */ -/* #define GC_STRESS 1 */ -/* #define VM_DEBUG 1 */ -/* #define GC_DEBUG 1 */ -/* #define GC_DEBUG_DETAIL 1 */ - -#if __STDC_VERSION__ < 199901L -# error please activate c99 features -#endif - -#ifndef PIC_CONTRIB_INITS -# define PIC_CONTRIB_INITS -#endif - -#ifndef PIC_DIRECT_THREADED_VM -# if defined(__GNUC__) || defined(__CLANG__) -# define PIC_DIRECT_THREADED_VM 1 -# endif -#endif - -#ifndef PIC_NAN_BOXING -# if __x86_64__ && __STDC_VERSION__ >= 201112L -# define PIC_NAN_BOXING 1 -# endif -#endif - -#ifndef PIC_ENABLE_READLINE -# if PIC_READLINE_FOUND -# define PIC_ENABLE_READLINE 1 -# else -# define PIC_ENABLE_READLINE 0 -# endif -#endif - -#ifndef PIC_NONE_IS_FALSE -# define PIC_NONE_IS_FALSE 1 -#endif - -#ifndef PIC_ARENA_SIZE -# define PIC_ARENA_SIZE 1000 -#endif - -#ifndef PIC_HEAP_PAGE_SIZE -# define PIC_HEAP_PAGE_SIZE 10000 -#endif - -#ifndef PIC_STACK_SIZE -# define PIC_STACK_SIZE 1024 -#endif - -#ifndef PIC_RESCUE_SIZE -# define PIC_RESCUE_SIZE 30 -#endif - -#ifndef PIC_SYM_POOL_SIZE -# define PIC_SYM_POOL_SIZE 128 -#endif - -#ifndef PIC_IREP_SIZE -# define PIC_IREP_SIZE 8 -#endif - -#ifndef PIC_POOL_SIZE -# define PIC_POOL_SIZE 8 -#endif - -#ifndef PIC_ISEQ_SIZE -# define PIC_ISEQ_SIZE 1024 -#endif - -#if DEBUG -# define GC_STRESS 0 -# define VM_DEBUG 1 -# define GC_DEBUG 0 -# define GC_DEBUG_DETAIL 0 -#endif diff --git a/include/picrin/cont.h b/include/picrin/cont.h deleted file mode 100644 index 0a0da9f1..00000000 --- a/include/picrin/cont.h +++ /dev/null @@ -1,62 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#ifndef PICRIN_CONT_H__ -#define PICRIN_CONT_H__ - -#if defined(__cplusplus) -extern "C" { -#endif - -struct pic_block { - PIC_OBJECT_HEADER - struct pic_block *prev; - int depth; - struct pic_proc *in, *out; -}; - -struct pic_cont { - PIC_OBJECT_HEADER - jmp_buf jmp; - - struct pic_block *blk; - - char *stk_pos, *stk_ptr; - ptrdiff_t stk_len; - - pic_value *st_ptr; - size_t sp_offset, st_len; - - pic_callinfo *ci_ptr; - size_t ci_offset, ci_len; - - pic_code *ip; - - struct pic_object **arena; - size_t arena_size; - int arena_idx; - - struct pic_jmpbuf *try_jmps; - size_t try_jmp_idx, try_jmp_size; - - pic_value results; -}; - -pic_value pic_values0(pic_state *); -pic_value pic_values1(pic_state *, pic_value); -pic_value pic_values2(pic_state *, pic_value, pic_value); -pic_value pic_values3(pic_state *, pic_value, pic_value, pic_value); -pic_value pic_values4(pic_state *, pic_value, pic_value, pic_value, pic_value); -pic_value pic_values5(pic_state *, pic_value, pic_value, pic_value, pic_value, pic_value); -pic_value pic_values_by_array(pic_state *, size_t, pic_value *); -pic_value pic_values_by_list(pic_state *, pic_value); -size_t pic_receive(pic_state *, size_t, pic_value *); - -pic_value pic_callcc(pic_state *, struct pic_proc *); - -#if defined(__cplusplus) -} -#endif - -#endif diff --git a/include/picrin/data.h b/include/picrin/data.h deleted file mode 100644 index a80ff209..00000000 --- a/include/picrin/data.h +++ /dev/null @@ -1,37 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#ifndef PICRIN_DATA_H__ -#define PICRIN_DATA_H__ - -#if defined(__cplusplus) -extern "C" { -#endif - -typedef struct { - const char *type_name; - void (*dtor)(pic_state *, void *); -} pic_data_type; - -struct pic_data { - PIC_OBJECT_HEADER; - const pic_data_type *type; - xhash storage; /* const char * to pic_value table */ - void *data; -}; - -#define pic_data_p(o) (pic_type(o) == PIC_TT_DATA) -#define pic_data_ptr(o) ((struct pic_data *)pic_ptr(o)) - -static inline bool pic_data_type_p(const pic_value obj, const pic_data_type *type) { - return pic_data_p(obj) && pic_data_ptr(obj)->type == type; -} - -struct pic_data *pic_data_alloc(pic_state *, const pic_data_type *, void *); - -#if defined(__cplusplus) -} -#endif - -#endif diff --git a/include/picrin/dict.h b/include/picrin/dict.h deleted file mode 100644 index 8bc58ad8..00000000 --- a/include/picrin/dict.h +++ /dev/null @@ -1,32 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#ifndef PICRIN_DICT_H__ -#define PICRIN_DICT_H__ - -#if defined(__cplusplus) -extern "C" { -#endif - -struct pic_dict { - PIC_OBJECT_HEADER - xhash hash; -}; - -#define pic_dict_p(v) (pic_type(v) == PIC_TT_DICT) -#define pic_dict_ptr(v) ((struct pic_dict *)pic_ptr(v)) - -struct pic_dict *pic_dict_new(pic_state *); - -pic_value pic_dict_ref(pic_state *, struct pic_dict *, pic_sym); -void pic_dict_set(pic_state *, struct pic_dict *, pic_sym, pic_value); -void pic_dict_del(pic_state *, struct pic_dict *, pic_sym); -size_t pic_dict_size(pic_state *, struct pic_dict *); -bool pic_dict_has(pic_state *, struct pic_dict *, pic_sym); - -#if defined(__cplusplus) -} -#endif - -#endif diff --git a/include/picrin/error.h b/include/picrin/error.h deleted file mode 100644 index bea590e2..00000000 --- a/include/picrin/error.h +++ /dev/null @@ -1,60 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#ifndef PICRIN_ERROR_H__ -#define PICRIN_ERROR_H__ - -#if defined(__cplusplus) -extern "C" { -#endif - -struct pic_jmpbuf { - jmp_buf here; - struct pic_proc *handler; - ptrdiff_t ci_offset; - ptrdiff_t sp_offset; - pic_code *ip; - jmp_buf *prev_jmp; -}; - -/* do not return from try block! */ - -#define pic_try \ - pic_try_with_handler(NULL) -#define pic_try_with_handler(handler) \ - pic_push_try(pic, handler); \ - if (setjmp(*pic->jmp) == 0) \ - do -#define pic_catch \ - while (pic_pop_try(pic), 0); \ - else \ - if (pic_pop_try(pic), 1) - -void pic_push_try(pic_state *, struct pic_proc *); -void pic_pop_try(pic_state *); - -noreturn void pic_throw(pic_state *, short, const char *, pic_value); -noreturn void pic_throw_error(pic_state *, struct pic_error *); - -struct pic_error { - PIC_OBJECT_HEADER - enum pic_error_kind { - PIC_ERROR_OTHER, - PIC_ERROR_FILE, - PIC_ERROR_READ, - PIC_ERROR_RAISED - } type; - struct pic_string *msg; - pic_value irrs; - pic_str *stack; -}; - -#define pic_error_p(v) (pic_type(v) == PIC_TT_ERROR) -#define pic_error_ptr(v) ((struct pic_error *)pic_ptr(v)) - -#if defined(__cplusplus) -} -#endif - -#endif diff --git a/include/picrin/gc.h b/include/picrin/gc.h deleted file mode 100644 index c5f33e6a..00000000 --- a/include/picrin/gc.h +++ /dev/null @@ -1,24 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#ifndef PICRIN_GC_H__ -#define PICRIN_GC_H__ - -#if defined(__cplusplus) -extern "C" { -#endif - -#define PIC_GC_UNMARK 0 -#define PIC_GC_MARK 1 - -struct pic_heap; - -struct pic_heap *pic_heap_open(); -void pic_heap_close(struct pic_heap *); - -#if defined(__cplusplus) -} -#endif - -#endif diff --git a/include/picrin/irep.h b/include/picrin/irep.h deleted file mode 100644 index 4cb1cfba..00000000 --- a/include/picrin/irep.h +++ /dev/null @@ -1,206 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#ifndef PICRIN_IREP_H__ -#define PICRIN_IREP_H__ - -#if defined(__cplusplus) -extern "C" { -#endif - -enum pic_opcode { - OP_NOP, - OP_POP, - OP_PUSHNIL, - OP_PUSHTRUE, - OP_PUSHFALSE, - OP_PUSHINT, - OP_PUSHCHAR, - OP_PUSHCONST, - OP_GREF, - OP_GSET, - OP_LREF, - OP_LSET, - OP_CREF, - OP_CSET, - OP_JMP, - OP_JMPIF, - OP_NOT, - OP_CALL, - OP_TAILCALL, - OP_RET, - OP_LAMBDA, - OP_CONS, - OP_CAR, - OP_CDR, - OP_NILP, - OP_ADD, - OP_SUB, - OP_MUL, - OP_DIV, - OP_MINUS, - OP_EQ, - OP_LT, - OP_LE, - OP_STOP -}; - -struct pic_code { - enum pic_opcode insn; - union { - int i; - char c; - struct { - short depth; - short idx; - } r; - } u; -}; - -struct pic_irep { - PIC_OBJECT_HEADER - pic_sym name; - pic_code *code; - int argc, localc, capturec; - bool varg; - struct pic_irep **irep; - pic_value *pool; - size_t clen, ilen, plen; -}; - -pic_value pic_analyze(pic_state *, pic_value); -struct pic_irep *pic_codegen(pic_state *, pic_value); - -static inline void -pic_dump_code(pic_code c) -{ - printf("[%2d] ", c.insn); - switch (c.insn) { - case OP_NOP: - puts("OP_NOP"); - break; - case OP_POP: - puts("OP_POP"); - break; - case OP_PUSHNIL: - puts("OP_PUSHNIL"); - break; - case OP_PUSHTRUE: - puts("OP_PUSHTRUE"); - break; - case OP_PUSHFALSE: - puts("OP_PUSHFALSE"); - break; - case OP_PUSHINT: - printf("OP_PUSHINT\t%d\n", c.u.i); - break; - case OP_PUSHCHAR: - printf("OP_PUSHCHAR\t%c\n", c.u.c); - break; - case OP_PUSHCONST: - printf("OP_PUSHCONST\t%d\n", c.u.i); - break; - case OP_GREF: - printf("OP_GREF\t%i\n", c.u.i); - break; - case OP_GSET: - printf("OP_GSET\t%i\n", c.u.i); - break; - case OP_LREF: - printf("OP_LREF\t%d\n", c.u.i); - break; - case OP_LSET: - printf("OP_LSET\t%d\n", c.u.i); - break; - case OP_CREF: - printf("OP_CREF\t%d\t%d\n", c.u.r.depth, c.u.r.idx); - break; - case OP_CSET: - printf("OP_CSET\t%d\t%d\n", c.u.r.depth, c.u.r.idx); - break; - case OP_JMP: - printf("OP_JMP\t%x\n", c.u.i); - break; - case OP_JMPIF: - printf("OP_JMPIF\t%x\n", c.u.i); - break; - case OP_NOT: - puts("OP_NOT"); - break; - case OP_CALL: - printf("OP_CALL\t%d\n", c.u.i); - break; - case OP_TAILCALL: - printf("OP_TAILCALL\t%d\n", c.u.i); - break; - case OP_RET: - printf("OP_RET\t%d\n", c.u.i); - break; - case OP_LAMBDA: - printf("OP_LAMBDA\t%d\n", c.u.i); - break; - case OP_CONS: - puts("OP_CONS"); - break; - case OP_CAR: - puts("OP_CAR"); - break; - case OP_NILP: - puts("OP_NILP"); - break; - case OP_CDR: - puts("OP_CDR"); - break; - case OP_ADD: - puts("OP_ADD"); - break; - case OP_SUB: - puts("OP_SUB"); - break; - case OP_MUL: - puts("OP_MUL"); - break; - case OP_DIV: - puts("OP_DIV"); - break; - case OP_MINUS: - puts("OP_MINUS"); - break; - case OP_EQ: - puts("OP_EQ"); - break; - case OP_LT: - puts("OP_LT"); - break; - case OP_LE: - puts("OP_LE"); - break; - case OP_STOP: - puts("OP_STOP"); - break; - } -} - -static inline void -pic_dump_irep(struct pic_irep *irep) -{ - unsigned i; - - printf("## irep %p\n", (void *)irep); - printf("[clen = %zd, argc = %d, localc = %d, capturec = %d]\n", irep->clen, irep->argc, irep->localc, irep->capturec); - for (i = 0; i < irep->clen; ++i) { - printf("%02x ", i); - pic_dump_code(irep->code[i]); - } - - for (i = 0; i < irep->ilen; ++i) { - pic_dump_irep(irep->irep[i]); - } -} - -#if defined(__cplusplus) -} -#endif - -#endif diff --git a/include/picrin/lib.h b/include/picrin/lib.h deleted file mode 100644 index ba43e49d..00000000 --- a/include/picrin/lib.h +++ /dev/null @@ -1,25 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#ifndef PICRIN_LIB_H__ -#define PICRIN_LIB_H__ - -#if defined(__cplusplus) -extern "C" { -#endif - -struct pic_lib { - PIC_OBJECT_HEADER - pic_value name; - struct pic_senv *env; - xhash exports; -}; - -#define pic_lib_ptr(o) ((struct pic_lib *)pic_ptr(o)) - -#if defined(__cplusplus) -} -#endif - -#endif diff --git a/include/picrin/macro.h b/include/picrin/macro.h deleted file mode 100644 index d655a735..00000000 --- a/include/picrin/macro.h +++ /dev/null @@ -1,47 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#ifndef PICRIN_MACRO_H__ -#define PICRIN_MACRO_H__ - -#if defined(__cplusplus) -extern "C" { -#endif - -struct pic_senv { - PIC_OBJECT_HEADER - xhash map; - struct pic_senv *up; -}; - -struct pic_macro { - PIC_OBJECT_HEADER - struct pic_proc *proc; - struct pic_senv *senv; -}; - -#define pic_macro_p(v) (pic_type(v) == PIC_TT_MACRO) -#define pic_macro_ptr(v) ((struct pic_macro *)pic_ptr(v)) - -#define pic_senv_p(v) (pic_type(v) == PIC_TT_SENV) -#define pic_senv_ptr(v) ((struct pic_senv *)pic_ptr(v)) - -struct pic_senv *pic_null_syntactic_environment(pic_state *); - -bool pic_identifier_p(pic_state *pic, pic_value obj); -bool pic_identifier_eq_p(pic_state *, struct pic_senv *, pic_sym, struct pic_senv *, pic_sym); - -struct pic_senv *pic_senv_new(pic_state *, struct pic_senv *); - -pic_sym pic_add_rename(pic_state *, struct pic_senv *, pic_sym); -bool pic_find_rename(pic_state *, struct pic_senv *, pic_sym, pic_sym * /* = NULL */); -void pic_put_rename(pic_state *, struct pic_senv *, pic_sym, pic_sym); - -void pic_define_syntactic_keyword(pic_state *, struct pic_senv *, pic_sym, pic_sym); - -#if defined(__cplusplus) -} -#endif - -#endif diff --git a/include/picrin/pair.h b/include/picrin/pair.h deleted file mode 100644 index 49de01cc..00000000 --- a/include/picrin/pair.h +++ /dev/null @@ -1,76 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#ifndef PICRIN_PAIR_H__ -#define PICRIN_PAIR_H__ - -#if defined(__cplusplus) -extern "C" { -#endif - -struct pic_pair { - PIC_OBJECT_HEADER - pic_value car; - pic_value cdr; -}; - -#define pic_pair_p(v) (pic_type(v) == PIC_TT_PAIR) -#define pic_pair_ptr(o) ((struct pic_pair *)pic_ptr(o)) - -pic_value pic_cons(pic_state *, pic_value, pic_value); -pic_value pic_car(pic_state *, pic_value); -pic_value pic_cdr(pic_state *, pic_value); -void pic_set_car(pic_state *, pic_value, pic_value); -void pic_set_cdr(pic_state *, pic_value, pic_value); - -bool pic_list_p(pic_value); -pic_value pic_list1(pic_state *, pic_value); -pic_value pic_list2(pic_state *, pic_value, pic_value); -pic_value pic_list3(pic_state *, pic_value, pic_value, pic_value); -pic_value pic_list4(pic_state *, pic_value, pic_value, pic_value, pic_value); -pic_value pic_list5(pic_state *, pic_value, pic_value, pic_value, pic_value, pic_value); -pic_value pic_list6(pic_state *, pic_value, pic_value, pic_value, pic_value, pic_value, pic_value); -pic_value pic_list7(pic_state *, pic_value, pic_value, pic_value, pic_value, pic_value, pic_value, pic_value); -pic_value pic_list_by_array(pic_state *, size_t, pic_value *); -pic_value pic_make_list(pic_state *, int, pic_value); - -#define pic_for_each(var, list) \ - pic_for_each_helper__(var, GENSYM(tmp), list) -#define pic_for_each_helper__(var, tmp, list) \ - for (pic_value tmp = (list); \ - pic_nil_p(tmp) ? false : ((var = pic_car(pic, tmp)), true); \ - tmp = pic_cdr(pic, tmp)) - -#define pic_push(pic, item, place) (place = pic_cons(pic, item, place)) -#define pic_pop(pic, place) (place = pic_cdr(pic, place)) - -int pic_length(pic_state *, pic_value); -pic_value pic_reverse(pic_state *, pic_value); -pic_value pic_append(pic_state *, pic_value, pic_value); - -pic_value pic_memq(pic_state *, pic_value key, pic_value list); -pic_value pic_memv(pic_state *, pic_value key, pic_value list); -pic_value pic_member(pic_state *, pic_value key, pic_value list, struct pic_proc * /* = NULL */); - -pic_value pic_assq(pic_state *, pic_value key, pic_value assoc); -pic_value pic_assv(pic_state *, pic_value key, pic_value assoc); -pic_value pic_assoc(pic_state *, pic_value key, pic_value assoc, struct pic_proc * /* = NULL */); - -pic_value pic_acons(pic_state *, pic_value key, pic_value val, pic_value assoc); - -pic_value pic_caar(pic_state *, pic_value); -pic_value pic_cadr(pic_state *, pic_value); -pic_value pic_cdar(pic_state *, pic_value); -pic_value pic_cddr(pic_state *, pic_value); - -pic_value pic_list_tail(pic_state *, pic_value, int); -pic_value pic_list_ref(pic_state *, pic_value, int); -void pic_list_set(pic_state *, pic_value, int, pic_value); -pic_value pic_list_copy(pic_state *, pic_value); - -#if defined(__cplusplus) -} -#endif - -#endif diff --git a/include/picrin/port.h b/include/picrin/port.h deleted file mode 100644 index e51d8759..00000000 --- a/include/picrin/port.h +++ /dev/null @@ -1,50 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#ifndef PICRIN_PORT_H__ -#define PICRIN_PORT_H__ - -#if defined(__cplusplus) -extern "C" { -#endif - -enum pic_port_flag { - PIC_PORT_IN = 1, - PIC_PORT_OUT = 2, - PIC_PORT_TEXT = 4, - PIC_PORT_BINARY = 8, -}; - -enum pic_port_status { - PIC_PORT_OPEN, - PIC_PORT_CLOSE, -}; - -struct pic_port { - PIC_OBJECT_HEADER - xFILE *file; - int flags; - int status; -}; - -#define pic_port_p(v) (pic_type(v) == PIC_TT_PORT) -#define pic_port_ptr(v) ((struct pic_port *)pic_ptr(v)) - -pic_value pic_eof_object(); - -struct pic_port *pic_stdin(pic_state *); -struct pic_port *pic_stdout(pic_state *); -struct pic_port *pic_stderr(pic_state *); - -struct pic_port *pic_open_input_string(pic_state *, const char *); -struct pic_port *pic_open_output_string(pic_state *); -struct pic_string *pic_get_output_string(pic_state *, struct pic_port *); - -void pic_close_port(pic_state *pic, struct pic_port *); - -#if defined(__cplusplus) -} -#endif - -#endif diff --git a/include/picrin/proc.h b/include/picrin/proc.h deleted file mode 100644 index b91960de..00000000 --- a/include/picrin/proc.h +++ /dev/null @@ -1,62 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#ifndef PICRIN_PROC_H__ -#define PICRIN_PROC_H__ - -#if defined(__cplusplus) -extern "C" { -#endif - -/* native C function */ -struct pic_func { - pic_func_t f; - pic_sym name; -}; - -struct pic_env { - PIC_OBJECT_HEADER - pic_value *regs; - int regc; - struct pic_env *up; - pic_value storage[]; -}; - -struct pic_proc { - PIC_OBJECT_HEADER - char kind; - union { - struct pic_func func; - struct pic_irep *irep; - } u; - struct pic_env *env; - struct pic_dict *attr; -}; - -#define PIC_PROC_KIND_FUNC 1 -#define PIC_PROC_KIND_IREP 2 - -#define pic_proc_func_p(proc) ((proc)->kind == PIC_PROC_KIND_FUNC) -#define pic_proc_irep_p(proc) ((proc)->kind == PIC_PROC_KIND_IREP) - -#define pic_proc_p(o) (pic_type(o) == PIC_TT_PROC) -#define pic_proc_ptr(o) ((struct pic_proc *)pic_ptr(o)) - -#define pic_env_p(o) (pic_type(o) == PIC_TT_ENV) -#define pic_env_ptr(o) ((struct pic_env *)pic_ptr(o)) - -struct pic_proc *pic_proc_new(pic_state *, pic_func_t, const char *); -struct pic_proc *pic_proc_new_irep(pic_state *, struct pic_irep *, struct pic_env *); - -pic_sym pic_proc_name(struct pic_proc *); - -struct pic_dict *pic_attr(pic_state *, struct pic_proc *); -pic_value pic_attr_ref(pic_state *, struct pic_proc *, const char *); -void pic_attr_set(pic_state *, struct pic_proc *, const char *, pic_value); - -#if defined(__cplusplus) -} -#endif - -#endif diff --git a/include/picrin/read.h b/include/picrin/read.h deleted file mode 100644 index 8b977d58..00000000 --- a/include/picrin/read.h +++ /dev/null @@ -1,39 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#ifndef PICRIN_READ_H__ -#define PICRIN_READ_H__ - -#if defined(__cplusplus) -extern "C" { -#endif - -enum pic_typecase { - PIC_CASE_DEFAULT, - PIC_CASE_FOLD, -}; - -struct pic_trie { - struct pic_trie *table[256]; - struct pic_proc *proc; -}; - -struct pic_reader { - short typecase; - xhash labels; - struct pic_trie *trie; -}; - -void pic_init_reader(pic_state *); - -void pic_define_reader(pic_state *, const char *, pic_func_t); - -struct pic_trie *pic_trie_new(pic_state *); -void pic_trie_delete(pic_state *, struct pic_trie *); - -#if defined(__cplusplus) -} -#endif - -#endif diff --git a/include/picrin/record.h b/include/picrin/record.h deleted file mode 100644 index bf8698f1..00000000 --- a/include/picrin/record.h +++ /dev/null @@ -1,30 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#ifndef PICRIN_RECORD_H -#define PICRIN_RECORD_H - -#if defined(__cplusplus) -extern "C" { -#endif - -struct pic_record { - PIC_OBJECT_HEADER - xhash hash; -}; - -#define pic_record_p(v) (pic_type(v) == PIC_TT_RECORD) -#define pic_record_ptr(v) ((struct pic_record *)pic_ptr(v)) - -struct pic_record *pic_record_new(pic_state *, pic_value); - -pic_value pic_record_type(pic_state *, struct pic_record *); -pic_value pic_record_ref(pic_state *, struct pic_record *, pic_sym); -void pic_record_set(pic_state *, struct pic_record *, pic_sym, pic_value); - -#if defined(__cplusplus) -} -#endif - -#endif diff --git a/include/picrin/string.h b/include/picrin/string.h deleted file mode 100644 index c2564ffe..00000000 --- a/include/picrin/string.h +++ /dev/null @@ -1,42 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#ifndef PICRIN_STRING_H__ -#define PICRIN_STRING_H__ - -#if defined(__cplusplus) -extern "C" { -#endif - -struct pic_string { - PIC_OBJECT_HEADER - xrope *rope; -}; - -#define pic_str_p(v) (pic_type(v) == PIC_TT_STRING) -#define pic_str_ptr(o) ((struct pic_string *)pic_ptr(o)) - -pic_str *pic_str_new(pic_state *, const char * /* nullable */, size_t); -pic_str *pic_str_new_cstr(pic_state *, const char *); -pic_str *pic_str_new_fill(pic_state *, size_t, char); - -size_t pic_strlen(pic_str *); -char pic_str_ref(pic_state *, pic_str *, size_t); -void pic_str_set(pic_state *, pic_str *, size_t, char); - -pic_str *pic_strcat(pic_state *, pic_str *, pic_str *); -pic_str *pic_substr(pic_state *, pic_str *, size_t, size_t); -int pic_strcmp(pic_str *, pic_str *); - -const char *pic_str_cstr(pic_str *); - -pic_value pic_format(pic_state *, const char *, ...); -pic_value pic_vformat(pic_state *, const char *, va_list); -pic_value pic_vfformat(pic_state *, xFILE *, const char *, va_list); - -#if defined(__cplusplus) -} -#endif - -#endif diff --git a/include/picrin/util.h b/include/picrin/util.h deleted file mode 100644 index f2f5e719..00000000 --- a/include/picrin/util.h +++ /dev/null @@ -1,51 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#ifndef PICRIN_UTIL_H__ -#define PICRIN_UTIL_H__ - -#if defined(__cplusplus) -extern "C" { -#endif - -#if __STDC_VERSION__ >= 201112L -# include -#elif __GNUC__ || __clang__ -# define noreturn __attribute__((noreturn)) -#else -# define noreturn -#endif - -#define FALLTHROUGH ((void)0) -#define UNUSED(v) ((void)(v)) - -#define GENSYM2__(x,y) G##x##_##y##__ -#define GENSYM1__(x,y) GENSYM2__(x,y) -#if defined(__COUNTER__) -# define GENSYM(x) GENSYM1__(__COUNTER__,x) -#else -# define GENSYM(x) GENSYM1__(__LINE__,x) -#endif - -#if GCC_VERSION >= 40500 || __clang__ -# define UNREACHABLE() (__builtin_unreachable()) -#else -# include -# define UNREACHABLE() (assert(false)) -#endif - -#define SWAP(type,a,b) \ - SWAP_HELPER__(type,GENSYM(tmp),a,b) -#define SWAP_HELPER__(type,tmp,a,b) \ - do { \ - type tmp = (a); \ - (a) = (b); \ - (b) = tmp; \ - } while (0) - -#if defined(__cplusplus) -} -#endif - -#endif diff --git a/include/picrin/value.h b/include/picrin/value.h deleted file mode 100644 index 6137c2eb..00000000 --- a/include/picrin/value.h +++ /dev/null @@ -1,484 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#ifndef PICRIN_VALUE_H__ -#define PICRIN_VALUE_H__ - -#if defined(__cplusplus) -extern "C" { -#endif - -/** - * pic_sym is just an alias to unsigned int. - */ - -typedef int pic_sym; - -/** - * `undef` values never seen from user-end: that is, - * it's used only for repsenting internal special state - */ - -enum pic_vtype { - PIC_VTYPE_NIL = 1, - PIC_VTYPE_TRUE, - PIC_VTYPE_FALSE, - PIC_VTYPE_UNDEF, - PIC_VTYPE_FLOAT, - PIC_VTYPE_INT, - PIC_VTYPE_SYMBOL, - PIC_VTYPE_CHAR, - PIC_VTYPE_EOF, - PIC_VTYPE_HEAP -}; - -#if PIC_NAN_BOXING - -/** - * value representation by nan-boxing: - * float : FFFFFFFFFFFFFFFF FFFFFFFFFFFFFFFF FFFFFFFFFFFFFFFF FFFFFFFFFFFFFFFF - * ptr : 111111111111TTTT PPPPPPPPPPPPPPPP PPPPPPPPPPPPPPPP PPPPPPPPPPPPPPPP - * int : 1111111111110110 0000000000000000 IIIIIIIIIIIIIIII IIIIIIIIIIIIIIII - * sym : 1111111111110111 0000000000000000 SSSSSSSSSSSSSSSS SSSSSSSSSSSSSSSS - * char : 1111111111111000 0000000000000000 CCCCCCCCCCCCCCCC ................ - */ - -typedef struct { - union { - void *data; - double f; - struct { - union { - int i; - pic_sym sym; - char c; - }; - uint32_t type_; - }; - } u; -} pic_value; - -#define pic_ptr(v) ((void *)((uint64_t)0xffffffffffff & (uint64_t)(v).u.data)) -#define pic_init_value(v,vtype) (((v).u.type_ = (((uint32_t)0xfff00000)|((uint32_t)((vtype)<<16)))), (v).u.i = 0) - -static inline enum pic_vtype -pic_vtype(pic_value v) -{ - return 0xfff00000 >= v.u.type_ - ? PIC_VTYPE_FLOAT - : (v.u.type_ & 0xf0000)>>16; -} - -#else - -typedef struct { - enum pic_vtype type; - union { - void *data; - double f; - int i; - pic_sym sym; - char c; - } u; -} pic_value; - -#define pic_ptr(v) ((v).u.data) -#define pic_vtype(v) ((v).type) -#define pic_init_value(v,vtype) ((v).type = (vtype), (v).u.data = NULL) - -#endif - -enum pic_tt { - /* immediate */ - PIC_TT_NIL, - PIC_TT_BOOL, - PIC_TT_FLOAT, - PIC_TT_INT, - PIC_TT_SYMBOL, - PIC_TT_CHAR, - PIC_TT_EOF, - PIC_TT_UNDEF, - /* heap */ - PIC_TT_PAIR, - PIC_TT_STRING, - PIC_TT_VECTOR, - PIC_TT_BLOB, - PIC_TT_PROC, - PIC_TT_PORT, - PIC_TT_ERROR, - PIC_TT_ENV, - PIC_TT_CONT, - PIC_TT_SENV, - PIC_TT_MACRO, - PIC_TT_LIB, - PIC_TT_VAR, - PIC_TT_IREP, - PIC_TT_DATA, - PIC_TT_DICT, - PIC_TT_RECORD, - PIC_TT_BLK, -}; - -#define PIC_OBJECT_HEADER \ - enum pic_tt tt; - -struct pic_object { - PIC_OBJECT_HEADER -}; - -struct pic_pair; -struct pic_string; -struct pic_vector; -struct pic_blob; - -struct pic_proc; -struct pic_port; - -/* set aliases to basic types */ -typedef pic_value pic_list; -typedef struct pic_pair pic_pair; -typedef struct pic_string pic_str; -typedef struct pic_vector pic_vec; -typedef struct pic_blob pic_blob; - -#define pic_float(v) ((v).u.f) -#define pic_int(v) ((v).u.i) -#define pic_sym(v) ((v).u.sym) -#define pic_char(v) ((v).u.c) - -#define pic_obj_p(v) (pic_vtype(v) == PIC_VTYPE_HEAP) -#define pic_obj_ptr(v) ((struct pic_object *)pic_ptr(v)) - -#define pic_nil_p(v) (pic_vtype(v) == PIC_VTYPE_NIL) -#define pic_true_p(v) (pic_vtype(v) == PIC_VTYPE_TRUE) -#define pic_false_p(v) (pic_vtype(v) == PIC_VTYPE_FALSE) -#define pic_undef_p(v) (pic_vtype(v) == PIC_VTYPE_UNDEF) -#define pic_float_p(v) (pic_vtype(v) == PIC_VTYPE_FLOAT) -#define pic_int_p(v) (pic_vtype(v) == PIC_VTYPE_INT) -#define pic_sym_p(v) (pic_vtype(v) == PIC_VTYPE_SYMBOL) -#define pic_char_p(v) (pic_vtype(v) == PIC_VTYPE_CHAR) -#define pic_eof_p(v) (pic_vtype(v) == PIC_VTYPE_EOF) - -#define pic_test(v) (! pic_false_p(v)) - -static inline enum pic_tt pic_type(pic_value); -static inline const char *pic_type_repr(enum pic_tt); - -#define pic_assert_type(pic, v, type) \ - if (! pic_##type##_p(v)) { \ - pic_errorf(pic, "expected " #type ", but got ~s", v); \ - } - -static inline bool pic_valid_int(double); - -static inline pic_value pic_nil_value(); -static inline pic_value pic_true_value(); -static inline pic_value pic_false_value(); -static inline pic_value pic_bool_value(bool); -static inline pic_value pic_undef_value(); -static inline pic_value pic_obj_value(void *); -static inline pic_value pic_float_value(double); -static inline pic_value pic_int_value(int); -static inline pic_value pic_sym_value(pic_sym); -static inline pic_value pic_char_value(char c); -static inline pic_value pic_none_value(); - -#define pic_symbol_value(sym) pic_sym_value(sym) - -static inline bool pic_eq_p(pic_value, pic_value); -static inline bool pic_eqv_p(pic_value, pic_value); - -static inline enum pic_tt -pic_type(pic_value v) -{ - switch (pic_vtype(v)) { - case PIC_VTYPE_NIL: - return PIC_TT_NIL; - case PIC_VTYPE_TRUE: - return PIC_TT_BOOL; - case PIC_VTYPE_FALSE: - return PIC_TT_BOOL; - case PIC_VTYPE_UNDEF: - return PIC_TT_UNDEF; - case PIC_VTYPE_FLOAT: - return PIC_TT_FLOAT; - case PIC_VTYPE_INT: - return PIC_TT_INT; - case PIC_VTYPE_SYMBOL: - return PIC_TT_SYMBOL; - case PIC_VTYPE_CHAR: - return PIC_TT_CHAR; - case PIC_VTYPE_EOF: - return PIC_TT_EOF; - case PIC_VTYPE_HEAP: - return ((struct pic_object *)pic_ptr(v))->tt; - default: - return -1; /* logic flaw */ - } -} - -static inline const char * -pic_type_repr(enum pic_tt tt) -{ - switch (tt) { - case PIC_TT_NIL: - return "nil"; - case PIC_TT_BOOL: - return "boolean"; - case PIC_TT_FLOAT: - return "float"; - case PIC_TT_INT: - return "int"; - case PIC_TT_SYMBOL: - return "symbol"; - case PIC_TT_CHAR: - return "char"; - case PIC_TT_EOF: - return "eof"; - case PIC_TT_UNDEF: - return "undef"; - case PIC_TT_PAIR: - return "pair"; - case PIC_TT_STRING: - return "string"; - case PIC_TT_VECTOR: - return "vector"; - case PIC_TT_BLOB: - return "blob"; - case PIC_TT_PORT: - return "port"; - case PIC_TT_ERROR: - return "error"; - case PIC_TT_ENV: - return "env"; - case PIC_TT_CONT: - return "cont"; - case PIC_TT_PROC: - return "proc"; - case PIC_TT_SENV: - return "senv"; - case PIC_TT_MACRO: - return "macro"; - case PIC_TT_LIB: - return "lib"; - case PIC_TT_VAR: - return "var"; - case PIC_TT_IREP: - return "irep"; - case PIC_TT_DATA: - return "data"; - case PIC_TT_DICT: - return "dict"; - case PIC_TT_RECORD: - return "record"; - case PIC_TT_BLK: - return "block"; - } - UNREACHABLE(); -} - -static inline bool -pic_valid_int(double v) -{ - return INT_MIN <= v && v <= INT_MAX; -} - -static inline pic_value -pic_nil_value() -{ - pic_value v; - - pic_init_value(v, PIC_VTYPE_NIL); - return v; -} - -static inline pic_value -pic_true_value() -{ - pic_value v; - - pic_init_value(v, PIC_VTYPE_TRUE); - return v; -} - -static inline pic_value -pic_false_value() -{ - pic_value v; - - pic_init_value(v, PIC_VTYPE_FALSE); - return v; -} - -static inline pic_value -pic_bool_value(bool b) -{ - pic_value v; - - pic_init_value(v, b ? PIC_VTYPE_TRUE : PIC_VTYPE_FALSE); - return v; -} - -#if PIC_NAN_BOXING - -static inline pic_value -pic_obj_value(void *ptr) -{ - pic_value v; - - pic_init_value(v, PIC_VTYPE_HEAP); - v.u.data = (void*)((long long)v.u.data | ((long long)ptr)); - return v; -} - -static inline pic_value -pic_float_value(double f) -{ - pic_value v; - - if (f != f) { - v.u.type_ = 0x7ff80000; - v.u.i = 0; - } else { - v.u.f = f; - } - return v; -} - -#else - -static inline pic_value -pic_obj_value(void *ptr) -{ - pic_value v; - - pic_init_value(v, PIC_VTYPE_HEAP); - v.u.data = ptr; - return v; -} - -static inline pic_value -pic_float_value(double f) -{ - pic_value v; - - pic_init_value(v, PIC_VTYPE_FLOAT); - v.u.f = f; - return v; -} - -#endif - -static inline pic_value -pic_int_value(int i) -{ - pic_value v; - - pic_init_value(v, PIC_VTYPE_INT); - v.u.i = i; - return v; -} - -static inline pic_value -pic_symbol_value(pic_sym sym) -{ - pic_value v; - - pic_init_value(v, PIC_VTYPE_SYMBOL); - v.u.sym = sym; - return v; -} - -static inline pic_value -pic_char_value(char c) -{ - pic_value v; - - pic_init_value(v, PIC_VTYPE_CHAR); - v.u.c = c; - return v; -} - -static inline pic_value -pic_undef_value() -{ - pic_value v; - - pic_init_value(v, PIC_VTYPE_UNDEF); - return v; -} - -static inline pic_value -pic_none_value() -{ -#if PIC_NONE_IS_FALSE - return pic_false_value(); -#else -# error enable PIC_NONE_IS_FALSE -#endif -} - -#if PIC_NAN_BOXING - -static inline bool -pic_eq_p(pic_value x, pic_value y) -{ - return x.u.data == y.u.data; -} - -static inline bool -pic_eqv_p(pic_value x, pic_value y) -{ - return x.u.data == y.u.data; -} - -#else - -static inline bool -pic_eq_p(pic_value x, pic_value y) -{ - if (pic_type(x) != pic_type(y)) - return false; - - switch (pic_type(x)) { - case PIC_TT_NIL: - return true; - case PIC_TT_BOOL: - return pic_vtype(x) == pic_vtype(y); - case PIC_TT_SYMBOL: - return pic_sym(x) == pic_sym(y); - default: - return pic_ptr(x) == pic_ptr(y); - } -} - -static inline bool -pic_eqv_p(pic_value x, pic_value y) -{ - if (pic_type(x) != pic_type(y)) - return false; - - switch (pic_type(x)) { - case PIC_TT_NIL: - return true; - case PIC_TT_BOOL: - return pic_vtype(x) == pic_vtype(y); - case PIC_TT_SYMBOL: - return pic_sym(x) == pic_sym(y); - case PIC_TT_FLOAT: - return pic_float(x) == pic_float(y); - case PIC_TT_INT: - return pic_int(x) == pic_int(y); - default: - return pic_ptr(x) == pic_ptr(y); - } -} - -#endif - -#if defined(__cplusplus) -} -#endif - -#endif diff --git a/include/picrin/var.h b/include/picrin/var.h deleted file mode 100644 index d3bbaf4e..00000000 --- a/include/picrin/var.h +++ /dev/null @@ -1,32 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#ifndef PICRIN_VAR_H__ -#define PICRIN_VAR_H__ - -#if defined(__cplusplus) -extern "C" { -#endif - -struct pic_var { - PIC_OBJECT_HEADER - pic_value stack; - struct pic_proc *conv; -}; - -#define pic_var_p(o) (pic_type(o) == PIC_TT_VAR) -#define pic_var_ptr(o) ((struct pic_var *)pic_ptr(o)) - -struct pic_var *pic_var_new(pic_state *, pic_value, struct pic_proc * /* = NULL */); - -pic_value pic_var_ref(pic_state *, struct pic_var *); -void pic_var_set(pic_state *, struct pic_var *, pic_value); -void pic_var_push(pic_state *, struct pic_var *, pic_value); -void pic_var_pop(pic_state *, struct pic_var *); - -#if defined(__cplusplus) -} -#endif - -#endif diff --git a/include/picrin/vector.h b/include/picrin/vector.h deleted file mode 100644 index 80a4cb73..00000000 --- a/include/picrin/vector.h +++ /dev/null @@ -1,29 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#ifndef PICRIN_VECTOR_H__ -#define PICRIN_VECTOR_H__ - -#if defined(__cplusplus) -extern "C" { -#endif - -struct pic_vector { - PIC_OBJECT_HEADER - pic_value *data; - size_t len; -}; - -#define pic_vec_p(v) (pic_type(v) == PIC_TT_VECTOR) -#define pic_vec_ptr(o) ((struct pic_vector *)pic_ptr(o)) - -struct pic_vector *pic_vec_new(pic_state *, size_t); -struct pic_vector *pic_vec_new_from_list(pic_state *, pic_value); -void pic_vec_extend_ip(pic_state *, struct pic_vector *, size_t); - -#if defined(__cplusplus) -} -#endif - -#endif diff --git a/piclib/CMakeLists.txt b/piclib/CMakeLists.txt index 8f230621..008e5ad5 100644 --- a/piclib/CMakeLists.txt +++ b/piclib/CMakeLists.txt @@ -1,22 +1,26 @@ list(APPEND PICLIB_SCHEME_LIBS - ${PROJECT_SOURCE_DIR}/piclib/picrin/base.scm - ${PROJECT_SOURCE_DIR}/piclib/picrin/list.scm - ${PROJECT_SOURCE_DIR}/piclib/picrin/symbol.scm ${PROJECT_SOURCE_DIR}/piclib/picrin/macro.scm - - ${PROJECT_SOURCE_DIR}/piclib/scheme/base.scm - + ${PROJECT_SOURCE_DIR}/piclib/picrin/base.scm ${PROJECT_SOURCE_DIR}/piclib/picrin/record.scm ${PROJECT_SOURCE_DIR}/piclib/picrin/array.scm ${PROJECT_SOURCE_DIR}/piclib/picrin/dictionary.scm - ${PROJECT_SOURCE_DIR}/piclib/picrin/test.scm ${PROJECT_SOURCE_DIR}/piclib/picrin/experimental/lambda.scm + ${PROJECT_SOURCE_DIR}/piclib/picrin/syntax-rules.scm + ${PROJECT_SOURCE_DIR}/piclib/picrin/test.scm + + ${PROJECT_SOURCE_DIR}/piclib/scheme/base.scm ${PROJECT_SOURCE_DIR}/piclib/scheme/cxr.scm + ${PROJECT_SOURCE_DIR}/piclib/scheme/read.scm + ${PROJECT_SOURCE_DIR}/piclib/scheme/write.scm ${PROJECT_SOURCE_DIR}/piclib/scheme/file.scm ${PROJECT_SOURCE_DIR}/piclib/scheme/case-lambda.scm ${PROJECT_SOURCE_DIR}/piclib/scheme/lazy.scm ${PROJECT_SOURCE_DIR}/piclib/scheme/eval.scm + ${PROJECT_SOURCE_DIR}/piclib/scheme/inexact.scm + ${PROJECT_SOURCE_DIR}/piclib/scheme/load.scm + ${PROJECT_SOURCE_DIR}/piclib/scheme/process-context.scm + ${PROJECT_SOURCE_DIR}/piclib/scheme/time.scm ${PROJECT_SOURCE_DIR}/piclib/scheme/r5rs.scm ${PROJECT_SOURCE_DIR}/piclib/scheme/null.scm diff --git a/piclib/picrin/array.scm b/piclib/picrin/array.scm index f7e1dc60..5ae0c107 100644 --- a/piclib/picrin/array.scm +++ b/piclib/picrin/array.scm @@ -1,6 +1,5 @@ (define-library (picrin array) - (import (scheme base) - (scheme write) + (import (picrin base) (picrin record)) (define-record-type @@ -11,6 +10,11 @@ (head array-head set-array-head!) (tail array-tail set-array-tail!)) + (define (floor-remainder i j) + (call-with-values (lambda () (floor/ i j)) + (lambda (q r) + r))) + (define (translate ary i) (floor-remainder i (array-size ary))) @@ -39,7 +43,7 @@ (if (null? rest) (make-array 0) (let ((capacity (car rest)) - (ary (create-array (vector) 0 0 0))) + (ary (create-array (make-vector 0) 0 0 0))) (array-reserve! ary capacity) ary))) @@ -90,16 +94,17 @@ (for-each proc (array->list ary))) (define-record-writer ( array) - (call-with-port (open-output-string) - (lambda (port) - (display "#.(array" port) - (array-for-each - (lambda (obj) - (display " " port) - (write obj port)) - array) - (display ")" port) - (get-output-string port)))) + (let ((port (open-output-string))) + (display "#.(array" port) + (array-for-each + (lambda (obj) + (display " " port) + (write obj port)) + array) + (display ")" port) + (let ((str (get-output-string port))) + (close-port port) + str))) (export make-array array diff --git a/piclib/picrin/base.scm b/piclib/picrin/base.scm index c4ca864f..cb2a3f8d 100644 --- a/piclib/picrin/base.scm +++ b/piclib/picrin/base.scm @@ -1,24 +1,270 @@ (define-library (picrin base) - (import (rename (picrin base core) (define define*)) - (picrin base macro) - (picrin base list) - (picrin base symbol)) - - (define-syntax define - (lambda (form use-env mac-env) - (if (symbol? (car (cdr form))) - (cons (make-identifier 'define* mac-env) (cdr form)) - (cons (make-identifier 'define mac-env) - (cons (car (car (cdr form))) - (cons (cons (make-identifier 'lambda mac-env) - (cons (cdr (car (cdr form))) - (cdr (cdr form)))) - '())))))) (export define - set! - quote lambda if + quote + set! begin - define-syntax)) + define-syntax) + + (export syntax-error + let-syntax + letrec-syntax) + + (export let + let* + letrec + letrec* + quasiquote + unquote + unquote-splicing + and + or + cond + case + => + else + do + when + unless + include) + + (export let-values + let*-values + define-values) + + (export eq? + eqv? + equal?) + + (export boolean? + boolean=? + not) + + (export symbol? + symbol->string + string->symbol + symbol=?) + + (export char? + char->integer + integer->char) + + (export number? + complex? + real? + rational? + integer? + exact? + inexact? + = + < + > + <= + >= + + + - + * + / + abs + floor/ + truncate/ + floor + ceiling + truncate + round + expt + number->string + string->number + finite? + infinite? + nan? + exp + log + sin + cos + tan + acos + asin + atan + sqrt) + + (export pair? + cons + car + cdr + set-car! + set-cdr! + null? + caar + cadr + cdar + cddr) + + (export list? + make-list + list + length + append + reverse + list-tail + list-ref + list-set! + list-copy + memq + memv + member + assq + assv + assoc) + + (export bytevector? + make-bytevector + bytevector-length + bytevector-u8-ref + bytevector-u8-set! + bytevector-copy + bytevector-copy! + bytevector-append) + + (export vector? + make-vector + vector-length + vector-ref + vector-set! + vector-copy! + vector-copy + vector-append + vector-fill! + list->vector + vector->list) + + (export string? + make-string + string-length + string-ref + string-set! + string-copy + string-copy! + string-append + string-fill! + string=? + string? + string<=? + string>=?) + + (export make-dictionary + dictionary? + dictionary-ref + dictionary-set! + dictionary-delete + dictionary-size) + + (export make-record + record? + record-type + record-ref + record-set!) + + (export current-input-port + current-output-port + current-error-port + + port? + input-port? + output-port? + textual-port? + binary-port? + + port-open? + close-port + + open-input-file + open-output-file + open-binary-input-file + open-binary-output-file + open-input-string + open-output-string + get-output-string + open-input-bytevector + open-output-bytevector + get-output-bytevector + + eof-object? + eof-object + + read-char + peek-char + char-ready? + read-line + read-string + + read-u8 + peek-u8 + u8-ready? + read-bytevector + read-bytevector! + + newline + write-char + write-string + write-u8 + write-bytevector + flush-output-port) + + (export make-parameter + parameter-ref + parameter-set! + parameter-push! + parameter-pop!) + + (export identifier? + identifier=? + make-identifier) + + (export call-with-current-continuation + call/cc + dynamic-wind + values + call-with-values) + + (export with-exception-handler + raise + raise-continuable + error + error-object? + error-object-message + error-object-irritants + read-error? + file-error?) + + (export procedure? + apply + map + for-each + attribute) + + (export read) + + (export write + write-simple + write-shared + display) + + (export command-line + exit + emergency-exit + file-exists? + delete-file + get-environment-variable + get-environment-variables) + + (export current-second + current-jiffy + jiffies-per-second) + + (export eval) + + (export load)) diff --git a/piclib/picrin/dictionary.scm b/piclib/picrin/dictionary.scm index a532b2e4..c5205711 100644 --- a/piclib/picrin/dictionary.scm +++ b/piclib/picrin/dictionary.scm @@ -1,21 +1,5 @@ (define-library (picrin dictionary) - (import (scheme base)) - - (define (dictionary-map proc dict) - (let ((kvs '())) - (dictionary-for-each - (lambda (key val) - (set! kvs (cons (proc key val) kvs))) - dict) - (reverse kvs))) - - (define (dictionary->plist dict) - (let ((kvs '())) - (dictionary-for-each - (lambda (key val) - (set! kvs (cons val (cons key kvs)))) - dict) - (reverse kvs))) + (import (picrin base)) (define (plist->dictionary plist) (let ((dict (make-dictionary))) @@ -24,12 +8,6 @@ dict) (dictionary-set! dict (car kv) (cadr kv))))) - (define (dictionary->alist dict) - (dictionary-map - (lambda (key val) - (cons key val)) - dict)) - (define (alist->dictionary alist) (let ((dict (make-dictionary))) (do ((kv alist (cdr kv))) @@ -40,9 +18,12 @@ (define (dictionary . plist) (plist->dictionary plist)) - (export dictionary - dictionary-map - dictionary->plist + (export dictionary? + dictionary + make-dictionary + dictionary-ref + dictionary-set! + dictionary-delete + dictionary-size plist->dictionary - dictionary->alist alist->dictionary)) diff --git a/piclib/picrin/experimental/lambda.scm b/piclib/picrin/experimental/lambda.scm index 5a1d3eb1..5f6ac0ab 100644 --- a/piclib/picrin/experimental/lambda.scm +++ b/piclib/picrin/experimental/lambda.scm @@ -1,5 +1,6 @@ (define-library (picrin experimental lambda) (import (scheme base) + (picrin base) (picrin macro)) (define-syntax destructuring-bind diff --git a/piclib/picrin/list.scm b/piclib/picrin/list.scm deleted file mode 100644 index 820e4da6..00000000 --- a/piclib/picrin/list.scm +++ /dev/null @@ -1,30 +0,0 @@ -(define-library (picrin list) - (import (picrin base list)) - - (export pair? - cons - car - cdr - set-car! - set-cdr! - null? - caar - cadr - cdar - cddr - list? - make-list - list - length - append - reverse - list-tail - list-ref - list-set! - list-copy - memq - memv - member - assq - assv - assoc)) diff --git a/piclib/picrin/macro.scm b/piclib/picrin/macro.scm index 8a202cf6..22bdf097 100644 --- a/piclib/picrin/macro.scm +++ b/piclib/picrin/macro.scm @@ -1,12 +1,5 @@ -;;; Hygienic Macros - (define-library (picrin macro) - (import (picrin base macro) - (picrin base) - (picrin list) - (picrin symbol) - (scheme base) - (picrin dictionary)) + (import (picrin base)) ;; assumes no derived expressions are provided yet @@ -36,18 +29,6 @@ (dictionary-set! cache sym val) val)))))) - (define (identifier=? env1 sym1 env2 sym2) - - (define (resolve sym env) - (define x (make-identifier sym env)) - (define y (make-identifier sym env)) - (if (eq? x y) - x - sym)) ; resolved to no variable - - (eq? (resolve sym1 env1) - (resolve sym2 env2))) - (define (make-syntactic-closure env free form) (define resolve @@ -126,8 +107,8 @@ (rename sym))))) (f (walk inject expr) inject compare)))) - (define (strip-syntax form) - (walk ungensym form)) + ;; (define (strip-syntax form) + ;; (walk ungensym form)) (define-syntax define-macro (er-macro-transformer @@ -153,5 +134,5 @@ rsc-macro-transformer er-macro-transformer ir-macro-transformer - strip-syntax + ;; strip-syntax define-macro)) diff --git a/piclib/picrin/record.scm b/piclib/picrin/record.scm index 818913e8..6784524b 100644 --- a/piclib/picrin/record.scm +++ b/piclib/picrin/record.scm @@ -1,17 +1,109 @@ (define-library (picrin record) - (import (scheme base)) + (import (picrin base) + (picrin macro)) - (define (define-record-writer* record-type writer) + ;; define-record-writer + + (define (set-record-writer! record-type writer) (record-set! record-type 'writer writer)) (define-syntax define-record-writer - (syntax-rules () - ((_ (type obj) body ...) - (define-record-writer* type - (lambda (obj) - body ...))) - ((_ type writer) - (define-record-writer* type - writer)))) + (er-macro-transformer + (lambda (form r compare) + (let ((formal (cadr form))) + (if (pair? formal) + `(,(r 'set-record-writer!) ,(car formal) + (,(r 'lambda) (,(cadr formal)) + ,@(cddr form))) + `(,(r 'set-record-writer!) ,formal + ,@(cddr form))))))) - (export define-record-writer)) + ;; define-record-type + + (define ((default-record-writer ctor) obj) + (let ((port (open-output-string))) + (display "#.(" port) + (display (car ctor) port) + (for-each + (lambda (field) + (display " " port) + (write (record-ref obj field) port)) + (cdr ctor)) + (display ")" port) + (get-output-string port))) + + (define ((boot-make-record-type ) name ctor) + (let ((rectype (make-record ))) + (record-set! rectype 'name name) + (record-set! rectype 'writer (default-record-writer ctor)) + rectype)) + + (define + (let (( + ((boot-make-record-type #t) 'record-type '(record-type name writer)))) + (record-set! '@@type ) + )) + + (define make-record-type (boot-make-record-type )) + + (define-syntax define-record-constructor + (ir-macro-transformer + (lambda (form inject compare?) + (let ((rectype (car (cdr form))) + (name (car (cdr (cdr form)))) + (fields (cdr (cdr (cdr form))))) + `(define (,name ,@fields) + (let ((record (make-record ,rectype))) + ,@(map (lambda (field) + `(record-set! record ',field ,field)) + fields) + record)))))) + + (define-syntax define-record-predicate + (ir-macro-transformer + (lambda (form inject compare?) + (let ((rectype (car (cdr form))) + (name (car (cdr (cdr form))))) + `(define (,name obj) + (and (record? obj) + (eq? (record-type obj) + ,rectype))))))) + + (define-syntax define-record-field + (ir-macro-transformer + (lambda (form inject compare?) + (let ((pred (car (cdr form))) + (field-name (car (cdr (cdr form)))) + (accessor (car (cdr (cdr (cdr form))))) + (modifier? (cdr (cdr (cdr (cdr form)))))) + (if (null? modifier?) + `(define (,accessor record) + (if (,pred record) + (record-ref record ',field-name) + (error "wrong record type"))) + `(begin + (define (,accessor record) + (if (,pred record) + (record-ref record ',field-name) + (error "wrong record type"))) + (define (,(car modifier?) record val) + (if (,pred record) + (record-set! record ',field-name val) + (error "wrong record type"))))))))) + + (define-syntax define-record-type + (ir-macro-transformer + (lambda (form inject compare?) + (let ((name (car (cdr form))) + (ctor (car (cdr (cdr form)))) + (pred (car (cdr (cdr (cdr form))))) + (fields (cdr (cdr (cdr (cdr form)))))) + `(begin + (define ,name (make-record-type ',name ',ctor)) + (define-record-constructor ,name ,@ctor) + (define-record-predicate ,name ,pred) + ,@(map (lambda (field) `(define-record-field ,pred ,@field)) + fields)))))) + + (export define-record-type + define-record-writer)) diff --git a/piclib/picrin/symbol.scm b/piclib/picrin/symbol.scm deleted file mode 100644 index eafa250b..00000000 --- a/piclib/picrin/symbol.scm +++ /dev/null @@ -1,7 +0,0 @@ -(define-library (picrin symbol) - (import (picrin base symbol)) - - (export symbol? - symbol=? - symbol->string - string->symbol)) diff --git a/piclib/picrin/syntax-rules.scm b/piclib/picrin/syntax-rules.scm new file mode 100644 index 00000000..342650a5 --- /dev/null +++ b/piclib/picrin/syntax-rules.scm @@ -0,0 +1,347 @@ +(define-library (picrin syntax-rules) + (import (picrin base) + (picrin macro)) + + (define-syntax define-auxiliary-syntax + (er-macro-transformer + (lambda (expr r c) + (list (r 'define-syntax) (cadr expr) + (list (r 'lambda) '_ + (list (r 'error) "invalid use of auxiliary syntax")))))) + + (define-auxiliary-syntax _) + (define-auxiliary-syntax ...) + + (define (walk proc expr) + (cond + ((null? expr) + '()) + ((pair? expr) + (cons (walk proc (car expr)) + (walk proc (cdr expr)))) + ((vector? expr) + (list->vector (map proc (vector->list expr)))) + (else + (proc expr)))) + + (define (flatten expr) + (let ((list '())) + (walk + (lambda (x) + (set! list (cons x list))) + expr) + (reverse list))) + + (define (reverse* l) + ;; (reverse* '(a b c d . e)) => (e d c b a) + (let loop ((a '()) + (d l)) + (if (pair? d) + (loop (cons (car d) a) (cdr d)) + (cons d a)))) + + (define (every? pred l) + (if (null? l) + #t + (and (pred (car l)) (every? pred (cdr l))))) + + (define-syntax syntax-rules + (er-macro-transformer + (lambda (form r compare) + (define _define (r 'define)) + (define _let (r 'let)) + (define _if (r 'if)) + (define _begin (r 'begin)) + (define _lambda (r 'lambda)) + (define _set! (r 'set!)) + (define _not (r 'not)) + (define _and (r 'and)) + (define _car (r 'car)) + (define _cdr (r 'cdr)) + (define _cons (r 'cons)) + (define _pair? (r 'pair?)) + (define _null? (r 'null?)) + (define _symbol? (r 'symbol?)) + (define _vector? (r 'vector?)) + (define _eqv? (r 'eqv?)) + (define _string=? (r 'string=?)) + (define _map (r 'map)) + (define _vector->list (r 'vector->list)) + (define _list->vector (r 'list->vector)) + (define _quote (r 'quote)) + (define _quasiquote (r 'quasiquote)) + (define _unquote (r 'unquote)) + (define _unquote-splicing (r 'unquote-splicing)) + (define _syntax-error (r 'syntax-error)) + (define _call/cc (r 'call/cc)) + (define _er-macro-transformer (r 'er-macro-transformer)) + + (define (var->sym v) + (let loop ((cnt 0) + (v v)) + (if (symbol? v) + (string->symbol + (string-append (symbol->string v) "/" (number->string cnt))) + (loop (+ 1 cnt) (car v))))) + + (define push-var list) + + (define (compile-match ellipsis literals pattern) + (letrec ((compile-match-base + (lambda (pattern) + (cond ((member pattern literals compare) + (values + `(,_if (,_and (,_symbol? expr) (cmp expr (rename ',pattern))) + #f + (exit #f)) + '())) + ((compare pattern (r '_)) (values #f '())) + ((and ellipsis (compare pattern ellipsis)) + (values `(,_syntax-error "invalid pattern") '())) + ((symbol? pattern) + (values `(,_set! ,(var->sym pattern) expr) (list pattern))) + ((pair? pattern) + (compile-match-list pattern)) + ((vector? pattern) + (compile-match-vector pattern)) + ((string? pattern) + (values + `(,_if (,_not (,_string=? ',pattern expr)) + (exit #f)) + '())) + (else + (values + `(,_if (,_not (,_eqv? ',pattern expr)) + (exit #f)) + '()))))) + + (compile-match-list + (lambda (pattern) + (let loop ((pattern pattern) + (matches '()) + (vars '()) + (accessor 'expr)) + (cond ;; (hoge) + ((not (pair? (cdr pattern))) + (let*-values (((match1 vars1) (compile-match-base (car pattern))) + ((match2 vars2) (compile-match-base (cdr pattern)))) + (values + `(,_begin ,@(reverse matches) + (,_if (,_pair? ,accessor) + (,_begin + (,_let ((expr (,_car ,accessor))) + ,match1) + (,_let ((expr (,_cdr ,accessor))) + ,match2)) + (exit #f))) + (append vars (append vars1 vars2))))) + ;; (hoge ... rest args) + ((and ellipsis (compare (cadr pattern) ellipsis)) + (let-values (((match-r vars-r) (compile-match-list-reverse pattern))) + (values + `(,_begin ,@(reverse matches) + (,_let ((expr (,_let loop ((a ()) + (d ,accessor)) + (,_if (,_pair? d) + (loop (,_cons (,_car d) a) (,_cdr d)) + (,_cons d a))))) + ,match-r)) + (append vars vars-r)))) + (else + (let-values (((match1 vars1) (compile-match-base (car pattern)))) + (loop (cdr pattern) + (cons `(,_if (,_pair? ,accessor) + (,_let ((expr (,_car ,accessor))) + ,match1) + (exit #f)) + matches) + (append vars vars1) + `(,_cdr ,accessor)))))))) + + (compile-match-list-reverse + (lambda (pattern) + (let loop ((pattern (reverse* pattern)) + (matches '()) + (vars '()) + (accessor 'expr)) + (cond ((and ellipsis (compare (car pattern) ellipsis)) + (let-values (((match1 vars1) (compile-match-ellipsis (cadr pattern)))) + (values + `(,_begin ,@(reverse matches) + (,_let ((expr ,accessor)) + ,match1)) + (append vars vars1)))) + (else + (let-values (((match1 vars1) (compile-match-base (car pattern)))) + (loop (cdr pattern) + (cons `(,_let ((expr (,_car ,accessor))) ,match1) matches) + (append vars vars1) + `(,_cdr ,accessor)))))))) + + (compile-match-ellipsis + (lambda (pattern) + (let-values (((match vars) (compile-match-base pattern))) + (values + `(,_let loop ((expr expr)) + (,_if (,_not (,_null? expr)) + (,_let ,(map (lambda (var) `(,(var->sym var) '())) vars) + (,_let ((expr (,_car expr))) + ,match) + ,@(map + (lambda (var) + `(,_set! ,(var->sym (push-var var)) + (,_cons ,(var->sym var) ,(var->sym (push-var var))))) + vars) + (loop (,_cdr expr))))) + (map push-var vars))))) + + (compile-match-vector + (lambda (pattern) + (let-values (((match vars) (compile-match-base (vector->list pattern)))) + (values + `(,_if (,_vector? expr) + (,_let ((expr (,_vector->list expr))) + ,match) + (exit #f)) + vars))))) + + (let-values (((match vars) (compile-match-base (cdr pattern)))) + (values `(,_let ((expr (,_cdr expr))) + ,match + #t) + vars)))) + +;;; compile expand + (define (compile-expand ellipsis reserved template) + (letrec ((compile-expand-base + (lambda (template ellipsis-valid) + (cond ((member template reserved eq?) + (values (var->sym template) (list template))) + ((symbol? template) + (values `(rename ',template) '())) + ((pair? template) + (compile-expand-list template ellipsis-valid)) + ((vector? template) + (compile-expand-vector template ellipsis-valid)) + (else + (values `',template '()))))) + + (compile-expand-list + (lambda (template ellipsis-valid) + (let loop ((template template) + (expands '()) + (vars '())) + (cond ;; (... hoge) + ((and ellipsis-valid + (pair? template) + (compare (car template) ellipsis)) + (if (and (pair? (cdr template)) (null? (cddr template))) + (compile-expand-base (cadr template) #f) + (values '(,_syntax-error "invalid template") '()))) + ;; hoge + ((not (pair? template)) + (let-values (((expand1 vars1) + (compile-expand-base template ellipsis-valid))) + (values + `(,_quasiquote (,@(reverse expands) . (,_unquote ,expand1))) + (append vars vars1)))) + ;; (a ... rest syms) + ((and ellipsis-valid + (pair? (cdr template)) + (compare (cadr template) ellipsis)) + (let-values (((expand1 vars1) + (compile-expand-base (car template) ellipsis-valid))) + (loop (cddr template) + (cons + `(,_unquote-splicing + (,_map (,_lambda ,(map var->sym vars1) ,expand1) + ,@(map (lambda (v) (var->sym (push-var v))) vars1))) + expands) + (append vars (map push-var vars1))))) + (else + (let-values (((expand1 vars1) + (compile-expand-base (car template) ellipsis-valid))) + (loop (cdr template) + (cons + `(,_unquote ,expand1) + expands) + (append vars vars1)))))))) + + (compile-expand-vector + (lambda (template ellipsis-valid) + (let-values (((expand1 vars1) + (compile-expand-base (vector->list template) ellipsis-valid))) + (values + `(,_list->vector ,expand1) + vars1))))) + + (compile-expand-base template ellipsis))) + + (define (check-vars vars-pattern vars-template) + ;;fixme + #t) + + (define (compile-rule ellipsis literals rule) + (let ((pattern (car rule)) + (template (cadr rule))) + (let*-values (((match vars-match) + (compile-match ellipsis literals pattern)) + ((expand vars-expand) + (compile-expand ellipsis (flatten vars-match) template))) + (if (check-vars vars-match vars-expand) + (list vars-match match expand) + 'mismatch)))) + + (define (expand-clauses clauses rename) + (cond ((null? clauses) + `(,_quote (syntax-error "no matching pattern"))) + ((compare (car clauses) 'mismatch) + `(,_syntax-error "invalid rule")) + (else + (let ((vars (list-ref (car clauses) 0)) + (match (list-ref (car clauses) 1)) + (expand (list-ref (car clauses) 2))) + `(,_let ,(map (lambda (v) (list (var->sym v) '())) vars) + (,_let ((result (,_call/cc (,_lambda (exit) ,match)))) + (,_if result + ,expand + ,(expand-clauses (cdr clauses) rename)))))))) + + (define (normalize-form form) + (if (and (list? form) (>= (length form) 2)) + (let ((ellipsis '...) + (literals (cadr form)) + (rules (cddr form))) + + (when (symbol? literals) + (set! ellipsis literals) + (set! literals (car rules)) + (set! rules (cdr rules))) + + (if (and (symbol? ellipsis) + (list? literals) + (every? symbol? literals) + (list? rules) + (every? (lambda (l) (and (list? l) (= (length l) 2))) rules)) + (if (member ellipsis literals compare) + `(syntax-rules #f ,literals ,@rules) + `(syntax-rules ,ellipsis ,literals ,@rules)) + #f)) + #f)) + + (let ((form (normalize-form form))) + (if form + (let ((ellipsis (list-ref form 1)) + (literals (list-ref form 2)) + (rules (list-tail form 3))) + (let ((clauses (map (lambda (rule) (compile-rule ellipsis literals rule)) + rules))) + `(,_er-macro-transformer + (,_lambda (expr rename cmp) + ,(expand-clauses clauses r))))) + + `(,_syntax-error "malformed syntax-rules")))))) + + (export syntax-rules + _ + ...)) diff --git a/piclib/picrin/test.scm b/piclib/picrin/test.scm index 28650b84..d1dfbc9d 100644 --- a/piclib/picrin/test.scm +++ b/piclib/picrin/test.scm @@ -1,8 +1,7 @@ (define-library (picrin test) - (import (scheme base) - (scheme write) - (scheme read) - (scheme process-context)) + (import (picrin base) + (picrin syntax-rules)) + (define test-counter 0) (define counter 0) (define failure-counter 0) @@ -77,7 +76,7 @@ (length fails)) (define (test-exit) - (exit (zero? (test-failure-count)))) + (exit (= (test-failure-count) 0))) (define-syntax test-syntax-error (syntax-rules () diff --git a/piclib/scheme/base.scm b/piclib/scheme/base.scm index 186b2f57..4ddabc80 100644 --- a/piclib/scheme/base.scm +++ b/piclib/scheme/base.scm @@ -1,675 +1,59 @@ (define-library (scheme base) (import (picrin base) - (picrin list) - (picrin symbol) - (picrin macro)) + (picrin macro) + (picrin record) + (picrin syntax-rules)) - (export define set! lambda quote - if begin define-syntax) + ;; 4.1.2. Literal expressions - ;; core syntax + (export quote) - (define-syntax syntax-error - (er-macro-transformer - (lambda (expr rename compare) - (apply error (cdr expr))))) + ;; 4.1.4. Procedures - (define-syntax define-auxiliary-syntax - (er-macro-transformer - (lambda (expr r c) - (list (r 'define-syntax) (cadr expr) - (list (r 'lambda) '_ - (list (r 'error) "invalid use of auxiliary syntax")))))) + (export lambda) - (define-auxiliary-syntax else) - (define-auxiliary-syntax =>) - (define-auxiliary-syntax _) - (define-auxiliary-syntax ...) - (define-auxiliary-syntax unquote) - (define-auxiliary-syntax unquote-splicing) + ;; 4.1.5. Conditionals - (define-syntax let - (er-macro-transformer - (lambda (expr r compare) - (if (symbol? (cadr expr)) - (begin - (define name (car (cdr expr))) - (define bindings (car (cdr (cdr expr)))) - (define body (cdr (cdr (cdr expr)))) - (list (r 'let) '() - (list (r 'define) name - (cons (r 'lambda) (cons (map car bindings) body))) - (cons name (map cadr bindings)))) - (begin - (set! bindings (cadr expr)) - (set! body (cddr expr)) - (cons (cons (r 'lambda) (cons (map car bindings) body)) - (map cadr bindings))))))) + (export if) - (define-syntax cond - (er-macro-transformer - (lambda (expr r compare) - (let ((clauses (cdr expr))) - (if (null? clauses) - #f - (begin - (define clause (car clauses)) - (if (compare (r 'else) (car clause)) - (cons (r 'begin) (cdr clause)) - (if (if (>= (length clause) 2) - (compare (r '=>) (list-ref clause 1)) - #f) - (list (r 'let) (list (list (r 'x) (car clause))) - (list (r 'if) (r 'x) - (list (list-ref clause 2) (r 'x)) - (cons (r 'cond) (cdr clauses)))) - (list (r 'if) (car clause) - (cons (r 'begin) (cdr clause)) - (cons (r 'cond) (cdr clauses))))))))))) + ;; 4.1.6. Assignments - (define-syntax and - (er-macro-transformer - (lambda (expr r compare) - (let ((exprs (cdr expr))) - (cond - ((null? exprs) - #t) - ((= (length exprs) 1) - (car exprs)) - (else - (list (r 'let) (list (list (r 'it) (car exprs))) - (list (r 'if) (r 'it) - (cons (r 'and) (cdr exprs)) - (r 'it))))))))) + (export set!) - (define-syntax or - (er-macro-transformer - (lambda (expr r compare) - (let ((exprs (cdr expr))) - (cond - ((null? exprs) - #t) - ((= (length exprs) 1) - (car exprs)) - (else - (list (r 'let) (list (list (r 'it) (car exprs))) - (list (r 'if) (r 'it) - (r 'it) - (cons (r 'or) (cdr exprs)))))))))) + ;; 4.1.7. Inclusion - (define-syntax quasiquote - (ir-macro-transformer - (lambda (form inject compare) + (export include) - (define (quasiquote? form) - (and (pair? form) (compare (car form) 'quasiquote))) + ;; 4.2.1. Conditionals - (define (unquote? form) - (and (pair? form) (compare (car form) 'unquote))) + (export cond + case + else + => + and + or + when + unless) - (define (unquote-splicing? form) - (and (pair? form) (pair? (car form)) - (compare (car (car form)) 'unquote-splicing))) + ;; 4.2.2. Binding constructs - (define (qq depth expr) - (cond - ;; unquote - ((unquote? expr) - (if (= depth 1) - (car (cdr expr)) - (list 'list - (list 'quote (inject 'unquote)) - (qq (- depth 1) (car (cdr expr)))))) - ;; unquote-splicing - ((unquote-splicing? expr) - (if (= depth 1) - (list 'append - (car (cdr (car expr))) - (qq depth (cdr expr))) - (list 'cons - (list 'list - (list 'quote (inject 'unquote-splicing)) - (qq (- depth 1) (car (cdr (car expr))))) - (qq depth (cdr expr))))) - ;; quasiquote - ((quasiquote? expr) - (list 'list - (list 'quote (inject 'quasiquote)) - (qq (+ depth 1) (car (cdr expr))))) - ;; list - ((pair? expr) - (list 'cons - (qq depth (car expr)) - (qq depth (cdr expr)))) - ;; vector - ((vector? expr) - (list 'list->vector (qq depth (vector->list expr)))) - ;; simple datum - (else - (list 'quote expr)))) + (export let + let* + letrec + letrec* + let-values + let*-values) - (let ((x (cadr form))) - (qq 1 x))))) + ;; 4.2.3. Sequencing - (define-syntax let* - (er-macro-transformer - (lambda (form r compare) - (let ((bindings (cadr form)) - (body (cddr form))) - (if (null? bindings) - `(,(r 'let) () ,@body) - `(,(r 'let) ((,(caar bindings) - ,@(cdar bindings))) - (,(r 'let*) (,@(cdr bindings)) - ,@body))))))) + (export begin) - (define-syntax letrec* - (er-macro-transformer - (lambda (form r compare) - (let ((bindings (cadr form)) - (body (cddr form))) - (let ((vars (map (lambda (v) `(,v #f)) (map car bindings))) - (initials (map (lambda (v) `(,(r 'set!) ,@v)) bindings))) - `(,(r 'let) (,@vars) - ,@initials - ,@body)))))) - - (define-syntax letrec - (er-macro-transformer - (lambda (form rename compare) - `(,(rename 'letrec*) ,@(cdr form))))) - - (define-syntax do - (er-macro-transformer - (lambda (form r compare) - (let ((bindings (car (cdr form))) - (finish (car (cdr (cdr form)))) - (body (cdr (cdr (cdr form))))) - `(,(r 'let) ,(r 'loop) ,(map (lambda (x) - (list (car x) (cadr x))) - bindings) - (,(r 'if) ,(car finish) - (,(r 'begin) ,@(cdr finish)) - (,(r 'begin) ,@body - (,(r 'loop) ,@(map (lambda (x) - (if (null? (cddr x)) - (car x) - (car (cddr x)))) - bindings))))))))) - - (define-syntax when - (er-macro-transformer - (lambda (expr rename compare) - (let ((test (cadr expr)) - (body (cddr expr))) - `(,(rename 'if) ,test - (,(rename 'begin) ,@body) - #f))))) - - (define-syntax unless - (er-macro-transformer - (lambda (expr rename compare) - (let ((test (cadr expr)) - (body (cddr expr))) - `(,(rename 'if) ,test - #f - (,(rename 'begin) ,@body)))))) - - (define-syntax case - (er-macro-transformer - (lambda (expr r compare) - (let ((key (cadr expr)) - (clauses (cddr expr))) - `(,(r 'let) ((,(r 'key) ,key)) - ,(let loop ((clauses clauses)) - (if (null? clauses) - #f - (begin - (define clause (car clauses)) - `(,(r 'if) ,(if (compare (r 'else) (car clause)) - '#t - `(,(r 'or) - ,@(map (lambda (x) - `(,(r 'eqv?) ,(r 'key) (,(r 'quote) ,x))) - (car clause)))) - ,(if (compare (r '=>) (list-ref clause 1)) - `(,(list-ref clause 2) ,(r 'key)) - `(,(r 'begin) ,@(cdr clause))) - ,(loop (cdr clauses))))))))))) - - (define-syntax letrec-syntax - (er-macro-transformer - (lambda (form r c) - (let ((formal (car (cdr form))) - (body (cdr (cdr form)))) - `(let () - ,@(map (lambda (x) - `(,(r 'define-syntax) ,(car x) ,(cadr x))) - formal) - ,@body))))) - - (define-syntax let-syntax - (er-macro-transformer - (lambda (form r c) - `(,(r 'letrec-syntax) ,@(cdr form))))) - - (import (scheme read) (scheme file)) - - (define-syntax include - (letrec ((read-file - (lambda (filename) - (let ((port (open-input-file filename))) - (dynamic-wind - (lambda () #f) - (lambda () - (let loop ((expr (read port)) (exprs '())) - (if (eof-object? expr) - (reverse exprs) - (loop (read port) (cons expr exprs))))) - (lambda () - (close-port port))))))) - (er-macro-transformer - (lambda (form rename compare) - (let ((filenames (cdr form))) - (let ((exprs (apply append (map read-file filenames)))) - `(,(rename 'begin) ,@exprs))))))) - - (export let let* letrec letrec* - quasiquote unquote unquote-splicing - and or - cond case else => - do when unless - let-syntax letrec-syntax - include - _ ... syntax-error) - - - ;; utility functions - - (define (walk proc expr) - (cond - ((null? expr) - '()) - ((pair? expr) - (cons (walk proc (car expr)) - (walk proc (cdr expr)))) - ((vector? expr) - (list->vector (map proc (vector->list expr)))) - (else - (proc expr)))) - - (define (flatten expr) - (let ((list '())) - (walk - (lambda (x) - (set! list (cons x list))) - expr) - (reverse list))) - - (define (reverse* l) - ;; (reverse* '(a b c d . e)) => (e d c b a) - (let loop ((a '()) - (d l)) - (if (pair? d) - (loop (cons (car d) a) (cdr d)) - (cons d a)))) - - (define (every? pred l) - (if (null? l) - #t - (and (pred (car l)) (every? pred (cdr l))))) - - - ;; extra syntax - - (define-syntax let*-values - (er-macro-transformer - (lambda (form r c) - (let ((formals (cadr form))) - (if (null? formals) - `(,(r 'let) () ,@(cddr form)) - `(,(r 'call-with-values) (,(r 'lambda) () ,@(cdar formals)) - (,(r 'lambda) (,@(caar formals)) - (,(r 'let*-values) (,@(cdr formals)) - ,@(cddr form))))))))) - - (define-syntax let-values - (er-macro-transformer - (lambda (form r c) - `(,(r 'let*-values) ,@(cdr form))))) - - (define uniq - (let ((counter 0)) - (lambda (x) - (let ((sym (string->symbol (string-append "var$" (number->string counter))))) - (set! counter (+ counter 1)) - sym)))) - - (define-syntax define-values - (ir-macro-transformer - (lambda (form inject compare) - (let* ((formal (cadr form)) - (formal* (walk uniq formal)) - (exprs (cddr form))) - `(begin - ,@(map - (lambda (var) `(define ,var #f)) - (flatten formal)) - (call-with-values (lambda () ,@exprs) - (lambda ,formal* - ,@(map - (lambda (var val) `(set! ,var ,val)) - (flatten formal) - (flatten formal*))))))))) - - (export let-values - let*-values - define-values) - - (define-syntax syntax-rules - (er-macro-transformer - (lambda (form r compare) - (define _define (r 'define)) - (define _let (r 'let)) - (define _if (r 'if)) - (define _begin (r 'begin)) - (define _lambda (r 'lambda)) - (define _set! (r 'set!)) - (define _not (r 'not)) - (define _and (r 'and)) - (define _car (r 'car)) - (define _cdr (r 'cdr)) - (define _cons (r 'cons)) - (define _pair? (r 'pair?)) - (define _null? (r 'null?)) - (define _symbol? (r 'symbol?)) - (define _vector? (r 'vector?)) - (define _eqv? (r 'eqv?)) - (define _string=? (r 'string=?)) - (define _map (r 'map)) - (define _vector->list (r 'vector->list)) - (define _list->vector (r 'list->vector)) - (define _quote (r 'quote)) - (define _quasiquote (r 'quasiquote)) - (define _unquote (r 'unquote)) - (define _unquote-splicing (r 'unquote-splicing)) - (define _syntax-error (r 'syntax-error)) - (define _call/cc (r 'call/cc)) - (define _er-macro-transformer (r 'er-macro-transformer)) - - (define (var->sym v) - (let loop ((cnt 0) - (v v)) - (if (symbol? v) - (string->symbol - (string-append (symbol->string v) "/" (number->string cnt))) - (loop (+ 1 cnt) (car v))))) - - (define push-var list) - - (define (compile-match ellipsis literals pattern) - (letrec ((compile-match-base - (lambda (pattern) - (cond ((member pattern literals compare) - (values - `(,_if (,_and (,_symbol? expr) (cmp expr (rename ',pattern))) - #f - (exit #f)) - '())) - ((compare pattern (r '_)) (values #f '())) - ((and ellipsis (compare pattern ellipsis)) - (values `(,_syntax-error "invalid pattern") '())) - ((symbol? pattern) - (values `(,_set! ,(var->sym pattern) expr) (list pattern))) - ((pair? pattern) - (compile-match-list pattern)) - ((vector? pattern) - (compile-match-vector pattern)) - ((string? pattern) - (values - `(,_if (,_not (,_string=? ',pattern expr)) - (exit #f)) - '())) - (else - (values - `(,_if (,_not (,_eqv? ',pattern expr)) - (exit #f)) - '()))))) - - (compile-match-list - (lambda (pattern) - (let loop ((pattern pattern) - (matches '()) - (vars '()) - (accessor 'expr)) - (cond ;; (hoge) - ((not (pair? (cdr pattern))) - (let*-values (((match1 vars1) (compile-match-base (car pattern))) - ((match2 vars2) (compile-match-base (cdr pattern)))) - (values - `(,_begin ,@(reverse matches) - (,_if (,_pair? ,accessor) - (,_begin - (,_let ((expr (,_car ,accessor))) - ,match1) - (,_let ((expr (,_cdr ,accessor))) - ,match2)) - (exit #f))) - (append vars (append vars1 vars2))))) - ;; (hoge ... rest args) - ((and ellipsis (compare (cadr pattern) ellipsis)) - (let-values (((match-r vars-r) (compile-match-list-reverse pattern))) - (values - `(,_begin ,@(reverse matches) - (,_let ((expr (,_let loop ((a ()) - (d ,accessor)) - (,_if (,_pair? d) - (loop (,_cons (,_car d) a) (,_cdr d)) - (,_cons d a))))) - ,match-r)) - (append vars vars-r)))) - (else - (let-values (((match1 vars1) (compile-match-base (car pattern)))) - (loop (cdr pattern) - (cons `(,_if (,_pair? ,accessor) - (,_let ((expr (,_car ,accessor))) - ,match1) - (exit #f)) - matches) - (append vars vars1) - `(,_cdr ,accessor)))))))) - - (compile-match-list-reverse - (lambda (pattern) - (let loop ((pattern (reverse* pattern)) - (matches '()) - (vars '()) - (accessor 'expr)) - (cond ((and ellipsis (compare (car pattern) ellipsis)) - (let-values (((match1 vars1) (compile-match-ellipsis (cadr pattern)))) - (values - `(,_begin ,@(reverse matches) - (,_let ((expr ,accessor)) - ,match1)) - (append vars vars1)))) - (else - (let-values (((match1 vars1) (compile-match-base (car pattern)))) - (loop (cdr pattern) - (cons `(,_let ((expr (,_car ,accessor))) ,match1) matches) - (append vars vars1) - `(,_cdr ,accessor)))))))) - - (compile-match-ellipsis - (lambda (pattern) - (let-values (((match vars) (compile-match-base pattern))) - (values - `(,_let loop ((expr expr)) - (,_if (,_not (,_null? expr)) - (,_let ,(map (lambda (var) `(,(var->sym var) '())) vars) - (,_let ((expr (,_car expr))) - ,match) - ,@(map - (lambda (var) - `(,_set! ,(var->sym (push-var var)) - (,_cons ,(var->sym var) ,(var->sym (push-var var))))) - vars) - (loop (,_cdr expr))))) - (map push-var vars))))) - - (compile-match-vector - (lambda (pattern) - (let-values (((match vars) (compile-match-base (vector->list pattern)))) - (values - `(,_if (,_vector? expr) - (,_let ((expr (,_vector->list expr))) - ,match) - (exit #f)) - vars))))) - - (let-values (((match vars) (compile-match-base (cdr pattern)))) - (values `(,_let ((expr (,_cdr expr))) - ,match - #t) - vars)))) - - ;;; compile expand - (define (compile-expand ellipsis reserved template) - (letrec ((compile-expand-base - (lambda (template ellipsis-valid) - (cond ((member template reserved eq?) - (values (var->sym template) (list template))) - ((symbol? template) - (values `(rename ',template) '())) - ((pair? template) - (compile-expand-list template ellipsis-valid)) - ((vector? template) - (compile-expand-vector template ellipsis-valid)) - (else - (values `',template '()))))) - - (compile-expand-list - (lambda (template ellipsis-valid) - (let loop ((template template) - (expands '()) - (vars '())) - (cond ;; (... hoge) - ((and ellipsis-valid - (pair? template) - (compare (car template) ellipsis)) - (if (and (pair? (cdr template)) (null? (cddr template))) - (compile-expand-base (cadr template) #f) - (values '(,_syntax-error "invalid template") '()))) - ;; hoge - ((not (pair? template)) - (let-values (((expand1 vars1) - (compile-expand-base template ellipsis-valid))) - (values - `(,_quasiquote (,@(reverse expands) . (,_unquote ,expand1))) - (append vars vars1)))) - ;; (a ... rest syms) - ((and ellipsis-valid - (pair? (cdr template)) - (compare (cadr template) ellipsis)) - (let-values (((expand1 vars1) - (compile-expand-base (car template) ellipsis-valid))) - (loop (cddr template) - (cons - `(,_unquote-splicing - (,_map (,_lambda ,(map var->sym vars1) ,expand1) - ,@(map (lambda (v) (var->sym (push-var v))) vars1))) - expands) - (append vars (map push-var vars1))))) - (else - (let-values (((expand1 vars1) - (compile-expand-base (car template) ellipsis-valid))) - (loop (cdr template) - (cons - `(,_unquote ,expand1) - expands) - (append vars vars1)))))))) - - (compile-expand-vector - (lambda (template ellipsis-valid) - (let-values (((expand1 vars1) - (compile-expand-base (vector->list template) ellipsis-valid))) - (values - `(,_list->vector ,expand1) - vars1))))) - - (compile-expand-base template ellipsis))) - - (define (check-vars vars-pattern vars-template) - ;;fixme - #t) - - (define (compile-rule ellipsis literals rule) - (let ((pattern (car rule)) - (template (cadr rule))) - (let*-values (((match vars-match) - (compile-match ellipsis literals pattern)) - ((expand vars-expand) - (compile-expand ellipsis (flatten vars-match) template))) - (if (check-vars vars-match vars-expand) - (list vars-match match expand) - 'mismatch)))) - - (define (expand-clauses clauses rename) - (cond ((null? clauses) - `(,_quote (syntax-error "no matching pattern"))) - ((compare (car clauses) 'mismatch) - `(,_syntax-error "invalid rule")) - (else - (let ((vars (list-ref (car clauses) 0)) - (match (list-ref (car clauses) 1)) - (expand (list-ref (car clauses) 2))) - `(,_let ,(map (lambda (v) (list (var->sym v) '())) vars) - (,_let ((result (,_call/cc (,_lambda (exit) ,match)))) - (,_if result - ,expand - ,(expand-clauses (cdr clauses) rename)))))))) - - (define (normalize-form form) - (if (and (list? form) (>= (length form) 2)) - (let ((ellipsis '...) - (literals (cadr form)) - (rules (cddr form))) - - (when (symbol? literals) - (set! ellipsis literals) - (set! literals (car rules)) - (set! rules (cdr rules))) - - (if (and (symbol? ellipsis) - (list? literals) - (every? symbol? literals) - (list? rules) - (every? (lambda (l) (and (list? l) (= (length l) 2))) rules)) - (if (member ellipsis literals compare) - `(syntax-rules #f ,literals ,@rules) - `(syntax-rules ,ellipsis ,literals ,@rules)) - #f)) - #f)) - - (let ((form (normalize-form form))) - (if form - (let ((ellipsis (list-ref form 1)) - (literals (list-ref form 2)) - (rules (list-tail form 3))) - (let ((clauses (map (lambda (rule) (compile-rule ellipsis literals rule)) - rules))) - `(,_er-macro-transformer - (,_lambda (expr rename cmp) - ,(expand-clauses clauses r))))) - - `(,_syntax-error "malformed syntax-rules")))))) - - (export syntax-rules) + ;; 4.2.4. Iteration + (export do) ;; 4.2.6. Dynamic bindings - (import (picrin parameter)) - (define-syntax parameterize (ir-macro-transformer (lambda (form inject compare) @@ -683,8 +67,8 @@ ,@(map (lambda (var) `(parameter-pop! ,var)) vars) result))))))) - (export parameterize make-parameter) - + (export make-parameter + parameterize) ;; 4.2.7. Exception handling @@ -748,98 +132,189 @@ (export guard) + ;; 4.2.8. Quasiquotation + + (export quasiquote + unquote + unquote-splicing) + + ;; 4.3.1. Binding constructs for syntactic keywords + + (export let-syntax + letrec-syntax) + + ;; 4.3.2 Pattern language + + (export syntax-rules + _ + ...) + + ;; 4.3.3. Signaling errors in macro transformers + + (export syntax-error) + + ;; 5.3. Variable definitions + + (export define) + + ;; 5.3.3. Multiple-value definitions + + (export define-values) + + ;; 5.4. Syntax definitions + + (export define-syntax) + ;; 5.5 Recored-type definitions - (import (picrin record) - (scheme write)) - - (define ((default-record-writer ctor) obj) - (let ((port (open-output-string))) - (display "#.(" port) - (display (car ctor) port) - (for-each - (lambda (field) - (display " " port) - (write (record-ref obj field) port)) - (cdr ctor)) - (display ")" port) - (get-output-string port))) - - (define ((boot-make-record-type ) name ctor) - (let ((rectype (make-record ))) - (record-set! rectype 'name name) - (record-set! rectype 'writer (default-record-writer ctor)) - rectype)) - - (define - (let (( - ((boot-make-record-type #t) 'record-type '(record-type name writer)))) - (record-set! '@@type ) - )) - - (define make-record-type (boot-make-record-type )) - - (define-syntax define-record-constructor - (ir-macro-transformer - (lambda (form inject compare?) - (let ((rectype (car (cdr form))) - (name (car (cdr (cdr form)))) - (fields (cdr (cdr (cdr form))))) - `(define (,name ,@fields) - (let ((record (make-record ,rectype))) - ,@(map (lambda (field) - `(record-set! record ',field ,field)) - fields) - record)))))) - - (define-syntax define-record-predicate - (ir-macro-transformer - (lambda (form inject compare?) - (let ((rectype (car (cdr form))) - (name (car (cdr (cdr form))))) - `(define (,name obj) - (and (record? obj) - (eq? (record-type obj) - ,rectype))))))) - - (define-syntax define-record-field - (ir-macro-transformer - (lambda (form inject compare?) - (let ((pred (car (cdr form))) - (field-name (car (cdr (cdr form)))) - (accessor (car (cdr (cdr (cdr form))))) - (modifier? (cdr (cdr (cdr (cdr form)))))) - (if (null? modifier?) - `(define (,accessor record) - (if (,pred record) - (record-ref record ',field-name) - (error "wrong record type"))) - `(begin - (define (,accessor record) - (if (,pred record) - (record-ref record ',field-name) - (error "wrong record type"))) - (define (,(car modifier?) record val) - (if (,pred record) - (record-set! record ',field-name val) - (error "wrong record type"))))))))) - - (define-syntax define-record-type - (ir-macro-transformer - (lambda (form inject compare?) - (let ((name (car (cdr form))) - (ctor (car (cdr (cdr form)))) - (pred (car (cdr (cdr (cdr form))))) - (fields (cdr (cdr (cdr (cdr form)))))) - `(begin - (define ,name (make-record-type ',name ',ctor)) - (define-record-constructor ,name ,@ctor) - (define-record-predicate ,name ,pred) - ,@(map (lambda (field) `(define-record-field ,pred ,@field)) - fields)))))) - (export define-record-type) + ;; 6.1. Equivalence predicates + + (export eq? + eqv? + equal?) + + ;; 6.2. Numbers + + (define (exact-integer? x) + (and (exact? x) + (integer? x))) + + (define (zero? x) + (= x 0)) + + (define (positive? x) + (> x 0)) + + (define (negative? x) + (< x 0)) + + (define (even? x) + (= x (* (exact (floor (/ x 2))) 2))) + + (define (odd? x) + (not (even? x))) + + (define (min . args) + (define (min a b) + (if (< a b) a b)) + (let loop ((args args) (acc +inf.0)) + (if (null? args) + acc + (loop (cdr args) (min (car args) acc))))) + + (define (max . args) + (define (max a b) + (if (> a b) a b)) + (let loop ((args args) (acc -inf.0)) + (if (null? args) + acc + (loop (cdr args) (max (car args) acc))))) + + (define (floor-quotient i j) + (call-with-values (lambda () (floor/ i j)) + (lambda (q r) + q))) + + (define (floor-remainder i j) + (call-with-values (lambda () (floor/ i j)) + (lambda (q r) + r))) + + (define (truncate-quotient i j) + (call-with-values (lambda () (truncate/ i j)) + (lambda (q r) + q))) + + (define (truncate-remainder i j) + (call-with-values (lambda () (truncate/ i j)) + (lambda (q r) + r))) + + (define (gcd . args) + (define (gcd i j) + (cond + ((> i j) (gcd j i)) + ((< i 0) (gcd (- i) j)) + ((> i 0) (gcd (truncate-remainder j i) i)) + (else j))) + (let loop ((args args) (acc 0)) + (if (null? args) + acc + (loop (cdr args) + (gcd acc (car args)))))) + + (define (lcm . args) + (define (lcm i j) + (/ (abs (* i j)) (gcd i j))) + (let loop ((args args) (acc 1)) + (if (null? args) + acc + (loop (cdr args) + (lcm acc (car args)))))) + + (define (square x) + (* x x)) + + (define (exact-integer-sqrt k) + (let ((s (exact (sqrt k)))) + (values s (- k (square s))))) + + (export number? + complex? + real? + rational? + integer? + exact? + inexact? + exact-integer? + exact + inexact + = + < + > + <= + >= + zero? + positive? + negative? + odd? + even? + min + max + + + - + * + / + abs + floor-quotient + floor-remainder + floor/ + truncate-quotient + truncate-remainder + truncate/ + (rename truncate-quotient quotient) + (rename truncate-remainder remainder) + (rename floor-remainder modulo) + gcd + lcm + floor + ceiling + truncate + round + exact-integer-sqrt + square + expt + number->string + string->number) + + ;; 6.3. Booleans + + (export boolean? + boolean=? + not) + ;; 6.4 Pairs and lists (export pair? @@ -870,14 +345,14 @@ assv assoc) - ;; 6.5 Symbols + ;; 6.5. Symbols (export symbol? symbol=? symbol->string string->symbol) - ;; 6.6 Characters + ;; 6.6. Characters (define-macro (define-char-transitive-predicate name op) `(define (,name . cs) @@ -889,13 +364,16 @@ (define-char-transitive-predicate char<=? <=) (define-char-transitive-predicate char>=? >=) - (export char=? + (export char? + char->integer + integer->char + char=? char? char<=? char>=?) - ;; 6.7 String + ;; 6.7. Strings (define (string->list string . opts) (let ((start (if (pair? opts) (car opts) 0)) @@ -920,9 +398,26 @@ (define (string . objs) (list->string objs)) - (export string string->list list->string) + (export string? + string + make-string + string-length + string-ref + string-set! + string-copy + string-copy! + string-append + string-fill! + string=? + string? + string<=? + string>=? + string->list + list->string + (rename string-copy substring)) - ;; 6.8. Vector + ;; 6.8. Vectors (define (vector . objs) (list->vector objs)) @@ -933,9 +428,23 @@ (define (string->vector . args) (list->vector (apply string->list args))) - (export vector vector->string string->vector) + (export vector + vector->string + string->vector) - ;; 6.9 bytevector + (export vector? + make-vector + vector-length + vector-ref + vector-set! + vector-copy! + vector-copy + vector-append + vector-fill! + list->vector + vector->list) + + ;; 6.9. bytevector (define (bytevector->list v start end) (do ((i start (+ i 1)) @@ -970,13 +479,21 @@ (string-length s)))) (list->bytevector (map char->integer (string->list s start end))))) - (export bytevector + (export bytevector? + bytevector + make-bytevector + bytevector-length + bytevector-u8-ref + bytevector-u8-set! + bytevector-copy + bytevector-copy! + bytevector-append bytevector->list list->bytevector utf8->string string->utf8) - ;; 6.10 control features + ;; 6.10. Control features (define (string-map f . strings) (list->string (apply map f (map string->list strings)))) @@ -990,8 +507,31 @@ (define (vector-for-each f . vectors) (apply for-each f (map vector->list vectors))) - (export string-map string-for-each - vector-map vector-for-each) + (export procedure? + apply + map + for-each + string-map + string-for-each + vector-map + vector-for-each + call-with-current-continuation + call/cc + dynamic-wind + values + call-with-values) + + ;; 6.11. Exceptions + + (export with-exception-handler + raise + raise-continuable + error + error-object? + error-object-message + error-object-irritants + read-error? + file-error?) ;; 6.13. Input and output @@ -1001,4 +541,49 @@ (lambda () (proc port)) (lambda () (close-port port)))) - (export call-with-port)) + (export current-input-port + current-output-port + current-error-port + + call-with-port + + port? + input-port? + output-port? + textual-port? + binary-port? + + (rename port-open? input-port-open?) + (rename port-open? output-port-open?) + close-port + (rename close-port close-input-port) + (rename close-port close-output-port) + + open-input-string + open-output-string + get-output-string + open-input-bytevector + open-output-bytevector + get-output-bytevector + + eof-object? + eof-object + + read-char + peek-char + char-ready? + read-line + read-string + + read-u8 + peek-u8 + u8-ready? + read-bytevector + read-bytevector! + + newline + write-char + write-string + write-u8 + write-bytevector + flush-output-port)) diff --git a/piclib/scheme/eval.scm b/piclib/scheme/eval.scm index 2a4f3b0f..54574c03 100644 --- a/piclib/scheme/eval.scm +++ b/piclib/scheme/eval.scm @@ -1,15 +1,5 @@ (define-library (scheme eval) - (import (scheme base)) - - (define (null-environment n) - (if (not (= n 5)) - (error "unsupported environment version" n) - '(scheme null))) - - (define (scheme-report-environment n) - (if (not (= n 5)) - (error "unsupported environment version" n) - '(scheme r5rs))) + (import (picrin base)) (define environment (let ((counter 0)) @@ -24,6 +14,4 @@ '(scheme base)) library-name)))) - (export null-environment - scheme-report-environment - environment)) + (export environment eval)) diff --git a/piclib/scheme/file.scm b/piclib/scheme/file.scm index b449e49d..8e2b7300 100644 --- a/piclib/scheme/file.scm +++ b/piclib/scheme/file.scm @@ -1,5 +1,6 @@ (define-library (scheme file) - (import (scheme base)) + (import (picrin base) + (scheme base)) (define (call-with-input-file filename callback) (call-with-port (open-input-file filename) callback)) @@ -19,7 +20,13 @@ (parameterize ((current-output-port port)) (thunk))))) - (export call-with-input-file + (export open-input-file + open-binary-input-file + open-output-file + open-binary-output-file + delete-file + file-exists? + call-with-input-file call-with-output-file with-input-from-file with-output-to-file)) diff --git a/piclib/scheme/inexact.scm b/piclib/scheme/inexact.scm new file mode 100644 index 00000000..28c162dc --- /dev/null +++ b/piclib/scheme/inexact.scm @@ -0,0 +1,15 @@ +(define-library (scheme inexact) + (import (picrin base)) + + (export acos + asin + atan + cos + exp + finite? + infinite? + log + nan? + sin + sqrt + tan)) diff --git a/piclib/scheme/load.scm b/piclib/scheme/load.scm new file mode 100644 index 00000000..5813a75d --- /dev/null +++ b/piclib/scheme/load.scm @@ -0,0 +1,4 @@ +(define-library (scheme load) + (import (picrin base)) + + (export load)) diff --git a/piclib/scheme/process-context.scm b/piclib/scheme/process-context.scm new file mode 100644 index 00000000..b19d9fb7 --- /dev/null +++ b/piclib/scheme/process-context.scm @@ -0,0 +1,8 @@ +(define-library (scheme process-context) + (import (picrin base)) + + (export command-line + emergency-exit + exit + get-environment-variable + get-environment-variables)) diff --git a/piclib/scheme/r5rs.scm b/piclib/scheme/r5rs.scm index e26a999d..f3b1c563 100644 --- a/piclib/scheme/r5rs.scm +++ b/piclib/scheme/r5rs.scm @@ -9,6 +9,16 @@ (scheme eval) (scheme load)) + (define (null-environment n) + (if (not (= n 5)) + (error "unsupported environment version" n) + '(scheme null))) + + (define (scheme-report-environment n) + (if (not (= n 5)) + (error "unsupported environment version" n) + '(scheme r5rs))) + (export * + - / < <= = > >= abs acos and ;; angle diff --git a/piclib/scheme/read.scm b/piclib/scheme/read.scm new file mode 100644 index 00000000..aca4ec9f --- /dev/null +++ b/piclib/scheme/read.scm @@ -0,0 +1,4 @@ +(define-library (scheme read) + (import (picrin base)) + + (export read)) diff --git a/piclib/scheme/time.scm b/piclib/scheme/time.scm new file mode 100644 index 00000000..4df7f090 --- /dev/null +++ b/piclib/scheme/time.scm @@ -0,0 +1,6 @@ +(define-library (scheme time) + (import (picrin base)) + + (export current-jiffy + current-second + jiffies-per-second)) diff --git a/piclib/scheme/write.scm b/piclib/scheme/write.scm new file mode 100644 index 00000000..2e495373 --- /dev/null +++ b/piclib/scheme/write.scm @@ -0,0 +1,7 @@ +(define-library (scheme write) + (import (picrin base)) + + (export write + write-simple + write-shared + display)) diff --git a/piclib/srfi/17.scm b/piclib/srfi/17.scm index eb02e66e..c1bed0d0 100644 --- a/piclib/srfi/17.scm +++ b/piclib/srfi/17.scm @@ -3,10 +3,10 @@ (import (except (scheme base) set!) (prefix (only (scheme base) set!) %) (picrin dictionary) - (picrin attribute) + (except (picrin base) set!) (srfi 1) (srfi 8)) - + (define-syntax set! (syntax-rules () ((_ (proc args ...) val) diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index f3e51499..0ca3b949 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -1,7 +1,12 @@ +### libpicrin ### + 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 +26,22 @@ 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") + +### picrin ### + +list(APPEND REPL_LIBRARIES picrin) + +# build +add_executable(repl src/main.c) +set_target_properties(repl PROPERTIES OUTPUT_NAME picrin) +target_link_libraries(repl ${REPL_LIBRARIES}) + +# install +install(TARGETS repl RUNTIME DESTINATION bin) diff --git a/src/blob.c b/src/blob.c deleted file mode 100644 index 0bb28713..00000000 --- a/src/blob.c +++ /dev/null @@ -1,196 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#include - -#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); -} diff --git a/src/bool.c b/src/bool.c deleted file mode 100644 index 8f8c75f1..00000000 --- a/src/bool.c +++ /dev/null @@ -1,201 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#include - -#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); -} diff --git a/src/char.c b/src/char.c deleted file mode 100644 index 6ec81c92..00000000 --- a/src/char.c +++ /dev/null @@ -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); -} diff --git a/src/codegen.c b/src/codegen.c deleted file mode 100644 index c1264dfb..00000000 --- a/src/codegen.c +++ /dev/null @@ -1,1458 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#include "picrin.h" -#include "picrin/pair.h" -#include "picrin/irep.h" -#include "picrin/proc.h" -#include "picrin/lib.h" -#include "picrin/macro.h" - -#if PIC_NONE_IS_FALSE -# define OP_PUSHNONE OP_PUSHFALSE -#else -# error enable PIC_NONE_IS_FALSE -#endif - -/** - * scope object - */ - -typedef struct analyze_scope { - int depth; - bool varg; - xvect args, locals, captures; /* rest args variable is counted as a local */ - struct analyze_scope *up; -} analyze_scope; - -/** - * global analyzer state - */ - -typedef struct analyze_state { - pic_state *pic; - analyze_scope *scope; - pic_sym rCONS, rCAR, rCDR, rNILP; - pic_sym rADD, rSUB, rMUL, rDIV; - pic_sym rEQ, rLT, rLE, rGT, rGE, rNOT; - pic_sym rVALUES, rCALL_WITH_VALUES; - pic_sym sCALL, sTAILCALL, sCALL_WITH_VALUES, sTAILCALL_WITH_VALUES; - pic_sym sGREF, sLREF, sCREF, sRETURN; -} analyze_state; - -static bool push_scope(analyze_state *, pic_value); -static void pop_scope(analyze_state *); - -#define register_symbol(pic, state, slot, name) do { \ - state->slot = pic_intern_cstr(pic, name); \ - } while (0) - -#define register_renamed_symbol(pic, state, slot, lib, id) do { \ - pic_sym sym, gsym; \ - sym = pic_intern_cstr(pic, id); \ - if (! pic_find_rename(pic, lib->env, sym, &gsym)) { \ - pic_error(pic, "internal error! native VM procedure not found"); \ - } \ - state->slot = gsym; \ - } while (0) - -static analyze_state * -new_analyze_state(pic_state *pic) -{ - analyze_state *state; - xh_iter it; - struct pic_lib *stdlib, *listlib; - - state = pic_alloc(pic, sizeof(analyze_state)); - state->pic = pic; - state->scope = NULL; - - stdlib = pic_find_library(pic, pic_read_cstr(pic, "(scheme base)")); - listlib = pic_find_library(pic, pic_read_cstr(pic, "(picrin base list)")); - - /* native VM procedures */ - register_renamed_symbol(pic, state, rCONS, listlib, "cons"); - register_renamed_symbol(pic, state, rCAR, listlib, "car"); - register_renamed_symbol(pic, state, rCDR, listlib, "cdr"); - register_renamed_symbol(pic, state, rNILP, listlib, "null?"); - register_renamed_symbol(pic, state, rADD, stdlib, "+"); - register_renamed_symbol(pic, state, rSUB, stdlib, "-"); - register_renamed_symbol(pic, state, rMUL, stdlib, "*"); - register_renamed_symbol(pic, state, rDIV, stdlib, "/"); - register_renamed_symbol(pic, state, rEQ, stdlib, "="); - register_renamed_symbol(pic, state, rLT, stdlib, "<"); - register_renamed_symbol(pic, state, rLE, stdlib, "<="); - register_renamed_symbol(pic, state, rGT, stdlib, ">"); - register_renamed_symbol(pic, state, rGE, stdlib, ">="); - register_renamed_symbol(pic, state, rNOT, stdlib, "not"); - register_renamed_symbol(pic, state, rVALUES, stdlib, "values"); - register_renamed_symbol(pic, state, rCALL_WITH_VALUES, stdlib, "call-with-values"); - - register_symbol(pic, state, sCALL, "call"); - register_symbol(pic, state, sTAILCALL, "tail-call"); - register_symbol(pic, state, sCALL_WITH_VALUES, "call-with-values"); - register_symbol(pic, state, sTAILCALL_WITH_VALUES, "tailcall-with-values"); - register_symbol(pic, state, sGREF, "gref"); - register_symbol(pic, state, sLREF, "lref"); - register_symbol(pic, state, sCREF, "cref"); - register_symbol(pic, state, sRETURN, "return"); - - /* push initial scope */ - push_scope(state, pic_nil_value()); - - xh_begin(&it, &pic->globals); - while (xh_next(&it)) { - pic_sym sym = xh_key(it.e, pic_sym); - xv_push(&state->scope->locals, &sym); - } - - return state; -} - -static void -destroy_analyze_state(analyze_state *state) -{ - pop_scope(state); - pic_free(state->pic, state); -} - -static bool -analyze_args(pic_state *pic, pic_value formals, bool *varg, xvect *args, xvect *locals) -{ - pic_value v, sym; - - for (v = formals; pic_pair_p(v); v = pic_cdr(pic, v)) { - sym = pic_car(pic, v); - if (! pic_sym_p(sym)) { - return false; - } - xv_push(args, &pic_sym(sym)); - } - if (pic_nil_p(v)) { - *varg = false; - } - else if (pic_sym_p(v)) { - *varg = true; - xv_push(locals, &pic_sym(v)); - } - else { - return false; - } - - return true; -} - -static bool -push_scope(analyze_state *state, pic_value formals) -{ - pic_state *pic = state->pic; - analyze_scope *scope; - bool varg; - xvect args, locals, captures; - - xv_init(&args, sizeof(pic_sym)); - xv_init(&locals, sizeof(pic_sym)); - xv_init(&captures, sizeof(pic_sym)); - - if (analyze_args(pic, formals, &varg, &args, &locals)) { - scope = pic_alloc(pic, sizeof(analyze_scope)); - scope->up = state->scope; - scope->depth = scope->up ? scope->up->depth + 1 : 0; - scope->varg = varg; - scope->args = args; - scope->locals = locals; - scope->captures = captures; - - state->scope = scope; - - return true; - } - else { - xv_destroy(&args); - xv_destroy(&locals); - return false; - } -} - -static void -pop_scope(analyze_state *state) -{ - analyze_scope *scope; - - scope = state->scope; - xv_destroy(&scope->args); - xv_destroy(&scope->locals); - xv_destroy(&scope->captures); - - scope = scope->up; - pic_free(state->pic, state->scope); - state->scope = scope; -} - -static bool -lookup_scope(analyze_scope *scope, pic_sym sym) -{ - pic_sym *arg, *local; - size_t i; - - /* args */ - for (i = 0; i < scope->args.size; ++i) { - arg = xv_get(&scope->args, i); - if (*arg == sym) - return true; - } - /* locals */ - for (i = 0; i < scope->locals.size; ++i) { - local = xv_get(&scope->locals, i); - if (*local == sym) - return true; - } - return false; -} - -static void -capture_var(analyze_scope *scope, pic_sym sym) -{ - pic_sym *var; - size_t i; - - for (i = 0; i < scope->captures.size; ++i) { - var = xv_get(&scope->captures, i); - if (*var == sym) { - break; - } - } - if (i == scope->captures.size) { - xv_push(&scope->captures, &sym); - } -} - -static int -find_var(analyze_state *state, pic_sym sym) -{ - analyze_scope *scope = state->scope; - int depth = 0; - - while (scope) { - if (lookup_scope(scope, sym)) { - if (depth > 0) { - capture_var(scope, sym); - } - return depth; - } - depth++; - scope = scope->up; - } - return -1; -} - -static void -define_var(analyze_state *state, pic_sym sym) -{ - pic_state *pic = state->pic; - analyze_scope *scope = state->scope; - - if (lookup_scope(scope, sym)) { - pic_warnf(pic, "redefining variable: ~s", pic_sym_value(sym)); - return; - } - - xv_push(&scope->locals, &sym); -} - -static pic_value analyze_node(analyze_state *, pic_value, bool); - -static pic_value -analyze(analyze_state *state, pic_value obj, bool tailpos) -{ - pic_state *pic = state->pic; - size_t ai = pic_gc_arena_preserve(pic); - pic_value res; - pic_sym tag; - - res = analyze_node(state, obj, tailpos); - - tag = pic_sym(pic_car(pic, res)); - if (tailpos) { - if (tag == pic->sIF || tag == pic->sBEGIN || tag == state->sTAILCALL || tag == state->sTAILCALL_WITH_VALUES || tag == state->sRETURN) { - /* pass through */ - } - else { - res = pic_list2(pic, pic_symbol_value(state->sRETURN), res); - } - } - - pic_gc_arena_restore(pic, ai); - pic_gc_protect(pic, res); - return res; -} - -static pic_value -analyze_global_var(analyze_state *state, pic_sym sym) -{ - pic_state *pic = state->pic; - - return pic_list2(pic, pic_symbol_value(state->sGREF), pic_sym_value(sym)); -} - -static pic_value -analyze_local_var(analyze_state *state, pic_sym sym) -{ - pic_state *pic = state->pic; - - return pic_list2(pic, pic_symbol_value(state->sLREF), pic_sym_value(sym)); -} - -static pic_value -analyze_free_var(analyze_state *state, pic_sym sym, int depth) -{ - pic_state *pic = state->pic; - - return pic_list3(pic, pic_symbol_value(state->sCREF), pic_int_value(depth), pic_sym_value(sym)); -} - -static pic_value -analyze_var(analyze_state *state, pic_sym sym) -{ - pic_state *pic = state->pic; - int depth; - - if ((depth = find_var(state, sym)) == -1) { - pic_errorf(pic, "unbound variable %s", pic_symbol_name(pic, sym)); - } - - if (depth == state->scope->depth) { - return analyze_global_var(state, sym); - } else if (depth == 0) { - return analyze_local_var(state, sym); - } else { - return analyze_free_var(state, sym, depth); - } -} - -static pic_value -analyze_procedure(analyze_state *state, pic_value name, pic_value formals, pic_value body_exprs) -{ - pic_state *pic = state->pic; - pic_value args, locals, varg, captures, body; - - assert(pic_sym_p(name) || pic_false_p(name)); - - if (push_scope(state, formals)) { - analyze_scope *scope = state->scope; - pic_sym *var; - size_t i; - - args = pic_nil_value(); - for (i = scope->args.size; i > 0; --i) { - var = xv_get(&scope->args, i - 1); - pic_push(pic, pic_sym_value(*var), args); - } - - varg = scope->varg - ? pic_true_value() - : pic_false_value(); - - /* To know what kind of local variables are defined, analyze body at first. */ - body = analyze(state, pic_cons(pic, pic_sym_value(pic->rBEGIN), body_exprs), true); - - locals = pic_nil_value(); - for (i = scope->locals.size; i > 0; --i) { - var = xv_get(&scope->locals, i - 1); - pic_push(pic, pic_sym_value(*var), locals); - } - - captures = pic_nil_value(); - for (i = scope->captures.size; i > 0; --i) { - var = xv_get(&scope->captures, i - 1); - pic_push(pic, pic_sym_value(*var), captures); - } - - pop_scope(state); - } - else { - pic_errorf(pic, "invalid formal syntax: ~s", args); - } - - return pic_list7(pic, pic_sym_value(pic->sLAMBDA), name, args, locals, varg, captures, body); -} - -static pic_value -analyze_lambda(analyze_state *state, pic_value obj) -{ - pic_state *pic = state->pic; - pic_value formals, body_exprs; - - if (pic_length(pic, obj) < 2) { - pic_error(pic, "syntax error"); - } - - formals = pic_list_ref(pic, obj, 1); - body_exprs = pic_list_tail(pic, obj, 2); - - return analyze_procedure(state, pic_false_value(), formals, body_exprs); -} - -static pic_value -analyze_declare(analyze_state *state, pic_sym var) -{ - define_var(state, var); - - return analyze_var(state, var); -} - -static pic_value -analyze_define(analyze_state *state, pic_value obj) -{ - pic_state *pic = state->pic; - pic_value var, val; - pic_sym sym; - - if (pic_length(pic, obj) != 3) { - pic_error(pic, "syntax error"); - } - - var = pic_list_ref(pic, obj, 1); - if (! pic_sym_p(var)) { - pic_error(pic, "syntax error"); - } else { - sym = pic_sym(var); - } - var = analyze_declare(state, sym); - - if (pic_pair_p(pic_list_ref(pic, obj, 2)) - && pic_sym_p(pic_list_ref(pic, pic_list_ref(pic, obj, 2), 0)) - && pic_sym(pic_list_ref(pic, pic_list_ref(pic, obj, 2), 0)) == pic->rLAMBDA) { - pic_value formals, body_exprs; - - formals = pic_list_ref(pic, pic_list_ref(pic, obj, 2), 1); - body_exprs = pic_list_tail(pic, pic_list_ref(pic, obj, 2), 2); - - val = analyze_procedure(state, pic_sym_value(sym), formals, body_exprs); - } else { - if (pic_length(pic, obj) != 3) { - pic_error(pic, "syntax error"); - } - val = analyze(state, pic_list_ref(pic, obj, 2), false); - } - - return pic_list3(pic, pic_symbol_value(pic->sSETBANG), var, val); -} - -static pic_value -analyze_if(analyze_state *state, pic_value obj, bool tailpos) -{ - pic_state *pic = state->pic; - pic_value cond, if_true, if_false; - - if_false = pic_none_value(); - switch (pic_length(pic, obj)) { - default: - pic_error(pic, "syntax error"); - break; - case 4: - if_false = pic_list_ref(pic, obj, 3); - FALLTHROUGH; - case 3: - if_true = pic_list_ref(pic, obj, 2); - } - - /* analyze in order */ - cond = analyze(state, pic_list_ref(pic, obj, 1), false); - if_true = analyze(state, if_true, tailpos); - if_false = analyze(state, if_false, tailpos); - - return pic_list4(pic, pic_symbol_value(pic->sIF), cond, if_true, if_false); -} - -static pic_value -analyze_begin(analyze_state *state, pic_value obj, bool tailpos) -{ - pic_state *pic = state->pic; - pic_value seq; - bool tail; - - switch (pic_length(pic, obj)) { - case 1: - return analyze(state, pic_none_value(), tailpos); - case 2: - return analyze(state, pic_list_ref(pic, obj, 1), tailpos); - default: - seq = pic_list1(pic, pic_symbol_value(pic->sBEGIN)); - for (obj = pic_cdr(pic, obj); ! pic_nil_p(obj); obj = pic_cdr(pic, obj)) { - if (pic_nil_p(pic_cdr(pic, obj))) { - tail = tailpos; - } else { - tail = false; - } - seq = pic_cons(pic, analyze(state, pic_car(pic, obj), tail), seq); - } - return pic_reverse(pic, seq); - } -} - -static pic_value -analyze_set(analyze_state *state, pic_value obj) -{ - pic_state *pic = state->pic; - pic_value var, val; - - if (pic_length(pic, obj) != 3) { - pic_error(pic, "syntax error"); - } - - var = pic_list_ref(pic, obj, 1); - if (! pic_sym_p(var)) { - pic_error(pic, "syntax error"); - } - - val = pic_list_ref(pic, obj, 2); - - var = analyze(state, var, false); - val = analyze(state, val, false); - - return pic_list3(pic, pic_symbol_value(pic->sSETBANG), var, val); -} - -static pic_value -analyze_quote(analyze_state *state, pic_value obj) -{ - pic_state *pic = state->pic; - - if (pic_length(pic, obj) != 2) { - pic_error(pic, "syntax error"); - } - return pic_list2(pic, pic_sym_value(pic->sQUOTE), pic_list_ref(pic, obj, 1)); -} - -#define ARGC_ASSERT_GE(n) do { \ - if (pic_length(pic, obj) < (n) + 1) { \ - pic_error(pic, "wrong number of arguments"); \ - } \ - } while (0) - -#define FOLD_ARGS(sym) do { \ - obj = analyze(state, pic_car(pic, args), false); \ - pic_for_each (arg, pic_cdr(pic, args)) { \ - obj = pic_list3(pic, pic_symbol_value(sym), obj, \ - analyze(state, arg, false)); \ - } \ - } while (0) - -static pic_value -analyze_add(analyze_state *state, pic_value obj, bool tailpos) -{ - pic_state *pic = state->pic; - pic_value args, arg; - - ARGC_ASSERT_GE(0); - switch (pic_length(pic, obj)) { - case 1: - return pic_list2(pic, pic_symbol_value(pic->sQUOTE), pic_int_value(0)); - case 2: - return analyze(state, pic_car(pic, pic_cdr(pic, obj)), tailpos); - default: - args = pic_cdr(pic, obj); - FOLD_ARGS(pic->sADD); - return obj; - } -} - -static pic_value -analyze_sub(analyze_state *state, pic_value obj) -{ - pic_state *pic = state->pic; - pic_value args, arg; - - ARGC_ASSERT_GE(1); - switch (pic_length(pic, obj)) { - case 2: - return pic_list2(pic, pic_symbol_value(pic->sMINUS), - analyze(state, pic_car(pic, pic_cdr(pic, obj)), false)); - default: - args = pic_cdr(pic, obj); - FOLD_ARGS(pic->sSUB); - return obj; - } -} - -static pic_value -analyze_mul(analyze_state *state, pic_value obj, bool tailpos) -{ - pic_state *pic = state->pic; - pic_value args, arg; - - ARGC_ASSERT_GE(0); - switch (pic_length(pic, obj)) { - case 1: - return pic_list2(pic, pic_symbol_value(pic->sQUOTE), pic_int_value(1)); - case 2: - return analyze(state, pic_car(pic, pic_cdr(pic, obj)), tailpos); - default: - args = pic_cdr(pic, obj); - FOLD_ARGS(pic->sMUL); - return obj; - } -} - -static pic_value -analyze_div(analyze_state *state, pic_value obj) -{ - pic_state *pic = state->pic; - pic_value args, arg; - - ARGC_ASSERT_GE(1); - switch (pic_length(pic, obj)) { - case 2: - args = pic_cdr(pic, obj); - obj = pic_list3(pic, pic_car(pic, obj), pic_float_value(1), pic_car(pic, args)); - return analyze(state, obj, false); - default: - args = pic_cdr(pic, obj); - FOLD_ARGS(pic->sDIV); - return obj; - } -} - -static pic_value -analyze_call(analyze_state *state, pic_value obj, bool tailpos) -{ - pic_state *pic = state->pic; - pic_value seq, elt; - pic_sym call; - - if (! tailpos) { - call = state->sCALL; - } else { - call = state->sTAILCALL; - } - seq = pic_list1(pic, pic_symbol_value(call)); - pic_for_each (elt, obj) { - seq = pic_cons(pic, analyze(state, elt, false), seq); - } - return pic_reverse(pic, seq); -} - -static pic_value -analyze_values(analyze_state *state, pic_value obj, bool tailpos) -{ - pic_state *pic = state->pic; - pic_value v, seq; - - if (! tailpos) { - return analyze_call(state, obj, false); - } - - seq = pic_list1(pic, pic_symbol_value(state->sRETURN)); - pic_for_each (v, pic_cdr(pic, obj)) { - seq = pic_cons(pic, analyze(state, v, false), seq); - } - return pic_reverse(pic, seq); -} - -static pic_value -analyze_call_with_values(analyze_state *state, pic_value obj, bool tailpos) -{ - pic_state *pic = state->pic; - pic_value prod, cnsm; - pic_sym call; - - if (pic_length(pic, obj) != 3) { - pic_error(pic, "wrong number of arguments"); - } - - if (! tailpos) { - call = state->sCALL_WITH_VALUES; - } else { - call = state->sTAILCALL_WITH_VALUES; - } - prod = analyze(state, pic_list_ref(pic, obj, 1), false); - cnsm = analyze(state, pic_list_ref(pic, obj, 2), false); - return pic_list3(pic, pic_symbol_value(call), prod, cnsm); -} - -#define ARGC_ASSERT(n) do { \ - if (pic_length(pic, obj) != (n) + 1) { \ - pic_error(pic, "wrong number of arguments"); \ - } \ - } while (0) - -#define ARGC_ASSERT_WITH_FALLBACK(n) do { \ - if (pic_length(pic, obj) != (n) + 1) { \ - goto fallback; \ - } \ - } while (0) - -#define CONSTRUCT_OP1(op) \ - pic_list2(pic, \ - pic_symbol_value(op), \ - analyze(state, pic_list_ref(pic, obj, 1), false)) - -#define CONSTRUCT_OP2(op) \ - pic_list3(pic, \ - pic_symbol_value(op), \ - analyze(state, pic_list_ref(pic, obj, 1), false), \ - analyze(state, pic_list_ref(pic, obj, 2), false)) - -static pic_value -analyze_node(analyze_state *state, pic_value obj, bool tailpos) -{ - pic_state *pic = state->pic; - - switch (pic_type(obj)) { - case PIC_TT_SYMBOL: { - return analyze_var(state, pic_sym(obj)); - } - case PIC_TT_PAIR: { - pic_value proc; - - if (! pic_list_p(obj)) { - pic_errorf(pic, "invalid expression given: ~s", obj); - } - - proc = pic_list_ref(pic, obj, 0); - if (pic_sym_p(proc)) { - pic_sym sym = pic_sym(proc); - - if (sym == pic->rDEFINE) { - return analyze_define(state, obj); - } - else if (sym == pic->rLAMBDA) { - return analyze_lambda(state, obj); - } - else if (sym == pic->rIF) { - return analyze_if(state, obj, tailpos); - } - else if (sym == pic->rBEGIN) { - return analyze_begin(state, obj, tailpos); - } - else if (sym == pic->rSETBANG) { - return analyze_set(state, obj); - } - else if (sym == pic->rQUOTE) { - return analyze_quote(state, obj); - } - else if (sym == state->rCONS) { - ARGC_ASSERT(2); - return CONSTRUCT_OP2(pic->sCONS); - } - else if (sym == state->rCAR) { - ARGC_ASSERT(1); - return CONSTRUCT_OP1(pic->sCAR); - } - else if (sym == state->rCDR) { - ARGC_ASSERT(1); - return CONSTRUCT_OP1(pic->sCDR); - } - else if (sym == state->rNILP) { - ARGC_ASSERT(1); - return CONSTRUCT_OP1(pic->sNILP); - } - else if (sym == state->rADD) { - return analyze_add(state, obj, tailpos); - } - else if (sym == state->rSUB) { - return analyze_sub(state, obj); - } - else if (sym == state->rMUL) { - return analyze_mul(state, obj, tailpos); - } - else if (sym == state->rDIV) { - return analyze_div(state, obj); - } - else if (sym == state->rEQ) { - ARGC_ASSERT_WITH_FALLBACK(2); - return CONSTRUCT_OP2(pic->sEQ); - } - else if (sym == state->rLT) { - ARGC_ASSERT_WITH_FALLBACK(2); - return CONSTRUCT_OP2(pic->sLT); - } - else if (sym == state->rLE) { - ARGC_ASSERT_WITH_FALLBACK(2); - return CONSTRUCT_OP2(pic->sLE); - } - else if (sym == state->rGT) { - ARGC_ASSERT_WITH_FALLBACK(2); - return CONSTRUCT_OP2(pic->sGT); - } - else if (sym == state->rGE) { - ARGC_ASSERT_WITH_FALLBACK(2); - return CONSTRUCT_OP2(pic->sGE); - } - else if (sym == state->rNOT) { - ARGC_ASSERT(1); - return CONSTRUCT_OP1(pic->sNOT); - } - else if (sym == state->rVALUES) { - return analyze_values(state, obj, tailpos); - } - else if (sym == state->rCALL_WITH_VALUES) { - return analyze_call_with_values(state, obj, tailpos); - } - } - fallback: - - return analyze_call(state, obj, tailpos); - } - default: - return pic_list2(pic, pic_symbol_value(pic->sQUOTE), obj); - } -} - -pic_value -pic_analyze(pic_state *pic, pic_value obj) -{ - analyze_state *state; - - state = new_analyze_state(pic); - - obj = analyze(state, obj, true); - - destroy_analyze_state(state); - return obj; -} - -/** - * scope object - */ - -typedef struct codegen_context { - pic_sym name; - /* rest args variable is counted as a local */ - bool varg; - xvect args, locals, captures; - /* actual bit code sequence */ - pic_code *code; - size_t clen, ccapa; - /* child ireps */ - struct pic_irep **irep; - size_t ilen, icapa; - /* constant object pool */ - pic_value *pool; - size_t plen, pcapa; - - struct codegen_context *up; -} codegen_context; - -/** - * global codegen state - */ - -typedef struct codegen_state { - pic_state *pic; - codegen_context *cxt; - pic_sym sGREF, sCREF, sLREF; - pic_sym sCALL, sTAILCALL, sRETURN; - pic_sym sCALL_WITH_VALUES, sTAILCALL_WITH_VALUES; -} codegen_state; - -static void push_codegen_context(codegen_state *, pic_value, pic_value, pic_value, bool, pic_value); -static struct pic_irep *pop_codegen_context(codegen_state *); - -static codegen_state * -new_codegen_state(pic_state *pic) -{ - codegen_state *state; - - state = pic_alloc(pic, sizeof(codegen_state)); - state->pic = pic; - state->cxt = NULL; - - register_symbol(pic, state, sCALL, "call"); - register_symbol(pic, state, sTAILCALL, "tail-call"); - register_symbol(pic, state, sGREF, "gref"); - register_symbol(pic, state, sLREF, "lref"); - register_symbol(pic, state, sCREF, "cref"); - register_symbol(pic, state, sRETURN, "return"); - register_symbol(pic, state, sCALL_WITH_VALUES, "call-with-values"); - register_symbol(pic, state, sTAILCALL_WITH_VALUES, "tailcall-with-values"); - - push_codegen_context(state, pic_false_value(), pic_nil_value(), pic_nil_value(), false, pic_nil_value()); - - return state; -} - -static struct pic_irep * -destroy_codegen_state(codegen_state *state) -{ - pic_state *pic = state->pic; - struct pic_irep *irep; - - irep = pop_codegen_context(state); - pic_free(pic, state); - - return irep; -} - -static void -create_activation(codegen_context *cxt) -{ - size_t i, n; - xhash regs; - pic_sym *var; - size_t offset; - - xh_init_int(®s, sizeof(size_t)); - - offset = 1; - for (i = 0; i < cxt->args.size; ++i) { - var = xv_get(&cxt->args, i); - n = i + offset; - xh_put_int(®s, *var, &n); - } - offset += i; - for (i = 0; i < cxt->locals.size; ++i) { - var = xv_get(&cxt->locals, i); - n = i + offset; - xh_put_int(®s, *var, &n); - } - - for (i = 0; i < cxt->captures.size; ++i) { - var = xv_get(&cxt->captures, i); - if ((n = xh_val(xh_get_int(®s, *var), size_t)) <= cxt->args.size || (cxt->varg && n == cxt->args.size + 1)) { - /* copy arguments to capture variable area */ - cxt->code[cxt->clen].insn = OP_LREF; - cxt->code[cxt->clen].u.i = n; - cxt->clen++; - } else { - /* otherwise, just extend the stack */ - cxt->code[cxt->clen].insn = OP_PUSHNONE; - cxt->clen++; - } - } - - xh_destroy(®s); -} - -static void -push_codegen_context(codegen_state *state, pic_value name, pic_value args, pic_value locals, bool varg, pic_value captures) -{ - pic_state *pic = state->pic; - codegen_context *cxt; - pic_value var; - - assert(pic_sym_p(name) || pic_false_p(name)); - - cxt = pic_alloc(pic, sizeof(codegen_context)); - cxt->up = state->cxt; - cxt->name = pic_false_p(name) - ? pic_intern_cstr(pic, "(anonymous lambda)") - : pic_sym(name); - cxt->varg = varg; - - xv_init(&cxt->args, sizeof(pic_sym)); - xv_init(&cxt->locals, sizeof(pic_sym)); - xv_init(&cxt->captures, sizeof(pic_sym)); - - pic_for_each (var, args) { - xv_push(&cxt->args, &pic_sym(var)); - } - pic_for_each (var, locals) { - xv_push(&cxt->locals, &pic_sym(var)); - } - pic_for_each (var, captures) { - xv_push(&cxt->captures, &pic_sym(var)); - } - - cxt->code = pic_calloc(pic, PIC_ISEQ_SIZE, sizeof(pic_code)); - cxt->clen = 0; - cxt->ccapa = PIC_ISEQ_SIZE; - - cxt->irep = pic_calloc(pic, PIC_IREP_SIZE, sizeof(struct pic_irep *)); - cxt->ilen = 0; - cxt->icapa = PIC_IREP_SIZE; - - cxt->pool = pic_calloc(pic, PIC_POOL_SIZE, sizeof(pic_value)); - cxt->plen = 0; - cxt->pcapa = PIC_POOL_SIZE; - - state->cxt = cxt; - - create_activation(cxt); -} - -static struct pic_irep * -pop_codegen_context(codegen_state *state) -{ - pic_state *pic = state->pic; - codegen_context *cxt = state->cxt; - struct pic_irep *irep; - - /* create irep */ - irep = (struct pic_irep *)pic_obj_alloc(pic, sizeof(struct pic_irep), PIC_TT_IREP); - irep->name = state->cxt->name; - irep->varg = state->cxt->varg; - irep->argc = state->cxt->args.size + 1; - irep->localc = state->cxt->locals.size; - irep->capturec = state->cxt->captures.size; - irep->code = pic_realloc(pic, state->cxt->code, sizeof(pic_code) * state->cxt->clen); - irep->clen = state->cxt->clen; - irep->irep = pic_realloc(pic, state->cxt->irep, sizeof(struct pic_irep *) * state->cxt->ilen); - irep->ilen = state->cxt->ilen; - irep->pool = pic_realloc(pic, state->cxt->pool, sizeof(pic_value) * state->cxt->plen); - irep->plen = state->cxt->plen; - - /* finalize */ - xv_destroy(&cxt->args); - xv_destroy(&cxt->locals); - xv_destroy(&cxt->captures); - - /* destroy context */ - cxt = cxt->up; - pic_free(pic, state->cxt); - state->cxt = cxt; - - return irep; -} - -static int -index_capture(codegen_state *state, pic_sym sym, int depth) -{ - codegen_context *cxt = state->cxt; - size_t i; - pic_sym *var; - - while (depth-- > 0) { - cxt = cxt->up; - } - - for (i = 0; i < cxt->captures.size; ++i) { - var = xv_get(&cxt->captures, i); - if (*var == sym) - return i; - } - return -1; -} - -static int -index_local(codegen_state *state, pic_sym sym) -{ - codegen_context *cxt = state->cxt; - size_t i, offset; - pic_sym *var; - - offset = 1; - for (i = 0; i < cxt->args.size; ++i) { - var = xv_get(&cxt->args, i); - if (*var == sym) - return i + offset; - } - offset += i; - for (i = 0; i < cxt->locals.size; ++i) { - var = xv_get(&cxt->locals, i); - if (*var == sym) - return i + offset; - } - return -1; -} - -static struct pic_irep *codegen_lambda(codegen_state *, pic_value); - -static void -codegen(codegen_state *state, pic_value obj) -{ - pic_state *pic = state->pic; - codegen_context *cxt = state->cxt; - pic_sym sym; - - sym = pic_sym(pic_car(pic, obj)); - if (sym == state->sGREF) { - cxt->code[cxt->clen].insn = OP_GREF; - cxt->code[cxt->clen].u.i = pic_sym(pic_list_ref(pic, obj, 1)); - cxt->clen++; - return; - } else if (sym == state->sCREF) { - pic_sym name; - int depth; - - depth = pic_int(pic_list_ref(pic, obj, 1)); - name = pic_sym(pic_list_ref(pic, obj, 2)); - cxt->code[cxt->clen].insn = OP_CREF; - cxt->code[cxt->clen].u.r.depth = depth; - cxt->code[cxt->clen].u.r.idx = index_capture(state, name, depth); - cxt->clen++; - return; - } else if (sym == state->sLREF) { - pic_sym name; - int i; - - name = pic_sym(pic_list_ref(pic, obj, 1)); - if ((i = index_capture(state, name, 0)) != -1) { - cxt->code[cxt->clen].insn = OP_LREF; - cxt->code[cxt->clen].u.i = i + cxt->args.size + cxt->locals.size + 1; - cxt->clen++; - return; - } - cxt->code[cxt->clen].insn = OP_LREF; - cxt->code[cxt->clen].u.i = index_local(state, name); - cxt->clen++; - return; - } else if (sym == pic->sSETBANG) { - pic_value var, val; - pic_sym type; - - val = pic_list_ref(pic, obj, 2); - codegen(state, val); - - var = pic_list_ref(pic, obj, 1); - type = pic_sym(pic_list_ref(pic, var, 0)); - if (type == state->sGREF) { - cxt->code[cxt->clen].insn = OP_GSET; - cxt->code[cxt->clen].u.i = pic_int(pic_list_ref(pic, var, 1)); - cxt->clen++; - cxt->code[cxt->clen].insn = OP_PUSHNONE; - cxt->clen++; - return; - } - else if (type == state->sCREF) { - pic_sym name; - int depth; - - depth = pic_int(pic_list_ref(pic, var, 1)); - name = pic_sym(pic_list_ref(pic, var, 2)); - cxt->code[cxt->clen].insn = OP_CSET; - cxt->code[cxt->clen].u.r.depth = depth; - cxt->code[cxt->clen].u.r.idx = index_capture(state, name, depth); - cxt->clen++; - cxt->code[cxt->clen].insn = OP_PUSHNONE; - cxt->clen++; - return; - } - else if (type == state->sLREF) { - pic_sym name; - int i; - - name = pic_sym(pic_list_ref(pic, var, 1)); - if ((i = index_capture(state, name, 0)) != -1) { - cxt->code[cxt->clen].insn = OP_LSET; - cxt->code[cxt->clen].u.i = i + cxt->args.size + cxt->locals.size + 1; - cxt->clen++; - cxt->code[cxt->clen].insn = OP_PUSHNONE; - cxt->clen++; - return; - } - cxt->code[cxt->clen].insn = OP_LSET; - cxt->code[cxt->clen].u.i = index_local(state, name); - cxt->clen++; - cxt->code[cxt->clen].insn = OP_PUSHNONE; - cxt->clen++; - return; - } - } - else if (sym == pic->sLAMBDA) { - int k; - - if (cxt->ilen >= cxt->icapa) { - cxt->icapa *= 2; - cxt->irep = pic_realloc(pic, cxt->irep, sizeof(struct pic_irep *) * cxt->icapa); - } - k = cxt->ilen++; - cxt->code[cxt->clen].insn = OP_LAMBDA; - cxt->code[cxt->clen].u.i = k; - cxt->clen++; - - cxt->irep[k] = codegen_lambda(state, obj); - return; - } - else if (sym == pic->sIF) { - int s, t; - - codegen(state, pic_list_ref(pic, obj, 1)); - - cxt->code[cxt->clen].insn = OP_JMPIF; - s = cxt->clen++; - - /* if false branch */ - codegen(state, pic_list_ref(pic, obj, 3)); - cxt->code[cxt->clen].insn = OP_JMP; - t = cxt->clen++; - - cxt->code[s].u.i = cxt->clen - s; - - /* if true branch */ - codegen(state, pic_list_ref(pic, obj, 2)); - cxt->code[t].u.i = cxt->clen - t; - return; - } - else if (sym == pic->sBEGIN) { - pic_value elt; - int i = 0; - - pic_for_each (elt, pic_cdr(pic, obj)) { - if (i++ != 0) { - cxt->code[cxt->clen].insn = OP_POP; - cxt->clen++; - } - codegen(state, elt); - } - return; - } - else if (sym == pic->sQUOTE) { - int pidx; - - obj = pic_list_ref(pic, obj, 1); - switch (pic_type(obj)) { - case PIC_TT_BOOL: - if (pic_true_p(obj)) { - cxt->code[cxt->clen].insn = OP_PUSHTRUE; - } else { - cxt->code[cxt->clen].insn = OP_PUSHFALSE; - } - cxt->clen++; - return; - case PIC_TT_INT: - cxt->code[cxt->clen].insn = OP_PUSHINT; - cxt->code[cxt->clen].u.i = pic_int(obj); - cxt->clen++; - return; - case PIC_TT_NIL: - cxt->code[cxt->clen].insn = OP_PUSHNIL; - cxt->clen++; - return; - case PIC_TT_CHAR: - cxt->code[cxt->clen].insn = OP_PUSHCHAR; - cxt->code[cxt->clen].u.c = pic_char(obj); - cxt->clen++; - return; - default: - if (cxt->plen >= cxt->pcapa) { - cxt->pcapa *= 2; - cxt->pool = pic_realloc(pic, cxt->pool, sizeof(pic_value) * cxt->pcapa); - } - pidx = cxt->plen++; - cxt->pool[pidx] = obj; - cxt->code[cxt->clen].insn = OP_PUSHCONST; - cxt->code[cxt->clen].u.i = pidx; - cxt->clen++; - return; - } - } - else if (sym == pic->sCONS) { - codegen(state, pic_list_ref(pic, obj, 1)); - codegen(state, pic_list_ref(pic, obj, 2)); - cxt->code[cxt->clen].insn = OP_CONS; - cxt->clen++; - return; - } - else if (sym == pic->sCAR) { - codegen(state, pic_list_ref(pic, obj, 1)); - cxt->code[cxt->clen].insn = OP_CAR; - cxt->clen++; - return; - } - else if (sym == pic->sCDR) { - codegen(state, pic_list_ref(pic, obj, 1)); - cxt->code[cxt->clen].insn = OP_CDR; - cxt->clen++; - return; - } - else if (sym == pic->sNILP) { - codegen(state, pic_list_ref(pic, obj, 1)); - cxt->code[cxt->clen].insn = OP_NILP; - cxt->clen++; - return; - } - else if (sym == pic->sADD) { - codegen(state, pic_list_ref(pic, obj, 1)); - codegen(state, pic_list_ref(pic, obj, 2)); - cxt->code[cxt->clen].insn = OP_ADD; - cxt->clen++; - return; - } - else if (sym == pic->sSUB) { - codegen(state, pic_list_ref(pic, obj, 1)); - codegen(state, pic_list_ref(pic, obj, 2)); - cxt->code[cxt->clen].insn = OP_SUB; - cxt->clen++; - return; - } - else if (sym == pic->sMUL) { - codegen(state, pic_list_ref(pic, obj, 1)); - codegen(state, pic_list_ref(pic, obj, 2)); - cxt->code[cxt->clen].insn = OP_MUL; - cxt->clen++; - return; - } - else if (sym == pic->sDIV) { - codegen(state, pic_list_ref(pic, obj, 1)); - codegen(state, pic_list_ref(pic, obj, 2)); - cxt->code[cxt->clen].insn = OP_DIV; - cxt->clen++; - return; - } - else if (sym == pic->sMINUS) { - codegen(state, pic_list_ref(pic, obj, 1)); - cxt->code[cxt->clen].insn = OP_MINUS; - cxt->clen++; - return; - } - else if (sym == pic->sEQ) { - codegen(state, pic_list_ref(pic, obj, 1)); - codegen(state, pic_list_ref(pic, obj, 2)); - cxt->code[cxt->clen].insn = OP_EQ; - cxt->clen++; - return; - } - else if (sym == pic->sLT) { - codegen(state, pic_list_ref(pic, obj, 1)); - codegen(state, pic_list_ref(pic, obj, 2)); - cxt->code[cxt->clen].insn = OP_LT; - cxt->clen++; - return; - } - else if (sym == pic->sLE) { - codegen(state, pic_list_ref(pic, obj, 1)); - codegen(state, pic_list_ref(pic, obj, 2)); - cxt->code[cxt->clen].insn = OP_LE; - cxt->clen++; - return; - } - else if (sym == pic->sGT) { - codegen(state, pic_list_ref(pic, obj, 2)); - codegen(state, pic_list_ref(pic, obj, 1)); - cxt->code[cxt->clen].insn = OP_LT; - cxt->clen++; - return; - } - else if (sym == pic->sGE) { - codegen(state, pic_list_ref(pic, obj, 2)); - codegen(state, pic_list_ref(pic, obj, 1)); - cxt->code[cxt->clen].insn = OP_LE; - cxt->clen++; - return; - } - else if (sym == pic->sNOT) { - codegen(state, pic_list_ref(pic, obj, 1)); - cxt->code[cxt->clen].insn = OP_NOT; - cxt->clen++; - return; - } - else if (sym == state->sCALL || sym == state->sTAILCALL) { - int len = pic_length(pic, obj); - pic_value elt; - - pic_for_each (elt, pic_cdr(pic, obj)) { - codegen(state, elt); - } - cxt->code[cxt->clen].insn = (sym == state->sCALL) ? OP_CALL : OP_TAILCALL; - cxt->code[cxt->clen].u.i = len - 1; - cxt->clen++; - return; - } - else if (sym == state->sCALL_WITH_VALUES || sym == state->sTAILCALL_WITH_VALUES) { - /* stack consumer at first */ - codegen(state, pic_list_ref(pic, obj, 2)); - codegen(state, pic_list_ref(pic, obj, 1)); - /* call producer */ - cxt->code[cxt->clen].insn = OP_CALL; - cxt->code[cxt->clen].u.i = 1; - cxt->clen++; - /* call consumer */ - cxt->code[cxt->clen].insn = (sym == state->sCALL_WITH_VALUES) ? OP_CALL : OP_TAILCALL; - cxt->code[cxt->clen].u.i = -1; - cxt->clen++; - return; - } - else if (sym == state->sRETURN) { - int len = pic_length(pic, obj); - pic_value elt; - - pic_for_each (elt, pic_cdr(pic, obj)) { - codegen(state, elt); - } - cxt->code[cxt->clen].insn = OP_RET; - cxt->code[cxt->clen].u.i = len - 1; - cxt->clen++; - return; - } - pic_error(pic, "codegen: unknown AST type"); -} - -static struct pic_irep * -codegen_lambda(codegen_state *state, pic_value obj) -{ - pic_state *pic = state->pic; - pic_value name, args, locals, closes, body; - bool varg; - - name = pic_list_ref(pic, obj, 1); - args = pic_list_ref(pic, obj, 2); - locals = pic_list_ref(pic, obj, 3); - varg = pic_true_p(pic_list_ref(pic, obj, 4)); - closes = pic_list_ref(pic, obj, 5); - body = pic_list_ref(pic, obj, 6); - - /* inner environment */ - push_codegen_context(state, name, args, locals, varg, closes); - { - /* body */ - codegen(state, body); - } - return pop_codegen_context(state); -} - -struct pic_irep * -pic_codegen(pic_state *pic, pic_value obj) -{ - codegen_state *state; - - state = new_codegen_state(pic); - - codegen(state, obj); - - return destroy_codegen_state(state); -} - -struct pic_proc * -pic_compile(pic_state *pic, pic_value obj, struct pic_lib *lib) -{ - struct pic_irep *irep; - size_t ai = pic_gc_arena_preserve(pic); - -#if DEBUG - fprintf(stdout, "ai = %zu\n", pic_gc_arena_preserve(pic)); - - fprintf(stdout, "# input expression\n"); - pic_debug(pic, obj); - fprintf(stdout, "\n"); - - fprintf(stdout, "ai = %zu\n", pic_gc_arena_preserve(pic)); -#endif - - /* macroexpand */ - obj = pic_macroexpand(pic, obj, lib); -#if DEBUG - fprintf(stdout, "## macroexpand completed\n"); - pic_debug(pic, obj); - fprintf(stdout, "\n"); - fprintf(stdout, "ai = %zu\n", pic_gc_arena_preserve(pic)); -#endif - - /* analyze */ - obj = pic_analyze(pic, obj); -#if DEBUG - fprintf(stdout, "## analyzer completed\n"); - pic_debug(pic, obj); - fprintf(stdout, "\n"); - fprintf(stdout, "ai = %zu\n", pic_gc_arena_preserve(pic)); -#endif - - /* codegen */ - irep = pic_codegen(pic, obj); -#if DEBUG - fprintf(stdout, "## codegen completed\n"); - pic_dump_irep(irep); -#endif - -#if DEBUG - fprintf(stdout, "# compilation finished\n"); - puts(""); -#endif - - pic_gc_arena_restore(pic, ai); - pic_gc_protect(pic, pic_obj_value(irep)); - - return pic_proc_new_irep(pic, irep, NULL); -} diff --git a/src/cont.c b/src/cont.c deleted file mode 100644 index 6839c586..00000000 --- a/src/cont.c +++ /dev/null @@ -1,371 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#include -#include -#include - -#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, ""); - - /* 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, ""); - - /* 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); -} diff --git a/src/data.c b/src/data.c deleted file mode 100644 index 5d586c56..00000000 --- a/src/data.c +++ /dev/null @@ -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; -} diff --git a/src/debug.c b/src/debug.c deleted file mode 100644 index f59a4125..00000000 --- a/src/debug.c +++ /dev/null @@ -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); -} diff --git a/src/dict.c b/src/dict.c deleted file mode 100644 index 3c2a5964..00000000 --- a/src/dict.c +++ /dev/null @@ -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); - } -} diff --git a/src/error.c b/src/error.c deleted file mode 100644 index f4d46f5e..00000000 --- a/src/error.c +++ /dev/null @@ -1,286 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#include -#include -#include - -#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); -} diff --git a/src/eval.c b/src/eval.c deleted file mode 100644 index 5a037c94..00000000 --- a/src/eval.c +++ /dev/null @@ -1,39 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#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) -{ - pic_value program, spec; - struct pic_lib *lib; - - pic_get_args(pic, "oo", &program, &spec); - - lib = pic_find_library(pic, spec); - if (lib == NULL) { - pic_errorf(pic, "no library found: ~s", spec); - } - return pic_eval(pic, program, lib); -} - -void -pic_init_eval(pic_state *pic) -{ - pic_deflibrary (pic, "(scheme eval)") { - pic_defun(pic, "eval", pic_eval_eval); - } -} diff --git a/src/file.c b/src/file.c deleted file mode 100644 index befac195..00000000 --- a/src/file.c +++ /dev/null @@ -1,119 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#include "picrin.h" -#include "picrin/port.h" -#include "picrin/error.h" - -static noreturn void -file_error(pic_state *pic, const char *msg) -{ - pic_throw(pic, PIC_ERROR_FILE, msg, pic_nil_value()); -} - -static pic_value -generic_open_file(pic_state *pic, const char *fname, char *mode, short flags) -{ - struct pic_port *port; - xFILE *file; - - file = xfopen(fname, mode); - if (! file) { - file_error(pic, "could not open file"); - } - - port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port), PIC_TT_PORT); - port->file = file; - port->flags = flags; - port->status = PIC_PORT_OPEN; - - return pic_obj_value(port); -} - -pic_value -pic_file_open_input_file(pic_state *pic) -{ - static const short flags = PIC_PORT_IN | PIC_PORT_TEXT; - char *fname; - - pic_get_args(pic, "z", &fname); - - return generic_open_file(pic, fname, "r", flags); -} - -pic_value -pic_file_open_input_binary_file(pic_state *pic) -{ - static const short flags = PIC_PORT_IN | PIC_PORT_BINARY; - char *fname; - - pic_get_args(pic, "z", &fname); - - return generic_open_file(pic, fname, "rb", flags); -} - -pic_value -pic_file_open_output_file(pic_state *pic) -{ - static const short flags = PIC_PORT_OUT | PIC_PORT_TEXT; - char *fname; - - pic_get_args(pic, "z", &fname); - - return generic_open_file(pic, fname, "w", flags); -} - -pic_value -pic_file_open_output_binary_file(pic_state *pic) -{ - static const short flags = PIC_PORT_OUT | PIC_PORT_BINARY; - char *fname; - - pic_get_args(pic, "z", &fname); - - return generic_open_file(pic, fname, "wb", flags); -} - -pic_value -pic_file_exists_p(pic_state *pic) -{ - char *fname; - FILE *fp; - - pic_get_args(pic, "z", &fname); - - fp = fopen(fname, "r"); - if (fp) { - fclose(fp); - return pic_true_value(); - } else { - return pic_false_value(); - } -} - -pic_value -pic_file_delete(pic_state *pic) -{ - char *fname; - - pic_get_args(pic, "z", &fname); - - if (remove(fname) != 0) { - file_error(pic, "file cannot be deleted"); - } - return pic_none_value(); -} - -void -pic_init_file(pic_state *pic) -{ - pic_deflibrary (pic, "(scheme file)") { - pic_defun(pic, "open-input-file", pic_file_open_input_file); - pic_defun(pic, "open-input-binary-file", pic_file_open_input_binary_file); - pic_defun(pic, "open-output-file", pic_file_open_output_file); - pic_defun(pic, "open-output-binary-file", pic_file_open_output_binary_file); - pic_defun(pic, "file-exists?", pic_file_exists_p); - pic_defun(pic, "delete-file", pic_file_delete); - } -} diff --git a/src/gc.c b/src/gc.c deleted file mode 100644 index 9a947837..00000000 --- a/src/gc.c +++ /dev/null @@ -1,872 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#include - -#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 -#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; -} diff --git a/src/init.c b/src/init.c deleted file mode 100644 index 7f869048..00000000 --- a/src/init.c +++ /dev/null @@ -1,125 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#include - -#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) -{ - pic_value features = pic_nil_value(); - - pic_get_args(pic, ""); - - pic_push(pic, pic_sym_value(pic_intern_cstr(pic, "r7rs")), features); - pic_push(pic, pic_sym_value(pic_intern_cstr(pic, "ieee-float")), features); - pic_push(pic, pic_sym_value(pic_intern_cstr(pic, "picrin")), features); - - return features; -} - -static pic_value -pic_libraries(pic_state *pic) -{ - pic_value libs = pic_nil_value(), lib; - - pic_get_args(pic, ""); - - pic_for_each (lib, pic->libs) { - libs = pic_cons(pic, pic_car(pic, lib), libs); - } - - 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) -{ - 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; - } -} diff --git a/src/lib.c b/src/lib.c deleted file mode 100644 index 45351083..00000000 --- a/src/lib.c +++ /dev/null @@ -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); -} diff --git a/src/load.c b/src/load.c deleted file mode 100644 index 440b45e2..00000000 --- a/src/load.c +++ /dev/null @@ -1,87 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#include "picrin.h" -#include "picrin/pair.h" - -pic_value -pic_load_cstr(pic_state *pic, const char *src) -{ - size_t ai; - pic_value v, exprs; - struct pic_proc *proc; - - exprs = pic_parse_cstr(pic, src); - if (pic_undef_p(exprs)) { - pic_errorf(pic, "load: read failure (%s)", pic_errmsg(pic)); - } - - pic_for_each (v, exprs) { - ai = pic_gc_arena_preserve(pic); - - proc = pic_compile(pic, v, pic->lib); - if (proc == NULL) { - pic_error(pic, "load: compilation failure"); - } - - pic_apply(pic, proc, pic_nil_value()); - - pic_gc_arena_restore(pic, ai); - } - - return pic_none_value(); -} - -pic_value -pic_load(pic_state *pic, const char *fn) -{ - FILE *file; - size_t ai; - pic_value v, exprs; - struct pic_proc *proc; - - file = fopen(fn, "r"); - if (file == NULL) { - pic_errorf(pic, "load: could not read file \"%s\"", fn); - } - - exprs = pic_parse_file(pic, file); - if (pic_undef_p(exprs)) { - pic_errorf(pic, "load: read failure (%s)", pic_errmsg(pic)); - } - - pic_for_each (v, exprs) { - ai = pic_gc_arena_preserve(pic); - - proc = pic_compile(pic, v, pic->lib); - if (proc == NULL) { - pic_error(pic, "load: compilation failure"); - } - - pic_apply(pic, proc, pic_nil_value()); - - pic_gc_arena_restore(pic, ai); - } - - return pic_none_value(); -} - -static pic_value -pic_load_load(pic_state *pic) -{ - pic_value envid; - char *fn; - - pic_get_args(pic, "z|o", &fn, &envid); - - return pic_load(pic, fn); -} - -void -pic_init_load(pic_state *pic) -{ - pic_deflibrary (pic, "(scheme load)") { - pic_defun(pic, "load", pic_load_load); - } -} diff --git a/src/macro.c b/src/macro.c deleted file mode 100644 index e9c9b64b..00000000 --- a/src/macro.c +++ /dev/null @@ -1,494 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#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) -{ - static const char skel[] = ".g"; - pic_sym uniq; - - pic_get_args(pic, ""); - - uniq = pic_gensym(pic, pic_intern_cstr(pic, skel)); - return pic_sym_value(uniq); -} - -static pic_value -pic_macro_ungensym(pic_state *pic) -{ - pic_sym sym; - - pic_get_args(pic, "m", &sym); - - return pic_sym_value(pic_ungensym(pic, sym)); -} - -static pic_value -pic_macro_macroexpand(pic_state *pic) -{ - pic_value expr; - - pic_get_args(pic, "o", &expr); - - 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_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); - } -} diff --git a/src/main.c b/src/main.c new file mode 100644 index 00000000..33eb7cf4 --- /dev/null +++ b/src/main.c @@ -0,0 +1,77 @@ +/** + * See Copyright Notice in picrin.h + */ + +#include "picrin.h" +#include "picrin/pair.h" +#include "picrin/error.h" + +void pic_init_contrib(pic_state *); +void pic_load_piclib(pic_state *); + +static pic_value +pic_features(pic_state *pic) +{ + pic_value features = pic_nil_value(); + + pic_get_args(pic, ""); + + pic_push(pic, pic_sym_value(pic_intern_cstr(pic, "r7rs")), features); + pic_push(pic, pic_sym_value(pic_intern_cstr(pic, "ieee-float")), features); + pic_push(pic, pic_sym_value(pic_intern_cstr(pic, "picrin")), features); + + return features; +} + +static pic_value +pic_libraries(pic_state *pic) +{ + pic_value libs = pic_nil_value(), lib; + + pic_get_args(pic, ""); + + pic_for_each (lib, pic->libs) { + libs = pic_cons(pic, pic_car(pic, lib), libs); + } + + return libs; +} + +void +pic_init_picrin(pic_state *pic) +{ + pic_deflibrary (pic, "(picrin library)") { + pic_defun(pic, "libraries", pic_libraries); + } + + pic_deflibrary (pic, "(scheme base)") { + pic_defun(pic, "features", pic_features); + + pic_init_contrib(pic); + pic_load_piclib(pic); + } +} + +int +main(int argc, char *argv[], char **envp) +{ + pic_state *pic; + int status = 0; + + pic = pic_open(argc, argv, envp); + + pic_init_picrin(pic); + + pic_try { + pic_import(pic, pic_read_cstr(pic, "(picrin main)")); + pic_funcall(pic, "main", pic_nil_value()); + } + pic_catch { + pic_print_backtrace(pic, pic->err); + status = 1; + } + + pic_close(pic); + + return status; +} diff --git a/src/number.c b/src/number.c deleted file mode 100644 index ed6ce95c..00000000 --- a/src/number.c +++ /dev/null @@ -1,944 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#include -#include -#include - -#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); - } -} diff --git a/src/pair.c b/src/pair.c deleted file mode 100644 index 5b62ceaf..00000000 --- a/src/pair.c +++ /dev/null @@ -1,767 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#include - -#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); - } -} diff --git a/src/port.c b/src/port.c deleted file mode 100644 index b9790d06..00000000 --- a/src/port.c +++ /dev/null @@ -1,749 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#include -#include -#include - -#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); -} diff --git a/src/proc.c b/src/proc.c deleted file mode 100644 index 889a621d..00000000 --- a/src/proc.c +++ /dev/null @@ -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); - } -} diff --git a/src/read.c b/src/read.c deleted file mode 100644 index 2eb12829..00000000 --- a/src/read.c +++ /dev/null @@ -1,976 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#include -#include -#include -#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); - } -} diff --git a/src/record.c b/src/record.c deleted file mode 100644 index d62776ca..00000000 --- a/src/record.c +++ /dev/null @@ -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); - } -} diff --git a/src/state.c b/src/state.c deleted file mode 100644 index d9427f3d..00000000 --- a/src/state.c +++ /dev/null @@ -1,205 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#include - -#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); -} diff --git a/src/string.c b/src/string.c deleted file mode 100644 index ab679f50..00000000 --- a/src/string.c +++ /dev/null @@ -1,424 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#include - -#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_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); -} diff --git a/src/symbol.c b/src/symbol.c deleted file mode 100644 index 2add0769..00000000 --- a/src/symbol.c +++ /dev/null @@ -1,161 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#include -#include -#include - -#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); - } -} diff --git a/src/system.c b/src/system.c deleted file mode 100644 index 20203d27..00000000 --- a/src/system.c +++ /dev/null @@ -1,136 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#include - -#include "picrin.h" -#include "picrin/string.h" -#include "picrin/pair.h" -#include "picrin/cont.h" - -static pic_value -pic_system_cmdline(pic_state *pic) -{ - pic_value v = pic_nil_value(); - int i; - - pic_get_args(pic, ""); - - for (i = 0; i < pic->argc; ++i) { - size_t ai = pic_gc_arena_preserve(pic); - - v = pic_cons(pic, pic_obj_value(pic_str_new_cstr(pic, pic->argv[i])), v); - pic_gc_arena_restore(pic, ai); - } - - return pic_reverse(pic, v); -} - -static pic_value -pic_system_exit(pic_state *pic) -{ - pic_value v; - int argc, status = EXIT_SUCCESS; - - argc = pic_get_args(pic, "|o", &v); - if (argc == 1) { - switch (pic_type(v)) { - case PIC_TT_FLOAT: - status = (int)pic_float(v); - break; - case PIC_TT_INT: - status = pic_int(v); - break; - default: - break; - } - } - - pic_close(pic); - - exit(status); -} - -static pic_value -pic_system_emergency_exit(pic_state *pic) -{ - pic_value v; - int argc, status = EXIT_FAILURE; - - argc = pic_get_args(pic, "|o", &v); - if (argc == 1) { - switch (pic_type(v)) { - case PIC_TT_FLOAT: - status = (int)pic_float(v); - break; - case PIC_TT_INT: - status = pic_int(v); - break; - default: - break; - } - } - - _Exit(status); -} - -static pic_value -pic_system_getenv(pic_state *pic) -{ - char *str, *val; - - pic_get_args(pic, "z", &str); - - val = getenv(str); - - if (val == NULL) - return pic_nil_value(); - else - return pic_obj_value(pic_str_new_cstr(pic, val)); -} - -static pic_value -pic_system_getenvs(pic_state *pic) -{ - char **envp; - pic_value data = pic_nil_value(); - size_t ai = pic_gc_arena_preserve(pic); - - pic_get_args(pic, ""); - - if (! pic->envp) { - return pic_nil_value(); - } - - for (envp = pic->envp; *envp; ++envp) { - pic_str *key, *val; - int i; - - for (i = 0; (*envp)[i] != '='; ++i) - ; - - key = pic_str_new(pic, *envp, i); - val = pic_str_new_cstr(pic, getenv(pic_str_cstr(key))); - - /* push */ - data = pic_acons(pic, pic_obj_value(key), pic_obj_value(val), data); - - pic_gc_arena_restore(pic, ai); - pic_gc_protect(pic, data); - } - - return data; -} - -void -pic_init_system(pic_state *pic) -{ - pic_deflibrary (pic, "(scheme process-context)") { - pic_defun(pic, "command-line", pic_system_cmdline); - pic_defun(pic, "exit", pic_system_exit); - pic_defun(pic, "emergency-exit", pic_system_emergency_exit); - pic_defun(pic, "get-environment-variable", pic_system_getenv); - pic_defun(pic, "get-environment-variables", pic_system_getenvs); - } -} diff --git a/src/time.c b/src/time.c deleted file mode 100644 index 8e42dc8e..00000000 --- a/src/time.c +++ /dev/null @@ -1,49 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#include - -#include "picrin.h" - -#define UTC_TAI_DIFF 35 - -static pic_value -pic_current_second(pic_state *pic) -{ - time_t t; - - pic_get_args(pic, ""); - - time(&t); - return pic_float_value((double)t + UTC_TAI_DIFF); -} - -static pic_value -pic_current_jiffy(pic_state *pic) -{ - clock_t c; - - pic_get_args(pic, ""); - - c = clock(); - return pic_int_value(c); -} - -static pic_value -pic_jiffies_per_second(pic_state *pic) -{ - pic_get_args(pic, ""); - - return pic_int_value(CLOCKS_PER_SEC); -} - -void -pic_init_time(pic_state *pic) -{ - pic_deflibrary (pic, "(scheme time)") { - pic_defun(pic, "current-second", pic_current_second); - pic_defun(pic, "current-jiffy", pic_current_jiffy); - pic_defun(pic, "jiffies-per-second", pic_jiffies_per_second); - } -} diff --git a/src/var.c b/src/var.c deleted file mode 100644 index a5836797..00000000 --- a/src/var.c +++ /dev/null @@ -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); - } -} diff --git a/src/vector.c b/src/vector.c deleted file mode 100644 index d57214e7..00000000 --- a/src/vector.c +++ /dev/null @@ -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); -} diff --git a/src/vm.c b/src/vm.c deleted file mode 100644 index 2fcd74fc..00000000 --- a/src/vm.c +++ /dev/null @@ -1,1069 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#include -#include -#include -#include - -#include "picrin.h" -#include "picrin/pair.h" -#include "picrin/string.h" -#include "picrin/vector.h" -#include "picrin/proc.h" -#include "picrin/port.h" -#include "picrin/irep.h" -#include "picrin/blob.h" -#include "picrin/var.h" -#include "picrin/lib.h" -#include "picrin/macro.h" -#include "picrin/error.h" -#include "picrin/dict.h" -#include "picrin/record.h" - -#define GET_OPERAND(pic,n) ((pic)->ci->fp[(n)]) - -struct pic_proc * -pic_get_proc(pic_state *pic) -{ - pic_value v = GET_OPERAND(pic,0); - - if (! pic_proc_p(v)) { - pic_error(pic, "fatal error"); - } - return pic_proc_ptr(v); -} - -/** - * char type - * ---- ---- - * o object - * i int - * I int with exactness - * f float - * F float with exactness - * s string object - * z c string - * m symbol - * v vector object - * b bytevector object - * c char - * l lambda object - * p port object - * d dictionary object - * e error object - * - * | optional operator - * * variable length operator - */ - -int -pic_get_args(pic_state *pic, const char *format, ...) -{ - char c; - int i = 1, argc = pic->ci->argc; - va_list ap; - bool opt = false; - - va_start(ap, format); - while ((c = *format++)) { - switch (c) { - default: - if (argc <= i && ! opt) { - pic_error(pic, "wrong number of arguments"); - } - break; - case '|': - break; - case '*': - break; - } - - /* in order to run out of all arguments passed to this function - (i.e. do va_arg for each argument), optional argument existence - check is done in every case closure */ - - if (c == '*') - break; - - switch (c) { - case '|': - opt = true; - break; - case 'o': { - pic_value *p; - - p = va_arg(ap, pic_value*); - if (i < argc) { - *p = GET_OPERAND(pic,i); - i++; - } - break; - } - case 'f': { - double *f; - - f = va_arg(ap, double *); - if (i < argc) { - pic_value v; - - v = GET_OPERAND(pic, i); - switch (pic_type(v)) { - case PIC_TT_FLOAT: - *f = pic_float(v); - break; - case PIC_TT_INT: - *f = pic_int(v); - break; - default: - pic_errorf(pic, "pic_get_args: expected float or int, but got ~s", v); - } - i++; - } - break; - } - case 'F': { - double *f; - bool *e; - - f = va_arg(ap, double *); - e = va_arg(ap, bool *); - if (i < argc) { - pic_value v; - - v = GET_OPERAND(pic, i); - switch (pic_type(v)) { - case PIC_TT_FLOAT: - *f = pic_float(v); - *e = false; - break; - case PIC_TT_INT: - *f = pic_int(v); - *e = true; - break; - default: - pic_errorf(pic, "pic_get_args: expected float or int, but got ~s", v); - } - i++; - } - break; - } - case 'I': { - int *k; - bool *e; - - k = va_arg(ap, int *); - e = va_arg(ap, bool *); - if (i < argc) { - pic_value v; - - v = GET_OPERAND(pic, i); - switch (pic_type(v)) { - case PIC_TT_FLOAT: - *k = (int)pic_float(v); - *e = false; - break; - case PIC_TT_INT: - *k = pic_int(v); - *e = true; - break; - default: - pic_errorf(pic, "pic_get_args: expected float or int, but got ~s", v); - } - i++; - } - break; - } - case 'i': { - int *k; - - k = va_arg(ap, int *); - if (i < argc) { - pic_value v; - - v = GET_OPERAND(pic, i); - switch (pic_type(v)) { - case PIC_TT_FLOAT: - *k = (int)pic_float(v); - break; - case PIC_TT_INT: - *k = pic_int(v); - break; - default: - pic_errorf(pic, "pic_get_args: expected int, but got ~s", v); - } - i++; - } - break; - } - case 's': { - pic_str **str; - pic_value v; - - str = va_arg(ap, pic_str **); - if (i < argc) { - v = GET_OPERAND(pic,i); - if (pic_str_p(v)) { - *str = pic_str_ptr(v); - } - else { - pic_errorf(pic, "pic_get_args: expected string, but got ~s", v); - } - i++; - } - break; - } - case 'z': { - const char **cstr; - pic_value v; - - cstr = va_arg(ap, const char **); - if (i < argc) { - v = GET_OPERAND(pic,i); - if (! pic_str_p(v)) { - pic_errorf(pic, "pic_get_args: expected string, but got ~s", v); - } - *cstr = pic_str_cstr(pic_str_ptr(v)); - i++; - } - break; - } - case 'm': { - pic_sym *m; - pic_value v; - - m = va_arg(ap, pic_sym *); - if (i < argc) { - v = GET_OPERAND(pic,i); - if (pic_sym_p(v)) { - *m = pic_sym(v); - } - else { - pic_errorf(pic, "pic_get_args: expected symbol, but got ~s", v); - } - i++; - } - break; - } - case 'v': { - struct pic_vector **vec; - pic_value v; - - vec = va_arg(ap, struct pic_vector **); - if (i < argc) { - v = GET_OPERAND(pic,i); - if (pic_vec_p(v)) { - *vec = pic_vec_ptr(v); - } - else { - pic_errorf(pic, "pic_get_args: expected vector, but got ~s", v); - } - i++; - } - break; - } - case 'b': { - struct pic_blob **b; - pic_value v; - - b = va_arg(ap, struct pic_blob **); - if (i < argc) { - v = GET_OPERAND(pic,i); - if (pic_blob_p(v)) { - *b = pic_blob_ptr(v); - } - else { - pic_errorf(pic, "pic_get_args: expected bytevector, but got ~s", v); - } - i++; - } - break; - } - case 'c': { - char *c; - pic_value v; - - c = va_arg(ap, char *); - if (i < argc) { - v = GET_OPERAND(pic,i); - if (pic_char_p(v)) { - *c = pic_char(v); - } - else { - pic_errorf(pic, "pic_get_args: expected char, but got ~s", v); - } - i++; - } - break; - } - case 'l': { - struct pic_proc **l; - pic_value v; - - l = va_arg(ap, struct pic_proc **); - if (i < argc) { - v = GET_OPERAND(pic,i); - if (pic_proc_p(v)) { - *l = pic_proc_ptr(v); - } - else { - pic_errorf(pic, "pic_get_args, expected procedure, but got ~s", v); - } - i++; - } - break; - } - case 'p': { - struct pic_port **p; - pic_value v; - - p = va_arg(ap, struct pic_port **); - if (i < argc) { - v = GET_OPERAND(pic,i); - if (pic_port_p(v)) { - *p = pic_port_ptr(v); - } - else { - pic_errorf(pic, "pic_get_args, expected port, but got ~s", v); - } - i++; - } - break; - } - case 'd': { - struct pic_dict **d; - pic_value v; - - d = va_arg(ap, struct pic_dict **); - if (i < argc) { - v = GET_OPERAND(pic,i); - if (pic_dict_p(v)) { - *d = pic_dict_ptr(v); - } - else { - pic_errorf(pic, "pic_get_args, expected dictionary, but got ~s", v); - } - i++; - } - break; - } - case 'r': { - struct pic_record **r; - pic_value v; - - r = va_arg(ap, struct pic_record **); - if (i < argc) { - v = GET_OPERAND(pic,i); - if (pic_record_p(v)) { - *r = pic_record_ptr(v); - } - else { - pic_errorf(pic, "pic_get_args: expected record, but got ~s", v); - } - i++; - } - break; - } - case 'e': { - struct pic_error **e; - pic_value v; - - e = va_arg(ap, struct pic_error **); - if (i < argc) { - v = GET_OPERAND(pic,i); - if (pic_error_p(v)) { - *e = pic_error_ptr(v); - } - else { - pic_error(pic, "pic_get_args, expected error"); - } - i++; - } - break; - } - default: - pic_errorf(pic, "pic_get_args: invalid argument specifier '%c' given", c); - } - } - if ('*' == c) { - size_t *n; - pic_value **argv; - - n = va_arg(ap, size_t *); - argv = va_arg(ap, pic_value **); - if (i <= argc) { - *n = argc - i; - *argv = &GET_OPERAND(pic, i); - i = argc; - } - } - else if (argc > i) { - pic_error(pic, "wrong number of arguments"); - } - va_end(ap); - return i - 1; -} - -void -pic_define(pic_state *pic, const char *name, pic_value val) -{ - pic_sym sym, rename; - - sym = pic_intern_cstr(pic, name); - - if (! pic_find_rename(pic, pic->lib->env, sym, &rename)) { - rename = pic_add_rename(pic, pic->lib->env, sym); - } else { - pic_warn(pic, "redefining global"); - } - - /* push to the global arena */ - xh_put_int(&pic->globals, rename, &val); - - /* export! */ - pic_export(pic, sym); -} - -pic_value -pic_ref(pic_state *pic, const char *name) -{ - pic_sym sym, rename; - - sym = pic_intern_cstr(pic, name); - - if (! pic_find_rename(pic, pic->lib->env, sym, &rename)) { - pic_errorf(pic, "symbol \"%s\" not defined", name); - } - - return xh_val(xh_get_int(&pic->globals, rename), pic_value); -} - -pic_value -pic_funcall(pic_state *pic, const char *name, pic_list args) -{ - pic_value proc; - - proc = pic_ref(pic, name); - - pic_assert_type(pic, proc, proc); - - return pic_apply(pic, pic_proc_ptr(proc), args); -} - -void -pic_defun(pic_state *pic, const char *name, pic_func_t cfunc) -{ - struct pic_proc *proc; - - proc = pic_proc_new(pic, cfunc, name); - pic_define(pic, name, pic_obj_value(proc)); -} - -static void -vm_push_env(pic_state *pic) -{ - pic_callinfo *ci = pic->ci; - - ci->env = (struct pic_env *)pic_obj_alloc(pic, offsetof(struct pic_env, storage) + sizeof(pic_value) * ci->regc, PIC_TT_ENV); - ci->env->up = ci->up; - ci->env->regc = ci->regc; - ci->env->regs = ci->regs; -} - -static void -vm_tear_off(pic_callinfo *ci) -{ - struct pic_env *env; - int i; - - assert(ci->env != NULL); - - env = ci->env; - - if (env->regs == env->storage) { - return; /* is torn off */ - } - for (i = 0; i < env->regc; ++i) { - env->storage[i] = env->regs[i]; - } - env->regs = env->storage; -} - -void -pic_vm_tear_off(pic_state *pic) -{ - pic_callinfo *ci; - - for (ci = pic->ci; ci > pic->cibase; ci--) { - if (ci->env != NULL) { - vm_tear_off(ci); - } - } -} - -pic_value -pic_apply0(pic_state *pic, struct pic_proc *proc) -{ - return pic_apply(pic, proc, pic_nil_value()); -} - -pic_value -pic_apply1(pic_state *pic, struct pic_proc *proc, pic_value arg1) -{ - return pic_apply(pic, proc, pic_list1(pic, arg1)); -} - -pic_value -pic_apply2(pic_state *pic, struct pic_proc *proc, pic_value arg1, pic_value arg2) -{ - return pic_apply(pic, proc, pic_list2(pic, arg1, arg2)); -} - -pic_value -pic_apply3(pic_state *pic, struct pic_proc *proc, pic_value arg1, pic_value arg2, pic_value arg3) -{ - return pic_apply(pic, proc, pic_list3(pic, arg1, arg2, arg3)); -} - -pic_value -pic_apply4(pic_state *pic, struct pic_proc *proc, pic_value arg1, pic_value arg2, pic_value arg3, pic_value arg4) -{ - return pic_apply(pic, proc, pic_list4(pic, arg1, arg2, arg3, arg4)); -} - -pic_value -pic_apply5(pic_state *pic, struct pic_proc *proc, pic_value arg1, pic_value arg2, pic_value arg3, pic_value arg4, pic_value arg5) -{ - return pic_apply(pic, proc, pic_list5(pic, arg1, arg2, arg3, arg4, arg5)); -} - -#if VM_DEBUG -# define OPCODE_EXEC_HOOK pic_dump_code(c) -#else -# define OPCODE_EXEC_HOOK ((void)0) -#endif - -#if PIC_DIRECT_THREADED_VM -# define VM_LOOP JUMP; -# define CASE(x) L_##x: OPCODE_EXEC_HOOK; -# define NEXT pic->ip++; JUMP; -# define JUMP c = *pic->ip; goto *oplabels[c.insn]; -# define VM_LOOP_END -#else -# define VM_LOOP for (;;) { c = *pic->ip; switch (c.insn) { -# define CASE(x) case x: -# define NEXT pic->ip++; break -# define JUMP break -# define VM_LOOP_END } } -#endif - -#define PUSH(v) ((pic->sp >= pic->stend) ? abort() : (*pic->sp++ = (v))) -#define POP() (*--pic->sp) - -#define PUSHCI() (++pic->ci) -#define POPCI() (pic->ci--) - -pic_value -pic_apply(pic_state *pic, struct pic_proc *proc, pic_value argv) -{ - pic_code c; - size_t ai = pic_gc_arena_preserve(pic); - size_t argc, i; - pic_code boot[2]; - -#if PIC_DIRECT_THREADED_VM - static void *oplabels[] = { - &&L_OP_NOP, &&L_OP_POP, &&L_OP_PUSHNIL, &&L_OP_PUSHTRUE, &&L_OP_PUSHFALSE, - &&L_OP_PUSHINT, &&L_OP_PUSHCHAR, &&L_OP_PUSHCONST, - &&L_OP_GREF, &&L_OP_GSET, &&L_OP_LREF, &&L_OP_LSET, &&L_OP_CREF, &&L_OP_CSET, - &&L_OP_JMP, &&L_OP_JMPIF, &&L_OP_NOT, &&L_OP_CALL, &&L_OP_TAILCALL, &&L_OP_RET, - &&L_OP_LAMBDA, &&L_OP_CONS, &&L_OP_CAR, &&L_OP_CDR, &&L_OP_NILP, - &&L_OP_ADD, &&L_OP_SUB, &&L_OP_MUL, &&L_OP_DIV, &&L_OP_MINUS, - &&L_OP_EQ, &&L_OP_LT, &&L_OP_LE, &&L_OP_STOP - }; -#endif - - if (! pic_list_p(argv)) { - pic_error(pic, "argv must be a proper list"); - } - - argc = pic_length(pic, argv) + 1; - -#if VM_DEBUG - puts("### booting VM... ###"); - pic_value *stbase = pic->sp; - pic_callinfo *cibase = pic->ci; -#endif - - PUSH(pic_obj_value(proc)); - for (i = 1; i < argc; ++i) { - PUSH(pic_car(pic, argv)); - argv = pic_cdr(pic, argv); - } - - /* boot! */ - boot[0].insn = OP_CALL; - boot[0].u.i = argc; - boot[1].insn = OP_STOP; - pic->ip = boot; - - VM_LOOP { - CASE(OP_NOP) { - NEXT; - } - CASE(OP_POP) { - POP(); - NEXT; - } - CASE(OP_PUSHNIL) { - PUSH(pic_nil_value()); - NEXT; - } - CASE(OP_PUSHTRUE) { - PUSH(pic_true_value()); - NEXT; - } - CASE(OP_PUSHFALSE) { - PUSH(pic_false_value()); - NEXT; - } - CASE(OP_PUSHINT) { - PUSH(pic_int_value(c.u.i)); - NEXT; - } - CASE(OP_PUSHCHAR) { - PUSH(pic_char_value(c.u.c)); - NEXT; - } - CASE(OP_PUSHCONST) { - pic_value self; - struct pic_irep *irep; - - self = pic->ci->fp[0]; - if (! pic_proc_p(self)) { - pic_error(pic, "logic flaw"); - } - irep = pic_proc_ptr(self)->u.irep; - if (! pic_proc_irep_p(pic_proc_ptr(self))) { - pic_error(pic, "logic flaw"); - } - PUSH(irep->pool[c.u.i]); - NEXT; - } - CASE(OP_GREF) { - xh_entry *e; - - if ((e = xh_get_int(&pic->globals, c.u.i)) == NULL) { - pic_errorf(pic, "logic flaw; reference to uninitialized global variable: ~s", pic_symbol_name(pic, c.u.i)); - } - PUSH(xh_val(e, pic_value)); - NEXT; - } - CASE(OP_GSET) { - pic_value val; - - val = POP(); - xh_put_int(&pic->globals, c.u.i, &val); - NEXT; - } - CASE(OP_LREF) { - pic_callinfo *ci = pic->ci; - - if (ci->env != NULL && ci->env->regs == ci->env->storage) { - PUSH(ci->env->regs[c.u.i - (ci->regs - ci->fp)]); - NEXT; - } - PUSH(pic->ci->fp[c.u.i]); - NEXT; - } - CASE(OP_LSET) { - pic_callinfo *ci = pic->ci; - - if (ci->env != NULL && ci->env->regs == ci->env->storage) { - ci->env->regs[c.u.i - (ci->regs - ci->fp)] = POP(); - NEXT; - } - pic->ci->fp[c.u.i] = POP(); - NEXT; - } - CASE(OP_CREF) { - int depth = c.u.r.depth; - struct pic_env *env; - - env = pic->ci->up; - while (--depth) { - env = env->up; - } - PUSH(env->regs[c.u.r.idx]); - NEXT; - } - CASE(OP_CSET) { - int depth = c.u.r.depth; - struct pic_env *env; - - env = pic->ci->up; - while (--depth) { - env = env->up; - } - env->regs[c.u.r.idx] = POP(); - NEXT; - } - CASE(OP_JMP) { - pic->ip += c.u.i; - JUMP; - } - CASE(OP_JMPIF) { - pic_value v; - - v = POP(); - if (! pic_false_p(v)) { - pic->ip += c.u.i; - JUMP; - } - NEXT; - } - CASE(OP_NOT) { - pic_value v; - - v = pic_false_p(POP()) ? pic_true_value() : pic_false_value(); - PUSH(v); - NEXT; - } - CASE(OP_CALL) { - pic_value x, v; - pic_callinfo *ci; - struct pic_proc *proc; - - if (c.u.i == -1) { - pic->sp += pic->ci[1].retc - 1; - c.u.i = pic->ci[1].retc + 1; - } - - L_CALL: - x = pic->sp[-c.u.i]; - if (! pic_proc_p(x)) { - - if (pic_var_p(x)) { - if (c.u.i != 1) { - pic_errorf(pic, "invalid call-sequence for var object"); - } - POP(); - PUSH(pic_var_ref(pic, pic_var_ptr(x))); - NEXT; - } - pic_errorf(pic, "invalid application: ~s", x); - } - proc = pic_proc_ptr(x); - -#if VM_DEBUG - puts("\n== calling proc..."); - printf(" proc = "); - pic_debug(pic, pic_obj_value(proc)); - puts(""); - printf(" argv = ("); - for (short i = 1; i < c.u.i; ++i) { - if (i > 1) - printf(" "); - pic_debug(pic, pic->sp[-c.u.i + i]); - } - puts(")"); - if (! pic_proc_func_p(proc)) { - printf(" irep = %p\n", proc->u.irep); - printf(" name = %s\n", pic_symbol_name(pic, pic_proc_name(proc))); - pic_dump_irep(proc->u.irep); - } - else { - printf(" cfunc = %p\n", (void *)proc->u.func.f); - printf(" name = %s\n", pic_symbol_name(pic, pic_proc_name(proc))); - } - puts("== end\n"); -#endif - - ci = PUSHCI(); - ci->argc = c.u.i; - ci->retc = 1; - ci->ip = pic->ip; - ci->fp = pic->sp - c.u.i; - ci->env = NULL; - if (pic_proc_func_p(pic_proc_ptr(x))) { - - /* invoke! */ - v = proc->u.func.f(pic); - pic->sp[0] = v; - pic->sp += pic->ci->retc; - - pic_gc_arena_restore(pic, ai); - goto L_RET; - } - else { - struct pic_irep *irep = proc->u.irep; - int i; - pic_value rest; - - if (ci->argc != irep->argc) { - if (! (irep->varg && ci->argc >= irep->argc)) { - pic_errorf(pic, "wrong number of arguments (%d for %d%s)", ci->argc - 1, irep->argc - 1, (irep->varg ? "+" : "")); - } - } - /* prepare rest args */ - if (irep->varg) { - rest = pic_nil_value(); - for (i = 0; i < ci->argc - irep->argc; ++i) { - pic_gc_protect(pic, v = POP()); - rest = pic_cons(pic, v, rest); - } - PUSH(rest); - } - /* prepare local variable area */ - if (irep->localc > 0) { - int l = irep->localc; - if (irep->varg) { - --l; - } - for (i = 0; i < l; ++i) { - PUSH(pic_undef_value()); - } - } - - /* prepare env */ - ci->up = proc->env; - ci->regc = irep->capturec; - ci->regs = ci->fp + irep->argc + irep->localc; - - pic->ip = irep->code; - pic_gc_arena_restore(pic, ai); - JUMP; - } - } - CASE(OP_TAILCALL) { - int i, argc; - pic_value *argv; - pic_callinfo *ci; - - if (pic->ci->env != NULL) { - vm_tear_off(pic->ci); - } - - if (c.u.i == -1) { - pic->sp += pic->ci[1].retc - 1; - c.u.i = pic->ci[1].retc + 1; - } - - argc = c.u.i; - argv = pic->sp - argc; - for (i = 0; i < argc; ++i) { - pic->ci->fp[i] = argv[i]; - } - ci = POPCI(); - pic->sp = ci->fp + argc; - pic->ip = ci->ip; - - /* c is not changed */ - goto L_CALL; - } - CASE(OP_RET) { - int i, retc; - pic_value *retv; - pic_callinfo *ci; - - if (pic->ci->env != NULL) { - vm_tear_off(pic->ci); - } - - pic->ci->retc = c.u.i; - - L_RET: - retc = pic->ci->retc; - retv = pic->sp - retc; - if (retc == 0) { - pic->ci->fp[0] = retv[0]; /* copy at least once */ - } - for (i = 0; i < retc; ++i) { - pic->ci->fp[i] = retv[i]; - } - ci = POPCI(); - pic->sp = ci->fp + 1; /* advance only one! */ - pic->ip = ci->ip; - - NEXT; - } - CASE(OP_LAMBDA) { - pic_value self; - struct pic_irep *irep; - struct pic_proc *proc; - - self = pic->ci->fp[0]; - if (! pic_proc_p(self)) { - pic_error(pic, "logic flaw"); - } - irep = pic_proc_ptr(self)->u.irep; - if (! pic_proc_irep_p(pic_proc_ptr(self))) { - pic_error(pic, "logic flaw"); - } - - if (pic->ci->env == NULL) { - vm_push_env(pic); - } - - proc = pic_proc_new_irep(pic, irep->irep[c.u.i], pic->ci->env); - PUSH(pic_obj_value(proc)); - pic_gc_arena_restore(pic, ai); - NEXT; - } - CASE(OP_CONS) { - pic_value a, b; - pic_gc_protect(pic, b = POP()); - pic_gc_protect(pic, a = POP()); - PUSH(pic_cons(pic, a, b)); - pic_gc_arena_restore(pic, ai); - NEXT; - } - CASE(OP_CAR) { - pic_value p; - p = POP(); - PUSH(pic_car(pic, p)); - NEXT; - } - CASE(OP_CDR) { - pic_value p; - p = POP(); - PUSH(pic_cdr(pic, p)); - NEXT; - } - CASE(OP_NILP) { - pic_value p; - p = POP(); - PUSH(pic_bool_value(pic_nil_p(p))); - NEXT; - } - -#define DEFINE_ARITH_OP(opcode, op, guard) \ - CASE(opcode) { \ - pic_value a, b; \ - b = POP(); \ - a = POP(); \ - if (pic_int_p(a) && pic_int_p(b)) { \ - double f = (double)pic_int(a) op (double)pic_int(b); \ - if (INT_MIN <= f && f <= INT_MAX && (guard)) { \ - PUSH(pic_int_value((int)f)); \ - } \ - else { \ - PUSH(pic_float_value(f)); \ - } \ - } \ - else if (pic_float_p(a) && pic_float_p(b)) { \ - PUSH(pic_float_value(pic_float(a) op pic_float(b))); \ - } \ - else if (pic_int_p(a) && pic_float_p(b)) { \ - PUSH(pic_float_value(pic_int(a) op pic_float(b))); \ - } \ - else if (pic_float_p(a) && pic_int_p(b)) { \ - PUSH(pic_float_value(pic_float(a) op pic_int(b))); \ - } \ - else { \ - pic_error(pic, #op " got non-number operands"); \ - } \ - NEXT; \ - } - - DEFINE_ARITH_OP(OP_ADD, +, true); - DEFINE_ARITH_OP(OP_SUB, -, true); - DEFINE_ARITH_OP(OP_MUL, *, true); - DEFINE_ARITH_OP(OP_DIV, /, f == round(f)); - - CASE(OP_MINUS) { - pic_value n; - n = POP(); - if (pic_int_p(n)) { - PUSH(pic_int_value(-pic_int(n))); - } - else if (pic_float_p(n)) { - PUSH(pic_float_value(-pic_float(n))); - } - else { - pic_error(pic, "unary - got a non-number operand"); - } - NEXT; - } - -#define DEFINE_COMP_OP(opcode, op) \ - CASE(opcode) { \ - pic_value a, b; \ - b = POP(); \ - a = POP(); \ - if (pic_int_p(a) && pic_int_p(b)) { \ - PUSH(pic_bool_value(pic_int(a) op pic_int(b))); \ - } \ - else if (pic_float_p(a) && pic_float_p(b)) { \ - PUSH(pic_bool_value(pic_float(a) op pic_float(b))); \ - } \ - else if (pic_int_p(a) && pic_float_p(b)) { \ - PUSH(pic_bool_value(pic_int(a) op pic_float(b))); \ - } \ - else if (pic_float_p(a) && pic_int_p(b)) { \ - PUSH(pic_bool_value(pic_float(a) op pic_int(b))); \ - } \ - else { \ - pic_error(pic, #op " got non-number operands"); \ - } \ - NEXT; \ - } - - DEFINE_COMP_OP(OP_EQ, ==); - DEFINE_COMP_OP(OP_LT, <); - DEFINE_COMP_OP(OP_LE, <=); - - CASE(OP_STOP) { - -#if VM_DEBUG - puts("**VM END STATE**"); - printf("stbase\t= %p\nsp\t= %p\n", (void *)stbase, (void *)pic->sp); - printf("cibase\t= %p\nci\t= %p\n", (void *)cibase, (void *)pic->ci); - if (stbase < pic->sp - 1) { - pic_value *sp; - printf("* stack trace:"); - for (sp = stbase; pic->sp != sp; ++sp) { - pic_debug(pic, *sp); - puts(""); - } - } - if (stbase > pic->sp - 1) { - puts("*** stack underflow!"); - } -#endif - - return pic_gc_protect(pic, POP()); - } - } VM_LOOP_END; -} - -pic_value -pic_apply_trampoline(pic_state *pic, struct pic_proc *proc, pic_value args) -{ - static const pic_code iseq[2] = { - { OP_NOP, {} }, - { OP_TAILCALL, { .i = -1 } } - }; - - pic_value v, *sp; - pic_callinfo *ci; - - *pic->sp++ = pic_obj_value(proc); - - sp = pic->sp; - pic_for_each (v, args) { - *sp++ = v; - } - - ci = PUSHCI(); - ci->ip = (pic_code *)iseq; - ci->fp = pic->sp; - ci->retc = pic_length(pic, args); - - if (ci->retc == 0) { - return pic_none_value(); - } else { - return pic_car(pic, args); - } -} diff --git a/src/write.c b/src/write.c deleted file mode 100644 index 70a547b9..00000000 --- a/src/write.c +++ /dev/null @@ -1,506 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#include - -#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, "#", 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, "#"); - 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); - } -} diff --git a/t/r7rs-tests.scm b/t/r7rs-tests.scm index b96b14eb..6143a555 100644 --- a/t/r7rs-tests.scm +++ b/t/r7rs-tests.scm @@ -37,6 +37,7 @@ (scheme eval) (scheme process-context) (scheme case-lambda) + (scheme r5rs) (picrin test)) ;; R7RS test suite. Covers all procedures and syntax in the small diff --git a/tools/CMakeLists.txt b/tools/CMakeLists.txt deleted file mode 100644 index 24794f53..00000000 --- a/tools/CMakeLists.txt +++ /dev/null @@ -1,9 +0,0 @@ -list(APPEND REPL_LIBRARIES picrin) - -# build -add_executable(repl tools/main.c) -set_target_properties(repl PROPERTIES OUTPUT_NAME picrin) -target_link_libraries(repl ${REPL_LIBRARIES}) - -# install -install(TARGETS repl RUNTIME DESTINATION bin) diff --git a/tools/main.c b/tools/main.c deleted file mode 100644 index 617d4a0d..00000000 --- a/tools/main.c +++ /dev/null @@ -1,28 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#include "picrin.h" -#include "picrin/error.h" - -int -main(int argc, char *argv[], char **envp) -{ - pic_state *pic; - int status = 0; - - pic = pic_open(argc, argv, envp); - - pic_try { - pic_import(pic, pic_read_cstr(pic, "(picrin main)")); - pic_funcall(pic, "main", pic_nil_value()); - } - pic_catch { - pic_print_backtrace(pic, pic->err); - status = 1; - } - - pic_close(pic); - - return status; -}