From 4ff302bfcfbdf065e2612fd678fb6cd42777caad Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Mon, 1 Sep 2014 09:08:48 +0900
Subject: [PATCH 01/33] add benz submodule
---
.gitmodules | 3 +++
extlib/benz | 1 +
2 files changed, 4 insertions(+)
create mode 160000 extlib/benz
diff --git a/.gitmodules b/.gitmodules
index e676f24f..8280f76a 100644
--- a/.gitmodules
+++ b/.gitmodules
@@ -10,3 +10,6 @@
[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/extlib/benz b/extlib/benz
new file mode 160000
index 00000000..a3a8b11d
--- /dev/null
+++ b/extlib/benz
@@ -0,0 +1 @@
+Subproject commit a3a8b11d4b47a1ddfda8fe05aefa12c77b24a1cc
From 758c607046b7b7ca0788080820bcfa5642f6f0e6 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Mon, 1 Sep 2014 09:11:45 +0900
Subject: [PATCH 02/33] delete old submodules
---
.gitmodules | 12 ------------
extlib/xfile | 1 -
extlib/xhash | 1 -
extlib/xrope | 1 -
extlib/xvect | 1 -
5 files changed, 16 deletions(-)
delete mode 160000 extlib/xfile
delete mode 160000 extlib/xhash
delete mode 160000 extlib/xrope
delete mode 160000 extlib/xvect
diff --git a/.gitmodules b/.gitmodules
index 8280f76a..25d3e4f0 100644
--- a/.gitmodules
+++ b/.gitmodules
@@ -1,15 +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/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
From a2e968fe46659524a786ed369d20721577ca17fa Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Mon, 1 Sep 2014 09:16:44 +0900
Subject: [PATCH 03/33] remove include headers
---
include/picrin.h | 223 ------------------
include/picrin/blob.h | 27 ---
include/picrin/config.h | 115 ----------
include/picrin/cont.h | 62 -----
include/picrin/data.h | 37 ---
include/picrin/dict.h | 32 ---
include/picrin/error.h | 60 -----
include/picrin/gc.h | 24 --
include/picrin/irep.h | 206 -----------------
include/picrin/lib.h | 25 ---
include/picrin/macro.h | 47 ----
include/picrin/pair.h | 76 -------
include/picrin/port.h | 50 -----
include/picrin/proc.h | 62 -----
include/picrin/read.h | 39 ----
include/picrin/record.h | 30 ---
include/picrin/string.h | 42 ----
include/picrin/util.h | 51 -----
include/picrin/value.h | 484 ----------------------------------------
include/picrin/var.h | 32 ---
include/picrin/vector.h | 29 ---
21 files changed, 1753 deletions(-)
delete mode 100644 include/picrin.h
delete mode 100644 include/picrin/blob.h
delete mode 100644 include/picrin/config.h
delete mode 100644 include/picrin/cont.h
delete mode 100644 include/picrin/data.h
delete mode 100644 include/picrin/dict.h
delete mode 100644 include/picrin/error.h
delete mode 100644 include/picrin/gc.h
delete mode 100644 include/picrin/irep.h
delete mode 100644 include/picrin/lib.h
delete mode 100644 include/picrin/macro.h
delete mode 100644 include/picrin/pair.h
delete mode 100644 include/picrin/port.h
delete mode 100644 include/picrin/proc.h
delete mode 100644 include/picrin/read.h
delete mode 100644 include/picrin/record.h
delete mode 100644 include/picrin/string.h
delete mode 100644 include/picrin/util.h
delete mode 100644 include/picrin/value.h
delete mode 100644 include/picrin/var.h
delete mode 100644 include/picrin/vector.h
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 <stddef.h>
-#include <stdbool.h>
-#include <setjmp.h>
-#include <stdio.h>
-#include <stdint.h>
-#include <limits.h>
-#include <assert.h>
-
-#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 <stdnoreturn.h>
-#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 <assert.h>
-# 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
From 83f580bfcf68f6ef75d42ac4bf2e878e5f7e9301 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Mon, 1 Sep 2014 09:33:28 +0900
Subject: [PATCH 04/33] initial benz integration
---
CMakeLists.txt | 2 +-
src/CMakeLists.txt | 13 +-
src/blob.c | 196 ------
src/bool.c | 201 ------
src/char.c | 43 --
src/codegen.c | 1458 --------------------------------------------
src/cont.c | 371 -----------
src/data.c | 15 -
src/debug.c | 74 ---
src/dict.c | 169 -----
src/error.c | 286 ---------
src/eval.c | 10 -
src/gc.c | 872 --------------------------
src/init.c | 78 +--
src/lib.c | 273 ---------
src/macro.c | 449 +-------------
src/number.c | 944 ----------------------------
src/pair.c | 767 -----------------------
src/port.c | 749 -----------------------
src/proc.c | 183 ------
src/read.c | 976 -----------------------------
src/record.c | 115 ----
src/state.c | 205 -------
src/string.c | 424 -------------
src/symbol.c | 161 -----
src/var.c | 134 ----
src/vector.c | 283 ---------
src/vm.c | 1069 --------------------------------
src/write.c | 506 ---------------
29 files changed, 12 insertions(+), 11014 deletions(-)
delete mode 100644 src/blob.c
delete mode 100644 src/bool.c
delete mode 100644 src/char.c
delete mode 100644 src/codegen.c
delete mode 100644 src/cont.c
delete mode 100644 src/data.c
delete mode 100644 src/debug.c
delete mode 100644 src/dict.c
delete mode 100644 src/error.c
delete mode 100644 src/gc.c
delete mode 100644 src/lib.c
delete mode 100644 src/number.c
delete mode 100644 src/pair.c
delete mode 100644 src/port.c
delete mode 100644 src/proc.c
delete mode 100644 src/read.c
delete mode 100644 src/record.c
delete mode 100644 src/state.c
delete mode 100644 src/string.c
delete mode 100644 src/symbol.c
delete mode 100644 src/var.c
delete mode 100644 src/vector.c
delete mode 100644 src/vm.c
delete mode 100644 src/write.c
diff --git a/CMakeLists.txt b/CMakeLists.txt
index 2ee8e462..cbc7883a 100644
--- a/CMakeLists.txt
+++ b/CMakeLists.txt
@@ -26,7 +26,7 @@ else()
add_definitions(-std=c99) # at least c99 is required
endif()
-include_directories(include extlib)
+include_directories(extlib/benz/include)
# build picrin
include(piclib/CMakeLists.txt)
diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt
index f3e51499..f4a62f1d 100644
--- a/src/CMakeLists.txt
+++ b/src/CMakeLists.txt
@@ -1,7 +1,10 @@
find_package(Perl REQUIRED)
-# xfile
-set(XFILE_SOURCES extlib/xfile/xfile.c)
+# benz
+file(GLOB BENZ_SOURCES extlib/benz/*.c)
+
+# srcs
+file(GLOB PICRIN_SOURCES src/*.c)
# piclib
set(PICLIB_SOURCE ${PROJECT_SOURCE_DIR}/src/load_piclib.c)
@@ -21,12 +24,10 @@ add_custom_command(
WORKING_DIRECTORY ${PROJECT_SOURCE_DIR}
)
-# build!
-file(GLOB PICRIN_SOURCES ${PROJECT_SOURCE_DIR}/src/*.c)
-add_library(picrin SHARED ${PICRIN_SOURCES} ${PICLIB_SOURCE} ${XFILE_SOURCES} ${PICRIN_CONTRIB_SOURCES} ${CONTRIB_INIT})
+add_library(picrin SHARED ${BENZ_SOURCES} ${PICRIN_SOURCES} ${PICLIB_SOURCE} ${PICRIN_CONTRIB_SOURCES} ${CONTRIB_INIT})
target_link_libraries(picrin m ${PICRIN_CONTRIB_LIBRARIES})
# install
set(CMAKE_INSTALL_RPATH ${CMAKE_INSTALL_PREFIX}/lib)
install(TARGETS picrin DESTINATION lib)
-install(DIRECTORY include/ DESTINATION include FILES_MATCHING PATTERN "*.h")
+install(DIRECTORY extlib/benz/include/ DESTINATION include FILES_MATCHING PATTERN "*.h")
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 <string.h>
-
-#include "picrin.h"
-#include "picrin/blob.h"
-
-char *
-pic_strndup(pic_state *pic, const char *s, size_t n)
-{
- char *r;
-
- r = pic_alloc(pic, n + 1);
- memcpy(r, s, n);
- r[n] = '\0';
- return r;
-}
-
-char *
-pic_strdup(pic_state *pic, const char *s)
-{
- return pic_strndup(pic, s, strlen(s));
-}
-
-struct pic_blob *
-pic_blob_new(pic_state *pic, size_t len)
-{
- struct pic_blob *bv;
-
- bv = (struct pic_blob *)pic_obj_alloc(pic, sizeof(struct pic_blob), PIC_TT_BLOB);
- bv->data = pic_alloc(pic, len);
- bv->len = len;
- return bv;
-}
-
-static pic_value
-pic_blob_bytevector_p(pic_state *pic)
-{
- pic_value v;
-
- pic_get_args(pic, "o", &v);
-
- return pic_bool_value(pic_blob_p(v));
-}
-
-static pic_value
-pic_blob_make_bytevector(pic_state *pic)
-{
- pic_blob *blob;
- int k, b = 0, i;
-
- pic_get_args(pic, "i|i", &k, &b);
-
- if (b < 0 || b > 255)
- pic_error(pic, "byte out of range");
-
- blob = pic_blob_new(pic, k);
- for (i = 0; i < k; ++i) {
- blob->data[i] = b;
- }
-
- return pic_obj_value(blob);
-}
-
-static pic_value
-pic_blob_bytevector_length(pic_state *pic)
-{
- struct pic_blob *bv;
-
- pic_get_args(pic, "b", &bv);
-
- return pic_int_value(bv->len);
-}
-
-static pic_value
-pic_blob_bytevector_u8_ref(pic_state *pic)
-{
- struct pic_blob *bv;
- int k;
-
- pic_get_args(pic, "bi", &bv, &k);
-
- return pic_int_value(bv->data[k]);
-}
-
-static pic_value
-pic_blob_bytevector_u8_set(pic_state *pic)
-{
- struct pic_blob *bv;
- int k, v;
-
- pic_get_args(pic, "bii", &bv, &k, &v);
-
- if (v < 0 || v > 255)
- pic_error(pic, "byte out of range");
-
- bv->data[k] = v;
- return pic_none_value();
-}
-
-static pic_value
-pic_blob_bytevector_copy_i(pic_state *pic)
-{
- pic_blob *to, *from;
- int n, at, start, end;
-
- n = pic_get_args(pic, "bib|ii", &to, &at, &from, &start, &end);
-
- switch (n) {
- case 3:
- start = 0;
- case 4:
- end = from->len;
- }
-
- if (to == from && (start <= at && at < end)) {
- /* copy in reversed order */
- at += end - start;
- while (start < end) {
- to->data[--at] = from->data[--end];
- }
- return pic_none_value();
- }
-
- while (start < end) {
- to->data[at++] = from->data[start++];
- }
-
- return pic_none_value();
-}
-
-static pic_value
-pic_blob_bytevector_copy(pic_state *pic)
-{
- pic_blob *from, *to;
- int n, start, end, i = 0;
-
- n = pic_get_args(pic, "b|ii", &from, &start, &end);
-
- switch (n) {
- case 1:
- start = 0;
- case 2:
- end = from->len;
- }
-
- to = pic_blob_new(pic, end - start);
- while (start < end) {
- to->data[i++] = from->data[start++];
- }
-
- return pic_obj_value(to);
-}
-
-static pic_value
-pic_blob_bytevector_append(pic_state *pic)
-{
- size_t argc, i, j, len;
- pic_value *argv;
- pic_blob *blob;
-
- pic_get_args(pic, "*", &argc, &argv);
-
- len = 0;
- for (i = 0; i < argc; ++i) {
- pic_assert_type(pic, argv[i], blob);
- len += pic_blob_ptr(argv[i])->len;
- }
-
- blob = pic_blob_new(pic, len);
-
- len = 0;
- for (i = 0; i < argc; ++i) {
- for (j = 0; j < pic_blob_ptr(argv[i])->len; ++j) {
- blob->data[len + j] = pic_blob_ptr(argv[i])->data[j];
- }
- len += pic_blob_ptr(argv[i])->len;
- }
-
- return pic_obj_value(blob);
-}
-
-void
-pic_init_blob(pic_state *pic)
-{
- pic_defun(pic, "bytevector?", pic_blob_bytevector_p);
- pic_defun(pic, "make-bytevector", pic_blob_make_bytevector);
- pic_defun(pic, "bytevector-length", pic_blob_bytevector_length);
- pic_defun(pic, "bytevector-u8-ref", pic_blob_bytevector_u8_ref);
- pic_defun(pic, "bytevector-u8-set!", pic_blob_bytevector_u8_set);
- pic_defun(pic, "bytevector-copy!", pic_blob_bytevector_copy_i);
- pic_defun(pic, "bytevector-copy", pic_blob_bytevector_copy);
- pic_defun(pic, "bytevector-append", pic_blob_bytevector_append);
-}
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 <string.h>
-
-#include "picrin.h"
-#include "picrin/pair.h"
-#include "picrin/vector.h"
-#include "picrin/blob.h"
-#include "picrin/string.h"
-
-static bool
-str_equal_p(struct pic_string *str1, struct pic_string *str2)
-{
- return pic_strcmp(str1, str2) == 0;
-}
-
-static bool
-blob_equal_p(struct pic_blob *blob1, struct pic_blob *blob2)
-{
- size_t i;
-
- if (blob1->len != blob2->len) {
- return false;
- }
- for (i = 0; i < blob1->len; ++i) {
- if (blob1->data[i] != blob2->data[i])
- return false;
- }
- return true;
-}
-
-static bool
-internal_equal_p(pic_state *pic, pic_value x, pic_value y, size_t depth, xhash *ht)
-{
- pic_value local = pic_nil_value();
- size_t c;
-
- if (depth > 10) {
- if (depth > 200) {
- pic_errorf(pic, "Stack overflow in equal\n");
- }
- if (pic_pair_p(x) || pic_vec_p(x)) {
- if (xh_get_ptr(ht, pic_obj_ptr(x)) != NULL) {
- return true; /* `x' was seen already. */
- } else {
- xh_put_ptr(ht, pic_obj_ptr(x), NULL);
- }
- }
- }
-
- c = 0;
-
- LOOP:
-
- if (pic_eqv_p(x, y))
- return true;
-
- if (pic_type(x) != pic_type(y))
- return false;
-
- switch (pic_type(x)) {
- case PIC_TT_STRING:
- return str_equal_p(pic_str_ptr(x), pic_str_ptr(y));
-
- case PIC_TT_BLOB:
- return blob_equal_p(pic_blob_ptr(x), pic_blob_ptr(y));
-
- case PIC_TT_PAIR: {
- if (pic_nil_p(local)) {
- local = x;
- }
- if (internal_equal_p(pic, pic_car(pic, x), pic_car(pic, y), depth + 1, ht)) {
- x = pic_cdr(pic, x);
- y = pic_cdr(pic, y);
-
- c++;
-
- if (c == 2) {
- c = 0;
- local = pic_cdr(pic, local);
- if (pic_eq_p(local, x)) {
- return true;
- }
- }
- goto LOOP;
- } else {
- return false;
- }
- }
- case PIC_TT_VECTOR: {
- size_t i;
- struct pic_vector *u, *v;
-
- u = pic_vec_ptr(x);
- v = pic_vec_ptr(y);
-
- if (u->len != v->len) {
- return false;
- }
- for (i = 0; i < u->len; ++i) {
- if (! internal_equal_p(pic, u->data[i], v->data[i], depth + 1, ht))
- return false;
- }
- return true;
- }
- default:
- return false;
- }
-}
-
-bool
-pic_equal_p(pic_state *pic, pic_value x, pic_value y){
- xhash ht;
-
- xh_init_ptr(&ht, 0);
-
- return internal_equal_p(pic, x, y, 0, &ht);
-}
-
-static pic_value
-pic_bool_eq_p(pic_state *pic)
-{
- pic_value x, y;
-
- pic_get_args(pic, "oo", &x, &y);
-
- return pic_bool_value(pic_eq_p(x, y));
-}
-
-static pic_value
-pic_bool_eqv_p(pic_state *pic)
-{
- pic_value x, y;
-
- pic_get_args(pic, "oo", &x, &y);
-
- return pic_bool_value(pic_eqv_p(x, y));
-}
-
-static pic_value
-pic_bool_equal_p(pic_state *pic)
-{
- pic_value x, y;
-
- pic_get_args(pic, "oo", &x, &y);
-
- return pic_bool_value(pic_equal_p(pic, x, y));
-}
-
-static pic_value
-pic_bool_not(pic_state *pic)
-{
- pic_value v;
-
- pic_get_args(pic, "o", &v);
-
- return pic_false_p(v) ? pic_true_value() : pic_false_value();
-}
-
-static pic_value
-pic_bool_boolean_p(pic_state *pic)
-{
- pic_value v;
-
- pic_get_args(pic, "o", &v);
-
- return (pic_true_p(v) || pic_false_p(v)) ? pic_true_value() : pic_false_value();
-}
-
-static pic_value
-pic_bool_boolean_eq_p(pic_state *pic)
-{
- size_t argc, i;
- pic_value *argv;
-
- pic_get_args(pic, "*", &argc, &argv);
-
- for (i = 0; i < argc; ++i) {
- if (! (pic_true_p(argv[i]) || pic_false_p(argv[i]))) {
- return pic_false_value();
- }
- if (! pic_eq_p(argv[i], argv[0])) {
- return pic_false_value();
- }
- }
- return pic_true_value();
-}
-
-void
-pic_init_bool(pic_state *pic)
-{
- pic_defun(pic, "eq?", pic_bool_eq_p);
- pic_defun(pic, "eqv?", pic_bool_eqv_p);
- pic_defun(pic, "equal?", pic_bool_equal_p);
-
- pic_defun(pic, "not", pic_bool_not);
- pic_defun(pic, "boolean?", pic_bool_boolean_p);
- pic_defun(pic, "boolean=?", pic_bool_boolean_eq_p);
-}
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 <setjmp.h>
-#include <string.h>
-#include <stdarg.h>
-
-#include "picrin.h"
-#include "picrin/proc.h"
-#include "picrin/cont.h"
-#include "picrin/pair.h"
-#include "picrin/error.h"
-
-pic_value
-pic_values0(pic_state *pic)
-{
- return pic_values_by_list(pic, pic_nil_value());
-}
-
-pic_value
-pic_values1(pic_state *pic, pic_value arg1)
-{
- return pic_values_by_list(pic, pic_list1(pic, arg1));
-}
-
-pic_value
-pic_values2(pic_state *pic, pic_value arg1, pic_value arg2)
-{
- return pic_values_by_list(pic, pic_list2(pic, arg1, arg2));
-}
-
-pic_value
-pic_values3(pic_state *pic, pic_value arg1, pic_value arg2, pic_value arg3)
-{
- return pic_values_by_list(pic, pic_list3(pic, arg1, arg2, arg3));
-}
-
-pic_value
-pic_values4(pic_state *pic, pic_value arg1, pic_value arg2, pic_value arg3, pic_value arg4)
-{
- return pic_values_by_list(pic, pic_list4(pic, arg1, arg2, arg3, arg4));
-}
-
-pic_value
-pic_values5(pic_state *pic, pic_value arg1, pic_value arg2, pic_value arg3, pic_value arg4, pic_value arg5)
-{
- return pic_values_by_list(pic, pic_list5(pic, arg1, arg2, arg3, arg4, arg5));
-}
-
-pic_value
-pic_values_by_array(pic_state *pic, size_t argc, pic_value *argv)
-{
- size_t i;
-
- for (i = 0; i < argc; ++i) {
- pic->sp[i] = argv[i];
- }
- pic->ci->retc = argc;
-
- return argc == 0 ? pic_none_value() : pic->sp[0];
-}
-
-pic_value
-pic_values_by_list(pic_state *pic, pic_value list)
-{
- pic_value v;
- size_t i;
-
- i = 0;
- pic_for_each (v, list) {
- pic->sp[i++] = v;
- }
- pic->ci->retc = i;
-
- return pic_nil_p(list) ? pic_none_value() : pic->sp[0];
-}
-
-size_t
-pic_receive(pic_state *pic, size_t n, pic_value *argv)
-{
- pic_callinfo *ci;
- size_t i, retc;
-
- /* take info from discarded frame */
- ci = pic->ci + 1;
- retc = ci->retc;
-
- for (i = 0; i < retc && i < n; ++i) {
- argv[i] = ci->fp[i];
- }
-
- return retc;
-}
-
-static void save_cont(pic_state *, struct pic_cont **);
-static void restore_cont(pic_state *, struct pic_cont *);
-
-static ptrdiff_t
-native_stack_length(pic_state *pic, char **pos)
-{
- char t;
-
- *pos = (pic->native_stack_start > &t)
- ? &t
- : pic->native_stack_start;
-
- return (pic->native_stack_start > &t)
- ? pic->native_stack_start - &t
- : &t - pic->native_stack_start;
-}
-
-static void
-save_cont(pic_state *pic, struct pic_cont **c)
-{
- void pic_vm_tear_off(pic_state *);
- struct pic_cont *cont;
- char *pos;
-
- pic_vm_tear_off(pic); /* tear off */
-
- cont = *c = (struct pic_cont *)pic_obj_alloc(pic, sizeof(struct pic_cont), PIC_TT_CONT);
-
- cont->blk = pic->blk;
-
- cont->stk_len = native_stack_length(pic, &pos);
- cont->stk_pos = pos;
- assert(cont->stk_len > 0);
- cont->stk_ptr = pic_alloc(pic, cont->stk_len);
- memcpy(cont->stk_ptr, cont->stk_pos, cont->stk_len);
-
- cont->sp_offset = pic->sp - pic->stbase;
- cont->st_len = pic->stend - pic->stbase;
- cont->st_ptr = (pic_value *)pic_alloc(pic, sizeof(pic_value) * cont->st_len);
- memcpy(cont->st_ptr, pic->stbase, sizeof(pic_value) * cont->st_len);
-
- cont->ci_offset = pic->ci - pic->cibase;
- cont->ci_len = pic->ciend - pic->cibase;
- cont->ci_ptr = (pic_callinfo *)pic_alloc(pic, sizeof(pic_callinfo) * cont->ci_len);
- memcpy(cont->ci_ptr, pic->cibase, sizeof(pic_callinfo) * cont->ci_len);
-
- cont->ip = pic->ip;
-
- cont->arena_idx = pic->arena_idx;
- cont->arena_size = pic->arena_size;
- cont->arena = (struct pic_object **)pic_alloc(pic, sizeof(struct pic_object *) * pic->arena_size);
- memcpy(cont->arena, pic->arena, sizeof(struct pic_object *) * pic->arena_size);
-
- cont->try_jmp_idx = pic->try_jmp_idx;
- cont->try_jmp_size = pic->try_jmp_size;
- cont->try_jmps = pic_alloc(pic, sizeof(struct pic_jmpbuf) * pic->try_jmp_size);
- memcpy(cont->try_jmps, pic->try_jmps, sizeof(struct pic_jmpbuf) * pic->try_jmp_size);
-
- cont->results = pic_undef_value();
-}
-
-static void
-native_stack_extend(pic_state *pic, struct pic_cont *cont)
-{
- volatile pic_value v[1024];
-
- ((void)v);
- restore_cont(pic, cont);
-}
-
-noreturn static void
-restore_cont(pic_state *pic, struct pic_cont *cont)
-{
- char v;
- struct pic_cont *tmp = cont;
- struct pic_block *blk;
-
- if (&v < pic->native_stack_start) {
- if (&v > cont->stk_pos) native_stack_extend(pic, cont);
- }
- else {
- if (&v > cont->stk_pos + cont->stk_len) native_stack_extend(pic, cont);
- }
-
- blk = pic->blk;
- pic->blk = cont->blk;
-
- pic->stbase = (pic_value *)pic_realloc(pic, pic->stbase, sizeof(pic_value) * cont->st_len);
- memcpy(pic->stbase, cont->st_ptr, sizeof(pic_value) * cont->st_len);
- pic->sp = pic->stbase + cont->sp_offset;
- pic->stend = pic->stbase + cont->st_len;
-
- pic->cibase = (pic_callinfo *)pic_realloc(pic, pic->cibase, sizeof(pic_callinfo) * cont->ci_len);
- memcpy(pic->cibase, cont->ci_ptr, sizeof(pic_callinfo) * cont->ci_len);
- pic->ci = pic->cibase + cont->ci_offset;
- pic->ciend = pic->cibase + cont->ci_len;
-
- pic->ip = cont->ip;
-
- pic->arena = (struct pic_object **)pic_realloc(pic, pic->arena, sizeof(struct pic_object *) * cont->arena_size);
- memcpy(pic->arena, cont->arena, sizeof(struct pic_object *) * cont->arena_size);
- pic->arena_size = cont->arena_size;
- pic->arena_idx = cont->arena_idx;
-
- pic->try_jmps = pic_realloc(pic, pic->try_jmps, sizeof(struct pic_jmpbuf) * cont->try_jmp_size);
- memcpy(pic->try_jmps, cont->try_jmps, sizeof(struct pic_jmpbuf) * cont->try_jmp_size);
- pic->try_jmp_size = cont->try_jmp_size;
- pic->try_jmp_idx = cont->try_jmp_idx;
-
- memcpy(cont->stk_pos, cont->stk_ptr, cont->stk_len);
-
- longjmp(tmp->jmp, 1);
-}
-
-static void
-walk_to_block(pic_state *pic, struct pic_block *here, struct pic_block *there)
-{
- if (here == there)
- return;
-
- if (here->depth < there->depth) {
- walk_to_block(pic, here, there->prev);
- pic_apply0(pic, there->in);
- }
- else {
- pic_apply0(pic, there->out);
- walk_to_block(pic, here->prev, there);
- }
-}
-
-static pic_value
-pic_dynamic_wind(pic_state *pic, struct pic_proc *in, struct pic_proc *thunk, struct pic_proc *out)
-{
- struct pic_block *here;
- pic_value val;
-
- if (in != NULL) {
- pic_apply0(pic, in); /* enter */
- }
-
- here = pic->blk;
- pic->blk = (struct pic_block *)pic_obj_alloc(pic, sizeof(struct pic_block), PIC_TT_BLK);
- pic->blk->prev = here;
- pic->blk->depth = here->depth + 1;
- pic->blk->in = in;
- pic->blk->out = out;
-
- val = pic_apply0(pic, thunk);
-
- pic->blk = here;
-
- if (out != NULL) {
- pic_apply0(pic, out); /* exit */
- }
-
- return val;
-}
-
-noreturn static pic_value
-cont_call(pic_state *pic)
-{
- struct pic_proc *proc;
- size_t argc;
- pic_value *argv;
- struct pic_cont *cont;
-
- proc = pic_get_proc(pic);
- pic_get_args(pic, "*", &argc, &argv);
-
- cont = (struct pic_cont *)pic_ptr(pic_attr_ref(pic, proc, "@@cont"));
- cont->results = pic_list_by_array(pic, argc, argv);
-
- /* execute guard handlers */
- walk_to_block(pic, pic->blk, cont->blk);
-
- restore_cont(pic, cont);
-}
-
-pic_value
-pic_callcc(pic_state *pic, struct pic_proc *proc)
-{
- struct pic_cont *cont;
-
- save_cont(pic, &cont);
- if (setjmp(cont->jmp)) {
- return pic_values_by_list(pic, cont->results);
- }
- else {
- struct pic_proc *c;
-
- c = pic_proc_new(pic, cont_call, "<continuation-procedure>");
-
- /* save the continuation object in proc */
- pic_attr_set(pic, c, "@@cont", pic_obj_value(cont));
-
- return pic_apply1(pic, proc, pic_obj_value(c));
- }
-}
-
-static pic_value
-pic_callcc_trampoline(pic_state *pic, struct pic_proc *proc)
-{
- struct pic_cont *cont;
-
- save_cont(pic, &cont);
- if (setjmp(cont->jmp)) {
- return pic_values_by_list(pic, cont->results);
- }
- else {
- struct pic_proc *c;
-
- c = pic_proc_new(pic, cont_call, "<continuation-procedure>");
-
- /* save the continuation object in proc */
- pic_attr_set(pic, c, "@@cont", pic_obj_value(cont));
-
- return pic_apply_trampoline(pic, proc, pic_list1(pic, pic_obj_value(c)));
- }
-}
-
-static pic_value
-pic_cont_callcc(pic_state *pic)
-{
- struct pic_proc *cb;
-
- pic_get_args(pic, "l", &cb);
-
- return pic_callcc_trampoline(pic, cb);
-}
-
-static pic_value
-pic_cont_dynamic_wind(pic_state *pic)
-{
- struct pic_proc *in, *thunk, *out;
-
- pic_get_args(pic, "lll", &in, &thunk, &out);
-
- return pic_dynamic_wind(pic, in, thunk, out);
-}
-
-static pic_value
-pic_cont_values(pic_state *pic)
-{
- size_t argc;
- pic_value *argv;
-
- pic_get_args(pic, "*", &argc, &argv);
-
- return pic_values_by_array(pic, argc, argv);
-}
-
-static pic_value
-pic_cont_call_with_values(pic_state *pic)
-{
- struct pic_proc *producer, *consumer;
- size_t argc;
- pic_value args[256];
-
- pic_get_args(pic, "ll", &producer, &consumer);
-
- pic_apply(pic, producer, pic_nil_value());
-
- argc = pic_receive(pic, 256, args);
-
- return pic_apply_trampoline(pic, consumer, pic_list_by_array(pic, argc, args));
-}
-
-void
-pic_init_cont(pic_state *pic)
-{
- pic_defun(pic, "call-with-current-continuation", pic_cont_callcc);
- pic_defun(pic, "call/cc", pic_cont_callcc);
- pic_defun(pic, "dynamic-wind", pic_cont_dynamic_wind);
- pic_defun(pic, "values", pic_cont_values);
- pic_defun(pic, "call-with-values", pic_cont_call_with_values);
-}
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 <stdlib.h>
-#include <string.h>
-#include <stdarg.h>
-
-#include "picrin.h"
-#include "picrin/pair.h"
-#include "picrin/string.h"
-#include "picrin/error.h"
-
-void
-pic_abort(pic_state *pic, const char *msg)
-{
- UNUSED(pic);
-
- fprintf(stderr, "abort: %s\n", msg);
- abort();
-}
-
-void
-pic_warnf(pic_state *pic, const char *fmt, ...)
-{
- va_list ap;
- pic_value err_line;
-
- va_start(ap, fmt);
- err_line = pic_vformat(pic, fmt, ap);
- va_end(ap);
-
- fprintf(stderr, "warn: %s\n", pic_str_cstr(pic_str_ptr(pic_car(pic, err_line))));
-}
-
-void
-pic_push_try(pic_state *pic, struct pic_proc *handler)
-{
- struct pic_jmpbuf *try_jmp;
-
- if (pic->try_jmp_idx >= pic->try_jmp_size) {
- pic->try_jmp_size *= 2;
- pic->try_jmps = pic_realloc(pic, pic->try_jmps, sizeof(struct pic_jmpbuf) * pic->try_jmp_size);
- }
-
- try_jmp = pic->try_jmps + pic->try_jmp_idx++;
-
- try_jmp->handler = handler;
-
- try_jmp->ci_offset = pic->ci - pic->cibase;
- try_jmp->sp_offset = pic->sp - pic->stbase;
- try_jmp->ip = pic->ip;
-
- try_jmp->prev_jmp = pic->jmp;
- pic->jmp = &try_jmp->here;
-}
-
-void
-pic_pop_try(pic_state *pic)
-{
- struct pic_jmpbuf *try_jmp;
-
- try_jmp = pic->try_jmps + --pic->try_jmp_idx;
-
- /* assert(pic->jmp == &try_jmp->here); */
-
- pic->ci = try_jmp->ci_offset + pic->cibase;
- pic->sp = try_jmp->sp_offset + pic->stbase;
- pic->ip = try_jmp->ip;
-
- pic->jmp = try_jmp->prev_jmp;
-}
-
-static struct pic_error *
-error_new(pic_state *pic, short type, pic_str *msg, pic_value irrs)
-{
- struct pic_error *e;
- pic_str *stack;
-
- stack = pic_get_backtrace(pic);
-
- e = (struct pic_error *)pic_obj_alloc(pic, sizeof(struct pic_error), PIC_TT_ERROR);
- e->type = type;
- e->msg = msg;
- e->irrs = irrs;
- e->stack = stack;
-
- return e;
-}
-
-noreturn void
-pic_throw_error(pic_state *pic, struct pic_error *e)
-{
- void pic_vm_tear_off(pic_state *);
-
- pic_vm_tear_off(pic); /* tear off */
-
- pic->err = e;
- if (! pic->jmp) {
- puts(pic_errmsg(pic));
- abort();
- }
-
- longjmp(*pic->jmp, 1);
-}
-
-noreturn void
-pic_throw(pic_state *pic, short type, const char *msg, pic_value irrs)
-{
- struct pic_error *e;
-
- e = error_new(pic, type, pic_str_new_cstr(pic, msg), irrs);
-
- pic_throw_error(pic, e);
-}
-
-const char *
-pic_errmsg(pic_state *pic)
-{
- assert(pic->err != NULL);
-
- return pic_str_cstr(pic->err->msg);
-}
-
-void
-pic_errorf(pic_state *pic, const char *fmt, ...)
-{
- va_list ap;
- pic_value err_line, irrs;
- const char *msg;
-
- va_start(ap, fmt);
- err_line = pic_vformat(pic, fmt, ap);
- va_end(ap);
-
- msg = pic_str_cstr(pic_str_ptr(pic_car(pic, err_line)));
- irrs = pic_cdr(pic, err_line);
-
- pic_throw(pic, PIC_ERROR_OTHER, msg, irrs);
-}
-
-static pic_value
-pic_error_with_exception_handler(pic_state *pic)
-{
- struct pic_proc *handler, *thunk;
- pic_value v;
-
- pic_get_args(pic, "ll", &handler, &thunk);
-
- pic_try_with_handler(handler) {
- v = pic_apply0(pic, thunk);
- }
- pic_catch {
- struct pic_error *e = pic->err;
-
- pic->err = NULL;
-
- if (e->type == PIC_ERROR_RAISED) {
- v = pic_list_ref(pic, e->irrs, 0);
- } else {
- v = pic_obj_value(e);
- }
- v = pic_apply1(pic, handler, v);
- pic_errorf(pic, "error handler returned ~s, by error ~s", v, pic_obj_value(e));
- }
- return v;
-}
-
-noreturn static pic_value
-pic_error_raise(pic_state *pic)
-{
- pic_value v;
-
- pic_get_args(pic, "o", &v);
-
- pic_throw(pic, PIC_ERROR_RAISED, "object is raised", pic_list1(pic, v));
-}
-
-static pic_value
-pic_error_raise_continuable(pic_state *pic)
-{
- pic_value v;
-
- pic_get_args(pic, "o", &v);
-
- if (pic->try_jmp_idx == 0) {
- pic_errorf(pic, "no exception handler registered");
- }
- if (pic->try_jmps[pic->try_jmp_idx - 1].handler == NULL) {
- pic_errorf(pic, "uncontinuable exception handler is on top");
- }
- else {
- pic->try_jmp_idx--;
- v = pic_apply1(pic, pic->try_jmps[pic->try_jmp_idx].handler, v);
- ++pic->try_jmp_idx;
- }
- return v;
-}
-
-noreturn static pic_value
-pic_error_error(pic_state *pic)
-{
- const char *str;
- size_t argc;
- pic_value *argv;
-
- pic_get_args(pic, "z*", &str, &argc, &argv);
-
- pic_throw(pic, PIC_ERROR_OTHER, str, pic_list_by_array(pic, argc, argv));
-}
-
-static pic_value
-pic_error_error_object_p(pic_state *pic)
-{
- pic_value v;
-
- pic_get_args(pic, "o", &v);
-
- return pic_bool_value(pic_error_p(v));
-}
-
-static pic_value
-pic_error_error_object_message(pic_state *pic)
-{
- struct pic_error *e;
-
- pic_get_args(pic, "e", &e);
-
- return pic_obj_value(e->msg);
-}
-
-static pic_value
-pic_error_error_object_irritants(pic_state *pic)
-{
- struct pic_error *e;
-
- pic_get_args(pic, "e", &e);
-
- return e->irrs;
-}
-
-static pic_value
-pic_error_read_error_p(pic_state *pic)
-{
- pic_value v;
- struct pic_error *e;
-
- pic_get_args(pic, "o", &v);
-
- if (! pic_error_p(v)) {
- return pic_false_value();
- }
-
- e = pic_error_ptr(v);
- return pic_bool_value(e->type == PIC_ERROR_READ);
-}
-
-static pic_value
-pic_error_file_error_p(pic_state *pic)
-{
- pic_value v;
- struct pic_error *e;
-
- pic_get_args(pic, "o", &v);
-
- if (! pic_error_p(v)) {
- return pic_false_value();
- }
-
- e = pic_error_ptr(v);
- return pic_bool_value(e->type == PIC_ERROR_FILE);
-}
-
-void
-pic_init_error(pic_state *pic)
-{
- pic_defun(pic, "with-exception-handler", pic_error_with_exception_handler);
- pic_defun(pic, "raise", pic_error_raise);
- pic_defun(pic, "raise-continuable", pic_error_raise_continuable);
- pic_defun(pic, "error", pic_error_error);
- pic_defun(pic, "error-object?", pic_error_error_object_p);
- pic_defun(pic, "error-object-message", pic_error_error_object_message);
- pic_defun(pic, "error-object-irritants", pic_error_error_object_irritants);
- pic_defun(pic, "read-error?", pic_error_read_error_p);
- pic_defun(pic, "file-error?", pic_error_file_error_p);
-}
diff --git a/src/eval.c b/src/eval.c
index 5a037c94..dd31829c 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -5,16 +5,6 @@
#include "picrin.h"
#include "picrin/macro.h"
-pic_value
-pic_eval(pic_state *pic, pic_value program, struct pic_lib *lib)
-{
- struct pic_proc *proc;
-
- proc = pic_compile(pic, program, lib);
-
- return pic_apply(pic, proc, pic_nil_value());
-}
-
static pic_value
pic_eval_eval(pic_state *pic)
{
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 <stdlib.h>
-
-#include "picrin.h"
-#include "picrin/gc.h"
-#include "picrin/pair.h"
-#include "picrin/string.h"
-#include "picrin/vector.h"
-#include "picrin/irep.h"
-#include "picrin/proc.h"
-#include "picrin/port.h"
-#include "picrin/blob.h"
-#include "picrin/cont.h"
-#include "picrin/error.h"
-#include "picrin/macro.h"
-#include "picrin/lib.h"
-#include "picrin/var.h"
-#include "picrin/data.h"
-#include "picrin/dict.h"
-#include "picrin/record.h"
-#include "picrin/read.h"
-
-#if GC_DEBUG
-# include <string.h>
-#endif
-
-union header {
- struct {
- union header *ptr;
- size_t size;
- unsigned int mark : 1;
- } s;
- long alignment[4];
-};
-
-struct heap_page {
- union header *basep, *endp;
- struct heap_page *next;
-};
-
-struct pic_heap {
- union header base, *freep;
- struct heap_page *pages;
-};
-
-
-static void
-heap_init(struct pic_heap *heap)
-{
- heap->base.s.ptr = &heap->base;
- heap->base.s.size = 0; /* not 1, since it must never be used for allocation */
- heap->base.s.mark = PIC_GC_UNMARK;
-
- heap->freep = &heap->base;
- heap->pages = NULL;
-
-#if GC_DEBUG
- printf("freep = %p\n", (void *)heap->freep);
-#endif
-}
-
-struct pic_heap *
-pic_heap_open()
-{
- struct pic_heap *heap;
-
- heap = (struct pic_heap *)calloc(1, sizeof(struct pic_heap));
- heap_init(heap);
- return heap;
-}
-
-void
-pic_heap_close(struct pic_heap *heap)
-{
- struct heap_page *page;
-
- while (heap->pages) {
- page = heap->pages;
- heap->pages = heap->pages->next;
- free(page);
- }
-}
-
-static void gc_free(pic_state *, union header *);
-
-static void
-add_heap_page(pic_state *pic)
-{
- union header *up, *np;
- struct heap_page *page;
- size_t nu;
-
-#if GC_DEBUG
- puts("adding heap page!");
-#endif
-
- nu = (PIC_HEAP_PAGE_SIZE + sizeof(union header) - 1) / sizeof(union header) + 1;
-
- up = (union header *)pic_calloc(pic, 1 + nu + 1, sizeof(union header));
- up->s.size = nu + 1;
- up->s.mark = PIC_GC_UNMARK;
- gc_free(pic, up);
-
- np = up + 1;
- np->s.size = nu;
- np->s.ptr = up->s.ptr;
- up->s.size = 1;
- up->s.ptr = np;
-
- page = (struct heap_page *)pic_alloc(pic, sizeof(struct heap_page));
- page->basep = up;
- page->endp = up + nu + 1;
- page->next = pic->heap->pages;
-
- pic->heap->pages = page;
-}
-
-static void *
-alloc(void *ptr, size_t size)
-{
- if (size == 0) {
- if (ptr) {
- free(ptr);
- }
- return NULL;
- }
- if (ptr) {
- return realloc(ptr, size);
- } else {
- return malloc(size);
- }
-}
-
-void *
-pic_alloc(pic_state *pic, size_t size)
-{
- void *ptr;
-
- ptr = alloc(NULL, size);
- if (ptr == NULL && size > 0) {
- pic_abort(pic, "memory exhausted");
- }
- return ptr;
-}
-
-void *
-pic_realloc(pic_state *pic, void *ptr, size_t size)
-{
- ptr = alloc(ptr, size);
- if (ptr == NULL && size > 0) {
- pic_abort(pic, "memory exhausted");
- }
- return ptr;
-}
-
-void *
-pic_calloc(pic_state *pic, size_t count, size_t size)
-{
- void *ptr;
-
- size *= count;
- ptr = alloc(NULL, size);
- if (ptr == NULL && size > 0) {
- pic_abort(pic, "memory exhausted");
- }
- memset(ptr, 0, size);
- return ptr;
-}
-
-void
-pic_free(pic_state *pic, void *ptr)
-{
- UNUSED(pic);
-
- free(ptr);
-}
-
-static void
-gc_protect(pic_state *pic, struct pic_object *obj)
-{
- if (pic->arena_idx >= pic->arena_size) {
- pic->arena_size = pic->arena_size * 2 + 1;
- pic->arena = pic_realloc(pic, pic->arena, sizeof(struct pic_object *) * pic->arena_size);
- }
- pic->arena[pic->arena_idx++] = obj;
-}
-
-pic_value
-pic_gc_protect(pic_state *pic, pic_value v)
-{
- struct pic_object *obj;
-
- if (pic_vtype(v) != PIC_VTYPE_HEAP) {
- return v;
- }
- obj = pic_obj_ptr(v);
-
- gc_protect(pic, obj);
-
- return v;
-}
-
-size_t
-pic_gc_arena_preserve(pic_state *pic)
-{
- return pic->arena_idx;
-}
-
-void
-pic_gc_arena_restore(pic_state *pic, size_t state)
-{
- pic->arena_idx = state;
-}
-
-static void *
-gc_alloc(pic_state *pic, size_t size)
-{
- union header *freep, *p, *prevp;
- size_t nunits;
-
-#if GC_DEBUG
- assert(size > 0);
-#endif
-
- nunits = (size + sizeof(union header) - 1) / sizeof(union header) + 1;
-
- prevp = freep = pic->heap->freep;
- for (p = prevp->s.ptr; ; prevp = p, p = p->s.ptr) {
- if (p->s.size >= nunits)
- break;
- if (p == freep) {
- return NULL;
- }
- }
-
-#if GC_DEBUG
- {
- unsigned char *c;
- size_t s, i, j;
- if (p->s.size == nunits) {
- c = (unsigned char *)(p + p->s.size - nunits + 1);
- s = nunits - 1;
- } else {
- c = (unsigned char *)(p + p->s.size - nunits);
- s = nunits;
- }
-
- for (i = 0; i < s; ++i) {
- for (j = 0; j < sizeof(union header); ++j) {
- assert(c[i * sizeof(union header) + j] == 0xAA);
- }
- }
- }
-#endif
-
- if (p->s.size == nunits) {
- prevp->s.ptr = p->s.ptr;
- }
- else {
- p->s.size -= nunits;
- p += p->s.size;
- p->s.size = nunits;
- }
- pic->heap->freep = prevp;
-
- p->s.mark = PIC_GC_UNMARK;
-
-#if GC_DEBUG
- memset(p+1, 0, sizeof(union header) * (nunits - 1));
- p->s.ptr = (union header *)0xcafebabe;
-#endif
-
- return (void *)(p + 1);
-}
-
-static void
-gc_free(pic_state *pic, union header *bp)
-{
- union header *freep, *p;
-
-#if GC_DEBUG
- assert(bp != NULL);
- assert(bp->s.size > 1);
-#endif
-
-#if GC_DEBUG
- memset(bp + 1, 0xAA, (bp->s.size - 1) * sizeof(union header));
-#endif
-
- freep = pic->heap->freep;
- for (p = freep; ! (bp > p && bp < p->s.ptr); p = p->s.ptr) {
- if (p >= p->s.ptr && (bp > p || bp < p->s.ptr)) {
- break;
- }
- }
- if (bp + bp->s.size == p->s.ptr) {
- bp->s.size += p->s.ptr->s.size;
- bp->s.ptr = p->s.ptr->s.ptr;
-
-#if GC_DEBUG
- memset(p->s.ptr, 0xAA, sizeof(union header));
-#endif
- }
- else {
- bp->s.ptr = p->s.ptr;
- }
- if (p + p->s.size == bp && p->s.size > 1) {
- p->s.size += bp->s.size;
- p->s.ptr = bp->s.ptr;
-
-#if GC_DEBUG
- memset(bp, 0xAA, sizeof(union header));
-#endif
- }
- else {
- p->s.ptr = bp;
- }
- pic->heap->freep = p;
-}
-
-static void gc_mark(pic_state *, pic_value);
-static void gc_mark_object(pic_state *pic, struct pic_object *obj);
-
-static bool
-gc_is_marked(union header *p)
-{
- return p->s.mark == PIC_GC_MARK;
-}
-
-static void
-gc_unmark(union header *p)
-{
- p->s.mark = PIC_GC_UNMARK;
-}
-
-static void
-gc_mark_object(pic_state *pic, struct pic_object *obj)
-{
- union header *p;
-
- p = ((union header *)obj) - 1;
-
- if (gc_is_marked(p))
- return;
- p->s.mark = PIC_GC_MARK;
-
- switch (obj->tt) {
- case PIC_TT_PAIR: {
- gc_mark(pic, ((struct pic_pair *)obj)->car);
- gc_mark(pic, ((struct pic_pair *)obj)->cdr);
- break;
- }
- case PIC_TT_ENV: {
- struct pic_env *env = (struct pic_env *)obj;
- int i;
-
- for (i = 0; i < env->regc; ++i) {
- gc_mark(pic, env->regs[i]);
- }
- if (env->up) {
- gc_mark_object(pic, (struct pic_object *)env->up);
- }
- break;
- }
- case PIC_TT_PROC: {
- struct pic_proc *proc = (struct pic_proc *)obj;
- if (proc->env) {
- gc_mark_object(pic, (struct pic_object *)proc->env);
- }
- if (proc->attr) {
- gc_mark_object(pic, (struct pic_object *)proc->attr);
- }
- if (pic_proc_irep_p(proc)) {
- gc_mark_object(pic, (struct pic_object *)proc->u.irep);
- }
- break;
- }
- case PIC_TT_PORT: {
- break;
- }
- case PIC_TT_ERROR: {
- struct pic_error *err = (struct pic_error *)obj;
- gc_mark_object(pic,(struct pic_object *)err->msg);
- gc_mark(pic, err->irrs);
- gc_mark_object(pic, (struct pic_object *)err->stack);
- break;
- }
- case PIC_TT_STRING: {
- break;
- }
- case PIC_TT_VECTOR: {
- size_t i;
- for (i = 0; i < ((struct pic_vector *)obj)->len; ++i) {
- gc_mark(pic, ((struct pic_vector *)obj)->data[i]);
- }
- break;
- }
- case PIC_TT_BLOB: {
- break;
- }
- case PIC_TT_CONT: {
- struct pic_cont *cont = (struct pic_cont *)obj;
- pic_value *stack;
- pic_callinfo *ci;
- size_t i;
-
- /* block */
- gc_mark_object(pic, (struct pic_object *)cont->blk);
-
- /* stack */
- for (stack = cont->st_ptr; stack != cont->st_ptr + cont->sp_offset; ++stack) {
- gc_mark(pic, *stack);
- }
-
- /* callinfo */
- for (ci = cont->ci_ptr + cont->ci_offset; ci != cont->ci_ptr; --ci) {
- if (ci->env) {
- gc_mark_object(pic, (struct pic_object *)ci->env);
- }
- }
-
- /* arena */
- for (i = 0; i < (size_t)cont->arena_idx; ++i) {
- gc_mark_object(pic, cont->arena[i]);
- }
-
- /* error handlers */
- for (i = 0; i < cont->try_jmp_idx; ++i) {
- if (cont->try_jmps[i].handler) {
- gc_mark_object(pic, (struct pic_object *)cont->try_jmps[i].handler);
- }
- }
-
- /* result values */
- gc_mark(pic, cont->results);
- break;
- }
- case PIC_TT_MACRO: {
- struct pic_macro *mac = (struct pic_macro *)obj;
-
- if (mac->proc) {
- gc_mark_object(pic, (struct pic_object *)mac->proc);
- }
- if (mac->senv) {
- gc_mark_object(pic, (struct pic_object *)mac->senv);
- }
- break;
- }
- case PIC_TT_SENV: {
- struct pic_senv *senv = (struct pic_senv *)obj;
-
- if (senv->up) {
- gc_mark_object(pic, (struct pic_object *)senv->up);
- }
- break;
- }
- case PIC_TT_LIB: {
- struct pic_lib *lib = (struct pic_lib *)obj;
- gc_mark(pic, lib->name);
- gc_mark_object(pic, (struct pic_object *)lib->env);
- break;
- }
- case PIC_TT_VAR: {
- struct pic_var *var = (struct pic_var *)obj;
- gc_mark(pic, var->stack);
- if (var->conv) {
- gc_mark_object(pic, (struct pic_object *)var->conv);
- }
- break;
- }
- case PIC_TT_IREP: {
- struct pic_irep *irep = (struct pic_irep *)obj;
- size_t i;
-
- for (i = 0; i < irep->ilen; ++i) {
- gc_mark_object(pic, (struct pic_object *)irep->irep[i]);
- }
- for (i = 0; i < irep->plen; ++i) {
- gc_mark(pic, irep->pool[i]);
- }
- break;
- }
- case PIC_TT_DATA: {
- struct pic_data *data = (struct pic_data *)obj;
- xh_iter it;
-
- xh_begin(&it, &data->storage);
- while (xh_next(&it)) {
- gc_mark(pic, xh_val(it.e, pic_value));
- }
- break;
- }
- case PIC_TT_DICT: {
- struct pic_dict *dict = (struct pic_dict *)obj;
- xh_iter it;
-
- xh_begin(&it, &dict->hash);
- while (xh_next(&it)) {
- gc_mark(pic, xh_val(it.e, pic_value));
- }
- break;
- }
- case PIC_TT_RECORD: {
- struct pic_record *rec = (struct pic_record *)obj;
- xh_iter it;
-
- xh_begin(&it, &rec->hash);
- while (xh_next(&it)) {
- gc_mark(pic, xh_val(it.e, pic_value));
- }
- break;
- }
- case PIC_TT_BLK: {
- struct pic_block *blk = (struct pic_block *)obj;
-
- if (blk->prev) {
- gc_mark_object(pic, (struct pic_object *)blk->prev);
- }
- if (blk->in) {
- gc_mark_object(pic, (struct pic_object *)blk->in);
- }
- if (blk->out) {
- gc_mark_object(pic, (struct pic_object *)blk->out);
- }
- break;
- }
- case PIC_TT_NIL:
- case PIC_TT_BOOL:
- case PIC_TT_FLOAT:
- case PIC_TT_INT:
- case PIC_TT_SYMBOL:
- case PIC_TT_CHAR:
- case PIC_TT_EOF:
- case PIC_TT_UNDEF:
- pic_abort(pic, "logic flaw");
- }
-}
-
-static void
-gc_mark(pic_state *pic, pic_value v)
-{
- struct pic_object *obj;
-
- if (pic_vtype(v) != PIC_VTYPE_HEAP)
- return;
- obj = pic_obj_ptr(v);
-
- gc_mark_object(pic, obj);
-}
-
-static void
-gc_mark_trie(pic_state *pic, struct pic_trie *trie)
-{
- size_t i;
-
- for (i = 0; i < sizeof trie->table / sizeof(struct pic_trie *); ++i) {
- if (trie->table[i] != NULL) {
- gc_mark_trie(pic, trie->table[i]);
- }
- }
- if (trie->proc != NULL) {
- gc_mark_object(pic, (struct pic_object *)trie->proc);
- }
-}
-
-static void
-gc_mark_phase(pic_state *pic)
-{
- pic_value *stack;
- pic_callinfo *ci;
- size_t i, j;
- xh_iter it;
-
- /* block */
- if (pic->blk) {
- gc_mark_object(pic, (struct pic_object *)pic->blk);
- }
-
- /* stack */
- for (stack = pic->stbase; stack != pic->sp; ++stack) {
- gc_mark(pic, *stack);
- }
-
- /* callinfo */
- for (ci = pic->ci; ci != pic->cibase; --ci) {
- if (ci->env) {
- gc_mark_object(pic, (struct pic_object *)ci->env);
- }
- }
-
- /* error object */
- if (pic->err) {
- gc_mark_object(pic, (struct pic_object *)pic->err);
- }
-
- /* arena */
- for (j = 0; j < pic->arena_idx; ++j) {
- gc_mark_object(pic, pic->arena[j]);
- }
-
- /* global variables */
- xh_begin(&it, &pic->globals);
- while (xh_next(&it)) {
- gc_mark(pic, xh_val(it.e, pic_value));
- }
-
- /* macro objects */
- xh_begin(&it, &pic->macros);
- while (xh_next(&it)) {
- gc_mark_object(pic, xh_val(it.e, struct pic_object *));
- }
-
- /* error handlers */
- for (i = 0; i < pic->try_jmp_idx; ++i) {
- if (pic->try_jmps[i].handler) {
- gc_mark_object(pic, (struct pic_object *)pic->try_jmps[i].handler);
- }
- }
-
- /* readers */
- gc_mark_trie(pic, pic->reader->trie);
-
- /* library table */
- gc_mark(pic, pic->libs);
-}
-
-static void
-gc_finalize_object(pic_state *pic, struct pic_object *obj)
-{
-#if GC_DEBUG
- printf("* finalizing object: %s", pic_type_repr(pic_type(pic_obj_value(obj))));
- // pic_debug(pic, pic_obj_value(obj));
- puts("");
-#endif
-
- switch (obj->tt) {
- case PIC_TT_PAIR: {
- break;
- }
- case PIC_TT_ENV: {
- break;
- }
- case PIC_TT_PROC: {
- break;
- }
- case PIC_TT_VECTOR: {
- pic_free(pic, ((struct pic_vector *)obj)->data);
- break;
- }
- case PIC_TT_BLOB: {
- pic_free(pic, ((struct pic_blob *)obj)->data);
- break;
- }
- case PIC_TT_STRING: {
- XROPE_DECREF(((struct pic_string *)obj)->rope);
- break;
- }
- case PIC_TT_PORT: {
- break;
- }
- case PIC_TT_ERROR: {
- break;
- }
- case PIC_TT_CONT: {
- struct pic_cont *cont = (struct pic_cont *)obj;
- pic_free(pic, cont->stk_ptr);
- pic_free(pic, cont->st_ptr);
- pic_free(pic, cont->ci_ptr);
- pic_free(pic, cont->arena);
- pic_free(pic, cont->try_jmps);
- break;
- }
- case PIC_TT_SENV: {
- struct pic_senv *senv = (struct pic_senv *)obj;
- xh_destroy(&senv->map);
- break;
- }
- case PIC_TT_MACRO: {
- break;
- }
- case PIC_TT_LIB: {
- struct pic_lib *lib = (struct pic_lib *)obj;
- xh_destroy(&lib->exports);
- break;
- }
- case PIC_TT_VAR: {
- break;
- }
- case PIC_TT_IREP: {
- struct pic_irep *irep = (struct pic_irep *)obj;
- pic_free(pic, irep->code);
- pic_free(pic, irep->irep);
- pic_free(pic, irep->pool);
- break;
- }
- case PIC_TT_DATA: {
- struct pic_data *data = (struct pic_data *)obj;
- data->type->dtor(pic, data->data);
- xh_destroy(&data->storage);
- break;
- }
- case PIC_TT_DICT: {
- struct pic_dict *dict = (struct pic_dict *)obj;
- xh_destroy(&dict->hash);
- break;
- }
- case PIC_TT_RECORD: {
- struct pic_record *rec = (struct pic_record *)obj;
- xh_destroy(&rec->hash);
- break;
- }
- case PIC_TT_BLK: {
- break;
- }
- case PIC_TT_NIL:
- case PIC_TT_BOOL:
- case PIC_TT_FLOAT:
- case PIC_TT_INT:
- case PIC_TT_SYMBOL:
- case PIC_TT_CHAR:
- case PIC_TT_EOF:
- case PIC_TT_UNDEF:
- pic_abort(pic, "logic flaw");
- }
-}
-
-static void
-gc_sweep_page(pic_state *pic, struct heap_page *page)
-{
-#if GC_DEBUG
- static union header *NIL = (union header *)0xdeadbeef;
-#else
- static union header *NIL = NULL;
-#endif
- union header *bp, *p, *s = NIL, *t;
-
-#if GC_DEBUG
- int c = 0;
-#endif
-
- for (bp = page->basep; ; bp = bp->s.ptr) {
- for (p = bp + bp->s.size; p != bp->s.ptr; p += p->s.size) {
- if (p == page->endp) {
- goto escape;
- }
- if (! gc_is_marked(p)) {
- if (s == NIL) {
- s = p;
- }
- else {
- t->s.ptr = p;
- }
- t = p;
- t->s.ptr = NIL; /* For dead objects we can safely reuse ptr field */
- }
- gc_unmark(p);
- }
- }
- escape:
-
- /* free! */
- while (s != NIL) {
- t = s->s.ptr;
- gc_finalize_object(pic, (struct pic_object *)(s + 1));
- gc_free(pic, s);
- s = t;
-
-#if GC_DEBUG
- c++;
-#endif
- }
-
-#if GC_DEBUG
- printf("freed objects count: %d\n", c);
-#endif
-}
-
-static void
-gc_sweep_phase(pic_state *pic)
-{
- struct heap_page *page = pic->heap->pages;
-
- while (page) {
- gc_sweep_page(pic, page);
- page = page->next;
- }
-}
-
-void
-pic_gc_run(pic_state *pic)
-{
-#if GC_DEBUG
- struct heap_page *page;
-#endif
-
-#if DEBUG
- puts("gc run!");
-#endif
-
- gc_mark_phase(pic);
- gc_sweep_phase(pic);
-
-#if GC_DEBUG
- for (page = pic->heap->pages; page; page = page->next) {
- union header *bp, *p;
- unsigned char *c;
-
- for (bp = page->basep; ; bp = bp->s.ptr) {
- for (c = (unsigned char *)(bp+1); c != (unsigned char *)(bp + bp->s.size); ++c) {
- assert(*c == 0xAA);
- }
- for (p = bp + bp->s.size; p != bp->s.ptr; p += p->s.size) {
- if (p == page->endp) {
- /* if (page->next) */
- /* assert(bp->s.ptr == page->next->basep); */
- /* else */
- /* assert(bp->s.ptr == &pic->heap->base); */
- goto escape;
- }
- assert(! gc_is_marked(p));
- }
- }
- escape:
- ((void)0);
- }
-
- puts("not error on heap found! gc successfully finished");
-#endif
-}
-
-struct pic_object *
-pic_obj_alloc_unsafe(pic_state *pic, size_t size, enum pic_tt tt)
-{
- struct pic_object *obj;
-
-#if GC_DEBUG
- printf("*allocating: %s\n", pic_type_repr(tt));
-#endif
-
-#if GC_STRESS
- pic_gc_run(pic);
-#endif
-
- obj = (struct pic_object *)gc_alloc(pic, size);
- if (obj == NULL) {
- pic_gc_run(pic);
- obj = (struct pic_object *)gc_alloc(pic, size);
- if (obj == NULL) {
- add_heap_page(pic);
- obj = (struct pic_object *)gc_alloc(pic, size);
- if (obj == NULL)
- pic_abort(pic, "GC memory exhausted");
- }
- }
- obj->tt = tt;
-
- return obj;
-}
-
-struct pic_object *
-pic_obj_alloc(pic_state *pic, size_t size, enum pic_tt tt)
-{
- struct pic_object *obj;
-
- obj = pic_obj_alloc_unsafe(pic, size, tt);
-
- gc_protect(pic, obj);
- return obj;
-}
diff --git a/src/init.c b/src/init.c
index 7f869048..76b51d35 100644
--- a/src/init.c
+++ b/src/init.c
@@ -6,10 +6,6 @@
#include "picrin.h"
#include "picrin/pair.h"
-#include "picrin/read.h"
-#include "picrin/lib.h"
-#include "picrin/macro.h"
-#include "picrin/error.h"
static pic_value
pic_features(pic_state *pic)
@@ -39,87 +35,19 @@ pic_libraries(pic_state *pic)
return libs;
}
-void pic_init_bool(pic_state *);
-void pic_init_pair(pic_state *);
-void pic_init_port(pic_state *);
-void pic_init_number(pic_state *);
-void pic_init_time(pic_state *);
-void pic_init_system(pic_state *);
-void pic_init_file(pic_state *);
-void pic_init_proc(pic_state *);
-void pic_init_symbol(pic_state *);
-void pic_init_vector(pic_state *);
-void pic_init_blob(pic_state *);
-void pic_init_cont(pic_state *);
-void pic_init_char(pic_state *);
-void pic_init_error(pic_state *);
-void pic_init_str(pic_state *);
-void pic_init_macro(pic_state *);
-void pic_init_var(pic_state *);
-void pic_init_load(pic_state *);
-void pic_init_write(pic_state *);
-void pic_init_read(pic_state *);
-void pic_init_dict(pic_state *);
-void pic_init_record(pic_state *);
-void pic_init_eval(pic_state *);
-void pic_init_lib(pic_state *);
void pic_init_contrib(pic_state *);
-
void pic_load_piclib(pic_state *);
-#define DONE pic_gc_arena_restore(pic, ai);
-
void
-pic_init_core(pic_state *pic)
+pic_init_misc(pic_state *pic)
{
- size_t ai = pic_gc_arena_preserve(pic);
-
- pic_init_reader(pic);
-
- pic_deflibrary (pic, "(picrin base core)") {
- pic_define_syntactic_keyword(pic, pic->lib->env, pic->sDEFINE, pic->rDEFINE);
- pic_define_syntactic_keyword(pic, pic->lib->env, pic->sSETBANG, pic->rSETBANG);
- pic_define_syntactic_keyword(pic, pic->lib->env, pic->sQUOTE, pic->rQUOTE);
- pic_define_syntactic_keyword(pic, pic->lib->env, pic->sLAMBDA, pic->rLAMBDA);
- pic_define_syntactic_keyword(pic, pic->lib->env, pic->sIF, pic->rIF);
- pic_define_syntactic_keyword(pic, pic->lib->env, pic->sBEGIN, pic->rBEGIN);
- pic_define_syntactic_keyword(pic, pic->lib->env, pic->sDEFINE_SYNTAX, pic->rDEFINE_SYNTAX);
- }
-
pic_deflibrary (pic, "(picrin library)") {
pic_defun(pic, "libraries", pic_libraries);
}
pic_deflibrary (pic, "(scheme base)") {
pic_defun(pic, "features", pic_features);
-
- pic_init_bool(pic); DONE;
- pic_init_pair(pic); DONE;
- pic_init_port(pic); DONE;
- pic_init_number(pic); DONE;
- pic_init_time(pic); DONE;
- pic_init_system(pic); DONE;
- pic_init_file(pic); DONE;
- pic_init_proc(pic); DONE;
- pic_init_symbol(pic); DONE;
- pic_init_vector(pic); DONE;
- pic_init_blob(pic); DONE;
- pic_init_cont(pic); DONE;
- pic_init_char(pic); DONE;
- pic_init_error(pic); DONE;
- pic_init_str(pic); DONE;
- pic_init_macro(pic); DONE;
- pic_init_var(pic); DONE;
- pic_init_load(pic); DONE;
- pic_init_write(pic); DONE;
- pic_init_read(pic); DONE;
- pic_init_dict(pic); DONE;
- pic_init_record(pic); DONE;
- pic_init_eval(pic); DONE;
- pic_init_lib(pic); DONE;
-
- pic_init_contrib(pic); DONE;
-
- pic_load_piclib(pic); DONE;
+ pic_init_contrib(pic);
+ pic_load_piclib(pic);
}
}
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/macro.c b/src/macro.c
index e9c9b64b..84237ebc 100644
--- a/src/macro.c
+++ b/src/macro.c
@@ -3,399 +3,6 @@
*/
#include "picrin.h"
-#include "picrin/pair.h"
-#include "picrin/string.h"
-#include "picrin/proc.h"
-#include "picrin/macro.h"
-#include "picrin/lib.h"
-#include "picrin/error.h"
-#include "picrin/dict.h"
-#include "picrin/cont.h"
-
-pic_sym
-pic_add_rename(pic_state *pic, struct pic_senv *senv, pic_sym sym)
-{
- pic_sym rename;
-
- rename = pic_gensym(pic, sym);
- pic_put_rename(pic, senv, sym, rename);
- return rename;
-}
-
-void
-pic_put_rename(pic_state *pic, struct pic_senv *senv, pic_sym sym, pic_sym rename)
-{
- UNUSED(pic);
-
- xh_put_int(&senv->map, sym, &rename);
-}
-
-bool
-pic_find_rename(pic_state *pic, struct pic_senv *senv, pic_sym sym, pic_sym *rename)
-{
- xh_entry *e;
-
- UNUSED(pic);
-
- if ((e = xh_get_int(&senv->map, sym)) == NULL) {
- return false;
- }
- if (rename != NULL) {
- *rename = xh_val(e, pic_sym);
- }
- return true;
-}
-
-static void
-define_macro(pic_state *pic, pic_sym rename, struct pic_proc *proc, struct pic_senv *senv)
-{
- struct pic_macro *mac;
-
- mac = (struct pic_macro *)pic_obj_alloc(pic, sizeof(struct pic_macro), PIC_TT_MACRO);
- mac->senv = senv;
- mac->proc = proc;
-
- xh_put_int(&pic->macros, rename, &mac);
-}
-
-static struct pic_macro *
-find_macro(pic_state *pic, pic_sym rename)
-{
- xh_entry *e;
-
- if ((e = xh_get_int(&pic->macros, rename)) == NULL) {
- return NULL;
- }
- return xh_val(e, struct pic_macro *);
-}
-
-static pic_sym
-make_identifier(pic_state *pic, pic_sym sym, struct pic_senv *senv)
-{
- pic_sym rename;
-
- while (true) {
- if (pic_find_rename(pic, senv, sym, &rename)) {
- return rename;
- }
- if (! senv->up)
- break;
- senv = senv->up;
- }
- if (! pic_interned_p(pic, sym)) {
- return sym;
- }
- else {
- return pic_gensym(pic, sym);
- }
-}
-
-static pic_value macroexpand(pic_state *, pic_value, struct pic_senv *);
-
-static pic_value
-macroexpand_symbol(pic_state *pic, pic_sym sym, struct pic_senv *senv)
-{
- return pic_sym_value(make_identifier(pic, sym, senv));
-}
-
-static pic_value
-macroexpand_quote(pic_state *pic, pic_value expr)
-{
- return pic_cons(pic, pic_sym_value(pic->rQUOTE), pic_cdr(pic, expr));
-}
-
-static pic_value
-macroexpand_list(pic_state *pic, pic_value obj, struct pic_senv *senv)
-{
- size_t ai = pic_gc_arena_preserve(pic);
- pic_value x, head, tail;
-
- if (pic_pair_p(obj)) {
- head = macroexpand(pic, pic_car(pic, obj), senv);
- tail = macroexpand_list(pic, pic_cdr(pic, obj), senv);
- x = pic_cons(pic, head, tail);
- } else {
- x = macroexpand(pic, obj, senv);
- }
-
- pic_gc_arena_restore(pic, ai);
- pic_gc_protect(pic, x);
- return x;
-}
-
-static pic_value
-macroexpand_lambda(pic_state *pic, pic_value expr, struct pic_senv *senv)
-{
- pic_value formal, body;
- struct pic_senv *in;
- pic_value a;
-
- if (pic_length(pic, expr) < 2) {
- pic_error(pic, "syntax error");
- }
-
- in = pic_senv_new(pic, senv);
-
- for (a = pic_cadr(pic, expr); pic_pair_p(a); a = pic_cdr(pic, a)) {
- pic_value v = pic_car(pic, a);
-
- if (! pic_sym_p(v)) {
- pic_error(pic, "syntax error");
- }
- pic_add_rename(pic, in, pic_sym(v));
- }
- if (pic_sym_p(a)) {
- pic_add_rename(pic, in, pic_sym(a));
- }
- else if (! pic_nil_p(a)) {
- pic_error(pic, "syntax error");
- }
-
- formal = macroexpand_list(pic, pic_cadr(pic, expr), in);
- body = macroexpand_list(pic, pic_cddr(pic, expr), in);
-
- return pic_cons(pic, pic_sym_value(pic->rLAMBDA), pic_cons(pic, formal, body));
-}
-
-static pic_value
-macroexpand_define(pic_state *pic, pic_value expr, struct pic_senv *senv)
-{
- pic_sym sym, rename;
- pic_value var, val;
-
- if (pic_length(pic, expr) != 3) {
- pic_error(pic, "syntax error");
- }
-
- var = pic_cadr(pic, expr);
- if (! pic_sym_p(var)) {
- pic_error(pic, "binding to non-symbol object");
- }
- sym = pic_sym(var);
- if (! pic_find_rename(pic, senv, sym, &rename)) {
- rename = pic_add_rename(pic, senv, sym);
- }
- val = macroexpand(pic, pic_list_ref(pic, expr, 2), senv);
-
- return pic_list3(pic, pic_sym_value(pic->rDEFINE), pic_sym_value(rename), val);
-}
-
-static pic_value
-macroexpand_defsyntax(pic_state *pic, pic_value expr, struct pic_senv *senv)
-{
- pic_value var, val;
- pic_sym sym, rename;
-
- if (pic_length(pic, expr) != 3) {
- pic_error(pic, "syntax error");
- }
-
- var = pic_cadr(pic, expr);
- if (! pic_sym_p(var)) {
- pic_error(pic, "binding to non-symbol object");
- }
- sym = pic_sym(var);
- if (! pic_find_rename(pic, senv, sym, &rename)) {
- rename = pic_add_rename(pic, senv, sym);
- } else {
- pic_warnf(pic, "redefining syntax variable: ~s", pic_sym_value(sym));
- }
-
- val = pic_cadr(pic, pic_cdr(pic, expr));
-
- pic_try {
- val = pic_eval(pic, val, pic->lib);
- } pic_catch {
- pic_errorf(pic, "macroexpand error while definition: %s", pic_errmsg(pic));
- }
-
- if (! pic_proc_p(val)) {
- pic_errorf(pic, "macro definition \"~s\" evaluates to non-procedure object", var);
- }
-
- define_macro(pic, rename, pic_proc_ptr(val), senv);
-
- return pic_none_value();
-}
-
-static pic_value
-macroexpand_macro(pic_state *pic, struct pic_macro *mac, pic_value expr, struct pic_senv *senv)
-{
- pic_value v, args;
-
-#if DEBUG
- puts("before expand-1:");
- pic_debug(pic, expr);
- puts("");
-#endif
-
- if (mac->senv == NULL) { /* legacy macro */
- args = pic_cdr(pic, expr);
- } else {
- args = pic_list3(pic, expr, pic_obj_value(senv), pic_obj_value(mac->senv));
- }
-
- pic_try {
- v = pic_apply(pic, mac->proc, args);
- } pic_catch {
- pic_errorf(pic, "macroexpand error while application: %s", pic_errmsg(pic));
- }
-
-#if DEBUG
- puts("after expand-1:");
- pic_debug(pic, v);
- puts("");
-#endif
-
- return v;
-}
-
-static pic_value
-macroexpand_node(pic_state *pic, pic_value expr, struct pic_senv *senv)
-{
- switch (pic_type(expr)) {
- case PIC_TT_SYMBOL: {
- return macroexpand_symbol(pic, pic_sym(expr), senv);
- }
- case PIC_TT_PAIR: {
- pic_value car;
- struct pic_macro *mac;
-
- if (! pic_list_p(expr)) {
- pic_errorf(pic, "cannot macroexpand improper list: ~s", expr);
- }
-
- car = macroexpand(pic, pic_car(pic, expr), senv);
- if (pic_sym_p(car)) {
- pic_sym tag = pic_sym(car);
-
- if (tag == pic->rDEFINE_SYNTAX) {
- return macroexpand_defsyntax(pic, expr, senv);
- }
- else if (tag == pic->rLAMBDA) {
- return macroexpand_lambda(pic, expr, senv);
- }
- else if (tag == pic->rDEFINE) {
- return macroexpand_define(pic, expr, senv);
- }
- else if (tag == pic->rQUOTE) {
- return macroexpand_quote(pic, expr);
- }
-
- if ((mac = find_macro(pic, tag)) != NULL) {
- return macroexpand_node(pic, macroexpand_macro(pic, mac, expr, senv), senv);
- }
- }
-
- return pic_cons(pic, car, macroexpand_list(pic, pic_cdr(pic, expr), senv));
- }
- default:
- return expr;
- }
-}
-
-static pic_value
-macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv)
-{
- size_t ai = pic_gc_arena_preserve(pic);
- pic_value v;
-
-#if DEBUG
- printf("[macroexpand] expanding... ");
- pic_debug(pic, expr);
- puts("");
-#endif
-
- v = macroexpand_node(pic, expr, senv);
-
- pic_gc_arena_restore(pic, ai);
- pic_gc_protect(pic, v);
- return v;
-}
-
-pic_value
-pic_macroexpand(pic_state *pic, pic_value expr, struct pic_lib *lib)
-{
- struct pic_lib *prev;
- pic_value v;
-
-#if DEBUG
- puts("before expand:");
- pic_debug(pic, expr);
- puts("");
-#endif
-
- /* change library for macro-expansion time processing */
- prev = pic->lib;
- pic->lib = lib;
-
- v = macroexpand(pic, expr, lib->env);
-
- pic->lib = prev;
-
-#if DEBUG
- puts("after expand:");
- pic_debug(pic, v);
- puts("");
-#endif
-
- return v;
-}
-
-struct pic_senv *
-pic_senv_new(pic_state *pic, struct pic_senv *up)
-{
- struct pic_senv *senv;
-
- senv = (struct pic_senv *)pic_obj_alloc(pic, sizeof(struct pic_senv), PIC_TT_SENV);
- senv->up = up;
- xh_init_int(&senv->map, sizeof(pic_sym));
-
- return senv;
-}
-
-struct pic_senv *
-pic_null_syntactic_environment(pic_state *pic)
-{
- struct pic_senv *senv;
-
- senv = pic_senv_new(pic, NULL);
-
- pic_define_syntactic_keyword(pic, senv, pic->sDEFINE_LIBRARY, pic->rDEFINE_LIBRARY);
- pic_define_syntactic_keyword(pic, senv, pic->sIMPORT, pic->rIMPORT);
- pic_define_syntactic_keyword(pic, senv, pic->sEXPORT, pic->rEXPORT);
- pic_define_syntactic_keyword(pic, senv, pic->sIN_LIBRARY, pic->rIN_LIBRARY);
-
- return senv;
-}
-
-void
-pic_define_syntactic_keyword(pic_state *pic, struct pic_senv *senv, pic_sym sym, pic_sym rsym)
-{
- pic_put_rename(pic, senv, sym, rsym);
-
- if (pic->lib && pic->lib->env == senv) {
- pic_export(pic, sym);
- }
-}
-
-void
-pic_defmacro(pic_state *pic, pic_sym name, pic_sym id, pic_func_t func)
-{
- pic_put_rename(pic, pic->lib->env, name, id);
-
- /* symbol registration */
- define_macro(pic, id, pic_proc_new(pic, func, pic_symbol_name(pic, name)), NULL);
-
- /* auto export! */
- pic_export(pic, name);
-}
-
-bool
-pic_identifier_p(pic_state *pic, pic_value obj)
-{
- return pic_sym_p(obj) && ! pic_interned_p(pic, pic_sym(obj));
-}
static pic_value
pic_macro_gensym(pic_state *pic)
@@ -429,66 +36,12 @@ pic_macro_macroexpand(pic_state *pic)
return pic_macroexpand(pic, expr, pic->lib);
}
-static pic_value
-pic_macro_macroexpand_1(pic_state *pic)
-{
- struct pic_senv *senv = pic->lib->env;
- struct pic_macro *mac;
- pic_value expr;
- pic_sym sym;
-
- pic_get_args(pic, "o", &expr);
-
- if (pic_sym_p(expr)) {
- if (pic_interned_p(pic, pic_sym(expr))) {
- return pic_values2(pic, macroexpand_symbol(pic, pic_sym(expr), senv), pic_true_value());
- }
- }
- if (pic_pair_p(expr) && pic_sym_p(pic_car(pic, expr))) {
- sym = make_identifier(pic, pic_sym(pic_car(pic, expr)), senv);
- if ((mac = find_macro(pic, sym)) != NULL) {
- return pic_values2(pic, macroexpand_macro(pic, mac, expr, senv), pic_true_value());
- }
- }
-
- return pic_values2(pic, expr, pic_false_value()); /* no expansion occurred */
-}
-
-static pic_value
-pic_macro_identifier_p(pic_state *pic)
-{
- pic_value obj;
-
- pic_get_args(pic, "o", &obj);
-
- return pic_bool_value(pic_identifier_p(pic, obj));
-}
-
-static pic_value
-pic_macro_make_identifier(pic_state *pic)
-{
- pic_value obj;
- pic_sym sym;
-
- pic_get_args(pic, "mo", &sym, &obj);
-
- pic_assert_type(pic, obj, senv);
-
- return pic_sym_value(make_identifier(pic, sym, pic_senv_ptr(obj)));
-}
-
void
-pic_init_macro(pic_state *pic)
+pic_init_macro2(pic_state *pic)
{
- pic_deflibrary (pic, "(picrin base macro)") {
- pic_defun(pic, "identifier?", pic_macro_identifier_p);
- pic_defun(pic, "make-identifier", pic_macro_make_identifier);
- }
-
pic_deflibrary (pic, "(picrin macro)") {
pic_defun(pic, "gensym", pic_macro_gensym);
pic_defun(pic, "ungensym", pic_macro_ungensym);
pic_defun(pic, "macroexpand", pic_macro_macroexpand);
- pic_defun(pic, "macroexpand-1", pic_macro_macroexpand_1);
}
}
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 <math.h>
-#include <limits.h>
-#include <stdlib.h>
-
-#include "picrin.h"
-#include "picrin/string.h"
-#include "picrin/cont.h"
-
-static int
-gcd(int a, int b)
-{
- if (a > b)
- return gcd(b, a);
- if (a < 0)
- return gcd(-a, b);
- if (a > 0)
- return gcd(b % a, a);
- return b;
-}
-
-static double
-lcm(int a, int b)
-{
- return fabs((double)a * b) / gcd(a, b);
-}
-
-/**
- * Returns the length of string representing val.
- * radix is between 2 and 36 (inclusive).
- * No error checks are performed in this function.
- */
-static int
-number_string_length(int val, int radix)
-{
- long long v = val; /* in case val == INT_MIN */
- int count = 0;
- if (val == 0) {
- return 1;
- }
- if (val < 0) {
- v = - v;
- count = 1;
- }
- while (v > 0) {
- ++count;
- v /= radix;
- }
- return count;
-}
-
-/**
- * Returns the string representing val.
- * radix is between 2 and 36 (inclusive).
- * This function overwrites buffer and stores the result.
- * No error checks are performed in this function. It is caller's responsibility to avoid buffer-overrun.
- */
-static void
-number_string(int val, int radix, int length, char *buffer) {
- const char digits[37] = "0123456789abcdefghijklmnopqrstuvwxyz";
- long long v = val;
- int i;
- if (val == 0) {
- buffer[0] = '0';
- buffer[1] = '\0';
- return;
- }
- if (val < 0) {
- buffer[0] = '-';
- v = -v;
- }
-
- for(i = length - 1; v > 0; --i) {
- buffer[i] = digits[v % radix];
- v /= radix;
- }
- buffer[length] = '\0';
- return;
-}
-
-static pic_value
-pic_number_real_p(pic_state *pic)
-{
- pic_value v;
-
- pic_get_args(pic, "o", &v);
-
- return pic_bool_value(pic_float_p(v) || pic_int_p(v));
-}
-
-static pic_value
-pic_number_integer_p(pic_state *pic)
-{
- pic_value v;
-
- pic_get_args(pic, "o", &v);
-
- if (pic_int_p(v)) {
- return pic_true_value();
- }
- if (pic_float_p(v)) {
- double f = pic_float(v);
-
- if (isinf(f)) {
- return pic_false_value();
- }
-
- if (f == round(f)) {
- return pic_true_value();
- }
- }
- return pic_false_value();
-}
-
-static pic_value
-pic_number_exact_p(pic_state *pic)
-{
- pic_value v;
-
- pic_get_args(pic, "o", &v);
-
- return pic_bool_value(pic_int_p(v));
-}
-
-static pic_value
-pic_number_inexact_p(pic_state *pic)
-{
- pic_value v;
-
- pic_get_args(pic, "o", &v);
-
- return pic_bool_value(pic_float_p(v));
-}
-
-static pic_value
-pic_number_finite_p(pic_state *pic)
-{
- pic_value v;
-
- pic_get_args(pic, "o", &v);
-
- if (pic_int_p(v))
- return pic_true_value();
- if (pic_float_p(v) && ! (isinf(pic_float(v)) || isnan(pic_float(v))))
- return pic_true_value();
- else
- return pic_false_value();
-}
-
-static pic_value
-pic_number_infinite_p(pic_state *pic)
-{
- pic_value v;
-
- pic_get_args(pic, "o", &v);
-
- if (pic_float_p(v) && isinf(pic_float(v)))
- return pic_true_value();
- else
- return pic_false_value();
-}
-
-static pic_value
-pic_number_nan_p(pic_state *pic)
-{
- pic_value v;
-
- pic_get_args(pic, "o", &v);
-
- if (pic_float_p(v) && isnan(pic_float(v)))
- return pic_true_value();
- else
- return pic_false_value();
-}
-
-#define DEFINE_ARITH_CMP(op, name) \
- static pic_value \
- pic_number_##name(pic_state *pic) \
- { \
- size_t argc; \
- pic_value *argv; \
- size_t i; \
- double f,g; \
- \
- pic_get_args(pic, "ff*", &f, &g, &argc, &argv); \
- \
- if (! (f op g)) \
- return pic_false_value(); \
- \
- for (i = 0; i < argc; ++i) { \
- f = g; \
- if (pic_float_p(argv[i])) \
- g = pic_float(argv[i]); \
- else if (pic_int_p(argv[i])) \
- g = pic_int(argv[i]); \
- else \
- pic_error(pic, #op ": number required"); \
- \
- if (! (f op g)) \
- return pic_false_value(); \
- } \
- \
- return pic_true_value(); \
- }
-
-DEFINE_ARITH_CMP(==, eq)
-DEFINE_ARITH_CMP(<, lt)
-DEFINE_ARITH_CMP(>, gt)
-DEFINE_ARITH_CMP(<=, le)
-DEFINE_ARITH_CMP(>=, ge)
-
-static pic_value
-pic_number_zero_p(pic_state *pic)
-{
- double f;
-
- pic_get_args(pic, "f", &f);
-
- return pic_bool_value(f == 0);
-}
-
-static pic_value
-pic_number_positive_p(pic_state *pic)
-{
- double f;
-
- pic_get_args(pic, "f", &f);
-
- return pic_bool_value(f > 0);
-}
-
-static pic_value
-pic_number_negative_p(pic_state *pic)
-{
- double f;
-
- pic_get_args(pic, "f", &f);
-
- return pic_bool_value(f < 0);
-}
-
-static pic_value
-pic_number_odd_p(pic_state *pic)
-{
- int i;
-
- pic_get_args(pic, "i", &i);
-
- return pic_bool_value(i % 2 != 0);
-}
-
-static pic_value
-pic_number_even_p(pic_state *pic)
-{
- int i;
-
- pic_get_args(pic, "i", &i);
-
- return pic_bool_value(i % 2 == 0);
-}
-
-static pic_value
-pic_number_max(pic_state *pic)
-{
- size_t argc;
- pic_value *argv;
- size_t i;
- double f;
- bool e = true;
-
- pic_get_args(pic, "*", &argc, &argv);
-
- f = -INFINITY;
- for (i = 0; i < argc; ++i) {
- if (pic_int_p(argv[i])) {
- f = fmax(f, pic_int(argv[i]));
- }
- else if (pic_float_p(argv[i])) {
- e = false;
- f = fmax(f, pic_float(argv[i]));
- }
- else {
- pic_error(pic, "max: number required");
- }
- }
-
- return e ? pic_int_value(f) : pic_float_value(f);
-}
-
-static pic_value
-pic_number_min(pic_state *pic)
-{
- size_t argc;
- pic_value *argv;
- size_t i;
- double f;
- bool e = true;
-
- pic_get_args(pic, "*", &argc, &argv);
-
- f = INFINITY;
- for (i = 0; i < argc; ++i) {
- if (pic_int_p(argv[i])) {
- f = fmin(f, pic_int(argv[i]));
- }
- else if (pic_float_p(argv[i])) {
- e = false;
- f = fmin(f, pic_float(argv[i]));
- }
- else {
- pic_error(pic, "min: number required");
- }
- }
-
- return e ? pic_int_value(f) : pic_float_value(f);
-}
-
-#define DEFINE_ARITH_OP(op, name, unit) \
- static pic_value \
- pic_number_##name(pic_state *pic) \
- { \
- size_t argc; \
- pic_value *argv; \
- size_t i; \
- double f; \
- bool e = true; \
- \
- pic_get_args(pic, "*", &argc, &argv); \
- \
- f = unit; \
- for (i = 0; i < argc; ++i) { \
- if (pic_int_p(argv[i])) { \
- f op##= pic_int(argv[i]); \
- } \
- else if (pic_float_p(argv[i])) { \
- e = false; \
- f op##= pic_float(argv[i]); \
- } \
- else { \
- pic_error(pic, #op ": number required"); \
- } \
- } \
- \
- return e ? pic_int_value((int)f) : pic_float_value(f); \
- }
-
-DEFINE_ARITH_OP(+, add, 0)
-DEFINE_ARITH_OP(*, mul, 1)
-
-#define DEFINE_ARITH_INV_OP(op, name, unit, exact) \
- static pic_value \
- pic_number_##name(pic_state *pic) \
- { \
- size_t argc; \
- pic_value *argv; \
- size_t i; \
- double f; \
- bool e; \
- \
- pic_get_args(pic, "F*", &f, &e, &argc, &argv); \
- \
- e = e && exact; \
- \
- if (argc == 0) { \
- f = unit op f; \
- } \
- for (i = 0; i < argc; ++i) { \
- if (pic_int_p(argv[i])) { \
- f op##= pic_int(argv[i]); \
- } \
- else if (pic_float_p(argv[i])) { \
- e = false; \
- f op##= pic_float(argv[i]); \
- } \
- else { \
- pic_error(pic, #op ": number required"); \
- } \
- } \
- \
- return e ? pic_int_value((int)f) : pic_float_value(f); \
- }
-
-DEFINE_ARITH_INV_OP(-, sub, 0, true)
-DEFINE_ARITH_INV_OP(/, div, 1, false)
-
-static pic_value
-pic_number_abs(pic_state *pic)
-{
- double f;
- bool e;
-
- pic_get_args(pic, "F", &f, &e);
-
- if (e) {
- return pic_int_value(fabs(f));
- }
- else {
- return pic_float_value(fabs(f));
- }
-}
-
-static pic_value
-pic_number_floor_quotient(pic_state *pic)
-{
- int i,j;
- bool e1, e2;
-
- pic_get_args(pic, "II", &i, &e1, &j, &e2);
-
- if (e1 && e2) {
- return pic_int_value((int)floor((double)i/j));
- }
- else {
- return pic_float_value(floor((double)i/j));
- }
-}
-
-static pic_value
-pic_number_floor_remainder(pic_state *pic)
-{
- int i,j,q;
- bool e1, e2;
-
- pic_get_args(pic, "II", &i, &e1, &j, &e2);
-
- q = (int)floor((double)i/j);
- if (e1 && e2) {
- return pic_int_value(i - j * q);
- }
- else {
- return pic_float_value(i - j * q);
- }
-}
-
-static pic_value
-pic_number_floor2(pic_state *pic)
-{
- int i, j;
- bool e1, e2;
- double q, r;
-
- pic_get_args(pic, "II", &i, &e1, &j, &e2);
-
- q = floor((double)i/j);
- r = i - j * q;
-
- if (e1 && e2) {
- return pic_values2(pic, pic_int_value(q), pic_int_value(r));
- }
- else {
- return pic_values2(pic, pic_float_value(q), pic_float_value(r));
- }
-}
-
-static pic_value
-pic_number_trunc_quotient(pic_state *pic)
-{
- int i,j;
- bool e1, e2;
-
- pic_get_args(pic, "II", &i, &e1, &j, &e2);
-
- if (e1 && e2) {
- return pic_int_value((int)trunc((double)i/j));
- }
- else {
- return pic_float_value(trunc((double)i/j));
- }
-}
-
-static pic_value
-pic_number_trunc_remainder(pic_state *pic)
-{
- int i,j,q;
- bool e1, e2;
-
- pic_get_args(pic, "II", &i, &e1, &j, &e2);
-
- q = (int)trunc((double)i/j);
- if (e1 && e2) {
- return pic_int_value(i - j * q);
- }
- else {
- return pic_float_value(i - j * q);
- }
-}
-
-static pic_value
-pic_number_trunc2(pic_state *pic)
-{
- int i, j;
- bool e1, e2;
- double q, r;
-
- pic_get_args(pic, "II", &i, &e1, &j, &e2);
-
- q = trunc((double)i/j);
- r = i - j * q;
-
- if (e1 && e2) {
- return pic_values2(pic, pic_int_value(q), pic_int_value(r));
- }
- else {
- return pic_values2(pic, pic_float_value(q), pic_float_value(r));
- }
-}
-
-static pic_value
-pic_number_gcd(pic_state *pic)
-{
- size_t argc;
- pic_value *args;
- int r;
- bool e = true;
-
- pic_get_args(pic, "*", &argc, &args);
-
- r = 0;
- while (argc-- > 0) {
- if (pic_int_p(args[argc])) {
- r = gcd(r, pic_int(args[argc]));
- }
- else if (pic_float_p(args[argc])) {
- e = false;
- r = gcd(r, pic_float(args[argc]));
- }
- else {
- pic_error(pic, "gcd: number required");
- }
- }
- return e ? pic_int_value(r) : pic_float_value(r);
-}
-
-static pic_value
-pic_number_lcm(pic_state *pic)
-{
- size_t argc;
- pic_value *args;
- double r;
- bool e = true;
-
- pic_get_args(pic, "*", &argc, &args);
-
- r = 1;
- while (argc-- > 0) {
- if (pic_int_p(args[argc])) {
- r = lcm(r, pic_int(args[argc]));
- }
- else if (pic_float_p(args[argc])) {
- e = false;
- r = lcm(r, pic_float(args[argc]));
- }
- else {
- pic_error(pic, "lcm: number required");
- }
- }
- return e && pic_valid_int(r) ? pic_int_value(r) : pic_float_value(r);
-}
-
-static pic_value
-pic_number_floor(pic_state *pic)
-{
- double f;
- bool e;
-
- pic_get_args(pic, "F", &f, &e);
-
- if (e) {
- return pic_int_value((int)f);
- }
- else {
- return pic_float_value(floor(f));
- }
-}
-
-static pic_value
-pic_number_ceil(pic_state *pic)
-{
- double f;
- bool e;
-
- pic_get_args(pic, "F", &f, &e);
-
- if (e) {
- return pic_int_value((int)f);
- }
- else {
- return pic_float_value(ceil(f));
- }
-}
-
-static pic_value
-pic_number_trunc(pic_state *pic)
-{
- double f;
- bool e;
-
- pic_get_args(pic, "F", &f, &e);
-
- if (e) {
- return pic_int_value((int)f);
- }
- else {
- return pic_float_value(trunc(f));
- }
-}
-
-static pic_value
-pic_number_round(pic_state *pic)
-{
- double f;
- bool e;
-
- pic_get_args(pic, "F", &f, &e);
-
- if (e) {
- return pic_int_value((int)f);
- }
- else {
- return pic_float_value(round(f));
- }
-}
-
-static pic_value
-pic_number_exp(pic_state *pic)
-{
- double f;
-
- pic_get_args(pic, "f", &f);
- return pic_float_value(exp(f));
-}
-
-static pic_value
-pic_number_log(pic_state *pic)
-{
- double f,g;
- int argc;
-
- argc = pic_get_args(pic, "f|f", &f, &g);
- if (argc == 1) {
- return pic_float_value(log(f));
- }
- else {
- return pic_float_value(log(f) / log(g));
- }
-}
-
-static pic_value
-pic_number_sin(pic_state *pic)
-{
- double f;
-
- pic_get_args(pic, "f", &f);
- f = sin(f);
- return pic_float_value(f);
-}
-
-static pic_value
-pic_number_cos(pic_state *pic)
-{
- double f;
-
- pic_get_args(pic, "f", &f);
- f = cos(f);
- return pic_float_value(f);
-}
-
-static pic_value
-pic_number_tan(pic_state *pic)
-{
- double f;
-
- pic_get_args(pic, "f", &f);
- f = tan(f);
- return pic_float_value(f);
-}
-
-static pic_value
-pic_number_acos(pic_state *pic)
-{
- double f;
-
- pic_get_args(pic, "f", &f);
- f = acos(f);
- return pic_float_value(f);
-}
-
-static pic_value
-pic_number_asin(pic_state *pic)
-{
- double f;
-
- pic_get_args(pic, "f", &f);
- f = asin(f);
- return pic_float_value(f);
-}
-
-static pic_value
-pic_number_atan(pic_state *pic)
-{
- double f,g;
- int argc;
-
- argc = pic_get_args(pic, "f|f", &f, &g);
- if (argc == 1) {
- f = atan(f);
- return pic_float_value(f);
- }
- else {
- return pic_float_value(atan2(f,g));
- }
-}
-
-static pic_value
-pic_number_exact_integer_sqrt(pic_state *pic)
-{
- int k, n, m;
-
- pic_get_args(pic, "i", &k);
-
- n = sqrt(k);
- m = k - n * n;
-
- return pic_values2(pic, pic_int_value(n), pic_int_value(m));
-}
-
-static pic_value
-pic_number_square(pic_state *pic)
-{
- double f;
- bool e;
-
- pic_get_args(pic, "F", &f, &e);
-
- if (e) {
- long long i = (long long)f;
-
- if (i * i <= INT_MAX) {
- return pic_int_value(i * i);
- }
- }
- return pic_float_value(f * f);
-}
-
-static pic_value
-pic_number_sqrt(pic_state *pic)
-{
- double f;
-
- pic_get_args(pic, "f", &f);
-
- return pic_float_value(sqrt(f));
-}
-
-static pic_value
-pic_number_expt(pic_state *pic)
-{
- double f, g, h;
- bool e1, e2;
-
- pic_get_args(pic, "FF", &f, &e1, &g, &e2);
-
- h = pow(f, g);
- if (e1 && e2) {
- if (h <= INT_MAX) {
- return pic_int_value((int)h);
- }
- }
- return pic_float_value(h);
-}
-
-static pic_value
-pic_number_inexact(pic_state *pic)
-{
- double f;
-
- pic_get_args(pic, "f", &f);
-
- return pic_float_value(f);
-}
-
-static pic_value
-pic_number_exact(pic_state *pic)
-{
- double f;
-
- pic_get_args(pic, "f", &f);
-
- return pic_int_value((int)round(f));
-}
-
-static pic_value
-pic_number_number_to_string(pic_state *pic)
-{
- double f;
- bool e;
- int radix = 10;
-
- pic_get_args(pic, "F|i", &f, &e, &radix);
-
- if (radix < 2 || radix > 36) {
- pic_errorf(pic, "number->string: invalid radix %d (between 2 and 36, inclusive)", radix);
- }
-
- if (e) {
- int ival = (int) f;
- int ilen = number_string_length(ival, radix);
- char buf[ilen + 1];
-
- number_string(ival, radix, ilen, buf);
-
- return pic_obj_value(pic_str_new(pic, buf, sizeof buf - 1));
- }
- else {
- char buf[snprintf(NULL, 0, "%a", f) + 1];
-
- snprintf(buf, sizeof buf, "%a", f);
-
- return pic_obj_value(pic_str_new(pic, buf, sizeof buf - 1));
- }
-}
-
-static pic_value
-pic_number_string_to_number(pic_state *pic)
-{
- const char *str;
- int radix = 10;
- long num;
- char *eptr;
- double flo;
-
- pic_get_args(pic, "z|i", &str, &radix);
-
- num = strtol(str, &eptr, radix);
- if (*eptr == '\0') {
- return pic_valid_int(num)
- ? pic_int_value(num)
- : pic_float_value(num);
- }
-
- flo = strtod(str, &eptr);
- if (*eptr == '\0') {
- return pic_float_value(flo);
- }
-
- pic_errorf(pic, "invalid string given: %s", str);
-}
-
-void
-pic_init_number(pic_state *pic)
-{
- size_t ai = pic_gc_arena_preserve(pic);
-
- pic_defun(pic, "number?", pic_number_real_p);
- pic_defun(pic, "complex?", pic_number_real_p);
- pic_defun(pic, "real?", pic_number_real_p);
- pic_defun(pic, "rational?", pic_number_real_p);
- pic_defun(pic, "integer?", pic_number_integer_p);
- pic_gc_arena_restore(pic, ai);
-
- pic_defun(pic, "exact?", pic_number_exact_p);
- pic_defun(pic, "inexact?", pic_number_inexact_p);
- pic_defun(pic, "exact-integer?", pic_number_exact_p);
- pic_gc_arena_restore(pic, ai);
-
- pic_defun(pic, "=", pic_number_eq);
- pic_defun(pic, "<", pic_number_lt);
- pic_defun(pic, ">", pic_number_gt);
- pic_defun(pic, "<=", pic_number_le);
- pic_defun(pic, ">=", pic_number_ge);
- pic_gc_arena_restore(pic, ai);
-
- pic_defun(pic, "zero?", pic_number_zero_p);
- pic_defun(pic, "positive?", pic_number_positive_p);
- pic_defun(pic, "negative?", pic_number_negative_p);
- pic_defun(pic, "odd?", pic_number_odd_p);
- pic_defun(pic, "even?", pic_number_even_p);
- pic_gc_arena_restore(pic, ai);
-
- pic_defun(pic, "min", pic_number_min);
- pic_defun(pic, "max", pic_number_max);
- pic_gc_arena_restore(pic, ai);
-
- pic_defun(pic, "+", pic_number_add);
- pic_defun(pic, "-", pic_number_sub);
- pic_defun(pic, "*", pic_number_mul);
- pic_defun(pic, "/", pic_number_div);
- pic_gc_arena_restore(pic, ai);
-
- pic_defun(pic, "abs", pic_number_abs);
- pic_defun(pic, "floor-quotient", pic_number_floor_quotient);
- pic_defun(pic, "floor-remainder", pic_number_floor_remainder);
- pic_defun(pic, "floor/", pic_number_floor2);
- pic_defun(pic, "truncate-quotient", pic_number_trunc_quotient);
- pic_defun(pic, "truncate-remainder", pic_number_trunc_remainder);
- pic_defun(pic, "truncate/", pic_number_trunc2);
- pic_defun(pic, "modulo", pic_number_floor_remainder);
- pic_defun(pic, "quotient", pic_number_trunc_quotient);
- pic_defun(pic, "remainder", pic_number_trunc_remainder);
- pic_gc_arena_restore(pic, ai);
-
- pic_defun(pic, "gcd", pic_number_gcd);
- pic_defun(pic, "lcm", pic_number_lcm);
- pic_gc_arena_restore(pic, ai);
-
- pic_defun(pic, "floor", pic_number_floor);
- pic_defun(pic, "ceiling", pic_number_ceil);
- pic_defun(pic, "truncate", pic_number_trunc);
- pic_defun(pic, "round", pic_number_round);
- pic_gc_arena_restore(pic, ai);
-
- pic_defun(pic, "exact-integer-sqrt", pic_number_exact_integer_sqrt);
- pic_defun(pic, "square", pic_number_square);
- pic_defun(pic, "expt", pic_number_expt);
- pic_gc_arena_restore(pic, ai);
-
- pic_defun(pic, "inexact", pic_number_inexact);
- pic_defun(pic, "exact", pic_number_exact);
- pic_gc_arena_restore(pic, ai);
-
- pic_defun(pic, "number->string", pic_number_number_to_string);
- pic_defun(pic, "string->number", pic_number_string_to_number);
- pic_gc_arena_restore(pic, ai);
-
- pic_deflibrary (pic, "(scheme inexact)") {
- pic_defun(pic, "finite?", pic_number_finite_p);
- pic_defun(pic, "infinite?", pic_number_infinite_p);
- pic_defun(pic, "nan?", pic_number_nan_p);
-
- pic_defun(pic, "exp", pic_number_exp);
- pic_defun(pic, "log", pic_number_log);
- pic_defun(pic, "sin", pic_number_sin);
- pic_defun(pic, "cos", pic_number_cos);
- pic_defun(pic, "tan", pic_number_tan);
- pic_defun(pic, "acos", pic_number_acos);
- pic_defun(pic, "asin", pic_number_asin);
- pic_defun(pic, "atan", pic_number_atan);
-
- pic_defun(pic, "sqrt", pic_number_sqrt);
- }
-}
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 <stdarg.h>
-
-#include "picrin.h"
-#include "picrin/pair.h"
-
-pic_value
-pic_cons(pic_state *pic, pic_value car, pic_value cdr)
-{
- struct pic_pair *pair;
-
- pair = (struct pic_pair *)pic_obj_alloc(pic, sizeof(struct pic_pair), PIC_TT_PAIR);
- pair->car = car;
- pair->cdr = cdr;
-
- return pic_obj_value(pair);
-}
-
-pic_value
-pic_car(pic_state *pic, pic_value obj)
-{
- struct pic_pair *pair;
-
- if (! pic_pair_p(obj)) {
- pic_errorf(pic, "pair required, but got ~s", obj);
- }
- pair = pic_pair_ptr(obj);
-
- return pair->car;
-}
-
-pic_value
-pic_cdr(pic_state *pic, pic_value obj)
-{
- struct pic_pair *pair;
-
- if (! pic_pair_p(obj)) {
- pic_errorf(pic, "pair required, but got ~s", obj);
- }
- pair = pic_pair_ptr(obj);
-
- return pair->cdr;
-}
-
-void
-pic_set_car(pic_state *pic, pic_value obj, pic_value val)
-{
- struct pic_pair *pair;
-
- if (! pic_pair_p(obj)) {
- pic_error(pic, "pair required");
- }
- pair = pic_pair_ptr(obj);
-
- pair->car = val;
-}
-
-void
-pic_set_cdr(pic_state *pic, pic_value obj, pic_value val)
-{
- struct pic_pair *pair;
-
- if (! pic_pair_p(obj)) {
- pic_error(pic, "pair required");
- }
- pair = pic_pair_ptr(obj);
-
- pair->cdr = val;
-}
-
-bool
-pic_list_p(pic_value obj)
-{
- pic_value local, rapid;
- int i;
-
- /* Floyd's cycle-finding algorithm. */
-
- local = rapid = obj;
- while (true) {
-
- /* advance rapid fast-forward; runs 2x faster than local */
- for (i = 0; i < 2; ++i) {
- if (pic_pair_p(rapid)) {
- rapid = pic_pair_ptr(rapid)->cdr;
- }
- else {
- return pic_nil_p(rapid);
- }
- }
-
- /* advance local */
- local = pic_pair_ptr(local)->cdr;
-
- if (pic_eq_p(local, rapid)) {
- return false;
- }
- }
-}
-
-pic_value
-pic_list1(pic_state *pic, pic_value obj1)
-{
- return pic_cons(pic, obj1, pic_nil_value());
-}
-
-pic_value
-pic_list2(pic_state *pic, pic_value obj1, pic_value obj2)
-{
- size_t ai = pic_gc_arena_preserve(pic);
- pic_value val;
-
- val = pic_cons(pic, obj1, pic_list1(pic, obj2));
-
- pic_gc_arena_restore(pic, ai);
- pic_gc_protect(pic, val);
- return val;
-}
-
-pic_value
-pic_list3(pic_state *pic, pic_value obj1, pic_value obj2, pic_value obj3)
-{
- size_t ai = pic_gc_arena_preserve(pic);
- pic_value val;
-
- val = pic_cons(pic, obj1, pic_list2(pic, obj2, obj3));
-
- pic_gc_arena_restore(pic, ai);
- pic_gc_protect(pic, val);
- return val;
-}
-
-pic_value
-pic_list4(pic_state *pic, pic_value obj1, pic_value obj2, pic_value obj3, pic_value obj4)
-{
- size_t ai = pic_gc_arena_preserve(pic);
- pic_value val;
-
- val = pic_cons(pic, obj1, pic_list3(pic, obj2, obj3, obj4));
-
- pic_gc_arena_restore(pic, ai);
- pic_gc_protect(pic, val);
- return val;
-}
-
-pic_value
-pic_list5(pic_state *pic, pic_value obj1, pic_value obj2, pic_value obj3, pic_value obj4, pic_value obj5)
-{
- size_t ai = pic_gc_arena_preserve(pic);
- pic_value val;
-
- val = pic_cons(pic, obj1, pic_list4(pic, obj2, obj3, obj4, obj5));
-
- pic_gc_arena_restore(pic, ai);
- pic_gc_protect(pic, val);
- return val;
-}
-
-pic_value
-pic_list6(pic_state *pic, pic_value obj1, pic_value obj2, pic_value obj3, pic_value obj4, pic_value obj5, pic_value obj6)
-{
- size_t ai = pic_gc_arena_preserve(pic);
- pic_value val;
-
- val = pic_cons(pic, obj1, pic_list5(pic, obj2, obj3, obj4, obj5, obj6));
-
- pic_gc_arena_restore(pic, ai);
- pic_gc_protect(pic, val);
- return val;
-}
-
-pic_value
-pic_list7(pic_state *pic, pic_value obj1, pic_value obj2, pic_value obj3, pic_value obj4, pic_value obj5, pic_value obj6, pic_value obj7)
-{
- size_t ai = pic_gc_arena_preserve(pic);
- pic_value val;
-
- val = pic_cons(pic, obj1, pic_list6(pic, obj2, obj3, obj4, obj5, obj6, obj7));
-
- pic_gc_arena_restore(pic, ai);
- pic_gc_protect(pic, val);
- return val;
-}
-
-pic_value
-pic_list_by_array(pic_state *pic, size_t c, pic_value *vs)
-{
- pic_value v;
-
- v = pic_nil_value();
- while (c--) {
- v = pic_cons(pic, vs[c], v);
- }
- return v;
-}
-
-pic_value
-pic_make_list(pic_state *pic, int k, pic_value fill)
-{
- pic_value list;
- int i;
-
- list = pic_nil_value();
- for (i = 0; i < k; ++i) {
- list = pic_cons(pic, fill, list);
- }
-
- return list;
-}
-
-int
-pic_length(pic_state *pic, pic_value obj)
-{
- int c = 0;
-
- if (! pic_list_p(obj)) {
- pic_errorf(pic, "length: expected list, but got ~s", obj);
- }
-
- while (! pic_nil_p(obj)) {
- obj = pic_cdr(pic, obj);
- ++c;
- }
-
- return c;
-}
-
-pic_value
-pic_reverse(pic_state *pic, pic_value list)
-{
- size_t ai = pic_gc_arena_preserve(pic);
- pic_value v, acc;
-
- acc = pic_nil_value();
- pic_for_each(v, list) {
- acc = pic_cons(pic, v, acc);
-
- pic_gc_arena_restore(pic, ai);
- pic_gc_protect(pic, acc);
- }
- return acc;
-}
-
-pic_value
-pic_append(pic_state *pic, pic_value xs, pic_value ys)
-{
- size_t ai = pic_gc_arena_preserve(pic);
- pic_value x;
-
- xs = pic_reverse(pic, xs);
- pic_for_each (x, xs) {
- ys = pic_cons(pic, x, ys);
-
- pic_gc_arena_restore(pic, ai);
- pic_gc_protect(pic, xs);
- pic_gc_protect(pic, ys);
- }
- return ys;
-}
-
-pic_value
-pic_memq(pic_state *pic, pic_value key, pic_value list)
-{
- enter:
-
- if (pic_nil_p(list))
- return pic_false_value();
-
- if (pic_eq_p(key, pic_car(pic, list)))
- return list;
-
- list = pic_cdr(pic, list);
- goto enter;
-}
-
-pic_value
-pic_memv(pic_state *pic, pic_value key, pic_value list)
-{
- enter:
-
- if (pic_nil_p(list))
- return pic_false_value();
-
- if (pic_eqv_p(key, pic_car(pic, list)))
- return list;
-
- list = pic_cdr(pic, list);
- goto enter;
-}
-
-pic_value
-pic_member(pic_state *pic, pic_value key, pic_value list, struct pic_proc *compar)
-{
- enter:
-
- if (pic_nil_p(list))
- return pic_false_value();
-
- if (compar == NULL) {
- if (pic_equal_p(pic, key, pic_car(pic, list)))
- return list;
- } else {
- if (pic_test(pic_apply2(pic, compar, key, pic_car(pic, list))))
- return list;
- }
-
- list = pic_cdr(pic, list);
- goto enter;
-}
-
-pic_value
-pic_assq(pic_state *pic, pic_value key, pic_value assoc)
-{
- pic_value cell;
-
- enter:
-
- if (pic_nil_p(assoc))
- return pic_false_value();
-
- cell = pic_car(pic, assoc);
- if (pic_eq_p(key, pic_car(pic, cell)))
- return cell;
-
- assoc = pic_cdr(pic, assoc);
- goto enter;
-}
-
-pic_value
-pic_assv(pic_state *pic, pic_value key, pic_value assoc)
-{
- pic_value cell;
-
- enter:
-
- if (pic_nil_p(assoc))
- return pic_false_value();
-
- cell = pic_car(pic, assoc);
- if (pic_eqv_p(key, pic_car(pic, cell)))
- return cell;
-
- assoc = pic_cdr(pic, assoc);
- goto enter;
-}
-
-pic_value
-pic_assoc(pic_state *pic, pic_value key, pic_value assoc, struct pic_proc *compar)
-{
- pic_value cell;
-
- enter:
-
- if (pic_nil_p(assoc))
- return pic_false_value();
-
- cell = pic_car(pic, assoc);
- if (compar == NULL) {
- if (pic_equal_p(pic, key, pic_car(pic, cell)))
- return cell;
- } else {
- if (pic_test(pic_apply2(pic, compar, key, pic_car(pic, cell))))
- return cell;
- }
-
- assoc = pic_cdr(pic, assoc);
- goto enter;
-}
-
-pic_value
-pic_acons(pic_state *pic, pic_value key, pic_value val, pic_value assoc)
-{
- return pic_cons(pic, pic_cons(pic, key, val), assoc);
-}
-
-pic_value
-pic_caar(pic_state *pic, pic_value v)
-{
- return pic_car(pic, pic_car(pic, v));
-}
-
-pic_value
-pic_cadr(pic_state *pic, pic_value v)
-{
- return pic_car(pic, pic_cdr(pic, v));
-}
-
-pic_value
-pic_cdar(pic_state *pic, pic_value v)
-{
- return pic_cdr(pic, pic_car(pic, v));
-}
-
-pic_value
-pic_cddr(pic_state *pic, pic_value v)
-{
- return pic_cdr(pic, pic_cdr(pic, v));
-}
-
-pic_value
-pic_list_tail(pic_state *pic, pic_value list, int i)
-{
- while (i-- > 0) {
- list = pic_cdr(pic, list);
- }
- return list;
-}
-
-pic_value
-pic_list_ref(pic_state *pic, pic_value list, int i)
-{
- return pic_car(pic, pic_list_tail(pic, list, i));
-}
-
-void
-pic_list_set(pic_state *pic, pic_value list, int i, pic_value obj)
-{
- pic_pair_ptr(pic_list_tail(pic, list, i))->car = obj;
-}
-
-pic_value
-pic_list_copy(pic_state *pic, pic_value obj)
-{
- if (pic_pair_p(obj)) {
- return pic_cons(pic, pic_car(pic, obj), pic_list_copy(pic, pic_cdr(pic, obj)));
- }
- else {
- return obj;
- }
-}
-
-static pic_value
-pic_pair_pair_p(pic_state *pic)
-{
- pic_value v;
-
- pic_get_args(pic, "o", &v);
-
- return pic_bool_value(pic_pair_p(v));
-}
-
-static pic_value
-pic_pair_cons(pic_state *pic)
-{
- pic_value v,w;
-
- pic_get_args(pic, "oo", &v, &w);
-
- return pic_cons(pic, v, w);
-}
-
-static pic_value
-pic_pair_car(pic_state *pic)
-{
- pic_value v;
-
- pic_get_args(pic, "o", &v);
-
- return pic_car(pic, v);
-}
-
-static pic_value
-pic_pair_cdr(pic_state *pic)
-{
- pic_value v;
-
- pic_get_args(pic, "o", &v);
-
- return pic_cdr(pic, v);
-}
-
-static pic_value
-pic_pair_caar(pic_state *pic)
-{
- pic_value v;
-
- pic_get_args(pic, "o", &v);
-
- return pic_caar(pic, v);
-}
-
-static pic_value
-pic_pair_cadr(pic_state *pic)
-{
- pic_value v;
-
- pic_get_args(pic, "o", &v);
-
- return pic_cadr(pic, v);
-}
-
-static pic_value
-pic_pair_cdar(pic_state *pic)
-{
- pic_value v;
-
- pic_get_args(pic, "o", &v);
-
- return pic_cdar(pic, v);
-}
-
-static pic_value
-pic_pair_cddr(pic_state *pic)
-{
- pic_value v;
-
- pic_get_args(pic, "o", &v);
-
- return pic_cddr(pic, v);
-}
-
-static pic_value
-pic_pair_set_car(pic_state *pic)
-{
- pic_value v,w;
-
- pic_get_args(pic, "oo", &v, &w);
-
- if (! pic_pair_p(v))
- pic_error(pic, "pair expected");
-
- pic_pair_ptr(v)->car = w;
- return pic_none_value();
-}
-
-static pic_value
-pic_pair_set_cdr(pic_state *pic)
-{
- pic_value v,w;
-
- pic_get_args(pic, "oo", &v, &w);
-
- if (! pic_pair_p(v))
- pic_error(pic, "pair expected");
-
- pic_pair_ptr(v)->cdr = w;
- return pic_none_value();
-}
-
-static pic_value
-pic_pair_null_p(pic_state *pic)
-{
- pic_value v;
-
- pic_get_args(pic, "o", &v);
-
- return pic_bool_value(pic_nil_p(v));
-}
-
-static pic_value
-pic_pair_list_p(pic_state *pic)
-{
- pic_value v;
-
- pic_get_args(pic, "o", &v);
-
- return pic_bool_value(pic_list_p(v));
-}
-
-static pic_value
-pic_pair_make_list(pic_state *pic)
-{
- int i;
- pic_value fill = pic_none_value();
-
- pic_get_args(pic, "i|o", &i, &fill);
-
- return pic_make_list(pic, i, fill);
-}
-
-static pic_value
-pic_pair_list(pic_state *pic)
-{
- size_t argc;
- pic_value *argv;
-
- pic_get_args(pic, "*", &argc, &argv);
-
- return pic_list_by_array(pic, argc, argv);
-}
-
-static pic_value
-pic_pair_length(pic_state *pic)
-{
- pic_value list;
-
- pic_get_args(pic, "o", &list);
-
- return pic_int_value(pic_length(pic, list));
-}
-
-static pic_value
-pic_pair_append(pic_state *pic)
-{
- size_t argc;
- pic_value *args, list;
-
- pic_get_args(pic, "*", &argc, &args);
-
- if (argc == 0) {
- return pic_nil_value();
- }
-
- list = args[--argc];
-
- while (argc-- > 0) {
- list = pic_append(pic, args[argc], list);
- }
- return list;
-}
-
-static pic_value
-pic_pair_reverse(pic_state *pic)
-{
- pic_value list;
-
- pic_get_args(pic, "o", &list);
-
- return pic_reverse(pic, list);
-}
-
-static pic_value
-pic_pair_list_tail(pic_state *pic)
-{
- pic_value list;
- int i;
-
- pic_get_args(pic, "oi", &list, &i);
-
- return pic_list_tail(pic, list, i);
-}
-
-static pic_value
-pic_pair_list_ref(pic_state *pic)
-{
- pic_value list;
- int i;
-
- pic_get_args(pic, "oi", &list, &i);
-
- return pic_list_ref(pic, list, i);
-}
-
-static pic_value
-pic_pair_list_set(pic_state *pic)
-{
- pic_value list, obj;
- int i;
-
- pic_get_args(pic, "oio", &list, &i, &obj);
-
- pic_list_set(pic, list, i, obj);
-
- return pic_none_value();
-}
-
-static pic_value
-pic_pair_list_copy(pic_state *pic)
-{
- pic_value obj;
-
- pic_get_args(pic, "o", &obj);
-
- return pic_list_copy(pic, obj);
-}
-
-static pic_value
-pic_pair_memq(pic_state *pic)
-{
- pic_value key, list;
-
- pic_get_args(pic, "oo", &key, &list);
-
- return pic_memq(pic, key, list);
-}
-
-static pic_value
-pic_pair_memv(pic_state *pic)
-{
- pic_value key, list;
-
- pic_get_args(pic, "oo", &key, &list);
-
- return pic_memv(pic, key, list);
-}
-
-static pic_value
-pic_pair_member(pic_state *pic)
-{
- struct pic_proc *proc = NULL;
- pic_value key, list;
-
- pic_get_args(pic, "oo|l", &key, &list, &proc);
-
- return pic_member(pic, key, list, proc);
-}
-
-static pic_value
-pic_pair_assq(pic_state *pic)
-{
- pic_value key, list;
-
- pic_get_args(pic, "oo", &key, &list);
-
- return pic_assq(pic, key, list);
-}
-
-static pic_value
-pic_pair_assv(pic_state *pic)
-{
- pic_value key, list;
-
- pic_get_args(pic, "oo", &key, &list);
-
- return pic_assv(pic, key, list);
-}
-
-static pic_value
-pic_pair_assoc(pic_state *pic)
-{
- struct pic_proc *proc = NULL;
- pic_value key, list;
-
- pic_get_args(pic, "oo|l", &key, &list, &proc);
-
- return pic_assoc(pic, key, list, proc);
-}
-
-void
-pic_init_pair(pic_state *pic)
-{
- pic_deflibrary (pic, "(picrin base list)") {
- pic_defun(pic, "pair?", pic_pair_pair_p);
- pic_defun(pic, "cons", pic_pair_cons);
- pic_defun(pic, "car", pic_pair_car);
- pic_defun(pic, "cdr", pic_pair_cdr);
- pic_defun(pic, "set-car!", pic_pair_set_car);
- pic_defun(pic, "set-cdr!", pic_pair_set_cdr);
- pic_defun(pic, "null?", pic_pair_null_p);
- }
-
- pic_deflibrary (pic, "(picrin list)") {
- pic_defun(pic, "caar", pic_pair_caar);
- pic_defun(pic, "cadr", pic_pair_cadr);
- pic_defun(pic, "cdar", pic_pair_cdar);
- pic_defun(pic, "cddr", pic_pair_cddr);
- pic_defun(pic, "list?", pic_pair_list_p);
- pic_defun(pic, "make-list", pic_pair_make_list);
- pic_defun(pic, "list", pic_pair_list);
- pic_defun(pic, "length", pic_pair_length);
- pic_defun(pic, "append", pic_pair_append);
- pic_defun(pic, "reverse", pic_pair_reverse);
- pic_defun(pic, "list-tail", pic_pair_list_tail);
- pic_defun(pic, "list-ref", pic_pair_list_ref);
- pic_defun(pic, "list-set!", pic_pair_list_set);
- pic_defun(pic, "list-copy", pic_pair_list_copy);
- pic_defun(pic, "memq", pic_pair_memq);
- pic_defun(pic, "memv", pic_pair_memv);
- pic_defun(pic, "member", pic_pair_member);
- pic_defun(pic, "assq", pic_pair_assq);
- pic_defun(pic, "assv", pic_pair_assv);
- pic_defun(pic, "assoc", pic_pair_assoc);
- }
-}
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 <stdlib.h>
-#include <string.h>
-#include <limits.h>
-
-#include "picrin.h"
-#include "picrin/proc.h"
-#include "picrin/port.h"
-#include "picrin/string.h"
-#include "picrin/blob.h"
-#include "picrin/var.h"
-
-pic_value
-pic_eof_object()
-{
- pic_value v;
-
- pic_init_value(v, PIC_VTYPE_EOF);
-
- return v;
-}
-
-struct pic_port *
-pic_stdin(pic_state *pic)
-{
- struct pic_proc *proc;
-
- proc = pic_proc_ptr(pic_ref(pic, "current-input-port"));
-
- return pic_port_ptr(pic_apply(pic, proc, pic_nil_value()));
-}
-
-struct pic_port *
-pic_stdout(pic_state *pic)
-{
- struct pic_proc *proc;
-
- proc = pic_proc_ptr(pic_ref(pic, "current-output-port"));
-
- return pic_port_ptr(pic_apply(pic, proc, pic_nil_value()));
-}
-
-static struct pic_port *
-port_new_stdport(pic_state *pic, xFILE *file, short dir)
-{
- struct pic_port *port;
-
- port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port), PIC_TT_PORT);
- port->file = file;
- port->flags = dir | PIC_PORT_TEXT;
- port->status = PIC_PORT_OPEN;
- return port;
-}
-
-struct pic_port *
-pic_open_input_string(pic_state *pic, const char *str)
-{
- struct pic_port *port;
-
- port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port *), PIC_TT_PORT);
- port->file = xmopen();
- port->flags = PIC_PORT_IN | PIC_PORT_TEXT;
- port->status = PIC_PORT_OPEN;
-
- xfputs(str, port->file);
- xfflush(port->file);
- xrewind(port->file);
-
- return port;
-}
-
-struct pic_port *
-pic_open_output_string(pic_state *pic)
-{
- struct pic_port *port;
-
- port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port *), PIC_TT_PORT);
- port->file = xmopen();
- port->flags = PIC_PORT_OUT | PIC_PORT_TEXT;
- port->status = PIC_PORT_OPEN;
-
- return port;
-}
-
-struct pic_string *
-pic_get_output_string(pic_state *pic, struct pic_port *port)
-{
- long size;
- char *buf;
-
- /* get endpos */
- xfflush(port->file);
- size = xftell(port->file);
- xrewind(port->file);
-
- /* copy to buf */
- buf = (char *)pic_alloc(pic, size + 1);
- buf[size] = 0;
- xfread(buf, size, 1, port->file);
-
- return pic_str_new(pic, buf, size);
-}
-
-void
-pic_close_port(pic_state *pic, struct pic_port *port)
-{
- if (xfclose(port->file) == EOF) {
- pic_error(pic, "close-port: failure");
- }
- port->status = PIC_PORT_CLOSE;
-}
-
-static pic_value
-pic_port_input_port_p(pic_state *pic)
-{
- pic_value v;
-
- pic_get_args(pic, "o", &v);
-
- if (pic_port_p(v) && (pic_port_ptr(v)->flags & PIC_PORT_IN) != 0) {
- return pic_true_value();
- }
- else {
- return pic_false_value();
- }
-}
-
-static pic_value
-pic_port_output_port_p(pic_state *pic)
-{
- pic_value v;
-
- pic_get_args(pic, "o", &v);
-
- if (pic_port_p(v) && (pic_port_ptr(v)->flags & PIC_PORT_OUT) != 0) {
- return pic_true_value();
- }
- else {
- return pic_false_value();
- }
-}
-
-static pic_value
-pic_port_textual_port_p(pic_state *pic)
-{
- pic_value v;
-
- pic_get_args(pic, "o", &v);
-
- if (pic_port_p(v) && (pic_port_ptr(v)->flags & PIC_PORT_TEXT) != 0) {
- return pic_true_value();
- }
- else {
- return pic_false_value();
- }
-}
-
-static pic_value
-pic_port_binary_port_p(pic_state *pic)
-{
- pic_value v;
-
- pic_get_args(pic, "o", &v);
-
- if (pic_port_p(v) && (pic_port_ptr(v)->flags & PIC_PORT_BINARY) != 0) {
- return pic_true_value();
- }
- else {
- return pic_false_value();
- }
-}
-
-static pic_value
-pic_port_port_p(pic_state *pic)
-{
- pic_value v;
-
- pic_get_args(pic, "o", &v);
-
- return pic_bool_value(pic_port_p(v));
-}
-
-static pic_value
-pic_port_input_port_open_p(pic_state *pic)
-{
- pic_value v;
- struct pic_port *port;
-
- pic_get_args(pic, "o", &v);
-
- if (! pic_port_p(v))
- return pic_false_value();
- port = pic_port_ptr(v);
- if ((port->flags & PIC_PORT_IN) == 0)
- return pic_false_value();
-
- return pic_bool_value(port->status == PIC_PORT_OPEN);
-}
-
-static pic_value
-pic_port_output_port_open_p(pic_state *pic)
-{
- pic_value v;
- struct pic_port *port;
-
- pic_get_args(pic, "o", &v);
-
- if (! pic_port_p(v))
- return pic_false_value();
- port = pic_port_ptr(v);
- if ((port->flags & PIC_PORT_OUT) == 0)
- return pic_false_value();
-
- return pic_bool_value(port->status == PIC_PORT_OPEN);
-}
-
-static pic_value
-pic_port_eof_object_p(pic_state *pic)
-{
- pic_value v;
-
- pic_get_args(pic, "o", &v);
-
- if (pic_vtype(v) == PIC_VTYPE_EOF) {
- return pic_true_value();
- }
- else {
- return pic_false_value();
- }
-}
-
-static pic_value
-pic_port_eof_object(pic_state *pic)
-{
- pic_get_args(pic, "");
-
- return pic_eof_object();
-}
-
-static pic_value
-pic_port_close_port(pic_state *pic)
-{
- struct pic_port *port;
-
- pic_get_args(pic, "p", &port);
-
- pic_close_port(pic, port);
-
- return pic_none_value();
-}
-
-#define assert_port_profile(port, flgs, stat, caller) do { \
- if ((port->flags & (flgs)) != (flgs)) { \
- switch (flgs) { \
- case PIC_PORT_IN: \
- pic_error(pic, caller ": expected output port"); \
- case PIC_PORT_OUT: \
- pic_error(pic, caller ": expected input port"); \
- case PIC_PORT_IN | PIC_PORT_TEXT: \
- pic_error(pic, caller ": expected input/textual port"); \
- case PIC_PORT_IN | PIC_PORT_BINARY: \
- pic_error(pic, caller ": expected input/binary port"); \
- case PIC_PORT_OUT | PIC_PORT_TEXT: \
- pic_error(pic, caller ": expected output/textual port"); \
- case PIC_PORT_OUT | PIC_PORT_BINARY: \
- pic_error(pic, caller ": expected output/binary port"); \
- } \
- } \
- if (port->status != stat) { \
- switch (stat) { \
- case PIC_PORT_OPEN: \
- pic_error(pic, caller ": expected open port"); \
- case PIC_PORT_CLOSE: \
- pic_error(pic, caller ": expected close port"); \
- } \
- } \
- } while (0)
-
-static pic_value
-pic_port_open_input_string(pic_state *pic)
-{
- struct pic_port *port;
- char *str;
-
- pic_get_args(pic, "z", &str);
-
- port = pic_open_input_string(pic, str);
-
- return pic_obj_value(port);
-}
-
-static pic_value
-pic_port_open_output_string(pic_state *pic)
-{
- struct pic_port *port;
-
- pic_get_args(pic, "");
-
- port = pic_open_output_string(pic);
-
- return pic_obj_value(port);
-}
-
-static pic_value
-pic_port_get_output_string(pic_state *pic)
-{
- struct pic_port *port = pic_stdout(pic);
-
- pic_get_args(pic, "|p", &port);
-
- assert_port_profile(port, PIC_PORT_OUT | PIC_PORT_TEXT, PIC_PORT_OPEN, "get-output-string");
-
- return pic_obj_value(pic_get_output_string(pic, port));
-}
-
-static pic_value
-pic_port_open_input_blob(pic_state *pic)
-{
- struct pic_port *port;
- struct pic_blob *blob;
-
- pic_get_args(pic, "b", &blob);
-
- port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port *), PIC_TT_PORT);
- port->file = xmopen();
- port->flags = PIC_PORT_IN | PIC_PORT_BINARY;
- port->status = PIC_PORT_OPEN;
-
- xfwrite(blob->data, 1, blob->len, port->file);
- xfflush(port->file);
- xrewind(port->file);
-
- return pic_obj_value(port);
-}
-
-static pic_value
-pic_port_open_output_bytevector(pic_state *pic)
-{
- struct pic_port *port;
-
- pic_get_args(pic, "");
-
- port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port *), PIC_TT_PORT);
- port->file = xmopen();
- port->flags = PIC_PORT_OUT | PIC_PORT_BINARY;
- port->status = PIC_PORT_OPEN;
-
- return pic_obj_value(port);
-}
-
-static pic_value
-pic_port_get_output_bytevector(pic_state *pic)
-{
- struct pic_port *port = pic_stdout(pic);
- pic_blob *blob;
- long endpos;
-
- pic_get_args(pic, "|p", &port);
-
- assert_port_profile(port, PIC_PORT_OUT | PIC_PORT_BINARY, PIC_PORT_OPEN, "get-output-bytevector");
-
- /* get endpos */
- xfflush(port->file);
- endpos = xftell(port->file);
- xrewind(port->file);
-
- /* copy to buf */
- blob = pic_blob_new(pic, endpos);
- xfread(blob->data, 1, endpos, port->file);
-
- return pic_obj_value(blob);
-}
-
-static pic_value
-pic_port_read_char(pic_state *pic)
-{
- int c;
- struct pic_port *port = pic_stdin(pic);
-
- pic_get_args(pic, "|p", &port);
-
- assert_port_profile(port, PIC_PORT_IN | PIC_PORT_TEXT, PIC_PORT_OPEN, "read-char");
-
- if ((c = xfgetc(port->file)) == EOF) {
- return pic_eof_object();
- }
- else {
- return pic_char_value((char)c);
- }
-}
-
-static pic_value
-pic_port_peek_char(pic_state *pic)
-{
- int c;
- struct pic_port *port = pic_stdin(pic);
-
- pic_get_args(pic, "|p", &port);
-
- assert_port_profile(port, PIC_PORT_IN | PIC_PORT_TEXT, PIC_PORT_OPEN, "peek-char");
-
- if ((c = xfgetc(port->file)) == EOF) {
- return pic_eof_object();
- }
- else {
- xungetc(c, port->file);
- return pic_char_value((char)c);
- }
-}
-
-static pic_value
-pic_port_read_line(pic_state *pic)
-{
- int c;
- struct pic_port *port = pic_stdin(pic), *buf;
- struct pic_string *str;
-
- pic_get_args(pic, "|p", &port);
-
- assert_port_profile(port, PIC_PORT_IN | PIC_PORT_TEXT, PIC_PORT_OPEN, "read-line");
-
- buf = pic_open_output_string(pic);
- while ((c = xfgetc(port->file)) != EOF && c != '\n') {
- xfputc(c, buf->file);
- }
-
- str = pic_get_output_string(pic, buf);
- if (pic_strlen(str) == 0 && c == EOF) {
- return pic_eof_object();
- }
- else {
- return pic_obj_value(str);
- }
-}
-
-static pic_value
-pic_port_char_ready_p(pic_state *pic)
-{
- struct pic_port *port = pic_stdin(pic);
-
- assert_port_profile(port, PIC_PORT_IN | PIC_PORT_TEXT, PIC_PORT_OPEN, "char-ready?");
-
- pic_get_args(pic, "|p", &port);
-
- return pic_true_value(); /* FIXME: always returns #t */
-}
-
-static pic_value
-pic_port_read_string(pic_state *pic){
- struct pic_port *port = pic_stdin(pic), *buf;
- pic_str *str;
- int k, i;
- int c;
-
- pic_get_args(pic, "i|p", &k, &port);
-
- assert_port_profile(port, PIC_PORT_IN | PIC_PORT_TEXT, PIC_PORT_OPEN, "read-stritg");
-
- c = EOF;
- buf = pic_open_output_string(pic);
- for(i = 0; i < k; ++i) {
- if((c = xfgetc(port->file)) == EOF){
- break;
- }
- xfputc(c, buf->file);
- }
-
- str = pic_get_output_string(pic, buf);
- if (pic_strlen(str) == 0 && c == EOF) {
- return pic_eof_object();
- }
- else {
- return pic_obj_value(str);
- }
-
-}
-
-static pic_value
-pic_port_read_byte(pic_state *pic){
- struct pic_port *port = pic_stdin(pic);
- int c;
- pic_get_args(pic, "|p", &port);
-
- assert_port_profile(port, PIC_PORT_IN | PIC_PORT_BINARY, PIC_PORT_OPEN, "read-u8");
- if ((c = xfgetc(port->file)) == EOF) {
- return pic_eof_object();
- }
-
- return pic_int_value(c);
-}
-
-static pic_value
-pic_port_peek_byte(pic_state *pic)
-{
- int c;
- struct pic_port *port = pic_stdin(pic);
-
- pic_get_args(pic, "|p", &port);
-
- assert_port_profile(port, PIC_PORT_IN | PIC_PORT_BINARY, PIC_PORT_OPEN, "peek-u8");
-
- c = xfgetc(port->file);
- if (c == EOF) {
- return pic_eof_object();
- }
- else {
- xungetc(c, port->file);
- return pic_int_value(c);
- }
-}
-
-static pic_value
-pic_port_byte_ready_p(pic_state *pic)
-{
- struct pic_port *port = pic_stdin(pic);
-
- pic_get_args(pic, "|p", &port);
-
- assert_port_profile(port, PIC_PORT_IN | PIC_PORT_BINARY, PIC_PORT_OPEN, "u8-ready?");
-
- return pic_true_value(); /* FIXME: always returns #t */
-}
-
-
-static pic_value
-pic_port_read_blob(pic_state *pic)
-{
- struct pic_port *port = pic_stdin(pic);
- pic_blob *blob;
- int k, i;
-
- pic_get_args(pic, "i|p", &k, &port);
-
- assert_port_profile(port, PIC_PORT_IN | PIC_PORT_BINARY, PIC_PORT_OPEN, "read-bytevector");
-
- blob = pic_blob_new(pic, k);
-
- i = xfread(blob->data, sizeof(char), k, port->file);
- if ( i == 0 ) {
- return pic_eof_object();
- }
- else {
- pic_realloc(pic, blob->data, i);
- blob->len = i;
- return pic_obj_value(blob);
- }
-}
-
-static pic_value
-pic_port_read_blob_ip(pic_state *pic)
-{
- struct pic_port *port;
- struct pic_blob *bv;
- int i, n, start, end, len;
- char *buf;
-
- n = pic_get_args(pic, "b|pii", &bv, &port, &start, &end);
- switch (n) {
- case 1:
- port = pic_stdin(pic);
- case 2:
- start = 0;
- case 3:
- end = bv->len;
- }
-
- assert_port_profile(port, PIC_PORT_IN | PIC_PORT_BINARY, PIC_PORT_OPEN, "read-bytevector!");
- len = end - start;
-
- buf = pic_calloc(pic, len, sizeof(char));
- i = xfread(buf, sizeof(char), len, port->file);
- memcpy(bv->data + start, buf, i);
- pic_free(pic, buf);
-
- if ( i == 0) {
- return pic_eof_object();
- }
- else {
- return pic_int_value(i);
- }
-}
-
-static pic_value
-pic_port_newline(pic_state *pic)
-{
- struct pic_port *port = pic_stdout(pic);
-
- pic_get_args(pic, "|p", &port);
-
- assert_port_profile(port, PIC_PORT_OUT | PIC_PORT_TEXT, PIC_PORT_OPEN, "newline");
-
- xfputs("\n", port->file);
- return pic_none_value();
-}
-
-static pic_value
-pic_port_write_char(pic_state *pic)
-{
- char c;
- struct pic_port *port = pic_stdout(pic);
-
- pic_get_args(pic, "c|p", &c, &port);
-
- assert_port_profile(port, PIC_PORT_OUT | PIC_PORT_TEXT, PIC_PORT_OPEN, "write-char");
-
- xfputc(c, port->file);
- return pic_none_value();
-}
-
-static pic_value
-pic_port_write_string(pic_state *pic)
-{
- char *str;
- struct pic_port *port;
- int start, end, n, i;
-
- n = pic_get_args(pic, "z|pii", &str, &port, &start, &end);
- switch (n) {
- case 1:
- port = pic_stdout(pic);
- case 2:
- start = 0;
- case 3:
- end = INT_MAX;
- }
-
- assert_port_profile(port, PIC_PORT_OUT | PIC_PORT_TEXT, PIC_PORT_OPEN, "write-string");
-
- for (i = start; i < end && str[i] != '\0'; ++i) {
- xfputc(str[i], port->file);
- }
- return pic_none_value();
-}
-
-static pic_value
-pic_port_write_byte(pic_state *pic)
-{
- int i;
- struct pic_port *port = pic_stdout(pic);
-
- pic_get_args(pic, "i|p", &i, &port);
-
- assert_port_profile(port, PIC_PORT_OUT | PIC_PORT_BINARY, PIC_PORT_OPEN, "write-u8");
-
- xfputc(i, port->file);
- return pic_none_value();
-}
-
-static pic_value
-pic_port_write_blob(pic_state *pic)
-{
- struct pic_blob *blob;
- struct pic_port *port;
- int start, end, n, i;
-
- n = pic_get_args(pic, "b|pii", &blob, &port, &start, &end);
- switch (n) {
- case 1:
- port = pic_stdout(pic);
- case 2:
- start = 0;
- case 3:
- end = blob->len;
- }
-
- assert_port_profile(port, PIC_PORT_OUT | PIC_PORT_BINARY, PIC_PORT_OPEN, "write-bytevector");
-
- for (i = start; i < end; ++i) {
- xfputc(blob->data[i], port->file);
- }
- return pic_none_value();
-}
-
-static pic_value
-pic_port_flush(pic_state *pic)
-{
- struct pic_port *port = pic_stdout(pic);
-
- pic_get_args(pic, "|p", &port);
-
- assert_port_profile(port, PIC_PORT_OUT, PIC_PORT_OPEN, "flush-output-port");
-
- xfflush(port->file);
- return pic_none_value();
-}
-
-void
-pic_init_port(pic_state *pic)
-{
- struct pic_port *STDIN, *STDOUT, *STDERR;
-
- STDIN = port_new_stdport(pic, xstdin, PIC_PORT_IN);
- STDOUT = port_new_stdport(pic, xstdout, PIC_PORT_OUT);
- STDERR = port_new_stdport(pic, xstderr, PIC_PORT_OUT);
-
- pic_deflibrary (pic, "(picrin port)") {
- pic_define(pic, "standard-input-port", pic_obj_value(STDIN));
- pic_define(pic, "standard-output-port", pic_obj_value(STDOUT));
- pic_define(pic, "standard-error-port", pic_obj_value(STDERR));
- }
-
- pic_define(pic, "current-input-port", pic_obj_value(pic_var_new(pic, pic_obj_value(STDIN), NULL)));
- pic_define(pic, "current-output-port", pic_obj_value(pic_var_new(pic, pic_obj_value(STDOUT), NULL)));
- pic_define(pic, "current-error-port", pic_obj_value(pic_var_new(pic, pic_obj_value(STDERR), NULL)));
-
- pic_defun(pic, "input-port?", pic_port_input_port_p);
- pic_defun(pic, "output-port?", pic_port_output_port_p);
- pic_defun(pic, "textual-port?", pic_port_textual_port_p);
- pic_defun(pic, "binary-port?", pic_port_binary_port_p);
- pic_defun(pic, "port?", pic_port_port_p);
- pic_defun(pic, "input-port-open?", pic_port_input_port_open_p);
- pic_defun(pic, "output-port-open?", pic_port_output_port_open_p);
- pic_defun(pic, "close-port", pic_port_close_port);
- pic_defun(pic, "close-input-port", pic_port_close_port);
- pic_defun(pic, "close-output-port", pic_port_close_port);
-
- /* string I/O */
- pic_defun(pic, "open-input-string", pic_port_open_input_string);
- pic_defun(pic, "open-output-string", pic_port_open_output_string);
- pic_defun(pic, "get-output-string", pic_port_get_output_string);
- pic_defun(pic, "open-input-bytevector", pic_port_open_input_blob);
- pic_defun(pic, "open-output-bytevector", pic_port_open_output_bytevector);
- pic_defun(pic, "get-output-bytevector", pic_port_get_output_bytevector);
-
- /* input */
- pic_defun(pic, "read-char", pic_port_read_char);
- pic_defun(pic, "peek-char", pic_port_peek_char);
- pic_defun(pic, "read-line", pic_port_read_line);
- pic_defun(pic, "eof-object?", pic_port_eof_object_p);
- pic_defun(pic, "eof-object", pic_port_eof_object);
- pic_defun(pic, "char-ready?", pic_port_char_ready_p);
- pic_defun(pic, "read-string", pic_port_read_string);
- pic_defun(pic, "read-u8", pic_port_read_byte);
- pic_defun(pic, "peek-u8", pic_port_peek_byte);
- pic_defun(pic, "u8-ready?", pic_port_byte_ready_p);
- pic_defun(pic, "read-bytevector", pic_port_read_blob);
- pic_defun(pic, "read-bytevector!", pic_port_read_blob_ip);
-
- /* output */
- pic_defun(pic, "newline", pic_port_newline);
- pic_defun(pic, "write-char", pic_port_write_char);
- pic_defun(pic, "write-string", pic_port_write_string);
- pic_defun(pic, "write-u8", pic_port_write_byte);
- pic_defun(pic, "write-bytevector", pic_port_write_blob);
- pic_defun(pic, "flush-output-port", pic_port_flush);
-}
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 <ctype.h>
-#include <math.h>
-#include <stdlib.h>
-#include "picrin.h"
-#include "picrin/read.h"
-#include "picrin/error.h"
-#include "picrin/pair.h"
-#include "picrin/string.h"
-#include "picrin/vector.h"
-#include "picrin/blob.h"
-#include "picrin/port.h"
-#include "picrin/proc.h"
-
-static pic_value read(pic_state *pic, struct pic_port *port, int c);
-static pic_value read_nullable(pic_state *pic, struct pic_port *port, int c);
-
-static noreturn void
-read_error(pic_state *pic, const char *msg)
-{
- pic_throw(pic, PIC_ERROR_READ, msg, pic_nil_value());
-}
-
-static int
-skip(struct pic_port *port, int c)
-{
- while (isspace(c)) {
- c = xfgetc(port->file);
- }
- return c;
-}
-
-static int
-next(struct pic_port *port)
-{
- return xfgetc(port->file);
-}
-
-static int
-peek(struct pic_port *port)
-{
- int c;
-
- xungetc((c = xfgetc(port->file)), port->file);
-
- return c;
-}
-
-static bool
-expect(struct pic_port *port, const char *str)
-{
- int c;
-
- while ((c = (int)*str++) != 0) {
- if (c != peek(port))
- return false;
- next(port);
- }
-
- return true;
-}
-
-static bool
-isdelim(int c)
-{
- return c == EOF || strchr("();,|\" \t\n\r", c) != NULL; /* ignores "#", "'" */
-}
-
-static bool
-strcaseeq(const char *s1, const char *s2)
-{
- char a, b;
-
- while ((a = *s1++) * (b = *s2++)) {
- if (tolower(a) != tolower(b))
- return false;
- }
- return a == b;
-}
-
-static pic_value
-read_comment(pic_state *pic, struct pic_port *port, const char *str)
-{
- int c;
-
- UNUSED(pic);
- UNUSED(str);
-
- do {
- c = next(port);
- } while (! (c == EOF || c == '\n'));
-
- return pic_undef_value();
-}
-
-static pic_value
-read_block_comment(pic_state *pic, struct pic_port *port, const char *str)
-{
- int x, y;
- int i = 1;
-
- UNUSED(pic);
- UNUSED(str);
-
- y = next(port);
-
- while (y != EOF && i > 0) {
- x = y;
- y = next(port);
- if (x == '|' && y == '#') {
- i--;
- }
- if (x == '#' && y == '|') {
- i++;
- }
- }
-
- return pic_undef_value();
-}
-
-static pic_value
-read_datum_comment(pic_state *pic, struct pic_port *port, const char *str)
-{
- UNUSED(str);
-
- read(pic, port, next(port));
-
- return pic_undef_value();
-}
-
-static pic_value
-read_directive(pic_state *pic, struct pic_port *port, const char *str)
-{
- switch (peek(port)) {
- case 'n':
- if (expect(port, "no-fold-case")) {
- pic->reader->typecase = PIC_CASE_DEFAULT;
- return pic_undef_value();
- }
- break;
- case 'f':
- if (expect(port, "fold-case")) {
- pic->reader->typecase = PIC_CASE_FOLD;
- return pic_undef_value();
- }
- break;
- }
-
- return read_comment(pic, port, str);
-}
-
-static pic_value
-read_eval(pic_state *pic, struct pic_port *port, const char *str)
-{
- pic_value form;
-
- UNUSED(str);
-
- form = read(pic, port, next(port));
-
- return pic_eval(pic, form, pic->lib);
-}
-
-static pic_value
-read_quote(pic_state *pic, struct pic_port *port, const char *str)
-{
- UNUSED(str);
-
- return pic_list2(pic, pic_sym_value(pic->sQUOTE), read(pic, port, next(port)));
-}
-
-static pic_value
-read_quasiquote(pic_state *pic, struct pic_port *port, const char *str)
-{
- UNUSED(str);
-
- return pic_list2(pic, pic_sym_value(pic->sQUASIQUOTE), read(pic, port, next(port)));
-}
-
-static pic_value
-read_unquote(pic_state *pic, struct pic_port *port, const char *str)
-{
- UNUSED(str);
-
- return pic_list2(pic, pic_sym_value(pic->sUNQUOTE), read(pic, port, next(port)));
-}
-
-static pic_value
-read_unquote_splicing(pic_state *pic, struct pic_port *port, const char *str)
-{
- UNUSED(str);
-
- return pic_list2(pic, pic_sym_value(pic->sUNQUOTE_SPLICING), read(pic, port, next(port)));
-}
-
-static pic_value
-read_symbol(pic_state *pic, struct pic_port *port, const char *str)
-{
- size_t len, i;
- char *buf;
- pic_sym sym;
- int c;
-
- len = strlen(str);
- buf = pic_calloc(pic, 1, len + 1);
-
- for (i = 0; i < len; ++i) {
- if (pic->reader->typecase == PIC_CASE_FOLD) {
- buf[i] = tolower(str[i]);
- } else {
- buf[i] = str[i];
- }
- }
-
- while (! isdelim(peek(port))) {
- c = next(port);
- if (pic->reader->typecase == PIC_CASE_FOLD) {
- c = tolower(c);
- }
- len += 1;
- buf = pic_realloc(pic, buf, len + 1);
- buf[len - 1] = c;
- }
-
- sym = pic_intern(pic, buf, len);
- pic_free(pic, buf);
-
- return pic_sym_value(sym);
-}
-
-static size_t
-read_uinteger(pic_state *pic, struct pic_port *port, int c, char buf[])
-{
- size_t i = 0;
-
- if (! isdigit(c)) {
- read_error(pic, "expected one or more digits");
- }
-
- buf[i++] = c;
- while (isdigit(c = peek(port))) {
- buf[i++] = next(port);
- }
-
- buf[i] = '\0';
-
- return i;
-}
-
-static size_t
-read_suffix(pic_state *pic, struct pic_port *port, char buf[])
-{
- size_t i = 0;
- int c;
-
- c = peek(port);
-
- if (c != 'e' && c != 'E') {
- return i;
- }
-
- buf[i++] = next(port);
-
- switch ((c = next(port))) {
- case '-':
- case '+':
- buf[i++] = c;
- c = next(port);
- default:
- return i + read_uinteger(pic, port, c, buf + i);
- }
-}
-
-static pic_value
-read_unsigned(pic_state *pic, struct pic_port *port, int c)
-{
- char buf[256];
- size_t i;
-
- i = read_uinteger(pic, port, c, buf);
-
- switch (peek(port)) {
- case '.':
- buf[i++] = next(port);
- i += read_uinteger(pic, port, next(port), buf + i);
- read_suffix(pic, port, buf + i);
- return pic_float_value(atof(buf));
-
- default:
- read_suffix(pic, port, buf + i);
- return pic_int_value((int)atof(buf));
- }
-}
-
-static pic_value
-read_number(pic_state *pic, struct pic_port *port, const char *str)
-{
- return read_unsigned(pic, port, str[0]);
-}
-
-static pic_value
-negate(pic_value n)
-{
- if (pic_int_p(n)) {
- return pic_int_value(-pic_int(n));
- } else {
- return pic_float_value(-pic_float(n));
- }
-}
-
-static pic_value
-read_minus(pic_state *pic, struct pic_port *port, const char *str)
-{
- pic_value sym;
-
- if (isdigit(peek(port))) {
- return negate(read_unsigned(pic, port, next(port)));
- }
- else {
- sym = read_symbol(pic, port, str);
- if (strcaseeq(pic_symbol_name(pic, pic_sym(sym)), "-inf.0")) {
- return pic_float_value(-INFINITY);
- }
- if (strcaseeq(pic_symbol_name(pic, pic_sym(sym)), "-nan.0")) {
- return pic_float_value(-NAN);
- }
- return sym;
- }
-}
-
-static pic_value
-read_plus(pic_state *pic, struct pic_port *port, const char *str)
-{
- pic_value sym;
-
- if (isdigit(peek(port))) {
- return read_unsigned(pic, port, next(port));
- }
- else {
- sym = read_symbol(pic, port, str);
- if (strcaseeq(pic_symbol_name(pic, pic_sym(sym)), "+inf.0")) {
- return pic_float_value(INFINITY);
- }
- if (strcaseeq(pic_symbol_name(pic, pic_sym(sym)), "+nan.0")) {
- return pic_float_value(NAN);
- }
- return sym;
- }
-}
-
-static pic_value
-read_true(pic_state *pic, struct pic_port *port, const char *str)
-{
- UNUSED(pic);
- UNUSED(port);
- UNUSED(str);
-
- return pic_true_value();
-}
-
-static pic_value
-read_false(pic_state *pic, struct pic_port *port, const char *str)
-{
- UNUSED(pic);
- UNUSED(port);
- UNUSED(str);
-
- return pic_false_value();
-}
-
-static pic_value
-read_char(pic_state *pic, struct pic_port *port, const char *str)
-{
- int c;
-
- UNUSED(str);
-
- c = next(port);
-
- if (! isdelim(peek(port))) {
- switch (c) {
- default: read_error(pic, "unexpected character after char literal");
- case 'a': c = '\a'; if (! expect(port, "lerm")) goto fail; break;
- case 'b': c = '\b'; if (! expect(port, "ackspace")) goto fail; break;
- case 'd': c = 0x7F; if (! expect(port, "elete")) goto fail; break;
- case 'e': c = 0x1B; if (! expect(port, "scape")) goto fail; break;
- case 'n':
- if ((c = peek(port)) == 'e') {
- c = '\n';
- if (! expect(port, "ewline"))
- goto fail;
- } else {
- c = '\0';
- if (! expect(port, "ull"))
- goto fail;
- }
- break;
- case 'r': c = '\r'; if (! expect(port, "eturn")) goto fail; break;
- case 's': c = ' '; if (! expect(port, "pace")) goto fail; break;
- case 't': c = '\t'; if (! expect(port, "ab")) goto fail; break;
- }
- }
-
- return pic_char_value(c);
-
- fail:
- read_error(pic, "unexpected character while reading character literal");
-}
-
-static pic_value
-read_string(pic_state *pic, struct pic_port *port, const char *name)
-{
- int c;
- char *buf;
- size_t size, cnt;
- pic_str *str;
-
- UNUSED(name);
-
- size = 256;
- buf = pic_alloc(pic, size);
- cnt = 0;
-
- /* TODO: intraline whitespaces */
-
- while ((c = next(port)) != '"') {
- if (c == '\\') {
- switch (c = next(port)) {
- case 'a': c = '\a'; break;
- case 'b': c = '\b'; break;
- case 't': c = '\t'; break;
- case 'n': c = '\n'; break;
- case 'r': c = '\r'; break;
- }
- }
- buf[cnt++] = c;
- if (cnt >= size) {
- buf = pic_realloc(pic, buf, size *= 2);
- }
- }
- buf[cnt] = '\0';
-
- str = pic_str_new(pic, buf, cnt);
- pic_free(pic, buf);
- return pic_obj_value(str);
-}
-
-static pic_value
-read_pipe(pic_state *pic, struct pic_port *port, const char *str)
-{
- char *buf;
- size_t size, cnt;
- pic_sym sym;
- /* Currently supports only ascii chars */
- char HEX_BUF[3];
- size_t i = 0;
- int c;
-
- UNUSED(str);
-
- size = 256;
- buf = pic_alloc(pic, size);
- cnt = 0;
- while ((c = next(port)) != '|') {
- if (c == '\\') {
- switch ((c = next(port))) {
- case 'a': c = '\a'; break;
- case 'b': c = '\b'; break;
- case 't': c = '\t'; break;
- case 'n': c = '\n'; break;
- case 'r': c = '\r'; break;
- case 'x':
- i = 0;
- while ((HEX_BUF[i++] = next(port)) != ';') {
- if (i >= sizeof HEX_BUF)
- read_error(pic, "expected ';'");
- }
- c = strtol(HEX_BUF, NULL, 16);
- break;
- }
- }
- buf[cnt++] = c;
- if (cnt >= size) {
- buf = pic_realloc(pic, buf, size *= 2);
- }
- }
- buf[cnt] = '\0';
-
- sym = pic_intern_cstr(pic, buf);
- pic_free(pic, buf);
-
- return pic_sym_value(sym);
-}
-
-static pic_value
-read_blob(pic_state *pic, struct pic_port *port, const char *str)
-{
- int nbits, n, c;
- size_t len, i;
- char *dat, buf[256];
- pic_blob *blob;
-
- UNUSED(str);
-
- nbits = 0;
-
- while (isdigit(c = next(port))) {
- nbits = 10 * nbits + c - '0';
- }
-
- if (nbits != 8) {
- read_error(pic, "unsupported bytevector bit width");
- }
-
- if (c != '(') {
- read_error(pic, "expected '(' character");
- }
-
- len = 0;
- dat = NULL;
- c = next(port);
- while ((c = skip(port, c)) != ')') {
- read_uinteger(pic, port, c, buf);
- n = atoi(buf);
- if (n < 0 || (1 << nbits) <= n) {
- read_error(pic, "invalid element in bytevector literal");
- }
- len += 1;
- dat = pic_realloc(pic, dat, len);
- dat[len - 1] = n;
- c = next(port);
- }
-
- blob = pic_blob_new(pic, len);
- for (i = 0; i < len; ++i) {
- blob->data[i] = dat[i];
- }
-
- pic_free(pic, dat);
- return pic_obj_value(blob);
-}
-
-static pic_value
-read_pair(pic_state *pic, struct pic_port *port, const char *str)
-{
- const int tCLOSE = (str[0] == '(') ? ')' : ']';
- pic_value car, cdr;
- int c;
-
- retry:
-
- c = skip(port, ' ');
-
- if (c == tCLOSE) {
- return pic_nil_value();
- }
- if (c == '.' && isdelim(peek(port))) {
- cdr = read(pic, port, next(port));
-
- closing:
- if ((c = skip(port, ' ')) != tCLOSE) {
- if (pic_undef_p(read_nullable(pic, port, c))) {
- goto closing;
- }
- read_error(pic, "unmatched parenthesis");
- }
- return cdr;
- }
- else {
- car = read_nullable(pic, port, c);
-
- if (pic_undef_p(car)) {
- goto retry;
- }
-
- cdr = read_pair(pic, port, str);
- return pic_cons(pic, car, cdr);
- }
-}
-
-static pic_value
-read_vector(pic_state *pic, struct pic_port *port, const char *str)
-{
- pic_value list;
-
- list = read(pic, port, str[1]);
-
- return pic_obj_value(pic_vec_new_from_list(pic, list));
-}
-
-static pic_value
-read_label_set(pic_state *pic, struct pic_port *port, int i)
-{
- pic_value val;
- int c;
-
- switch ((c = skip(port, ' '))) {
- case '(': case '[':
- {
- pic_value tmp;
-
- val = pic_cons(pic, pic_none_value(), pic_none_value());
-
- xh_put_int(&pic->reader->labels, i, &val);
-
- tmp = read(pic, port, c);
- pic_pair_ptr(val)->car = pic_car(pic, tmp);
- pic_pair_ptr(val)->cdr = pic_cdr(pic, tmp);
-
- return val;
- }
- case '#':
- {
- bool vect;
-
- if (peek(port) == '(') {
- vect = true;
- } else {
- vect = false;
- }
-
- if (vect) {
- pic_vec *tmp;
-
- val = pic_obj_value(pic_vec_new(pic, 0));
-
- xh_put_int(&pic->reader->labels, i, &val);
-
- tmp = pic_vec_ptr(read(pic, port, c));
- SWAP(pic_value *, tmp->data, pic_vec_ptr(val)->data);
- SWAP(size_t, tmp->len, pic_vec_ptr(val)->len);
-
- return val;
- }
-
- FALLTHROUGH;
- }
- default:
- {
- val = read(pic, port, c);
-
- xh_put_int(&pic->reader->labels, i, &val);
-
- return val;
- }
- }
-}
-
-static pic_value
-read_label_ref(pic_state *pic, struct pic_port *port, int i)
-{
- xh_entry *e;
-
- UNUSED(port);
-
- e = xh_get_int(&pic->reader->labels, i);
- if (! e) {
- read_error(pic, "label of given index not defined");
- }
- return xh_val(e, pic_value);
-}
-
-static pic_value
-read_label(pic_state *pic, struct pic_port *port, const char *str)
-{
- int i, c;
-
- i = 0;
- c = str[1]; /* initial index letter */
- do {
- i = i * 10 + c;
- } while (isdigit(c = next(port)));
-
- if (c == '=') {
- return read_label_set(pic, port, i);
- }
- if (c == '#') {
- return read_label_ref(pic, port, i);
- }
- read_error(pic, "broken label expression");
-}
-
-static pic_value
-read_unmatch(pic_state *pic, struct pic_port *port, const char *str)
-{
- UNUSED(port);
- UNUSED(str);
-
- read_error(pic, "unmatched parenthesis");
-}
-
-static pic_value
-read_nullable(pic_state *pic, struct pic_port *port, int c)
-{
- struct pic_trie *trie = pic->reader->trie;
- char buf[128];
- size_t i = 0;
- pic_str *str;
-
- c = skip(port, c);
-
- if (c == EOF) {
- read_error(pic, "unexpected EOF");
- }
-
- if (trie->table[c] == NULL) {
- read_error(pic, "invalid character at the seeker head");
- }
-
- buf[i++] = c;
-
- while (i < sizeof buf) {
- trie = trie->table[c];
-
- if ((c = peek(port)) == EOF) {
- break;
- }
- if (trie->table[c] == NULL) {
- break;
- }
- buf[i++] = next(port);
- }
- if (i == sizeof buf) {
- read_error(pic, "too long dispatch string");
- }
-
- if (trie->proc == NULL) {
- read_error(pic, "no reader registered for current string");
- }
- str = pic_str_new(pic, buf, i);
- return pic_apply2(pic, trie->proc, pic_obj_value(port), pic_obj_value(str));
-}
-
-static pic_value
-read(pic_state *pic, struct pic_port *port, int c)
-{
- pic_value val;
-
- retry:
- val = read_nullable(pic, port, c);
-
- if (pic_undef_p(val)) {
- c = next(port);
- goto retry;
- }
-
- return val;
-}
-
-struct pic_trie *
-pic_trie_new(pic_state *pic)
-{
- struct pic_trie *trie;
-
- trie = pic_alloc(pic, sizeof(struct pic_trie));
- trie->proc = NULL;
- memset(trie->table, 0, sizeof trie->table);
-
- return trie;
-}
-
-void
-pic_trie_delete(pic_state *pic, struct pic_trie *trie)
-{
- size_t i;
-
- for (i = 0; i < sizeof trie->table / sizeof(struct pic_trie *); ++i) {
- if (trie->table[i] != NULL) {
- pic_trie_delete(pic, trie->table[i]);
- }
- }
-
- pic_free(pic, trie);
-}
-
-void
-pic_define_reader(pic_state *pic, const char *str, pic_func_t reader)
-{
- struct pic_trie *trie = pic->reader->trie;
- int c;
-
- while ((c = *str++)) {
- if (trie->table[c] == NULL) {
- trie->table[c] = pic_trie_new(pic);
- }
- trie = trie->table[c];
- }
- trie->proc = pic_proc_new(pic, reader, "reader");
-}
-
-#define DEFINE_READER(name) \
- static pic_value \
- pic_##name(pic_state *pic) \
- { \
- struct pic_port *port; \
- const char *str; \
- \
- pic_get_args(pic, "pz", &port, &str); \
- \
- return name(pic, port, str); \
- }
-
-DEFINE_READER(read_unmatch)
-DEFINE_READER(read_comment)
-DEFINE_READER(read_quote)
-DEFINE_READER(read_quasiquote)
-DEFINE_READER(read_unquote)
-DEFINE_READER(read_unquote_splicing)
-DEFINE_READER(read_string)
-DEFINE_READER(read_pipe)
-DEFINE_READER(read_plus)
-DEFINE_READER(read_minus)
-DEFINE_READER(read_pair)
-DEFINE_READER(read_directive)
-DEFINE_READER(read_block_comment)
-DEFINE_READER(read_datum_comment)
-DEFINE_READER(read_true)
-DEFINE_READER(read_false)
-DEFINE_READER(read_char)
-DEFINE_READER(read_vector)
-DEFINE_READER(read_blob)
-DEFINE_READER(read_eval)
-DEFINE_READER(read_symbol)
-DEFINE_READER(read_number)
-DEFINE_READER(read_label)
-
-void
-pic_init_reader(pic_state *pic)
-{
- static const char INIT[] = "!$%&*./:<=>?@^_~";
- char buf[3] = { 0 };
- size_t i;
-
- pic_define_reader(pic, ")", pic_read_unmatch);
- pic_define_reader(pic, ";", pic_read_comment);
- pic_define_reader(pic, "'", pic_read_quote);
- pic_define_reader(pic, "`", pic_read_quasiquote);
- pic_define_reader(pic, ",", pic_read_unquote);
- pic_define_reader(pic, ",@", pic_read_unquote_splicing);
- pic_define_reader(pic, "\"", pic_read_string);
- pic_define_reader(pic, "|", pic_read_pipe);
- pic_define_reader(pic, "+", pic_read_plus);
- pic_define_reader(pic, "-", pic_read_minus);
- pic_define_reader(pic, "(", pic_read_pair);
- pic_define_reader(pic, "[", pic_read_pair);
-
- pic_define_reader(pic, "#!", pic_read_directive);
- pic_define_reader(pic, "#|", pic_read_block_comment);
- pic_define_reader(pic, "#;", pic_read_datum_comment);
- pic_define_reader(pic, "#t", pic_read_true);
- pic_define_reader(pic, "#true", pic_read_true);
- pic_define_reader(pic, "#f", pic_read_false);
- pic_define_reader(pic, "#false", pic_read_false);
- pic_define_reader(pic, "#\\", pic_read_char);
- pic_define_reader(pic, "#(", pic_read_vector);
- pic_define_reader(pic, "#u", pic_read_blob);
- pic_define_reader(pic, "#.", pic_read_eval);
-
- /* read number */
- for (buf[0] = '0'; buf[0] <= '9'; ++buf[0]) {
- pic_define_reader(pic, buf, pic_read_number);
- }
-
- /* read symbol */
- for (buf[0] = 'a'; buf[0] <= 'z'; ++buf[0]) {
- pic_define_reader(pic, buf, pic_read_symbol);
- }
- for (buf[0] = 'A'; buf[0] <= 'Z'; ++buf[0]) {
- pic_define_reader(pic, buf, pic_read_symbol);
- }
- for (i = 0; i < sizeof INIT; ++i) {
- buf[0] = INIT[i];
- pic_define_reader(pic, buf, pic_read_symbol);
- }
-
- /* read label */
- buf[0] = '#';
- for (buf[1] = '0'; buf[1] <= '9'; ++buf[1]) {
- pic_define_reader(pic, buf, pic_read_label);
- }
-}
-
-pic_value
-pic_read(pic_state *pic, struct pic_port *port)
-{
- pic_value val;
- int c = next(port);
-
- retry:
- c = skip(port, c);
-
- if (c == EOF) {
- return pic_eof_object();
- }
-
- val = read_nullable(pic, port, c);
-
- if (pic_undef_p(val)) {
- c = next(port);
- goto retry;
- }
-
- return val;
-}
-
-pic_value
-pic_read_cstr(pic_state *pic, const char *str)
-{
- struct pic_port *port;
-
- port = pic_open_input_string(pic, str);
-
- return pic_read(pic, port);
-}
-
-static pic_value
-pic_parse(pic_state *pic, struct pic_port *port)
-{
- pic_value val, acc;
-
- pic_try {
- acc = pic_nil_value();
- while (! pic_eof_p(val = pic_read(pic, port))) {
- pic_push(pic, val, acc);
- }
- }
- pic_catch {
- return pic_undef_value();
- }
-
- return pic_reverse(pic, acc);
-}
-
-pic_list
-pic_parse_file(pic_state *pic, FILE *file)
-{
- struct pic_port *port;
-
- port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port *), PIC_TT_PORT);
- port->file = xfpopen(file);
- port->flags = PIC_PORT_OUT | PIC_PORT_TEXT;
- port->status = PIC_PORT_OPEN;
-
- return pic_parse(pic, port);
-}
-
-pic_list
-pic_parse_cstr(pic_state *pic, const char *str)
-{
- struct pic_port *port;
-
- port = pic_open_input_string(pic, str);
-
- return pic_parse(pic, port);
-}
-
-static pic_value
-pic_read_read(pic_state *pic)
-{
- struct pic_port *port = pic_stdin(pic);
-
- pic_get_args(pic, "|p", &port);
-
- return pic_read(pic, port);
-}
-
-void
-pic_init_read(pic_state *pic)
-{
- pic_deflibrary (pic, "(scheme read)") {
- pic_defun(pic, "read", pic_read_read);
- }
-}
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 <stdlib.h>
-
-#include "picrin.h"
-#include "picrin/gc.h"
-#include "picrin/read.h"
-#include "picrin/proc.h"
-#include "picrin/macro.h"
-#include "picrin/cont.h"
-#include "picrin/error.h"
-
-void pic_init_core(pic_state *);
-
-pic_state *
-pic_open(int argc, char *argv[], char **envp)
-{
- char t;
-
- pic_state *pic;
- size_t ai;
-
- pic = malloc(sizeof(pic_state));
-
- /* root block */
- pic->blk = NULL;
-
- /* command line */
- pic->argc = argc;
- pic->argv = argv;
- pic->envp = envp;
-
- /* prepare VM stack */
- pic->stbase = pic->sp = calloc(PIC_STACK_SIZE, sizeof(pic_value));
- pic->stend = pic->stbase + PIC_STACK_SIZE;
-
- /* callinfo */
- pic->cibase = pic->ci = calloc(PIC_STACK_SIZE, sizeof(pic_callinfo));
- pic->ciend = pic->cibase + PIC_STACK_SIZE;
-
- /* memory heap */
- pic->heap = pic_heap_open();
-
- /* symbol table */
- xh_init_str(&pic->syms, sizeof(pic_sym));
- xh_init_int(&pic->sym_names, sizeof(const char *));
- pic->sym_cnt = 0;
- pic->uniq_sym_cnt = 0;
-
- /* global variables */
- xh_init_int(&pic->globals, sizeof(pic_value));
-
- /* macros */
- xh_init_int(&pic->macros, sizeof(struct pic_macro *));
-
- /* libraries */
- pic->libs = pic_nil_value();
- pic->lib = NULL;
-
- /* reader */
- pic->reader = malloc(sizeof(struct pic_reader));
- pic->reader->typecase = PIC_CASE_DEFAULT;
- pic->reader->trie = pic_trie_new(pic);
- xh_init_int(&pic->reader->labels, sizeof(pic_value));
-
- /* error handling */
- pic->jmp = NULL;
- pic->err = NULL;
- pic->try_jmps = calloc(PIC_RESCUE_SIZE, sizeof(struct pic_jmpbuf));
- pic->try_jmp_idx = 0;
- pic->try_jmp_size = PIC_RESCUE_SIZE;
-
- /* GC arena */
- pic->arena = calloc(PIC_ARENA_SIZE, sizeof(struct pic_object **));
- pic->arena_size = PIC_ARENA_SIZE;
- pic->arena_idx = 0;
-
- /* native stack marker */
- pic->native_stack_start = &t;
-
-#define register_core_symbol(pic,slot,name) do { \
- pic->slot = pic_intern_cstr(pic, name); \
- } while (0)
-
- ai = pic_gc_arena_preserve(pic);
- register_core_symbol(pic, sDEFINE, "define");
- register_core_symbol(pic, sLAMBDA, "lambda");
- register_core_symbol(pic, sIF, "if");
- register_core_symbol(pic, sBEGIN, "begin");
- register_core_symbol(pic, sSETBANG, "set!");
- register_core_symbol(pic, sQUOTE, "quote");
- register_core_symbol(pic, sQUASIQUOTE, "quasiquote");
- register_core_symbol(pic, sUNQUOTE, "unquote");
- register_core_symbol(pic, sUNQUOTE_SPLICING, "unquote-splicing");
- register_core_symbol(pic, sDEFINE_SYNTAX, "define-syntax");
- register_core_symbol(pic, sIMPORT, "import");
- register_core_symbol(pic, sEXPORT, "export");
- register_core_symbol(pic, sDEFINE_LIBRARY, "define-library");
- register_core_symbol(pic, sIN_LIBRARY, "in-library");
- register_core_symbol(pic, sCONS, "cons");
- register_core_symbol(pic, sCAR, "car");
- register_core_symbol(pic, sCDR, "cdr");
- register_core_symbol(pic, sNILP, "null?");
- register_core_symbol(pic, sADD, "+");
- register_core_symbol(pic, sSUB, "-");
- register_core_symbol(pic, sMUL, "*");
- register_core_symbol(pic, sDIV, "/");
- register_core_symbol(pic, sMINUS, "minus");
- register_core_symbol(pic, sEQ, "=");
- register_core_symbol(pic, sLT, "<");
- register_core_symbol(pic, sLE, "<=");
- register_core_symbol(pic, sGT, ">");
- register_core_symbol(pic, sGE, ">=");
- register_core_symbol(pic, sNOT, "not");
- pic_gc_arena_restore(pic, ai);
-
-#define register_renamed_symbol(pic,slot,name) do { \
- pic->slot = pic_gensym(pic, pic_intern_cstr(pic, name)); \
- } while (0)
-
- ai = pic_gc_arena_preserve(pic);
- register_renamed_symbol(pic, rDEFINE, "define");
- register_renamed_symbol(pic, rLAMBDA, "lambda");
- register_renamed_symbol(pic, rIF, "if");
- register_renamed_symbol(pic, rBEGIN, "begin");
- register_renamed_symbol(pic, rSETBANG, "set!");
- register_renamed_symbol(pic, rQUOTE, "quote");
- register_renamed_symbol(pic, rDEFINE_SYNTAX, "define-syntax");
- register_renamed_symbol(pic, rIMPORT, "import");
- register_renamed_symbol(pic, rEXPORT, "export");
- register_renamed_symbol(pic, rDEFINE_LIBRARY, "define-library");
- register_renamed_symbol(pic, rIN_LIBRARY, "in-library");
- pic_gc_arena_restore(pic, ai);
-
- /* root block */
- pic->blk = (struct pic_block *)pic_obj_alloc(pic, sizeof(struct pic_block), PIC_TT_BLK);
- pic->blk->prev = NULL;
- pic->blk->depth = 0;
- pic->blk->in = pic->blk->out = NULL;
-
- pic_init_core(pic);
-
- /* set library */
- pic_make_library(pic, pic_read_cstr(pic, "(picrin user)"));
- pic_in_library(pic, pic_read_cstr(pic, "(picrin user)"));
-
- return pic;
-}
-
-void
-pic_close(pic_state *pic)
-{
- xh_iter it;
-
- /* invoke exit handlers */
- while (pic->blk) {
- if (pic->blk->out) {
- pic_apply0(pic, pic->blk->out);
- }
- pic->blk = pic->blk->prev;
- }
-
- /* clear out root objects */
- pic->sp = pic->stbase;
- pic->ci = pic->cibase;
- pic->arena_idx = 0;
- pic->err = NULL;
- xh_clear(&pic->macros);
- pic->libs = pic_nil_value();
-
- /* free all heap objects */
- pic_gc_run(pic);
-
- /* free heaps */
- pic_heap_close(pic->heap);
-
- /* free runtime context */
- free(pic->stbase);
- free(pic->cibase);
-
- /* free reader struct */
- xh_destroy(&pic->reader->labels);
- pic_trie_delete(pic, pic->reader->trie);
- free(pic->reader);
-
- /* free global stacks */
- free(pic->try_jmps);
- xh_destroy(&pic->syms);
- xh_destroy(&pic->globals);
- xh_destroy(&pic->macros);
-
- /* free GC arena */
- free(pic->arena);
-
- /* free symbol names */
- xh_begin(&it, &pic->sym_names);
- while (xh_next(&it)) {
- free(xh_val(it.e, char *));
- }
- xh_destroy(&pic->sym_names);
-
- free(pic);
-}
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 <string.h>
-
-#include "picrin.h"
-#include "picrin/string.h"
-#include "picrin/pair.h"
-#include "picrin/port.h"
-
-static pic_str *
-str_new_rope(pic_state *pic, xrope *rope)
-{
- pic_str *str;
-
- str = (pic_str *)pic_obj_alloc(pic, sizeof(pic_str), PIC_TT_STRING);
- str->rope = rope; /* delegate ownership */
- return str;
-}
-
-pic_str *
-pic_str_new(pic_state *pic, const char *imbed, size_t len)
-{
- if (imbed == NULL && len > 0) {
- pic_errorf(pic, "zero length specified against NULL ptr");
- }
- return str_new_rope(pic, xr_new_copy(imbed, len));
-}
-
-pic_str *
-pic_str_new_cstr(pic_state *pic, const char *cstr)
-{
- return pic_str_new(pic, cstr, strlen(cstr));
-}
-
-pic_str *
-pic_str_new_fill(pic_state *pic, size_t len, char fill)
-{
- size_t i;
- char *cstr;
- pic_str *str;
-
- cstr = (char *)pic_alloc(pic, len + 1);
- cstr[len] = '\0';
- for (i = 0; i < len; ++i) {
- cstr[i] = fill;
- }
-
- str = pic_str_new(pic, cstr, len);
-
- pic_free(pic, cstr);
- return str;
-}
-
-size_t
-pic_strlen(pic_str *str)
-{
- return xr_len(str->rope);
-}
-
-char
-pic_str_ref(pic_state *pic, pic_str *str, size_t i)
-{
- int c;
-
- c = xr_at(str->rope, i);
- if (c == -1) {
- pic_errorf(pic, "index out of range %d", i);
- }
- return (char)c;
-}
-
-static xrope *
-xr_put(xrope *rope, size_t i, char c)
-{
- xrope *x, *y, *z;
- char buf[2];
-
- if (xr_len(rope) <= i) {
- return NULL;
- }
-
- buf[0] = c;
- buf[1] = '\0';
-
- x = xr_sub(rope, 0, i);
- y = xr_new_copy(buf, 1);
- z = xr_cat(x, y);
- XROPE_DECREF(x);
- XROPE_DECREF(y);
-
- x = z;
- y = xr_sub(rope, i + 1, xr_len(rope));
- z = xr_cat(z, y);
- XROPE_DECREF(x);
- XROPE_DECREF(y);
-
- return z;
-}
-
-void
-pic_str_set(pic_state *pic, pic_str *str, size_t i, char c)
-{
- xrope *x;
-
- x = xr_put(str->rope, i, c);
- if (x == NULL) {
- pic_errorf(pic, "index out of range %d", i);
- }
- XROPE_DECREF(str->rope);
- str->rope = x;
-}
-
-pic_str *
-pic_strcat(pic_state *pic, pic_str *a, pic_str *b)
-{
- return str_new_rope(pic, xr_cat(a->rope, b->rope));
-}
-
-pic_str *
-pic_substr(pic_state *pic, pic_str *str, size_t s, size_t e)
-{
- return str_new_rope(pic, xr_sub(str->rope, s, e));
-}
-
-int
-pic_strcmp(pic_str *str1, pic_str *str2)
-{
- return strcmp(xr_cstr(str1->rope), xr_cstr(str2->rope));
-}
-
-const char *
-pic_str_cstr(pic_str *str)
-{
- return xr_cstr(str->rope);
-}
-
-pic_value
-pic_vfformat(pic_state *pic, xFILE *file, const char *fmt, va_list ap)
-{
- char c;
- pic_value irrs = pic_nil_value();
-
- while ((c = *fmt++)) {
- switch (c) {
- default:
- xfputc(c, file);
- break;
- case '%':
- c = *fmt++;
- if (! c)
- goto exit;
- switch (c) {
- default:
- xfputc(c, file);
- break;
- case '%':
- xfputc('%', file);
- break;
- case 'c':
- xfprintf(file, "%c", va_arg(ap, int));
- break;
- case 's':
- xfprintf(file, "%s", va_arg(ap, const char *));
- break;
- case 'd':
- xfprintf(file, "%d", va_arg(ap, int));
- break;
- case 'p':
- xfprintf(file, "%p", va_arg(ap, void *));
- break;
- case 'f':
- xfprintf(file, "%f", va_arg(ap, double));
- break;
- }
- break;
- case '~':
- c = *fmt++;
- if (! c)
- goto exit;
- switch (c) {
- default:
- xfputc(c, file);
- break;
- case '~':
- xfputc('~', file);
- break;
- case '%':
- xfputc('\n', file);
- break;
- case 'a':
- irrs = pic_cons(pic, pic_fdisplay(pic, va_arg(ap, pic_value), file), irrs);
- break;
- case 's':
- irrs = pic_cons(pic, pic_fwrite(pic, va_arg(ap, pic_value), file), irrs);
- break;
- }
- break;
- }
- }
- exit:
-
- return pic_reverse(pic, irrs);
-}
-
-pic_value
-pic_vformat(pic_state *pic, const char *fmt, va_list ap)
-{
- struct pic_port *port;
- pic_value irrs;
-
- port = pic_open_output_string(pic);
-
- irrs = pic_vfformat(pic, port->file, fmt, ap);
- irrs = pic_cons(pic, pic_obj_value(pic_get_output_string(pic, port)), irrs);
-
- pic_close_port(pic, port);
- return irrs;
-}
-
-pic_value
-pic_format(pic_state *pic, const char *fmt, ...)
-{
- va_list ap;
- pic_value objs;
-
- va_start(ap, fmt);
- objs = pic_vformat(pic, fmt, ap);
- va_end(ap);
-
- return objs;
-}
-
-static pic_value
-pic_str_string_p(pic_state *pic)
-{
- pic_value v;
-
- pic_get_args(pic, "o", &v);
-
- return pic_bool_value(pic_str_p(v));
-}
-
-static pic_value
-pic_str_make_string(pic_state *pic)
-{
- int len;
- char c = ' ';
-
- pic_get_args(pic, "i|c", &len, &c);
-
- return pic_obj_value(pic_str_new_fill(pic, len, c));
-}
-
-static pic_value
-pic_str_string_length(pic_state *pic)
-{
- pic_str *str;
-
- pic_get_args(pic, "s", &str);
-
- return pic_int_value(pic_strlen(str));
-}
-
-static pic_value
-pic_str_string_ref(pic_state *pic)
-{
- pic_str *str;
- int k;
-
- pic_get_args(pic, "si", &str, &k);
-
- return pic_char_value(pic_str_ref(pic, str, k));
-}
-
-static pic_value
-pic_str_string_set(pic_state *pic)
-{
- pic_str *str;
- char c;
- int k;
-
- pic_get_args(pic, "sic", &str, &k, &c);
-
- pic_str_set(pic, str, k, c);
- return pic_none_value();
-}
-
-#define DEFINE_STRING_CMP(name, op) \
- static pic_value \
- pic_str_string_##name(pic_state *pic) \
- { \
- size_t argc; \
- pic_value *argv; \
- size_t i; \
- \
- pic_get_args(pic, "*", &argc, &argv); \
- \
- if (argc < 1 || ! pic_str_p(argv[0])) { \
- return pic_false_value(); \
- } \
- \
- for (i = 1; i < argc; ++i) { \
- if (! pic_str_p(argv[i])) { \
- return pic_false_value(); \
- } \
- if (! (pic_strcmp(pic_str_ptr(argv[i-1]), pic_str_ptr(argv[i])) op 0)) { \
- return pic_false_value(); \
- } \
- } \
- return pic_true_value(); \
- }
-
-DEFINE_STRING_CMP(eq, ==)
-DEFINE_STRING_CMP(lt, <)
-DEFINE_STRING_CMP(gt, >)
-DEFINE_STRING_CMP(le, <=)
-DEFINE_STRING_CMP(ge, >=)
-
-static pic_value
-pic_str_string_copy(pic_state *pic)
-{
- pic_str *str;
- int n, start, end;
-
- n = pic_get_args(pic, "s|ii", &str, &start, &end);
-
- switch (n) {
- case 1:
- start = 0;
- case 2:
- end = pic_strlen(str);
- }
-
- return pic_obj_value(pic_substr(pic, str, start, end));
-}
-
-static pic_value
-pic_str_string_copy_ip(pic_state *pic)
-{
- pic_str *to, *from;
- int n, at, start, end;
-
- n = pic_get_args(pic, "sis|ii", &to, &at, &from, &start, &end);
-
- switch (n) {
- case 3:
- start = 0;
- case 4:
- end = pic_strlen(from);
- }
- if (to == from) {
- from = pic_substr(pic, from, 0, end);
- }
-
- while (start < end) {
- pic_str_set(pic, to, at++, pic_str_ref(pic, from, start++));
- }
- return pic_none_value();
-}
-
-static pic_value
-pic_str_string_append(pic_state *pic)
-{
- size_t argc, i;
- pic_value *argv;
- pic_str *str;
-
- pic_get_args(pic, "*", &argc, &argv);
-
- str = pic_str_new(pic, NULL, 0);
- for (i = 0; i < argc; ++i) {
- if (! pic_str_p(argv[i])) {
- pic_error(pic, "type error");
- }
- str = pic_strcat(pic, str, pic_str_ptr(argv[i]));
- }
- return pic_obj_value(str);
-}
-
-static pic_value
-pic_str_string_fill_ip(pic_state *pic)
-{
- pic_str *str;
- char c;
- int n, start, end;
-
- n = pic_get_args(pic, "sc|ii", &str, &c, &start, &end);
-
- switch (n) {
- case 2:
- start = 0;
- case 3:
- end = pic_strlen(str);
- }
-
- while (start < end) {
- pic_str_set(pic, str, start++, c);
- }
- return pic_none_value();
-}
-
-void
-pic_init_str(pic_state *pic)
-{
- pic_defun(pic, "string?", pic_str_string_p);
- pic_defun(pic, "make-string", pic_str_make_string);
- pic_defun(pic, "string-length", pic_str_string_length);
- pic_defun(pic, "string-ref", pic_str_string_ref);
- pic_defun(pic, "string-set!", pic_str_string_set);
-
- pic_defun(pic, "string=?", pic_str_string_eq);
- pic_defun(pic, "string<?", pic_str_string_lt);
- pic_defun(pic, "string>?", pic_str_string_gt);
- pic_defun(pic, "string<=?", pic_str_string_le);
- pic_defun(pic, "string>=?", pic_str_string_ge);
-
- pic_defun(pic, "string-copy", pic_str_string_copy);
- pic_defun(pic, "string-copy!", pic_str_string_copy_ip);
- pic_defun(pic, "string-append", pic_str_string_append);
- pic_defun(pic, "string-fill!", pic_str_string_fill_ip);
- pic_defun(pic, "substring", pic_str_string_copy);
-}
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 <string.h>
-#include <stdlib.h>
-#include <math.h>
-
-#include "picrin.h"
-#include "picrin/string.h"
-
-pic_sym
-pic_intern(pic_state *pic, const char *str, size_t len)
-{
- char *cstr;
- xh_entry *e;
- pic_sym id;
-
- cstr = (char *)pic_malloc(pic, len + 1);
- cstr[len] = '\0';
- memcpy(cstr, str, len);
-
- e = xh_get_str(&pic->syms, cstr);
- if (e) {
- return xh_val(e, pic_sym);
- }
-
- id = pic->sym_cnt++;
- xh_put_str(&pic->syms, cstr, &id);
- xh_put_int(&pic->sym_names, id, &cstr);
- return id;
-}
-
-pic_sym
-pic_intern_cstr(pic_state *pic, const char *str)
-{
- return pic_intern(pic, str, strlen(str));
-}
-
-pic_sym
-pic_gensym(pic_state *pic, pic_sym base)
-{
- int uid = pic->uniq_sym_cnt++, len;
- char *str, mark;
- pic_sym uniq;
-
- if (pic_interned_p(pic, base)) {
- mark = '@';
- } else {
- mark = '.';
- }
-
- len = snprintf(NULL, 0, "%s%c%d", pic_symbol_name(pic, base), mark, uid);
- str = pic_alloc(pic, len + 1);
- sprintf(str, "%s%c%d", pic_symbol_name(pic, base), mark, uid);
-
- /* don't put the symbol to pic->syms to keep it uninterned */
- uniq = pic->sym_cnt++;
- xh_put_int(&pic->sym_names, uniq, &str);
-
- return uniq;
-}
-
-pic_sym
-pic_ungensym(pic_state *pic, pic_sym base)
-{
- const char *name, *occr;
-
- if (pic_interned_p(pic, base)) {
- return base;
- }
-
- name = pic_symbol_name(pic, base);
- if ((occr = strrchr(name, '@')) == NULL) {
- pic_abort(pic, "logic flaw");
- }
- return pic_intern(pic, name, occr - name);
-}
-
-bool
-pic_interned_p(pic_state *pic, pic_sym sym)
-{
- return sym == pic_intern_cstr(pic, pic_symbol_name(pic, sym));
-}
-
-const char *
-pic_symbol_name(pic_state *pic, pic_sym sym)
-{
- return xh_val(xh_get_int(&pic->sym_names, sym), const char *);
-}
-
-static pic_value
-pic_symbol_symbol_p(pic_state *pic)
-{
- pic_value v;
-
- pic_get_args(pic, "o", &v);
-
- return pic_bool_value(pic_sym_p(v));
-}
-
-static pic_value
-pic_symbol_symbol_eq_p(pic_state *pic)
-{
- size_t argc, i;
- pic_value *argv;
-
- pic_get_args(pic, "*", &argc, &argv);
-
- for (i = 0; i < argc; ++i) {
- if (! pic_sym_p(argv[i])) {
- return pic_false_value();
- }
- if (! pic_eq_p(argv[i], argv[0])) {
- return pic_false_value();
- }
- }
- return pic_true_value();
-}
-
-static pic_value
-pic_symbol_symbol_to_string(pic_state *pic)
-{
- pic_value v;
-
- pic_get_args(pic, "o", &v);
-
- if (! pic_sym_p(v)) {
- pic_error(pic, "symbol->string: expected symbol");
- }
-
- return pic_obj_value(pic_str_new_cstr(pic, pic_symbol_name(pic, pic_sym(v))));
-}
-
-static pic_value
-pic_symbol_string_to_symbol(pic_state *pic)
-{
- pic_value v;
-
- pic_get_args(pic, "o", &v);
-
- if (! pic_str_p(v)) {
- pic_error(pic, "string->symbol: expected string");
- }
-
- return pic_symbol_value(pic_intern_cstr(pic, pic_str_cstr(pic_str_ptr(v))));
-}
-
-void
-pic_init_symbol(pic_state *pic)
-{
- pic_deflibrary (pic, "(picrin base symbol)") {
- pic_defun(pic, "symbol?", pic_symbol_symbol_p);
- pic_defun(pic, "symbol->string", pic_symbol_symbol_to_string);
- pic_defun(pic, "string->symbol", pic_symbol_string_to_symbol);
- }
-
- pic_deflibrary (pic, "(picrin symbol)") {
- pic_defun(pic, "symbol=?", pic_symbol_symbol_eq_p);
- }
-}
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 <stdlib.h>
-#include <stdarg.h>
-#include <limits.h>
-#include <math.h>
-
-#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 <math.h>
-
-#include "picrin.h"
-#include "picrin/port.h"
-#include "picrin/pair.h"
-#include "picrin/string.h"
-#include "picrin/vector.h"
-#include "picrin/blob.h"
-#include "picrin/dict.h"
-#include "picrin/record.h"
-#include "picrin/proc.h"
-
-static bool
-is_tagged(pic_state *pic, pic_sym tag, pic_value pair)
-{
- return pic_pair_p(pic_cdr(pic, pair))
- && pic_nil_p(pic_cddr(pic, pair))
- && pic_eq_p(pic_car(pic, pair), pic_symbol_value(tag));
-}
-
-static bool
-is_quote(pic_state *pic, pic_value pair)
-{
- return is_tagged(pic, pic->sQUOTE, pair);
-}
-
-static bool
-is_unquote(pic_state *pic, pic_value pair)
-{
- return is_tagged(pic, pic->sUNQUOTE, pair);
-}
-
-static bool
-is_unquote_splicing(pic_state *pic, pic_value pair)
-{
- return is_tagged(pic, pic->sUNQUOTE_SPLICING, pair);
-}
-
-static bool
-is_quasiquote(pic_state *pic, pic_value pair)
-{
- return is_tagged(pic, pic->sQUASIQUOTE, pair);
-}
-
-struct writer_control {
- pic_state *pic;
- xFILE *file;
- int mode;
- xhash labels; /* object -> int */
- xhash visited; /* object -> int */
- int cnt;
-};
-
-#define WRITE_MODE 1
-#define DISPLAY_MODE 2
-
-static void
-writer_control_init(struct writer_control *p, pic_state *pic, xFILE *file, int mode)
-{
- p->pic = pic;
- p->file = file;
- p->mode = mode;
- p->cnt = 0;
- xh_init_ptr(&p->labels, sizeof(int));
- xh_init_ptr(&p->visited, sizeof(int));
-}
-
-static void
-writer_control_destroy(struct writer_control *p)
-{
- xh_destroy(&p->labels);
- xh_destroy(&p->visited);
-}
-
-static void
-traverse_shared(struct writer_control *p, pic_value obj)
-{
- xh_entry *e;
- size_t i;
- int c;
-
- switch (pic_type(obj)) {
- case PIC_TT_PAIR:
- case PIC_TT_VECTOR:
- e = xh_get_ptr(&p->labels, pic_obj_ptr(obj));
- if (e == NULL) {
- c = -1;
- xh_put_ptr(&p->labels, pic_obj_ptr(obj), &c);
- }
- else if (xh_val(e, int) == -1) {
- c = p->cnt++;
- xh_put_ptr(&p->labels, pic_obj_ptr(obj), &c);
- break;
- }
- else {
- break;
- }
-
- if (pic_pair_p(obj)) {
- traverse_shared(p, pic_car(p->pic, obj));
- traverse_shared(p, pic_cdr(p->pic, obj));
- }
- else {
- for (i = 0; i < pic_vec_ptr(obj)->len; ++i) {
- traverse_shared(p, pic_vec_ptr(obj)->data[i]);
- }
- }
- break;
- default:
- /* pass */
- break;
- }
-}
-
-static void write_core(struct writer_control *p, pic_value);
-
-static void
-write_pair(struct writer_control *p, struct pic_pair *pair)
-{
- xh_entry *e;
- int c;
-
- write_core(p, pair->car);
-
- if (pic_nil_p(pair->cdr)) {
- return;
- }
- else if (pic_pair_p(pair->cdr)) {
-
- /* shared objects */
- if ((e = xh_get_ptr(&p->labels, pic_obj_ptr(pair->cdr))) && xh_val(e, int) != -1) {
- xfprintf(p->file, " . ");
-
- if ((xh_get_ptr(&p->visited, pic_obj_ptr(pair->cdr)))) {
- xfprintf(p->file, "#%d#", xh_val(e, int));
- return;
- }
- else {
- xfprintf(p->file, "#%d=", xh_val(e, int));
- c = 1;
- xh_put_ptr(&p->visited, pic_obj_ptr(pair->cdr), &c);
- }
- }
- else {
- xfprintf(p->file, " ");
- }
-
- write_pair(p, pic_pair_ptr(pair->cdr));
- return;
- }
- else {
- xfprintf(p->file, " . ");
- write_core(p, pair->cdr);
- }
-}
-
-static void
-write_str(pic_state *pic, struct pic_string *str, xFILE *file)
-{
- size_t i;
- const char *cstr = pic_str_cstr(str);
-
- UNUSED(pic);
-
- for (i = 0; i < pic_strlen(str); ++i) {
- if (cstr[i] == '"' || cstr[i] == '\\') {
- xfputc('\\', file);
- }
- xfputc(cstr[i], file);
- }
-}
-
-static void
-write_record(pic_state *pic, struct pic_record *rec, xFILE *file)
-{
- const pic_sym sWRITER = pic_intern_cstr(pic, "writer");
- pic_value type, writer, str;
-
-#if DEBUG
-
- xfprintf(file, "#<record %p>", rec);
-
-#else
-
- type = pic_record_type(pic, rec);
- if (! pic_record_p(type)) {
- pic_errorf(pic, "\"@@type\" property of record object is not of record type");
- }
- writer = pic_record_ref(pic, pic_record_ptr(type), sWRITER);
- if (! pic_proc_p(writer)) {
- pic_errorf(pic, "\"writer\" property of record type object is not a procedure");
- }
- str = pic_apply1(pic, pic_proc_ptr(writer), pic_obj_value(rec));
- if (! pic_str_p(str)) {
- pic_errorf(pic, "return value from writer procedure is not of string type");
- }
- xfprintf(file, "%s", pic_str_cstr(pic_str_ptr(str)));
-
-#endif
-}
-
-static void
-write_core(struct writer_control *p, pic_value obj)
-{
- pic_state *pic = p->pic;
- xFILE *file = p->file;
- size_t i;
- xh_entry *e;
- xh_iter it;
- int c;
- float f;
-
- /* shared objects */
- if (pic_vtype(obj) == PIC_VTYPE_HEAP
- && (e = xh_get_ptr(&p->labels, pic_obj_ptr(obj)))
- && xh_val(e, int) != -1) {
- if ((xh_get_ptr(&p->visited, pic_obj_ptr(obj)))) {
- xfprintf(file, "#%d#", xh_val(e, int));
- return;
- }
- else {
- xfprintf(file, "#%d=", xh_val(e, int));
- c = 1;
- xh_put_ptr(&p->visited, pic_obj_ptr(obj), &c);
- }
- }
-
- switch (pic_type(obj)) {
- case PIC_TT_UNDEF:
- xfprintf(file, "#<undef>");
- break;
- case PIC_TT_NIL:
- xfprintf(file, "()");
- break;
- case PIC_TT_BOOL:
- if (pic_true_p(obj))
- xfprintf(file, "#t");
- else
- xfprintf(file, "#f");
- break;
- case PIC_TT_PAIR:
- if (is_quote(pic, obj)) {
- xfprintf(file, "'");
- write_core(p, pic_list_ref(pic, obj, 1));
- break;
- }
- else if (is_unquote(pic, obj)) {
- xfprintf(file, ",");
- write_core(p, pic_list_ref(pic, obj, 1));
- break;
- }
- else if (is_unquote_splicing(pic, obj)) {
- xfprintf(file, ",@");
- write_core(p, pic_list_ref(pic, obj, 1));
- break;
- }
- else if (is_quasiquote(pic, obj)) {
- xfprintf(file, "`");
- write_core(p, pic_list_ref(pic, obj, 1));
- break;
- }
- xfprintf(file, "(");
- write_pair(p, pic_pair_ptr(obj));
- xfprintf(file, ")");
- break;
- case PIC_TT_SYMBOL:
- xfprintf(file, "%s", pic_symbol_name(pic, pic_sym(obj)));
- break;
- case PIC_TT_CHAR:
- if (p->mode == DISPLAY_MODE) {
- xfputc(pic_char(obj), file);
- break;
- }
- switch (pic_char(obj)) {
- default: xfprintf(file, "#\\%c", pic_char(obj)); break;
- case '\a': xfprintf(file, "#\\alarm"); break;
- case '\b': xfprintf(file, "#\\backspace"); break;
- case 0x7f: xfprintf(file, "#\\delete"); break;
- case 0x1b: xfprintf(file, "#\\escape"); break;
- case '\n': xfprintf(file, "#\\newline"); break;
- case '\r': xfprintf(file, "#\\return"); break;
- case ' ': xfprintf(file, "#\\space"); break;
- case '\t': xfprintf(file, "#\\tab"); break;
- }
- break;
- case PIC_TT_FLOAT:
- f = pic_float(obj);
- if (isnan(f)) {
- xfprintf(file, signbit(f) ? "-nan.0" : "+nan.0");
- } else if (isinf(f)) {
- xfprintf(file, signbit(f) ? "-inf.0" : "+inf.0");
- } else {
- xfprintf(file, "%f", pic_float(obj));
- }
- break;
- case PIC_TT_INT:
- xfprintf(file, "%d", pic_int(obj));
- break;
- case PIC_TT_EOF:
- xfprintf(file, "#.(eof-object)");
- break;
- case PIC_TT_STRING:
- if (p->mode == DISPLAY_MODE) {
- xfprintf(file, "%s", pic_str_cstr(pic_str_ptr(obj)));
- break;
- }
- xfprintf(file, "\"");
- write_str(pic, pic_str_ptr(obj), file);
- xfprintf(file, "\"");
- break;
- case PIC_TT_VECTOR:
- xfprintf(file, "#(");
- for (i = 0; i < pic_vec_ptr(obj)->len; ++i) {
- write_core(p, pic_vec_ptr(obj)->data[i]);
- if (i + 1 < pic_vec_ptr(obj)->len) {
- xfprintf(file, " ");
- }
- }
- xfprintf(file, ")");
- break;
- case PIC_TT_BLOB:
- xfprintf(file, "#u8(");
- for (i = 0; i < pic_blob_ptr(obj)->len; ++i) {
- xfprintf(file, "%d", pic_blob_ptr(obj)->data[i]);
- if (i + 1 < pic_blob_ptr(obj)->len) {
- xfprintf(file, " ");
- }
- }
- xfprintf(file, ")");
- break;
- case PIC_TT_DICT:
- xfprintf(file, "#.(dictionary");
- xh_begin(&it, &pic_dict_ptr(obj)->hash);
- while (xh_next(&it)) {
- xfprintf(file, " '%s ", pic_symbol_name(pic, xh_key(it.e, pic_sym)));
- write_core(p, xh_val(it.e, pic_value));
- }
- xfprintf(file, ")");
- break;
- case PIC_TT_RECORD:
- write_record(pic, pic_record_ptr(obj), file);
- break;
- default:
- xfprintf(file, "#<%s %p>", pic_type_repr(pic_type(obj)), pic_ptr(obj));
- break;
- }
-}
-
-static void
-write(pic_state *pic, pic_value obj, xFILE *file)
-{
- struct writer_control p;
-
- writer_control_init(&p, pic, file, WRITE_MODE);
-
- traverse_shared(&p, obj); /* FIXME */
-
- write_core(&p, obj);
-
- writer_control_destroy(&p);
-}
-
-static void
-write_simple(pic_state *pic, pic_value obj, xFILE *file)
-{
- struct writer_control p;
-
- writer_control_init(&p, pic, file, WRITE_MODE);
-
- /* no traverse here! */
-
- write_core(&p, obj);
-
- writer_control_destroy(&p);
-}
-
-static void
-write_shared(pic_state *pic, pic_value obj, xFILE *file)
-{
- struct writer_control p;
-
- writer_control_init(&p, pic, file, WRITE_MODE);
-
- traverse_shared(&p, obj);
-
- write_core(&p, obj);
-
- writer_control_destroy(&p);
-}
-
-static void
-display(pic_state *pic, pic_value obj, xFILE *file)
-{
- struct writer_control p;
-
- writer_control_init(&p, pic, file, DISPLAY_MODE);
-
- traverse_shared(&p, obj); /* FIXME */
-
- write_core(&p, obj);
-
- writer_control_destroy(&p);
-}
-
-pic_value
-pic_write(pic_state *pic, pic_value obj)
-{
- return pic_fwrite(pic, obj, xstdout);
-}
-
-pic_value
-pic_fwrite(pic_state *pic, pic_value obj, xFILE *file)
-{
- write(pic, obj, file);
- xfflush(file);
- return obj;
-}
-
-pic_value
-pic_display(pic_state *pic, pic_value obj)
-{
- return pic_fdisplay(pic, obj, xstdout);
-}
-
-pic_value
-pic_fdisplay(pic_state *pic, pic_value obj, xFILE *file)
-{
- display(pic, obj, file);
- xfflush(file);
- return obj;
-}
-
-void
-pic_printf(pic_state *pic, const char *fmt, ...)
-{
- va_list ap;
- pic_str *str;
-
- va_start(ap, fmt);
-
- str = pic_str_ptr(pic_car(pic, pic_vformat(pic, fmt, ap)));
-
- va_end(ap);
-
- xprintf("%s", pic_str_cstr(str));
- xfflush(xstdout);
-}
-
-static pic_value
-pic_write_write(pic_state *pic)
-{
- pic_value v;
- struct pic_port *port = pic_stdout(pic);
-
- pic_get_args(pic, "o|p", &v, &port);
- write(pic, v, port->file);
- return pic_none_value();
-}
-
-static pic_value
-pic_write_write_simple(pic_state *pic)
-{
- pic_value v;
- struct pic_port *port = pic_stdout(pic);
-
- pic_get_args(pic, "o|p", &v, &port);
- write_simple(pic, v, port->file);
- return pic_none_value();
-}
-
-static pic_value
-pic_write_write_shared(pic_state *pic)
-{
- pic_value v;
- struct pic_port *port = pic_stdout(pic);
-
- pic_get_args(pic, "o|p", &v, &port);
- write_shared(pic, v, port->file);
- return pic_none_value();
-}
-
-static pic_value
-pic_write_display(pic_state *pic)
-{
- pic_value v;
- struct pic_port *port = pic_stdout(pic);
-
- pic_get_args(pic, "o|p", &v, &port);
- display(pic, v, port->file);
- return pic_none_value();
-}
-
-void
-pic_init_write(pic_state *pic)
-{
- pic_deflibrary (pic, "(scheme write)") {
- pic_defun(pic, "write", pic_write_write);
- pic_defun(pic, "write-simple", pic_write_write_simple);
- pic_defun(pic, "write-shared", pic_write_write_shared);
- pic_defun(pic, "display", pic_write_display);
- }
-}
From 8764bec50b51d1b905284a279e13c60ef6fabe5d Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Mon, 1 Sep 2014 09:40:55 +0900
Subject: [PATCH 05/33] move main.c to src/
---
CMakeLists.txt | 1 -
src/CMakeLists.txt | 14 ++++++++++++++
{tools => src}/main.c | 0
tools/CMakeLists.txt | 9 ---------
4 files changed, 14 insertions(+), 10 deletions(-)
rename {tools => src}/main.c (100%)
delete mode 100644 tools/CMakeLists.txt
diff --git a/CMakeLists.txt b/CMakeLists.txt
index cbc7883a..a46c0557 100644
--- a/CMakeLists.txt
+++ b/CMakeLists.txt
@@ -32,7 +32,6 @@ include_directories(extlib/benz/include)
include(piclib/CMakeLists.txt)
include(contrib/CMakeLists.txt)
include(src/CMakeLists.txt)
-include(tools/CMakeLists.txt)
# ----
diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt
index f4a62f1d..0ca3b949 100644
--- a/src/CMakeLists.txt
+++ b/src/CMakeLists.txt
@@ -1,3 +1,5 @@
+### libpicrin ###
+
find_package(Perl REQUIRED)
# benz
@@ -31,3 +33,15 @@ target_link_libraries(picrin m ${PICRIN_CONTRIB_LIBRARIES})
set(CMAKE_INSTALL_RPATH ${CMAKE_INSTALL_PREFIX}/lib)
install(TARGETS picrin DESTINATION lib)
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/tools/main.c b/src/main.c
similarity index 100%
rename from tools/main.c
rename to src/main.c
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)
From 7f092cb9abd2df17240e6301511c587333a2a570 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Mon, 1 Sep 2014 09:53:19 +0900
Subject: [PATCH 06/33] managed to make it work
---
piclib/scheme/base.scm | 23 ++++++++++++++++++++++-
src/init.c | 19 ++++++++++++++++++-
src/main.c | 2 ++
3 files changed, 42 insertions(+), 2 deletions(-)
diff --git a/piclib/scheme/base.scm b/piclib/scheme/base.scm
index 186b2f57..efb0a61a 100644
--- a/piclib/scheme/base.scm
+++ b/piclib/scheme/base.scm
@@ -7,6 +7,20 @@
(export define set! lambda quote
if begin define-syntax)
+ ;; call/cc
+
+ (define real-callcc call-with-current-continuation)
+
+ (set! call-with-current-continuation
+ (lambda (f)
+ (real-callcc
+ (lambda (c)
+ (f (lambda args (apply continue c args)))))))
+
+ (define call/cc call-with-current-continuation)
+
+ (export call/cc)
+
;; core syntax
(define-syntax syntax-error
@@ -840,6 +854,10 @@
(export define-record-type)
+ (export (rename floor-remainder modulo)
+ (rename truncate-quotient quotient)
+ (rename truncate-remainder remainder))
+
;; 6.4 Pairs and lists
(export pair?
@@ -920,7 +938,10 @@
(define (string . objs)
(list->string objs))
- (export string string->list list->string)
+ (export string
+ string->list
+ list->string
+ (rename string-copy substring))
;; 6.8. Vector
diff --git a/src/init.c b/src/init.c
index 76b51d35..6ff9eac0 100644
--- a/src/init.c
+++ b/src/init.c
@@ -35,11 +35,19 @@ pic_libraries(pic_state *pic)
return libs;
}
+void pic_init_eval(pic_state *);
+void pic_init_file(pic_state *);
+void pic_init_load(pic_state *);
+void pic_init_macro2(pic_state *);
+void pic_init_system(pic_state *);
+void pic_init_time(pic_state *);
+
void pic_init_contrib(pic_state *);
+
void pic_load_piclib(pic_state *);
void
-pic_init_misc(pic_state *pic)
+pic_init_picrin(pic_state *pic)
{
pic_deflibrary (pic, "(picrin library)") {
pic_defun(pic, "libraries", pic_libraries);
@@ -47,7 +55,16 @@ pic_init_misc(pic_state *pic)
pic_deflibrary (pic, "(scheme base)") {
pic_defun(pic, "features", pic_features);
+
+ pic_init_eval(pic);
+ pic_init_file(pic);
+ pic_init_load(pic);
+ pic_init_macro2(pic);
+ pic_init_system(pic);
+ pic_init_time(pic);
+
pic_init_contrib(pic);
+
pic_load_piclib(pic);
}
}
diff --git a/src/main.c b/src/main.c
index 617d4a0d..d37bbdca 100644
--- a/src/main.c
+++ b/src/main.c
@@ -13,6 +13,8 @@ main(int argc, char *argv[], char **envp)
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());
From 42ddd5793eda7927929a5f92f8967be6d5706d68 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Thu, 4 Sep 2014 18:43:53 +0900
Subject: [PATCH 07/33] update benz
---
extlib/benz | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extlib/benz b/extlib/benz
index a3a8b11d..14e7fd4e 160000
--- a/extlib/benz
+++ b/extlib/benz
@@ -1 +1 @@
-Subproject commit a3a8b11d4b47a1ddfda8fe05aefa12c77b24a1cc
+Subproject commit 14e7fd4e98ca4619edb5eb7e48b882d94e5e50d2
From 055ec2538dcc84a7f7f4dcaa8300852cfc39057a Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Thu, 4 Sep 2014 18:54:04 +0900
Subject: [PATCH 08/33] update prototypes (picrin/symbol.scm, picrin/list.scm,
picrin/base.scm)
---
piclib/CMakeLists.txt | 2 -
piclib/picrin/base.scm | 248 ++++++++++++++++++++++++++++++++++++---
piclib/picrin/list.scm | 30 -----
piclib/picrin/symbol.scm | 7 --
4 files changed, 231 insertions(+), 56 deletions(-)
delete mode 100644 piclib/picrin/list.scm
delete mode 100644 piclib/picrin/symbol.scm
diff --git a/piclib/CMakeLists.txt b/piclib/CMakeLists.txt
index 8f230621..31fae434 100644
--- a/piclib/CMakeLists.txt
+++ b/piclib/CMakeLists.txt
@@ -1,7 +1,5 @@
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
diff --git a/piclib/picrin/base.scm b/piclib/picrin/base.scm
index c4ca864f..90824b6c 100644
--- a/piclib/picrin/base.scm
+++ b/piclib/picrin/base.scm
@@ -1,24 +1,238 @@
(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
begin
- define-syntax))
+ define-syntax)
+
+ (export bytevector?
+ make-bytevector
+ bytevector-length
+ bytevector-u8-ref
+ bytevector-u8-set!
+ bytevector-copy!
+ bytevector-append)
+
+ (export eq?
+ eqv?
+ equal?)
+
+ (export boolean?
+ boolean=?
+ not)
+
+ (export char?
+ char->integer
+ integer->char)
+
+ (export call-with-current-continuation
+ continue
+ dynamic-wind
+ values
+ call-with-values)
+
+ (export make-dictionary
+ dictionary?
+ dictionary-ref
+ dictionary-set!
+ dictionary-delete
+ dictionary-size
+ dictionary-for-each)
+
+ (export with-exception-handler
+ raise
+ raise-continuable
+ error
+ error-object?
+ error-object-message
+ error-object-irritants
+ read-error?
+ file-error?)
+
+ (export identifier?
+ identifier=?
+ make-identifier)
+
+ (export number?
+ complex?
+ real?
+ rational?
+ integer?
+ exact?
+ inexact?
+ exact-integer?
+ =
+ <
+ >
+ <=
+ >=
+ zero?
+ positive?
+ negative?
+ odd?
+ even?
+ min
+ max
+ +
+ -
+ *
+ /
+ abs
+ floor-quotient
+ floor-remainder
+ floor/
+ truncate-quotient
+ truncate-remainder
+ truncate/
+ gcd
+ lcm
+ floor
+ ceiling
+ truncate
+ round
+ exact-integer-sqrt
+ square
+ 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 current-input-port
+ current-output-port
+ current-error-port
+ input-port?
+ output-port?
+ textual-port?
+ binary-port?
+ port?
+ input-port-open?
+ output-port-open?
+ close-port
+ close-input-port
+ close-output-port
+
+ open-input-string
+ open-output-string
+ get-output-string
+ open-input-bytevector
+ open-output-bytevector
+ get-output-bytevector
+
+ read-char
+ peek-char
+ read-line
+ eof-object?
+ eof-object
+ char-ready?
+ 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 procedure?
+ apply
+ map
+ for-each
+ attribute)
+
+ (export read)
+
+ (export make-record
+ record?
+ record-type
+ record-ref
+ record-set!)
+
+ (export string?
+ make-string
+ string-length
+ string-ref
+ string-set!
+ string=?
+ string<?
+ string>?
+ string<=?
+ string>=?
+ string-copy
+ string-copy!
+ string-append
+ string-fill!)
+
+ (export symbol?
+ symbol->string
+ string->symbol
+ symbol=?)
+
+ (export make-parameter
+ parameter-ref
+ parameter-set!
+ parameter-push!
+ parameter-pop!)
+
+ (export vector?
+ make-vector
+ vector-length
+ vector-ref
+ vector-set!
+ vector-copy!
+ vector-copy
+ vector-append
+ vector-fill!
+ list->vector
+ vector->list)
+
+ (export write
+ write-simple
+ write-shared
+ display))
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/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))
From 7a2b897f17a1dee0318ce49f59d1b6bc0cbc23b8 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Thu, 4 Sep 2014 18:59:25 +0900
Subject: [PATCH 09/33] add scheme/read.scm and scheme/write.scm
---
piclib/CMakeLists.txt | 2 ++
piclib/scheme/read.scm | 4 ++++
piclib/scheme/write.scm | 7 +++++++
3 files changed, 13 insertions(+)
create mode 100644 piclib/scheme/read.scm
create mode 100644 piclib/scheme/write.scm
diff --git a/piclib/CMakeLists.txt b/piclib/CMakeLists.txt
index 31fae434..6f79d0fd 100644
--- a/piclib/CMakeLists.txt
+++ b/piclib/CMakeLists.txt
@@ -11,6 +11,8 @@ list(APPEND PICLIB_SCHEME_LIBS
${PROJECT_SOURCE_DIR}/piclib/picrin/experimental/lambda.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
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/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))
From 7b55328ce68971cb365ddee0bae27e5796bfd63f Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Thu, 4 Sep 2014 19:11:33 +0900
Subject: [PATCH 10/33] rewrite load.c
---
src/load.c | 84 ++++++++++++++++++++++++------------------------------
1 file changed, 38 insertions(+), 46 deletions(-)
diff --git a/src/load.c b/src/load.c
index 440b45e2..d8c3af7f 100644
--- a/src/load.c
+++ b/src/load.c
@@ -4,67 +4,57 @@
#include "picrin.h"
#include "picrin/pair.h"
+#include "picrin/port.h"
+#include "picrin/error.h"
-pic_value
-pic_load_cstr(pic_state *pic, const char *src)
+void
+pic_load_port(pic_state *pic, struct pic_port *port)
{
- size_t ai;
- pic_value v, exprs;
- struct pic_proc *proc;
+ pic_value form;
- exprs = pic_parse_cstr(pic, src);
- if (pic_undef_p(exprs)) {
- pic_errorf(pic, "load: read failure (%s)", pic_errmsg(pic));
- }
+ pic_try {
+ size_t ai = pic_gc_arena_preserve(pic);
- pic_for_each (v, exprs) {
- ai = pic_gc_arena_preserve(pic);
+ while (! pic_eof_p(form = pic_read(pic, port))) {
+ pic_eval(pic, form, pic->lib);
- proc = pic_compile(pic, v, pic->lib);
- if (proc == NULL) {
- pic_error(pic, "load: compilation failure");
+ pic_gc_arena_restore(pic, ai);
}
-
- pic_apply(pic, proc, pic_nil_value());
-
- pic_gc_arena_restore(pic, ai);
}
-
- return pic_none_value();
+ pic_catch {
+ pic_errorf(pic, "load error: %s", pic_errmsg(pic));
+ }
}
-pic_value
-pic_load(pic_state *pic, const char *fn)
+void
+pic_load_cstr(pic_state *pic, const char *src)
{
- FILE *file;
- size_t ai;
- pic_value v, exprs;
- struct pic_proc *proc;
+ struct pic_port *port = pic_open_input_string(pic, src);
- file = fopen(fn, "r");
+ pic_load_port(pic, port);
+
+ pic_close_port(pic, port);
+}
+
+void
+pic_load(pic_state *pic, const char *filename)
+{
+ struct pic_port *port;
+ xFILE *file;
+
+ file = xfopen(filename, "r");
if (file == NULL) {
- pic_errorf(pic, "load: could not read file \"%s\"", fn);
+ pic_errorf(pic, "could not open file: %s", filename);
}
- exprs = pic_parse_file(pic, file);
- if (pic_undef_p(exprs)) {
- pic_errorf(pic, "load: read failure (%s)", pic_errmsg(pic));
- }
+ port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port), PIC_TT_PORT);
+ port->file = file;
+ port->flags = PIC_PORT_IN | PIC_PORT_TEXT;
+ port->status = PIC_PORT_OPEN;
- pic_for_each (v, exprs) {
- ai = pic_gc_arena_preserve(pic);
+ pic_load_port(pic, port);
- 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_close_port(pic, port);
}
static pic_value
@@ -75,7 +65,9 @@ pic_load_load(pic_state *pic)
pic_get_args(pic, "z|o", &fn, &envid);
- return pic_load(pic, fn);
+ pic_load(pic, fn);
+
+ return pic_none_value();
}
void
From be9d518e2f487525cf2181088803535738d72662 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Thu, 4 Sep 2014 19:11:41 +0900
Subject: [PATCH 11/33] addictional argument for pic_open
---
src/main.c | 3 ++-
1 file changed, 2 insertions(+), 1 deletion(-)
diff --git a/src/main.c b/src/main.c
index d37bbdca..14f2f9f0 100644
--- a/src/main.c
+++ b/src/main.c
@@ -8,10 +8,11 @@
int
main(int argc, char *argv[], char **envp)
{
+ xFILE *stdio[3] = { xstdin, xstdout, xstderr };
pic_state *pic;
int status = 0;
- pic = pic_open(argc, argv, envp);
+ pic = pic_open(argc, argv, envp, stdio);
pic_init_picrin(pic);
From 85ccc3082131c753999703c64fa46a20ff838455 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Thu, 4 Sep 2014 19:14:27 +0900
Subject: [PATCH 12/33] =?UTF-8?q?remove=20scheme=20implemetation=20of=20id?=
=?UTF-8?q?entifier=3D=3F?=
---
piclib/picrin/macro.scm | 12 ------------
1 file changed, 12 deletions(-)
diff --git a/piclib/picrin/macro.scm b/piclib/picrin/macro.scm
index 8a202cf6..0e5dc4b4 100644
--- a/piclib/picrin/macro.scm
+++ b/piclib/picrin/macro.scm
@@ -36,18 +36,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
From 6f40dcc5df4018f4ff2425937cddfe48637f80b2 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Thu, 4 Sep 2014 19:14:43 +0900
Subject: [PATCH 13/33] refactor define-record-writer
---
piclib/picrin/record.scm | 6 +++---
1 file changed, 3 insertions(+), 3 deletions(-)
diff --git a/piclib/picrin/record.scm b/piclib/picrin/record.scm
index 818913e8..18ee0fa7 100644
--- a/piclib/picrin/record.scm
+++ b/piclib/picrin/record.scm
@@ -1,17 +1,17 @@
(define-library (picrin record)
(import (scheme base))
- (define (define-record-writer* record-type 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
+ (set-record-writer! type
(lambda (obj)
body ...)))
((_ type writer)
- (define-record-writer* type
+ (set-record-writer! type
writer))))
(export define-record-writer))
From 268191d1c537036213f1ec224238d8570ee3d46e Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Fri, 5 Sep 2014 03:08:11 +0900
Subject: [PATCH 14/33] reorder base.scm
---
piclib/picrin/base.scm | 172 +++++++++++++++++++++--------------------
1 file changed, 87 insertions(+), 85 deletions(-)
diff --git a/piclib/picrin/base.scm b/piclib/picrin/base.scm
index 90824b6c..f1ea2c0b 100644
--- a/piclib/picrin/base.scm
+++ b/piclib/picrin/base.scm
@@ -1,20 +1,12 @@
(define-library (picrin base)
(export define
- set!
- quote
lambda
if
+ quote
+ set!
begin
define-syntax)
- (export bytevector?
- make-bytevector
- bytevector-length
- bytevector-u8-ref
- bytevector-u8-set!
- bytevector-copy!
- bytevector-append)
-
(export eq?
eqv?
equal?)
@@ -23,38 +15,15 @@
boolean=?
not)
+ (export symbol?
+ symbol->string
+ string->symbol
+ symbol=?)
+
(export char?
char->integer
integer->char)
- (export call-with-current-continuation
- continue
- dynamic-wind
- values
- call-with-values)
-
- (export make-dictionary
- dictionary?
- dictionary-ref
- dictionary-set!
- dictionary-delete
- dictionary-size
- dictionary-for-each)
-
- (export with-exception-handler
- raise
- raise-continuable
- error
- error-object?
- error-object-message
- error-object-irritants
- read-error?
- file-error?)
-
- (export identifier?
- identifier=?
- make-identifier)
-
(export number?
complex?
real?
@@ -139,6 +108,55 @@
assv
assoc)
+ (export bytevector?
+ make-bytevector
+ bytevector-length
+ bytevector-u8-ref
+ bytevector-u8-set!
+ 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=?
+ string<?
+ string>?
+ string<=?
+ string>=?
+ string-copy
+ string-copy!
+ string-append
+ string-fill!)
+
+ (export make-dictionary
+ dictionary?
+ dictionary-ref
+ dictionary-set!
+ dictionary-delete
+ dictionary-size
+ dictionary-for-each)
+
+ (export make-record
+ record?
+ record-type
+ record-ref
+ record-set!)
+
(export current-input-port
current-output-port
current-error-port
@@ -160,13 +178,15 @@
open-output-bytevector
get-output-bytevector
- read-char
- peek-char
- read-line
eof-object?
eof-object
+
+ read-char
+ peek-char
char-ready?
+ read-line
read-string
+
read-u8
peek-u8
u8-ready?
@@ -180,6 +200,32 @@
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
+ continue
+ 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
@@ -188,50 +234,6 @@
(export read)
- (export make-record
- record?
- record-type
- record-ref
- record-set!)
-
- (export string?
- make-string
- string-length
- string-ref
- string-set!
- string=?
- string<?
- string>?
- string<=?
- string>=?
- string-copy
- string-copy!
- string-append
- string-fill!)
-
- (export symbol?
- symbol->string
- string->symbol
- symbol=?)
-
- (export make-parameter
- parameter-ref
- parameter-set!
- parameter-push!
- parameter-pop!)
-
- (export vector?
- make-vector
- vector-length
- vector-ref
- vector-set!
- vector-copy!
- vector-copy
- vector-append
- vector-fill!
- list->vector
- vector->list)
-
(export write
write-simple
write-shared
From c15999cc764d2507ec6d914bf2e790fef20185e3 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Mon, 8 Sep 2014 17:08:38 +0900
Subject: [PATCH 15/33] update benz
---
extlib/benz | 2 +-
piclib/picrin/array.scm | 2 +-
piclib/picrin/base.scm | 33 +----
piclib/picrin/dictionary.scm | 3 +-
piclib/picrin/experimental/lambda.scm | 1 +
piclib/picrin/macro.scm | 7 +-
piclib/picrin/record.scm | 3 +-
piclib/picrin/test.scm | 6 +-
piclib/scheme/base.scm | 175 ++++++++++++++++++++++++--
9 files changed, 181 insertions(+), 51 deletions(-)
diff --git a/extlib/benz b/extlib/benz
index 14e7fd4e..b8b57435 160000
--- a/extlib/benz
+++ b/extlib/benz
@@ -1 +1 @@
-Subproject commit 14e7fd4e98ca4619edb5eb7e48b882d94e5e50d2
+Subproject commit b8b5743589ccbed555805d768d5c840aad350499
diff --git a/piclib/picrin/array.scm b/piclib/picrin/array.scm
index f7e1dc60..d12b7848 100644
--- a/piclib/picrin/array.scm
+++ b/piclib/picrin/array.scm
@@ -1,6 +1,6 @@
(define-library (picrin array)
(import (scheme base)
- (scheme write)
+ (picrin base)
(picrin record))
(define-record-type <array>
diff --git a/piclib/picrin/base.scm b/piclib/picrin/base.scm
index f1ea2c0b..e28310df 100644
--- a/piclib/picrin/base.scm
+++ b/piclib/picrin/base.scm
@@ -31,38 +31,22 @@
integer?
exact?
inexact?
- exact-integer?
=
<
>
<=
>=
- zero?
- positive?
- negative?
- odd?
- even?
- min
- max
+
-
*
/
abs
- floor-quotient
- floor-remainder
floor/
- truncate-quotient
- truncate-remainder
truncate/
- gcd
- lcm
floor
ceiling
truncate
round
- exact-integer-sqrt
- square
expt
number->string
string->number
@@ -129,19 +113,15 @@
vector->list)
(export string?
- make-string
string-length
string-ref
- string-set!
+ string-copy
+ string-append
string=?
string<?
string>?
string<=?
- string>=?
- string-copy
- string-copy!
- string-append
- string-fill!)
+ string>=?)
(export make-dictionary
dictionary?
@@ -160,16 +140,13 @@
(export current-input-port
current-output-port
current-error-port
+
+ port?
input-port?
output-port?
textual-port?
binary-port?
- port?
- input-port-open?
- output-port-open?
close-port
- close-input-port
- close-output-port
open-input-string
open-output-string
diff --git a/piclib/picrin/dictionary.scm b/piclib/picrin/dictionary.scm
index a532b2e4..1940d676 100644
--- a/piclib/picrin/dictionary.scm
+++ b/piclib/picrin/dictionary.scm
@@ -1,5 +1,6 @@
(define-library (picrin dictionary)
- (import (scheme base))
+ (import (scheme base)
+ (picrin base))
(define (dictionary-map proc dict)
(let ((kvs '()))
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/macro.scm b/piclib/picrin/macro.scm
index 0e5dc4b4..c17c7555 100644
--- a/piclib/picrin/macro.scm
+++ b/piclib/picrin/macro.scm
@@ -1,12 +1,7 @@
;;; 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
diff --git a/piclib/picrin/record.scm b/piclib/picrin/record.scm
index 18ee0fa7..b2b72489 100644
--- a/piclib/picrin/record.scm
+++ b/piclib/picrin/record.scm
@@ -1,5 +1,6 @@
(define-library (picrin record)
- (import (scheme base))
+ (import (picrin base)
+ (scheme base))
(define (set-record-writer! record-type writer)
(record-set! record-type 'writer writer))
diff --git a/piclib/picrin/test.scm b/piclib/picrin/test.scm
index 28650b84..17a1e41c 100644
--- a/piclib/picrin/test.scm
+++ b/piclib/picrin/test.scm
@@ -1,8 +1,8 @@
(define-library (picrin test)
(import (scheme base)
- (scheme write)
- (scheme read)
- (scheme process-context))
+ (scheme process-context)
+ (picrin base))
+
(define test-counter 0)
(define counter 0)
(define failure-counter 0)
diff --git a/piclib/scheme/base.scm b/piclib/scheme/base.scm
index efb0a61a..b166f24e 100644
--- a/piclib/scheme/base.scm
+++ b/piclib/scheme/base.scm
@@ -1,11 +1,14 @@
(define-library (scheme base)
(import (picrin base)
- (picrin list)
- (picrin symbol)
(picrin macro))
- (export define set! lambda quote
- if begin define-syntax)
+ (export define
+ set!
+ lambda
+ quote
+ if
+ begin
+ define-syntax)
;; call/cc
@@ -267,7 +270,7 @@
(lambda (form r c)
`(,(r 'letrec-syntax) ,@(cdr form)))))
- (import (scheme read) (scheme file))
+ (import (scheme file))
(define-syntax include
(letrec ((read-file
@@ -682,8 +685,6 @@
;; 4.2.6. Dynamic bindings
- (import (picrin parameter))
-
(define-syntax parameterize
(ir-macro-transformer
(lambda (form inject compare)
@@ -764,9 +765,6 @@
;; 5.5 Recored-type definitions
- (import (picrin record)
- (scheme write))
-
(define ((default-record-writer ctor) obj)
(let ((port (open-output-string)))
(display "#.(" port)
@@ -858,6 +856,163 @@
(rename truncate-quotient quotient)
(rename truncate-remainder remainder))
+ (export define
+ lambda
+ if
+ quote
+ set!
+ begin
+ define-syntax)
+
+ (export eq?
+ eqv?
+ equal?)
+
+ (export boolean?
+ boolean=?
+ not)
+
+ (export char?
+ char->integer
+ integer->char)
+
+ (export number?
+ complex?
+ real?
+ rational?
+ integer?
+ exact?
+ inexact?
+ exact-integer?
+ =
+ <
+ >
+ <=
+ >=
+ zero?
+ positive?
+ negative?
+ odd?
+ even?
+ min
+ max
+ +
+ -
+ *
+ /
+ abs
+ floor-quotient
+ floor-remainder
+ floor/
+ truncate-quotient
+ truncate-remainder
+ truncate/
+ gcd
+ lcm
+ floor
+ ceiling
+ truncate
+ round
+ exact-integer-sqrt
+ square
+ expt
+ number->string
+ string->number
+ finite?
+ infinite?
+ nan?
+ exp
+ log
+ sin
+ cos
+ tan
+ acos
+ asin
+ atan
+ sqrt)
+
+ (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=?
+ string<?
+ string>?
+ string<=?
+ string>=?
+ string-copy
+ string-copy!
+ string-append
+ string-fill!)
+
+ (export current-input-port
+ current-output-port
+ current-error-port
+
+ port?
+ input-port?
+ output-port?
+ textual-port?
+ binary-port?
+ close-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)
+
+ (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)
+
;; 6.4 Pairs and lists
(export pair?
From 685d21a1e2559a1d1a208e7d0d051db2e7425387 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Mon, 8 Sep 2014 17:15:50 +0900
Subject: [PATCH 16/33] move define-record-type
---
piclib/picrin/record.scm | 92 +++++++++++++++++++++++++++++++++++++++-
piclib/scheme/base.scm | 85 +------------------------------------
2 files changed, 92 insertions(+), 85 deletions(-)
diff --git a/piclib/picrin/record.scm b/piclib/picrin/record.scm
index b2b72489..00bb3d62 100644
--- a/piclib/picrin/record.scm
+++ b/piclib/picrin/record.scm
@@ -2,6 +2,8 @@
(import (picrin base)
(scheme base))
+ ;; define-record-writer
+
(define (set-record-writer! record-type writer)
(record-set! record-type 'writer writer))
@@ -15,4 +17,92 @@
(set-record-writer! type
writer))))
- (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 <meta-type>) name ctor)
+ (let ((rectype (make-record <meta-type>)))
+ (record-set! rectype 'name name)
+ (record-set! rectype 'writer (default-record-writer ctor))
+ rectype))
+
+ (define <record-type>
+ (let ((<record-type>
+ ((boot-make-record-type #t) 'record-type '(record-type name writer))))
+ (record-set! <record-type> '@@type <record-type>)
+ <record-type>))
+
+ (define make-record-type (boot-make-record-type <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/scheme/base.scm b/piclib/scheme/base.scm
index b166f24e..6af85954 100644
--- a/piclib/scheme/base.scm
+++ b/piclib/scheme/base.scm
@@ -765,90 +765,7 @@
;; 5.5 Recored-type definitions
- (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 <meta-type>) name ctor)
- (let ((rectype (make-record <meta-type>)))
- (record-set! rectype 'name name)
- (record-set! rectype 'writer (default-record-writer ctor))
- rectype))
-
- (define <record-type>
- (let ((<record-type>
- ((boot-make-record-type #t) 'record-type '(record-type name writer))))
- (record-set! <record-type> '@@type <record-type>)
- <record-type>))
-
- (define make-record-type (boot-make-record-type <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))))))
+ (import (picrin record))
(export define-record-type)
From c3ef97992de3864cea9b61a6c66725f40669afd3 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Mon, 8 Sep 2014 17:16:05 +0900
Subject: [PATCH 17/33] move core syntaxes
---
piclib/picrin/base.scm | 255 +++++++++++++++++++++++++++++++++++++++-
piclib/scheme/base.scm | 258 -----------------------------------------
2 files changed, 254 insertions(+), 259 deletions(-)
diff --git a/piclib/picrin/base.scm b/piclib/picrin/base.scm
index e28310df..342615bc 100644
--- a/piclib/picrin/base.scm
+++ b/piclib/picrin/base.scm
@@ -214,4 +214,257 @@
(export write
write-simple
write-shared
- display))
+ display)
+
+ (define-syntax syntax-error
+ (er-macro-transformer
+ (lambda (expr rename compare)
+ (apply error (cdr expr)))))
+
+ (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 else)
+ (define-auxiliary-syntax =>)
+ (define-auxiliary-syntax _)
+ (define-auxiliary-syntax ...)
+ (define-auxiliary-syntax unquote)
+ (define-auxiliary-syntax unquote-splicing)
+
+ (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)))))))
+
+ (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)))))))))))
+
+ (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)))))))))
+
+ (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))))))))))
+
+ (define-syntax quasiquote
+ (ir-macro-transformer
+ (lambda (form inject compare)
+
+ (define (quasiquote? form)
+ (and (pair? form) (compare (car form) 'quasiquote)))
+
+ (define (unquote? form)
+ (and (pair? form) (compare (car form) 'unquote)))
+
+ (define (unquote-splicing? form)
+ (and (pair? form) (pair? (car form))
+ (compare (car (car form)) 'unquote-splicing)))
+
+ (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))))
+
+ (let ((x (cadr form)))
+ (qq 1 x)))))
+
+ (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)))))))
+
+ (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)))))
+
+ (export let let* letrec letrec*
+ quasiquote unquote unquote-splicing
+ and or
+ cond case else =>
+ do when unless
+ let-syntax letrec-syntax
+ include
+ _ ... syntax-error))
diff --git a/piclib/scheme/base.scm b/piclib/scheme/base.scm
index 6af85954..8bf533aa 100644
--- a/piclib/scheme/base.scm
+++ b/piclib/scheme/base.scm
@@ -10,266 +10,8 @@
begin
define-syntax)
- ;; call/cc
-
- (define real-callcc call-with-current-continuation)
-
- (set! call-with-current-continuation
- (lambda (f)
- (real-callcc
- (lambda (c)
- (f (lambda args (apply continue c args)))))))
-
- (define call/cc call-with-current-continuation)
-
- (export call/cc)
-
;; core syntax
- (define-syntax syntax-error
- (er-macro-transformer
- (lambda (expr rename compare)
- (apply error (cdr expr)))))
-
- (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 else)
- (define-auxiliary-syntax =>)
- (define-auxiliary-syntax _)
- (define-auxiliary-syntax ...)
- (define-auxiliary-syntax unquote)
- (define-auxiliary-syntax unquote-splicing)
-
- (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)))))))
-
- (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)))))))))))
-
- (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)))))))))
-
- (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))))))))))
-
- (define-syntax quasiquote
- (ir-macro-transformer
- (lambda (form inject compare)
-
- (define (quasiquote? form)
- (and (pair? form) (compare (car form) 'quasiquote)))
-
- (define (unquote? form)
- (and (pair? form) (compare (car form) 'unquote)))
-
- (define (unquote-splicing? form)
- (and (pair? form) (pair? (car form))
- (compare (car (car form)) 'unquote-splicing)))
-
- (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))))
-
- (let ((x (cadr form)))
- (qq 1 x)))))
-
- (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)))))))
-
- (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 file))
(define-syntax include
From 3919c17fdca342c31c6bae41f776a60793a7762d Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Mon, 8 Sep 2014 20:20:08 +0900
Subject: [PATCH 18/33] WIP
---
extlib/benz | 2 +-
piclib/CMakeLists.txt | 14 +-
piclib/picrin/array.scm | 31 +-
piclib/picrin/base.scm | 580 ++++++++++++----------
piclib/picrin/dictionary.scm | 3 +-
piclib/picrin/macro.scm | 8 +-
piclib/picrin/record.scm | 19 +-
piclib/picrin/syntax-rules.scm | 335 +++++++++++++
piclib/picrin/test.scm | 7 +-
piclib/scheme/base.scm | 867 +++++++++++----------------------
piclib/scheme/eval.scm | 16 +-
piclib/scheme/file.scm | 11 +-
src/eval.c | 29 --
src/file.c | 119 -----
src/init.c | 70 ---
src/load.c | 79 ---
src/macro.c | 47 --
src/main.c | 47 ++
src/system.c | 136 ------
src/time.c | 49 --
20 files changed, 1044 insertions(+), 1425 deletions(-)
create mode 100644 piclib/picrin/syntax-rules.scm
delete mode 100644 src/eval.c
delete mode 100644 src/file.c
delete mode 100644 src/init.c
delete mode 100644 src/load.c
delete mode 100644 src/macro.c
delete mode 100644 src/system.c
delete mode 100644 src/time.c
diff --git a/extlib/benz b/extlib/benz
index b8b57435..a2848f3e 160000
--- a/extlib/benz
+++ b/extlib/benz
@@ -1 +1 @@
-Subproject commit b8b5743589ccbed555805d768d5c840aad350499
+Subproject commit a2848f3eafdbe3a4579dd4c8054ab7e3b62e6812
diff --git a/piclib/CMakeLists.txt b/piclib/CMakeLists.txt
index 6f79d0fd..008e5ad5 100644
--- a/piclib/CMakeLists.txt
+++ b/piclib/CMakeLists.txt
@@ -1,14 +1,14 @@
list(APPEND PICLIB_SCHEME_LIBS
- ${PROJECT_SOURCE_DIR}/piclib/picrin/base.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
@@ -17,6 +17,10 @@ list(APPEND PICLIB_SCHEME_LIBS
${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 d12b7848..5ae0c107 100644
--- a/piclib/picrin/array.scm
+++ b/piclib/picrin/array.scm
@@ -1,6 +1,5 @@
(define-library (picrin array)
- (import (scheme base)
- (picrin base)
+ (import (picrin base)
(picrin record))
(define-record-type <array>
@@ -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> 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 342615bc..7ae1995d 100644
--- a/piclib/picrin/base.scm
+++ b/piclib/picrin/base.scm
@@ -1,4 +1,307 @@
(define-library (picrin base)
+ (import (picrin macro))
+
+ (define-syntax syntax-error
+ (er-macro-transformer
+ (lambda (expr rename compare)
+ (apply error (cdr expr)))))
+
+ (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 else)
+ (define-auxiliary-syntax =>)
+ (define-auxiliary-syntax _)
+ (define-auxiliary-syntax ...)
+ (define-auxiliary-syntax unquote)
+ (define-auxiliary-syntax unquote-splicing)
+
+ (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)))))))
+
+ (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)))))))))))
+
+ (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)))))))))
+
+ (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))))))))))
+
+ (define-syntax quasiquote
+ (er-macro-transformer
+ (lambda (form rename compare)
+
+ (define (quasiquote? form)
+ (and (pair? form) (compare (car form) (rename 'quasiquote))))
+
+ (define (unquote? form)
+ (and (pair? form) (compare (car form) (rename 'unquote))))
+
+ (define (unquote-splicing? form)
+ (and (pair? form) (pair? (car form))
+ (compare (car (car form)) (rename 'unquote-splicing))))
+
+ (define (qq depth expr)
+ (cond
+ ;; unquote
+ ((unquote? expr)
+ (if (= depth 1)
+ (car (cdr expr))
+ (list (rename 'list)
+ (list (rename 'quote) (rename 'unquote))
+ (qq (- depth 1) (car (cdr expr))))))
+ ;; unquote-splicing
+ ((unquote-splicing? expr)
+ (if (= depth 1)
+ (list (rename 'append)
+ (car (cdr (car expr)))
+ (qq depth (cdr expr)))
+ (list (rename 'cons)
+ (list (rename 'list)
+ (list (rename 'quote) (rename 'unquote-splicing))
+ (qq (- depth 1) (car (cdr (car expr)))))
+ (qq depth (cdr expr)))))
+ ;; quasiquote
+ ((quasiquote? expr)
+ (list (rename 'list)
+ (list (rename 'quote) (rename 'quasiquote))
+ (qq (+ depth 1) (car (cdr expr)))))
+ ;; list
+ ((pair? expr)
+ (list (rename 'cons)
+ (qq depth (car expr))
+ (qq depth (cdr expr))))
+ ;; vector
+ ((vector? expr)
+ (list (rename 'list->vector) (qq depth (vector->list expr))))
+ ;; simple datum
+ (else
+ (list (rename 'quote) expr))))
+
+ (let ((x (cadr form)))
+ (qq 1 x)))))
+
+ (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)))))))
+
+ (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 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-syntax define-values
+ (er-macro-transformer
+ (lambda (form r compare)
+ (let ((formal (cadr form))
+ (exprs (cddr form)))
+ `(,(r 'begin)
+ ,@(let loop ((formal formal))
+ (if (not (pair? formal))
+ (if (symbol? formal)
+ `((,(r 'define) ,formal #f))
+ '())
+ `((,(r 'define) ,(car formal) #f) . ,@(loop (cdr formal)))))
+ (,(r 'call-with-values) (,(r 'lambda) () ,@exprs)
+ (,(r 'lambda) ,(r 'args)
+ ,@(let loop ((formal formal) (args (r 'args)))
+ (if (not (pair? formal))
+ (if (symbol? formal)
+ `((,(r 'set!) ,formal ,args))
+ '())
+ `((,(r 'set!) ,(car formal) (,(r 'car) ,args))
+ ,@(loop (cdr formal) `(,(r 'cdr) ,args))))))))))))
+
+ (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)))))
+
+ (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 define
lambda
if
@@ -7,6 +310,16 @@
begin
define-syntax)
+ (export let let* letrec letrec*
+ let-values let*-values define-values
+ quasiquote unquote unquote-splicing
+ and or
+ cond case else =>
+ do when unless
+ let-syntax letrec-syntax
+ include
+ _ ... syntax-error)
+
(export eq?
eqv?
equal?)
@@ -146,8 +459,13 @@
output-port?
textual-port?
binary-port?
+
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
@@ -188,6 +506,7 @@
make-identifier)
(export call-with-current-continuation
+ call/cc
continue
dynamic-wind
values
@@ -216,255 +535,18 @@
write-shared
display)
- (define-syntax syntax-error
- (er-macro-transformer
- (lambda (expr rename compare)
- (apply error (cdr expr)))))
+ (export command-line
+ exit
+ emergency-exit
+ file-exists?
+ delete-file
+ get-environment-variable
+ get-environment-variables)
- (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 current-second
+ current-jiffy
+ jiffies-per-second)
- (define-auxiliary-syntax else)
- (define-auxiliary-syntax =>)
- (define-auxiliary-syntax _)
- (define-auxiliary-syntax ...)
- (define-auxiliary-syntax unquote)
- (define-auxiliary-syntax unquote-splicing)
+ (export eval)
- (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)))))))
-
- (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)))))))))))
-
- (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)))))))))
-
- (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))))))))))
-
- (define-syntax quasiquote
- (ir-macro-transformer
- (lambda (form inject compare)
-
- (define (quasiquote? form)
- (and (pair? form) (compare (car form) 'quasiquote)))
-
- (define (unquote? form)
- (and (pair? form) (compare (car form) 'unquote)))
-
- (define (unquote-splicing? form)
- (and (pair? form) (pair? (car form))
- (compare (car (car form)) 'unquote-splicing)))
-
- (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))))
-
- (let ((x (cadr form)))
- (qq 1 x)))))
-
- (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)))))))
-
- (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)))))
-
- (export let let* letrec letrec*
- quasiquote unquote unquote-splicing
- and or
- cond case else =>
- do when unless
- let-syntax letrec-syntax
- include
- _ ... syntax-error))
+ (export load))
diff --git a/piclib/picrin/dictionary.scm b/piclib/picrin/dictionary.scm
index 1940d676..4ad679e9 100644
--- a/piclib/picrin/dictionary.scm
+++ b/piclib/picrin/dictionary.scm
@@ -1,6 +1,5 @@
(define-library (picrin dictionary)
- (import (scheme base)
- (picrin base))
+ (import (picrin base))
(define (dictionary-map proc dict)
(let ((kvs '()))
diff --git a/piclib/picrin/macro.scm b/piclib/picrin/macro.scm
index c17c7555..22bdf097 100644
--- a/piclib/picrin/macro.scm
+++ b/piclib/picrin/macro.scm
@@ -1,5 +1,3 @@
-;;; Hygienic Macros
-
(define-library (picrin macro)
(import (picrin base))
@@ -109,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
@@ -136,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 00bb3d62..6784524b 100644
--- a/piclib/picrin/record.scm
+++ b/piclib/picrin/record.scm
@@ -1,6 +1,6 @@
(define-library (picrin record)
(import (picrin base)
- (scheme base))
+ (picrin macro))
;; define-record-writer
@@ -8,14 +8,15 @@
(record-set! record-type 'writer writer))
(define-syntax define-record-writer
- (syntax-rules ()
- ((_ (type obj) body ...)
- (set-record-writer! type
- (lambda (obj)
- body ...)))
- ((_ type writer)
- (set-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)))))))
;; define-record-type
diff --git a/piclib/picrin/syntax-rules.scm b/piclib/picrin/syntax-rules.scm
new file mode 100644
index 00000000..1f206ac6
--- /dev/null
+++ b/piclib/picrin/syntax-rules.scm
@@ -0,0 +1,335 @@
+(define-library (picrin syntax-rules)
+ (import (picrin base)
+ (picrin macro))
+
+ (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 17a1e41c..d1dfbc9d 100644
--- a/piclib/picrin/test.scm
+++ b/piclib/picrin/test.scm
@@ -1,7 +1,6 @@
(define-library (picrin test)
- (import (scheme base)
- (scheme process-context)
- (picrin base))
+ (import (picrin base)
+ (picrin syntax-rules))
(define test-counter 0)
(define 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 8bf533aa..5303bf84 100644
--- a/piclib/scheme/base.scm
+++ b/piclib/scheme/base.scm
@@ -1,429 +1,56 @@
(define-library (scheme base)
(import (picrin base)
- (picrin macro))
+ (picrin macro)
+ (picrin record)
+ (picrin syntax-rules))
- (export define
- set!
- lambda
- quote
- if
- begin
- define-syntax)
+ (export else => _ ...)
- ;; core syntax
+ ;; 4.1.2. Literal expressions
- (import (scheme file))
+ (export quote)
- (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)))))))
+ ;; 4.1.4. Procedures
- (export let let* letrec letrec*
- quasiquote unquote unquote-splicing
- and or
- cond case else =>
- do when unless
- let-syntax letrec-syntax
- include
- _ ... syntax-error)
+ (export lambda)
+ ;; 4.1.5. Conditionals
- ;; utility functions
+ (export if)
- (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))))
+ ;; 4.1.6. Assignments
- (define (flatten expr)
- (let ((list '()))
- (walk
- (lambda (x)
- (set! list (cons x list)))
- expr)
- (reverse list)))
+ (export set!)
- (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))))
+ ;; 4.1.7. Inclusion
- (define (every? pred l)
- (if (null? l)
- #t
- (and (pred (car l)) (every? pred (cdr l)))))
+ (export include)
+ ;; 4.2.1. Conditionals
- ;; extra syntax
+ (export cond
+ case
+ and
+ or
+ when
+ unless)
- (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)))))))))
+ ;; 4.2.2. Binding constructs
- (define-syntax let-values
- (er-macro-transformer
- (lambda (form r c)
- `(,(r 'let*-values) ,@(cdr form)))))
+ (export let
+ let*
+ letrec
+ letrec*
+ let-values
+ let*-values)
- (define uniq
- (let ((counter 0))
- (lambda (x)
- (let ((sym (string->symbol (string-append "var$" (number->string counter)))))
- (set! counter (+ counter 1))
- sym))))
+ ;; 4.2.3. Sequencing
- (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 begin)
- (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
@@ -440,8 +67,8 @@
,@(map (lambda (var) `(parameter-pop! ,var)) vars)
result)))))))
- (export parameterize make-parameter)
-
+ (export make-parameter
+ parameterize)
;; 4.2.7. Exception handling
@@ -505,35 +132,80 @@
(export guard)
- ;; 5.5 Recored-type definitions
+ ;; 4.2.8. Quasiquotation
- (import (picrin record))
+ (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
(export define-record-type)
- (export (rename floor-remainder modulo)
- (rename truncate-quotient quotient)
- (rename truncate-remainder remainder))
-
- (export define
- lambda
- if
- quote
- set!
- begin
- define-syntax)
+ ;; 6.1. Equivalence predicates
(export eq?
eqv?
equal?)
- (export boolean?
- boolean=?
- not)
+ ;; 6.2. Numbers
- (export char?
- char->integer
- integer->char)
+ (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 (min . args)
+ (let loop ((args args) (min +inf.0))
+ (if (null? args)
+ min
+ (loop (cdr args) (if (< (car args) min)
+ (car args)
+ min)))))
+
+ (define (max . args)
+ (let loop ((args args) (max -inf.0))
+ (if (null? args)
+ max
+ (loop (cdr args) (if (> (car args) max)
+ (car args)
+ max)))))
+
+ (define (square x)
+ (* x x))
(export number?
complex?
@@ -551,8 +223,8 @@
zero?
positive?
negative?
- odd?
- even?
+ ;; odd?
+ ;; even?
min
max
+
@@ -560,117 +232,29 @@
*
/
abs
- floor-quotient
- floor-remainder
+ ;; floor-quotient
+ ;; floor-remainder
floor/
- truncate-quotient
- truncate-remainder
+ ;; truncate-quotient
+ ;; truncate-remainder
truncate/
- gcd
- lcm
+ ;; gcd
+ ;; lcm
floor
ceiling
truncate
round
- exact-integer-sqrt
+ ;; exact-integer-sqrt
square
expt
number->string
- string->number
- finite?
- infinite?
- nan?
- exp
- log
- sin
- cos
- tan
- acos
- asin
- atan
- sqrt)
+ string->number)
- (export vector?
- make-vector
- vector-length
- vector-ref
- vector-set!
- vector-copy!
- vector-copy
- vector-append
- vector-fill!
- list->vector
- vector->list)
+ ;; 6.3. Booleans
- (export string?
- make-string
- string-length
- string-ref
- string-set!
- string=?
- string<?
- string>?
- string<=?
- string>=?
- string-copy
- string-copy!
- string-append
- string-fill!)
-
- (export current-input-port
- current-output-port
- current-error-port
-
- port?
- input-port?
- output-port?
- textual-port?
- binary-port?
- close-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)
-
- (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)
+ (export boolean?
+ boolean=?
+ not)
;; 6.4 Pairs and lists
@@ -702,14 +286,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)
@@ -721,56 +305,82 @@
(define-char-transitive-predicate char<=? <=)
(define-char-transitive-predicate char>=? >=)
- (export char=?
+ (export char?
+ char->integer
+ integer->char
+ char=?
char<?
char>?
char<=?
char>=?)
- ;; 6.7 String
+ ;; 6.7. Strings
- (define (string->list string . opts)
- (let ((start (if (pair? opts) (car opts) 0))
- (end (if (>= (length opts) 2)
- (cadr opts)
- (string-length string))))
- (do ((i start (+ i 1))
- (res '()))
- ((= i end)
- (reverse res))
- (set! res (cons (string-ref string i) res)))))
+ ;; (define (string->list string . opts)
+ ;; (let ((start (if (pair? opts) (car opts) 0))
+ ;; (end (if (>= (length opts) 2)
+ ;; (cadr opts)
+ ;; (string-length string))))
+ ;; (do ((i start (+ i 1))
+ ;; (res '()))
+ ;; ((= i end)
+ ;; (reverse res))
+ ;; (set! res (cons (string-ref string i) res)))))
- (define (list->string list)
- (let ((len (length list)))
- (let ((v (make-string len)))
- (do ((i 0 (+ i 1))
- (l list (cdr l)))
- ((= i len)
- v)
- (string-set! v i (car l))))))
+ ;; (define (list->string list)
+ ;; (let ((len (length list)))
+ ;; (let ((v (make-string len)))
+ ;; (do ((i 0 (+ i 1))
+ ;; (l list (cdr l)))
+ ;; ((= i len)
+ ;; v)
+ ;; (string-set! v i (car l))))))
- (define (string . objs)
- (list->string objs))
+ ;; (define (string . objs)
+ ;; (list->string objs))
- (export string
- string->list
- list->string
- (rename string-copy substring))
+ ;; (export string
+ ;; string->list
+ ;; list->string
+ ;; (rename string-copy substring))
- ;; 6.8. Vector
+ (export string?
+ string-length
+ string-ref
+ string-copy
+ string-append
+ string=?
+ string<?
+ string>?
+ string<=?
+ string>=?)
+
+ ;; 6.8. Vectors
(define (vector . objs)
(list->vector objs))
- (define (vector->string . args)
- (list->string (apply vector->list args)))
+ ;; (define (vector->string . args)
+ ;; (list->string (apply vector->list args)))
- (define (string->vector . args)
- (list->vector (apply string->list args)))
+ ;; (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))
@@ -791,42 +401,72 @@
(define (bytevector . objs)
(list->bytevector objs))
- (define (utf8->string v . opts)
- (let ((start (if (pair? opts) (car opts) 0))
- (end (if (>= (length opts) 2)
- (cadr opts)
- (bytevector-length v))))
- (list->string (map integer->char (bytevector->list v start end)))))
+ ;; (define (utf8->string v . opts)
+ ;; (let ((start (if (pair? opts) (car opts) 0))
+ ;; (end (if (>= (length opts) 2)
+ ;; (cadr opts)
+ ;; (bytevector-length v))))
+ ;; (list->string (map integer->char (bytevector->list v start end)))))
- (define (string->utf8 s . opts)
- (let ((start (if (pair? opts) (car opts) 0))
- (end (if (>= (length opts) 2)
- (cadr opts)
- (string-length s))))
- (list->bytevector (map char->integer (string->list s start end)))))
+ ;; (define (string->utf8 s . opts)
+ ;; (let ((start (if (pair? opts) (car opts) 0))
+ ;; (end (if (>= (length opts) 2)
+ ;; (cadr opts)
+ ;; (string-length s))))
+ ;; (list->bytevector (map char->integer (string->list s start end)))))
- (export bytevector
- bytevector->list
- list->bytevector
- utf8->string
- string->utf8)
+ ;; (export bytevector
+ ;; bytevector->list
+ ;; list->bytevector
+ ;; utf8->string
+ ;; string->utf8)
- ;; 6.10 control features
+ (export bytevector?
+ make-bytevector
+ bytevector-length
+ bytevector-u8-ref
+ bytevector-u8-set!
+ bytevector-copy!
+ bytevector-append)
- (define (string-map f . strings)
- (list->string (apply map f (map string->list strings))))
+ ;; 6.10. Control features
- (define (string-for-each f . strings)
- (apply for-each f (map string->list strings)))
+ ;; (define (string-map f . strings)
+ ;; (list->string (apply map f (map string->list strings))))
- (define (vector-map f . vectors)
- (list->vector (apply map f (map vector->list vectors))))
+ ;; (define (string-for-each f . strings)
+ ;; (apply for-each f (map string->list strings)))
- (define (vector-for-each f . vectors)
- (apply for-each f (map vector->list vectors)))
+ ;; (define (vector-map f . vectors)
+ ;; (list->vector (apply map f (map vector->list vectors))))
- (export string-map string-for-each
- vector-map vector-for-each)
+ ;; (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
+ 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
@@ -836,4 +476,47 @@
(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?
+
+ 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/src/eval.c b/src/eval.c
deleted file mode 100644
index dd31829c..00000000
--- a/src/eval.c
+++ /dev/null
@@ -1,29 +0,0 @@
-/**
- * See Copyright Notice in picrin.h
- */
-
-#include "picrin.h"
-#include "picrin/macro.h"
-
-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/init.c b/src/init.c
deleted file mode 100644
index 6ff9eac0..00000000
--- a/src/init.c
+++ /dev/null
@@ -1,70 +0,0 @@
-/**
- * See Copyright Notice in picrin.h
- */
-
-#include <stdlib.h>
-
-#include "picrin.h"
-#include "picrin/pair.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_eval(pic_state *);
-void pic_init_file(pic_state *);
-void pic_init_load(pic_state *);
-void pic_init_macro2(pic_state *);
-void pic_init_system(pic_state *);
-void pic_init_time(pic_state *);
-
-void pic_init_contrib(pic_state *);
-
-void pic_load_piclib(pic_state *);
-
-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_eval(pic);
- pic_init_file(pic);
- pic_init_load(pic);
- pic_init_macro2(pic);
- pic_init_system(pic);
- pic_init_time(pic);
-
- pic_init_contrib(pic);
-
- pic_load_piclib(pic);
- }
-}
diff --git a/src/load.c b/src/load.c
deleted file mode 100644
index d8c3af7f..00000000
--- a/src/load.c
+++ /dev/null
@@ -1,79 +0,0 @@
-/**
- * See Copyright Notice in picrin.h
- */
-
-#include "picrin.h"
-#include "picrin/pair.h"
-#include "picrin/port.h"
-#include "picrin/error.h"
-
-void
-pic_load_port(pic_state *pic, struct pic_port *port)
-{
- pic_value form;
-
- pic_try {
- size_t ai = pic_gc_arena_preserve(pic);
-
- while (! pic_eof_p(form = pic_read(pic, port))) {
- pic_eval(pic, form, pic->lib);
-
- pic_gc_arena_restore(pic, ai);
- }
- }
- pic_catch {
- pic_errorf(pic, "load error: %s", pic_errmsg(pic));
- }
-}
-
-void
-pic_load_cstr(pic_state *pic, const char *src)
-{
- struct pic_port *port = pic_open_input_string(pic, src);
-
- pic_load_port(pic, port);
-
- pic_close_port(pic, port);
-}
-
-void
-pic_load(pic_state *pic, const char *filename)
-{
- struct pic_port *port;
- xFILE *file;
-
- file = xfopen(filename, "r");
- if (file == NULL) {
- pic_errorf(pic, "could not open file: %s", filename);
- }
-
- port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port), PIC_TT_PORT);
- port->file = file;
- port->flags = PIC_PORT_IN | PIC_PORT_TEXT;
- port->status = PIC_PORT_OPEN;
-
- pic_load_port(pic, port);
-
- pic_close_port(pic, port);
-}
-
-static pic_value
-pic_load_load(pic_state *pic)
-{
- pic_value envid;
- char *fn;
-
- pic_get_args(pic, "z|o", &fn, &envid);
-
- pic_load(pic, fn);
-
- return pic_none_value();
-}
-
-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 84237ebc..00000000
--- a/src/macro.c
+++ /dev/null
@@ -1,47 +0,0 @@
-/**
- * See Copyright Notice in picrin.h
- */
-
-#include "picrin.h"
-
-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);
-}
-
-void
-pic_init_macro2(pic_state *pic)
-{
- 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);
- }
-}
diff --git a/src/main.c b/src/main.c
index 14f2f9f0..9bd66a92 100644
--- a/src/main.c
+++ b/src/main.c
@@ -3,8 +3,55 @@
*/
#include "picrin.h"
+#include "picrin/pair.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_contrib(pic_state *);
+void pic_load_piclib(pic_state *);
+
+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)
{
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 <stdlib.h>
-
-#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 <time.h>
-
-#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);
- }
-}
From 0ad4daa338452c9e2170235336ab3847f4944bf5 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Mon, 8 Sep 2014 20:37:44 +0900
Subject: [PATCH 19/33] more fixes
---
piclib/CMakeLists.txt | 2 +-
piclib/scheme/base.scm | 139 ++++++++++++++++++++----------
piclib/scheme/inexact.scm | 15 ++++
piclib/scheme/load.scm | 4 +
piclib/scheme/process-context.scm | 8 ++
piclib/scheme/r5rs.scm | 10 +++
piclib/scheme/time.scm | 6 ++
piclib/srfi/17.scm | 2 +-
8 files changed, 139 insertions(+), 47 deletions(-)
create mode 100644 piclib/scheme/inexact.scm
create mode 100644 piclib/scheme/load.scm
create mode 100644 piclib/scheme/process-context.scm
create mode 100644 piclib/scheme/time.scm
diff --git a/piclib/CMakeLists.txt b/piclib/CMakeLists.txt
index 008e5ad5..25e77b3a 100644
--- a/piclib/CMakeLists.txt
+++ b/piclib/CMakeLists.txt
@@ -21,7 +21,7 @@ list(APPEND PICLIB_SCHEME_LIBS
${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/r5rs.scm
${PROJECT_SOURCE_DIR}/piclib/scheme/null.scm
${PROJECT_SOURCE_DIR}/piclib/srfi/1.scm
diff --git a/piclib/scheme/base.scm b/piclib/scheme/base.scm
index 5303bf84..5c918d99 100644
--- a/piclib/scheme/base.scm
+++ b/piclib/scheme/base.scm
@@ -188,6 +188,12 @@
(define (negative? x)
(< x 0))
+ (define (even? x)
+ (= x (* (/ x 2) 2)))
+
+ (define (odd? x)
+ (not (even? x)))
+
(define (min . args)
(let loop ((args args) (min +inf.0))
(if (null? args)
@@ -204,9 +210,43 @@
(car args)
max)))))
+ (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 i j)
+ (if (> i j)
+ (gcd j i)
+ (if (zero? i)
+ j
+ (gcd (truncate-remainder j i) i))))
+
+ (define (lcm i j)
+ (/ (* i j) (gcd i j)))
+
(define (square x)
(* x x))
+ (define (exact-integer-sqrt k)
+ (let ((s (exact (sqrt k))))
+ (values s (- k (square s)))))
+
(export number?
complex?
real?
@@ -215,6 +255,8 @@
exact?
inexact?
exact-integer?
+ exact
+ inexact
=
<
>
@@ -223,8 +265,8 @@
zero?
positive?
negative?
- ;; odd?
- ;; even?
+ odd?
+ even?
min
max
+
@@ -232,19 +274,22 @@
*
/
abs
- ;; floor-quotient
- ;; floor-remainder
+ floor-quotient
+ floor-remainder
floor/
- ;; truncate-quotient
- ;; truncate-remainder
+ truncate-quotient
+ truncate-remainder
truncate/
- ;; gcd
- ;; lcm
+ (rename truncate-quotient quotient)
+ (rename truncate-remainder remainder)
+ (rename floor-remainder modulo)
+ gcd
+ lcm
floor
ceiling
truncate
round
- ;; exact-integer-sqrt
+ exact-integer-sqrt
square
expt
number->string
@@ -316,16 +361,16 @@
;; 6.7. Strings
- ;; (define (string->list string . opts)
- ;; (let ((start (if (pair? opts) (car opts) 0))
- ;; (end (if (>= (length opts) 2)
- ;; (cadr opts)
- ;; (string-length string))))
- ;; (do ((i start (+ i 1))
- ;; (res '()))
- ;; ((= i end)
- ;; (reverse res))
- ;; (set! res (cons (string-ref string i) res)))))
+ (define (string->list string . opts)
+ (let ((start (if (pair? opts) (car opts) 0))
+ (end (if (>= (length opts) 2)
+ (cadr opts)
+ (string-length string))))
+ (do ((i start (+ i 1))
+ (res '()))
+ ((= i end)
+ (reverse res))
+ (set! res (cons (string-ref string i) res)))))
;; (define (list->string list)
;; (let ((len (length list)))
@@ -339,10 +384,10 @@
;; (define (string . objs)
;; (list->string objs))
- ;; (export string
- ;; string->list
- ;; list->string
- ;; (rename string-copy substring))
+ (export ;string
+ string->list
+ ;list->string
+ (rename string-copy substring))
(export string?
string-length
@@ -363,10 +408,12 @@
;; (define (vector->string . args)
;; (list->string (apply vector->list args)))
- ;; (define (string->vector . args)
- ;; (list->vector (apply string->list args)))
+ (define (string->vector . args)
+ (list->vector (apply string->list args)))
- ;; (export vector vector->string string->vector)
+ (export vector
+ ;vector->string
+ string->vector)
(export vector?
make-vector
@@ -408,18 +455,18 @@
;; (bytevector-length v))))
;; (list->string (map integer->char (bytevector->list v start end)))))
- ;; (define (string->utf8 s . opts)
- ;; (let ((start (if (pair? opts) (car opts) 0))
- ;; (end (if (>= (length opts) 2)
- ;; (cadr opts)
- ;; (string-length s))))
- ;; (list->bytevector (map char->integer (string->list s start end)))))
+ (define (string->utf8 s . opts)
+ (let ((start (if (pair? opts) (car opts) 0))
+ (end (if (>= (length opts) 2)
+ (cadr opts)
+ (string-length s))))
+ (list->bytevector (map char->integer (string->list s start end)))))
- ;; (export bytevector
- ;; bytevector->list
- ;; list->bytevector
- ;; utf8->string
- ;; string->utf8)
+ (export bytevector
+ bytevector->list
+ list->bytevector
+ ;; utf8->string
+ string->utf8)
(export bytevector?
make-bytevector
@@ -434,17 +481,19 @@
;; (define (string-map f . strings)
;; (list->string (apply map f (map string->list strings))))
- ;; (define (string-for-each f . strings)
- ;; (apply for-each f (map string->list strings)))
+ (define (string-for-each f . strings)
+ (apply for-each f (map string->list strings)))
- ;; (define (vector-map f . vectors)
- ;; (list->vector (apply map f (map vector->list vectors))))
+ (define (vector-map f . vectors)
+ (list->vector (apply map f (map vector->list vectors))))
- ;; (define (vector-for-each f . vectors)
- ;; (apply for-each f (map vector->list vectors)))
+ (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 ;string-map
+ string-for-each
+ vector-map
+ vector-for-each)
(export procedure?
apply
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/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/srfi/17.scm b/piclib/srfi/17.scm
index eb02e66e..a6c5bd95 100644
--- a/piclib/srfi/17.scm
+++ b/piclib/srfi/17.scm
@@ -3,7 +3,7 @@
(import (except (scheme base) set!)
(prefix (only (scheme base) set!) %)
(picrin dictionary)
- (picrin attribute)
+ (picrin base)
(srfi 1)
(srfi 8))
From 8b9a3f513a80d8aea1259a9d04d68baa380fa4bf Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Mon, 8 Sep 2014 20:44:16 +0900
Subject: [PATCH 20/33] update benz
---
extlib/benz | 2 +-
piclib/picrin/base.scm | 1 -
piclib/srfi/17.scm | 4 ++--
3 files changed, 3 insertions(+), 4 deletions(-)
diff --git a/extlib/benz b/extlib/benz
index a2848f3e..8c174cd5 160000
--- a/extlib/benz
+++ b/extlib/benz
@@ -1 +1 @@
-Subproject commit a2848f3eafdbe3a4579dd4c8054ab7e3b62e6812
+Subproject commit 8c174cd505aa4fc3b7937819506423b39b405216
diff --git a/piclib/picrin/base.scm b/piclib/picrin/base.scm
index 7ae1995d..92180e92 100644
--- a/piclib/picrin/base.scm
+++ b/piclib/picrin/base.scm
@@ -507,7 +507,6 @@
(export call-with-current-continuation
call/cc
- continue
dynamic-wind
values
call-with-values)
diff --git a/piclib/srfi/17.scm b/piclib/srfi/17.scm
index a6c5bd95..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 base)
+ (except (picrin base) set!)
(srfi 1)
(srfi 8))
-
+
(define-syntax set!
(syntax-rules ()
((_ (proc args ...) val)
From 1ac0ccb05e581f31e925e473a0ec96ddab65dd31 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Mon, 8 Sep 2014 20:49:28 +0900
Subject: [PATCH 21/33] change dictionary interface
---
extlib/benz | 2 +-
piclib/picrin/base.scm | 3 +--
piclib/picrin/dictionary.scm | 33 +++++++--------------------------
3 files changed, 9 insertions(+), 29 deletions(-)
diff --git a/extlib/benz b/extlib/benz
index 8c174cd5..dd80aff0 160000
--- a/extlib/benz
+++ b/extlib/benz
@@ -1 +1 @@
-Subproject commit 8c174cd505aa4fc3b7937819506423b39b405216
+Subproject commit dd80aff03ab36fea0633e0e449c71fd489bc738a
diff --git a/piclib/picrin/base.scm b/piclib/picrin/base.scm
index 92180e92..ead1be72 100644
--- a/piclib/picrin/base.scm
+++ b/piclib/picrin/base.scm
@@ -441,8 +441,7 @@
dictionary-ref
dictionary-set!
dictionary-delete
- dictionary-size
- dictionary-for-each)
+ dictionary-size)
(export make-record
record?
diff --git a/piclib/picrin/dictionary.scm b/piclib/picrin/dictionary.scm
index 4ad679e9..c5205711 100644
--- a/piclib/picrin/dictionary.scm
+++ b/piclib/picrin/dictionary.scm
@@ -1,22 +1,6 @@
(define-library (picrin dictionary)
(import (picrin 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)))
-
(define (plist->dictionary plist)
(let ((dict (make-dictionary)))
(do ((kv plist (cddr kv)))
@@ -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))
From 230c87d455f27ba5769d26404866cd098dd7d131 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Mon, 8 Sep 2014 23:46:22 +0900
Subject: [PATCH 22/33] update benz (boot.c)
---
extlib/benz | 2 +-
piclib/picrin/base.scm | 334 +++--------------------------------------
2 files changed, 25 insertions(+), 311 deletions(-)
diff --git a/extlib/benz b/extlib/benz
index dd80aff0..4fd4e15c 160000
--- a/extlib/benz
+++ b/extlib/benz
@@ -1 +1 @@
-Subproject commit dd80aff03ab36fea0633e0e449c71fd489bc738a
+Subproject commit 4fd4e15cc196a89e5ed5133896d7b8b9f4b2c10a
diff --git a/piclib/picrin/base.scm b/piclib/picrin/base.scm
index ead1be72..b7c8ab53 100644
--- a/piclib/picrin/base.scm
+++ b/piclib/picrin/base.scm
@@ -1,306 +1,4 @@
(define-library (picrin base)
- (import (picrin macro))
-
- (define-syntax syntax-error
- (er-macro-transformer
- (lambda (expr rename compare)
- (apply error (cdr expr)))))
-
- (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 else)
- (define-auxiliary-syntax =>)
- (define-auxiliary-syntax _)
- (define-auxiliary-syntax ...)
- (define-auxiliary-syntax unquote)
- (define-auxiliary-syntax unquote-splicing)
-
- (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)))))))
-
- (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)))))))))))
-
- (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)))))))))
-
- (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))))))))))
-
- (define-syntax quasiquote
- (er-macro-transformer
- (lambda (form rename compare)
-
- (define (quasiquote? form)
- (and (pair? form) (compare (car form) (rename 'quasiquote))))
-
- (define (unquote? form)
- (and (pair? form) (compare (car form) (rename 'unquote))))
-
- (define (unquote-splicing? form)
- (and (pair? form) (pair? (car form))
- (compare (car (car form)) (rename 'unquote-splicing))))
-
- (define (qq depth expr)
- (cond
- ;; unquote
- ((unquote? expr)
- (if (= depth 1)
- (car (cdr expr))
- (list (rename 'list)
- (list (rename 'quote) (rename 'unquote))
- (qq (- depth 1) (car (cdr expr))))))
- ;; unquote-splicing
- ((unquote-splicing? expr)
- (if (= depth 1)
- (list (rename 'append)
- (car (cdr (car expr)))
- (qq depth (cdr expr)))
- (list (rename 'cons)
- (list (rename 'list)
- (list (rename 'quote) (rename 'unquote-splicing))
- (qq (- depth 1) (car (cdr (car expr)))))
- (qq depth (cdr expr)))))
- ;; quasiquote
- ((quasiquote? expr)
- (list (rename 'list)
- (list (rename 'quote) (rename 'quasiquote))
- (qq (+ depth 1) (car (cdr expr)))))
- ;; list
- ((pair? expr)
- (list (rename 'cons)
- (qq depth (car expr))
- (qq depth (cdr expr))))
- ;; vector
- ((vector? expr)
- (list (rename 'list->vector) (qq depth (vector->list expr))))
- ;; simple datum
- (else
- (list (rename 'quote) expr))))
-
- (let ((x (cadr form)))
- (qq 1 x)))))
-
- (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)))))))
-
- (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 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-syntax define-values
- (er-macro-transformer
- (lambda (form r compare)
- (let ((formal (cadr form))
- (exprs (cddr form)))
- `(,(r 'begin)
- ,@(let loop ((formal formal))
- (if (not (pair? formal))
- (if (symbol? formal)
- `((,(r 'define) ,formal #f))
- '())
- `((,(r 'define) ,(car formal) #f) . ,@(loop (cdr formal)))))
- (,(r 'call-with-values) (,(r 'lambda) () ,@exprs)
- (,(r 'lambda) ,(r 'args)
- ,@(let loop ((formal formal) (args (r 'args)))
- (if (not (pair? formal))
- (if (symbol? formal)
- `((,(r 'set!) ,formal ,args))
- '())
- `((,(r 'set!) ,(car formal) (,(r 'car) ,args))
- ,@(loop (cdr formal) `(,(r 'cdr) ,args))))))))))))
-
- (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)))))
-
- (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 define
lambda
@@ -310,15 +8,31 @@
begin
define-syntax)
- (export let let* letrec letrec*
- let-values let*-values define-values
- quasiquote unquote unquote-splicing
- and or
- cond case else =>
- do when unless
- let-syntax letrec-syntax
+ (export let
+ let*
+ letrec
+ letrec*
+ let-values
+ let*-values
+ define-values
+ quasiquote
+ unquote
+ unquote-splicing
+ and
+ or
+ cond
+ case
+ do
+ when
+ unless
+ let-syntax
+ letrec-syntax
include
- _ ... syntax-error)
+ =>
+ else
+ _
+ ...
+ syntax-error)
(export eq?
eqv?
From 0c6ffa3e7b427937f43c9151391b489789e60de0 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Tue, 9 Sep 2014 00:09:31 +0900
Subject: [PATCH 23/33] update benz (pic_open)
---
extlib/benz | 2 +-
src/main.c | 9 ++++-----
2 files changed, 5 insertions(+), 6 deletions(-)
diff --git a/extlib/benz b/extlib/benz
index 4fd4e15c..2d805222 160000
--- a/extlib/benz
+++ b/extlib/benz
@@ -1 +1 @@
-Subproject commit 4fd4e15cc196a89e5ed5133896d7b8b9f4b2c10a
+Subproject commit 2d80522230358a4f3f2a1cd1af56da16d0f612d0
diff --git a/src/main.c b/src/main.c
index 9bd66a92..33eb7cf4 100644
--- a/src/main.c
+++ b/src/main.c
@@ -6,6 +6,9 @@
#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)
{
@@ -34,9 +37,6 @@ pic_libraries(pic_state *pic)
return libs;
}
-void pic_init_contrib(pic_state *);
-void pic_load_piclib(pic_state *);
-
void
pic_init_picrin(pic_state *pic)
{
@@ -55,11 +55,10 @@ pic_init_picrin(pic_state *pic)
int
main(int argc, char *argv[], char **envp)
{
- xFILE *stdio[3] = { xstdin, xstdout, xstderr };
pic_state *pic;
int status = 0;
- pic = pic_open(argc, argv, envp, stdio);
+ pic = pic_open(argc, argv, envp);
pic_init_picrin(pic);
From 27322a3c809fdf46fa6636d85337c86c8b33d519 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Tue, 9 Sep 2014 00:59:12 +0900
Subject: [PATCH 24/33] update benz (_ and ...)
---
extlib/benz | 2 +-
piclib/picrin/base.scm | 22 +++++++++++-----------
piclib/picrin/syntax-rules.scm | 14 +++++++++++++-
piclib/scheme/base.scm | 8 +++++---
4 files changed, 30 insertions(+), 16 deletions(-)
diff --git a/extlib/benz b/extlib/benz
index 2d805222..c3acc4cb 160000
--- a/extlib/benz
+++ b/extlib/benz
@@ -1 +1 @@
-Subproject commit 2d80522230358a4f3f2a1cd1af56da16d0f612d0
+Subproject commit c3acc4cb44bcf3baf9c50bb4667ad20c77660c3f
diff --git a/piclib/picrin/base.scm b/piclib/picrin/base.scm
index b7c8ab53..7cdd3297 100644
--- a/piclib/picrin/base.scm
+++ b/piclib/picrin/base.scm
@@ -8,13 +8,14 @@
begin
define-syntax)
+ (export syntax-error
+ let-syntax
+ letrec-syntax)
+
(export let
let*
letrec
letrec*
- let-values
- let*-values
- define-values
quasiquote
unquote
unquote-splicing
@@ -22,17 +23,16 @@
or
cond
case
+ =>
+ else
do
when
unless
- let-syntax
- letrec-syntax
- include
- =>
- else
- _
- ...
- syntax-error)
+ include)
+
+ (export let-values
+ let*-values
+ define-values)
(export eq?
eqv?
diff --git a/piclib/picrin/syntax-rules.scm b/piclib/picrin/syntax-rules.scm
index 1f206ac6..342650a5 100644
--- a/piclib/picrin/syntax-rules.scm
+++ b/piclib/picrin/syntax-rules.scm
@@ -2,6 +2,16 @@
(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)
@@ -332,4 +342,6 @@
`(,_syntax-error "malformed syntax-rules"))))))
- (export syntax-rules))
+ (export syntax-rules
+ _
+ ...))
diff --git a/piclib/scheme/base.scm b/piclib/scheme/base.scm
index 5c918d99..92e20235 100644
--- a/piclib/scheme/base.scm
+++ b/piclib/scheme/base.scm
@@ -4,8 +4,6 @@
(picrin record)
(picrin syntax-rules))
- (export else => _ ...)
-
;; 4.1.2. Literal expressions
(export quote)
@@ -30,6 +28,8 @@
(export cond
case
+ else
+ =>
and
or
when
@@ -145,7 +145,9 @@
;; 4.3.2 Pattern language
- (export syntax-rules)
+ (export syntax-rules
+ _
+ ...)
;; 4.3.3. Signaling errors in macro transformers
From 9ab446ab9280b1ae1b54344305f60760daf83376 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Tue, 9 Sep 2014 01:28:08 +0900
Subject: [PATCH 25/33] support strings
---
extlib/benz | 2 +-
piclib/picrin/base.scm | 4 +++
piclib/scheme/base.scm | 61 ++++++++++++++++++++++--------------------
3 files changed, 37 insertions(+), 30 deletions(-)
diff --git a/extlib/benz b/extlib/benz
index c3acc4cb..5331d6f2 160000
--- a/extlib/benz
+++ b/extlib/benz
@@ -1 +1 @@
-Subproject commit c3acc4cb44bcf3baf9c50bb4667ad20c77660c3f
+Subproject commit 5331d6f23c7df61e75c00879cd270ea1c4d7df85
diff --git a/piclib/picrin/base.scm b/piclib/picrin/base.scm
index 7cdd3297..c6524d31 100644
--- a/piclib/picrin/base.scm
+++ b/piclib/picrin/base.scm
@@ -140,10 +140,14 @@
vector->list)
(export string?
+ make-string
string-length
string-ref
+ string-set!
string-copy
+ string-copy!
string-append
+ string-fill!
string=?
string<?
string>?
diff --git a/piclib/scheme/base.scm b/piclib/scheme/base.scm
index 92e20235..bddd8bd6 100644
--- a/piclib/scheme/base.scm
+++ b/piclib/scheme/base.scm
@@ -374,47 +374,50 @@
(reverse res))
(set! res (cons (string-ref string i) res)))))
- ;; (define (list->string list)
- ;; (let ((len (length list)))
- ;; (let ((v (make-string len)))
- ;; (do ((i 0 (+ i 1))
- ;; (l list (cdr l)))
- ;; ((= i len)
- ;; v)
- ;; (string-set! v i (car l))))))
+ (define (list->string list)
+ (let ((len (length list)))
+ (let ((v (make-string len)))
+ (do ((i 0 (+ i 1))
+ (l list (cdr l)))
+ ((= i len)
+ v)
+ (string-set! v i (car l))))))
- ;; (define (string . objs)
- ;; (list->string objs))
-
- (export ;string
- string->list
- ;list->string
- (rename string-copy substring))
+ (define (string . objs)
+ (list->string objs))
(export string?
+ string
+ make-string
string-length
string-ref
+ string-set!
string-copy
+ string-copy!
string-append
+ string-fill!
string=?
string<?
string>?
string<=?
- string>=?)
+ string>=?
+ string->list
+ list->string
+ (rename string-copy substring))
;; 6.8. Vectors
(define (vector . objs)
(list->vector objs))
- ;; (define (vector->string . args)
- ;; (list->string (apply vector->list args)))
+ (define (vector->string . args)
+ (list->string (apply vector->list args)))
(define (string->vector . args)
(list->vector (apply string->list args)))
(export vector
- ;vector->string
+ vector->string
string->vector)
(export vector?
@@ -450,12 +453,12 @@
(define (bytevector . objs)
(list->bytevector objs))
- ;; (define (utf8->string v . opts)
- ;; (let ((start (if (pair? opts) (car opts) 0))
- ;; (end (if (>= (length opts) 2)
- ;; (cadr opts)
- ;; (bytevector-length v))))
- ;; (list->string (map integer->char (bytevector->list v start end)))))
+ (define (utf8->string v . opts)
+ (let ((start (if (pair? opts) (car opts) 0))
+ (end (if (>= (length opts) 2)
+ (cadr opts)
+ (bytevector-length v))))
+ (list->string (map integer->char (bytevector->list v start end)))))
(define (string->utf8 s . opts)
(let ((start (if (pair? opts) (car opts) 0))
@@ -467,7 +470,7 @@
(export bytevector
bytevector->list
list->bytevector
- ;; utf8->string
+ utf8->string
string->utf8)
(export bytevector?
@@ -480,8 +483,8 @@
;; 6.10. Control features
- ;; (define (string-map f . strings)
- ;; (list->string (apply map f (map string->list strings))))
+ (define (string-map f . strings)
+ (list->string (apply map f (map string->list strings))))
(define (string-for-each f . strings)
(apply for-each f (map string->list strings)))
@@ -492,7 +495,7 @@
(define (vector-for-each f . vectors)
(apply for-each f (map vector->list vectors)))
- (export ;string-map
+ (export string-map
string-for-each
vector-map
vector-for-each)
From df18df8868ccecff2f429f08a2510450908dee26 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Tue, 9 Sep 2014 01:31:25 +0900
Subject: [PATCH 26/33] [bugfix] even? and odd? broken
---
piclib/scheme/base.scm | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/piclib/scheme/base.scm b/piclib/scheme/base.scm
index bddd8bd6..ad8a1679 100644
--- a/piclib/scheme/base.scm
+++ b/piclib/scheme/base.scm
@@ -191,7 +191,7 @@
(< x 0))
(define (even? x)
- (= x (* (/ x 2) 2)))
+ (= x (* (exact (floor (/ x 2))) 2)))
(define (odd? x)
(not (even? x)))
From 6020e2e71d05a17db5d8044b4817e11e4458ac4c Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Tue, 9 Sep 2014 01:48:12 +0900
Subject: [PATCH 27/33] update benz (bugs in define-values)
---
extlib/benz | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extlib/benz b/extlib/benz
index 5331d6f2..92749325 160000
--- a/extlib/benz
+++ b/extlib/benz
@@ -1 +1 @@
-Subproject commit 5331d6f23c7df61e75c00879cd270ea1c4d7df85
+Subproject commit 92749325a9ac2a37efde9dd8914b2306c1f80276
From 3c396b5f3c84c628c746aba342642091bb9efa99 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Tue, 9 Sep 2014 01:48:28 +0900
Subject: [PATCH 28/33] gcd and lcm take variable-length arguments
---
piclib/scheme/base.scm | 28 ++++++++++++++++++++--------
1 file changed, 20 insertions(+), 8 deletions(-)
diff --git a/piclib/scheme/base.scm b/piclib/scheme/base.scm
index ad8a1679..5fc30a9d 100644
--- a/piclib/scheme/base.scm
+++ b/piclib/scheme/base.scm
@@ -232,15 +232,27 @@
(lambda (q r)
r)))
- (define (gcd i j)
- (if (> i j)
- (gcd j i)
- (if (zero? i)
- j
- (gcd (truncate-remainder j i) i))))
+ (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 i j)
- (/ (* i j) (gcd i j)))
+ (define (lcm . args)
+ (define (lcm i j)
+ (/ (* 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))
From 64d7861bf32f40d3ed5e540388390aaf11743a04 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Tue, 9 Sep 2014 02:14:24 +0900
Subject: [PATCH 29/33] bytevector-copy is missed. added port-open?c
---
extlib/benz | 2 +-
piclib/picrin/base.scm | 2 ++
piclib/scheme/base.scm | 25 +++++++++++++------------
3 files changed, 16 insertions(+), 13 deletions(-)
diff --git a/extlib/benz b/extlib/benz
index 92749325..813ce064 160000
--- a/extlib/benz
+++ b/extlib/benz
@@ -1 +1 @@
-Subproject commit 92749325a9ac2a37efde9dd8914b2306c1f80276
+Subproject commit 813ce064f3eb5ab56b80b0560c2c06138084ccf3
diff --git a/piclib/picrin/base.scm b/piclib/picrin/base.scm
index c6524d31..cb2a3f8d 100644
--- a/piclib/picrin/base.scm
+++ b/piclib/picrin/base.scm
@@ -124,6 +124,7 @@
bytevector-length
bytevector-u8-ref
bytevector-u8-set!
+ bytevector-copy
bytevector-copy!
bytevector-append)
@@ -177,6 +178,7 @@
textual-port?
binary-port?
+ port-open?
close-port
open-input-file
diff --git a/piclib/scheme/base.scm b/piclib/scheme/base.scm
index 5fc30a9d..b7108bc5 100644
--- a/piclib/scheme/base.scm
+++ b/piclib/scheme/base.scm
@@ -479,19 +479,19 @@
(string-length s))))
(list->bytevector (map char->integer (string->list s start end)))))
- (export bytevector
- bytevector->list
- list->bytevector
- utf8->string
- string->utf8)
-
(export bytevector?
+ bytevector
make-bytevector
bytevector-length
bytevector-u8-ref
bytevector-u8-set!
+ bytevector-copy
bytevector-copy!
- bytevector-append)
+ bytevector-append
+ bytevector->list
+ list->bytevector
+ utf8->string
+ string->utf8)
;; 6.10. Control features
@@ -507,15 +507,14 @@
(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
@@ -554,6 +553,8 @@
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)
From afe547f1c3b5a51eaa50d4263474d8d24cbf0bca Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Tue, 9 Sep 2014 02:15:55 +0900
Subject: [PATCH 30/33] r5rs is missed
---
piclib/CMakeLists.txt | 2 +-
t/r7rs-tests.scm | 1 +
2 files changed, 2 insertions(+), 1 deletion(-)
diff --git a/piclib/CMakeLists.txt b/piclib/CMakeLists.txt
index 25e77b3a..008e5ad5 100644
--- a/piclib/CMakeLists.txt
+++ b/piclib/CMakeLists.txt
@@ -21,7 +21,7 @@ list(APPEND PICLIB_SCHEME_LIBS
${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/r5rs.scm
${PROJECT_SOURCE_DIR}/piclib/scheme/null.scm
${PROJECT_SOURCE_DIR}/piclib/srfi/1.scm
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
From d2e5ca69856738fed3fb138a889828a1f995cfa3 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Tue, 9 Sep 2014 02:24:19 +0900
Subject: [PATCH 31/33] lcm should do abs
---
piclib/scheme/base.scm | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/piclib/scheme/base.scm b/piclib/scheme/base.scm
index b7108bc5..db0590d8 100644
--- a/piclib/scheme/base.scm
+++ b/piclib/scheme/base.scm
@@ -247,7 +247,7 @@
(define (lcm . args)
(define (lcm i j)
- (/ (* i j) (gcd i j)))
+ (/ (abs (* i j)) (gcd i j)))
(let loop ((args args) (acc 1))
(if (null? args)
acc
From 3aced33d8441b7410bfe534fb05c62a14e1c489a Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Tue, 9 Sep 2014 02:29:24 +0900
Subject: [PATCH 32/33] small refactoring
---
piclib/scheme/base.scm | 20 ++++++++++----------
1 file changed, 10 insertions(+), 10 deletions(-)
diff --git a/piclib/scheme/base.scm b/piclib/scheme/base.scm
index db0590d8..4ddabc80 100644
--- a/piclib/scheme/base.scm
+++ b/piclib/scheme/base.scm
@@ -197,20 +197,20 @@
(not (even? x)))
(define (min . args)
- (let loop ((args args) (min +inf.0))
+ (define (min a b)
+ (if (< a b) a b))
+ (let loop ((args args) (acc +inf.0))
(if (null? args)
- min
- (loop (cdr args) (if (< (car args) min)
- (car args)
- min)))))
+ acc
+ (loop (cdr args) (min (car args) acc)))))
(define (max . args)
- (let loop ((args args) (max -inf.0))
+ (define (max a b)
+ (if (> a b) a b))
+ (let loop ((args args) (acc -inf.0))
(if (null? args)
- max
- (loop (cdr args) (if (> (car args) max)
- (car args)
- max)))))
+ acc
+ (loop (cdr args) (max (car args) acc)))))
(define (floor-quotient i j)
(call-with-values (lambda () (floor/ i j))
From a871f1b89dea56b7d65960760a123ba03fc38793 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Tue, 9 Sep 2014 14:47:16 +0900
Subject: [PATCH 33/33] update benz (xfile)
---
extlib/benz | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extlib/benz b/extlib/benz
index 813ce064..a0687e29 160000
--- a/extlib/benz
+++ b/extlib/benz
@@ -1 +1 @@
-Subproject commit 813ce064f3eb5ab56b80b0560c2c06138084ccf3
+Subproject commit a0687e29e00c5e0389c7ed65415edca5e2a0dd75