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

Merge branch 'benz-integration'

This commit is contained in:
Yuichi Nishiwaki 2014-09-10 00:32:14 +09:00
parent 5867c1e87e a871f1b89d
commit a0beeaead4
86 changed files with 1268 additions and 14248 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
.gitmodules vendored
View File

@ -1,12 +1,3 @@
[submodule "extlib/xhash"]
path = extlib/xhash
url = git://github.com/wasabiz/xhash.git
[submodule "extlib/xfile"]
path = extlib/xfile
url = git://github.com/wasabiz/xfile.git
[submodule "extlib/xrope"]
path = extlib/xrope
url = git://github.com/wasabiz/xrope.git
[submodule "extlib/xvect"]
path = extlib/xvect
url = git://github.com/wasabiz/xvect.git
[submodule "extlib/benz"]
path = extlib/benz
url = git://github.com/picrin-scheme/benz.git

3
CMakeLists.txt
View File

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

1
extlib/benz Submodule

@ -0,0 +1 @@
Subproject commit a0687e29e00c5e0389c7ed65415edca5e2a0dd75

1
extlib/xfile

@ -1 +0,0 @@
Subproject commit e9d634ff99d1a954af3fa80dc2f2ccb1227b4a2b

1
extlib/xhash

@ -1 +0,0 @@
Subproject commit 0b5f935aa7a236f1ef1787f81dce7f5ba679e95b

1
extlib/xrope

@ -1 +0,0 @@
Subproject commit 32d99fae069c1ec7bf0fc31345bfc27cae84b47a

1
extlib/xvect

@ -1 +0,0 @@
Subproject commit 973b9f3d89ff4669d08f1bc28e205bd9834bef10

223
include/picrin.h
View File

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

27
include/picrin/blob.h
View File

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

115
include/picrin/config.h
View File

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

62
include/picrin/cont.h
View File

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

37
include/picrin/data.h
View File

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

32
include/picrin/dict.h
View File

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

60
include/picrin/error.h
View File

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

24
include/picrin/gc.h
View File

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

206
include/picrin/irep.h
View File

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

25
include/picrin/lib.h
View File

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

47
include/picrin/macro.h
View File

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

76
include/picrin/pair.h
View File

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

50
include/picrin/port.h
View File

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

62
include/picrin/proc.h
View File

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

39
include/picrin/read.h
View File

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

30
include/picrin/record.h
View File

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

42
include/picrin/string.h
View File

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

51
include/picrin/util.h
View File

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

484
include/picrin/value.h
View File

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

32
include/picrin/var.h
View File

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

29
include/picrin/vector.h
View File

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

18
piclib/CMakeLists.txt
View File

@ -1,22 +1,26 @@
list(APPEND PICLIB_SCHEME_LIBS
${PROJECT_SOURCE_DIR}/piclib/picrin/base.scm
${PROJECT_SOURCE_DIR}/piclib/picrin/list.scm
${PROJECT_SOURCE_DIR}/piclib/picrin/symbol.scm
${PROJECT_SOURCE_DIR}/piclib/picrin/macro.scm
${PROJECT_SOURCE_DIR}/piclib/scheme/base.scm
${PROJECT_SOURCE_DIR}/piclib/picrin/base.scm
${PROJECT_SOURCE_DIR}/piclib/picrin/record.scm
${PROJECT_SOURCE_DIR}/piclib/picrin/array.scm
${PROJECT_SOURCE_DIR}/piclib/picrin/dictionary.scm
${PROJECT_SOURCE_DIR}/piclib/picrin/test.scm
${PROJECT_SOURCE_DIR}/piclib/picrin/experimental/lambda.scm
${PROJECT_SOURCE_DIR}/piclib/picrin/syntax-rules.scm
${PROJECT_SOURCE_DIR}/piclib/picrin/test.scm
${PROJECT_SOURCE_DIR}/piclib/scheme/base.scm
${PROJECT_SOURCE_DIR}/piclib/scheme/cxr.scm
${PROJECT_SOURCE_DIR}/piclib/scheme/read.scm
${PROJECT_SOURCE_DIR}/piclib/scheme/write.scm
${PROJECT_SOURCE_DIR}/piclib/scheme/file.scm
${PROJECT_SOURCE_DIR}/piclib/scheme/case-lambda.scm
${PROJECT_SOURCE_DIR}/piclib/scheme/lazy.scm
${PROJECT_SOURCE_DIR}/piclib/scheme/eval.scm
${PROJECT_SOURCE_DIR}/piclib/scheme/inexact.scm
${PROJECT_SOURCE_DIR}/piclib/scheme/load.scm
${PROJECT_SOURCE_DIR}/piclib/scheme/process-context.scm
${PROJECT_SOURCE_DIR}/piclib/scheme/time.scm
${PROJECT_SOURCE_DIR}/piclib/scheme/r5rs.scm
${PROJECT_SOURCE_DIR}/piclib/scheme/null.scm

17
piclib/picrin/array.scm
View File

@ -1,6 +1,5 @@
(define-library (picrin array)
(import (scheme base)
(scheme write)
(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,8 +94,7 @@
(for-each proc (array->list ary)))
(define-record-writer (<array> array)
(call-with-port (open-output-string)
(lambda (port)
(let ((port (open-output-string)))
(display "#.(array" port)
(array-for-each
(lambda (obj)
@ -99,7 +102,9 @@
(write obj port))
array)
(display ")" port)
(get-output-string port))))
(let ((str (get-output-string port)))
(close-port port)
str)))
(export make-array
array

282
piclib/picrin/base.scm
View File

@ -1,24 +1,270 @@
(define-library (picrin base)
(import (rename (picrin base core) (define define*))
(picrin base macro)
(picrin base list)
(picrin base symbol))
(define-syntax define
(lambda (form use-env mac-env)
(if (symbol? (car (cdr form)))
(cons (make-identifier 'define* mac-env) (cdr form))
(cons (make-identifier 'define mac-env)
(cons (car (car (cdr form)))
(cons (cons (make-identifier 'lambda mac-env)
(cons (cdr (car (cdr form)))
(cdr (cdr form))))
'()))))))
(export define
set!
quote
lambda
if
quote
set!
begin
define-syntax))
define-syntax)
(export syntax-error
let-syntax
letrec-syntax)
(export let
let*
letrec
letrec*
quasiquote
unquote
unquote-splicing
and
or
cond
case
=>
else
do
when
unless
include)
(export let-values
let*-values
define-values)
(export eq?
eqv?
equal?)
(export boolean?
boolean=?
not)
(export symbol?
symbol->string
string->symbol
symbol=?)
(export char?
char->integer
integer->char)
(export number?
complex?
real?
rational?
integer?
exact?
inexact?
=
<
>
<=
>=
+
-
*
/
abs
floor/
truncate/
floor
ceiling
truncate
round
expt
number->string
string->number
finite?
infinite?
nan?
exp
log
sin
cos
tan
acos
asin
atan
sqrt)
(export pair?
cons
car
cdr
set-car!
set-cdr!
null?
caar
cadr
cdar
cddr)
(export list?
make-list
list
length
append
reverse
list-tail
list-ref
list-set!
list-copy
memq
memv
member
assq
assv
assoc)
(export bytevector?
make-bytevector
bytevector-length
bytevector-u8-ref
bytevector-u8-set!
bytevector-copy
bytevector-copy!
bytevector-append)
(export vector?
make-vector
vector-length
vector-ref
vector-set!
vector-copy!
vector-copy
vector-append
vector-fill!
list->vector
vector->list)
(export string?
make-string
string-length
string-ref
string-set!
string-copy
string-copy!
string-append
string-fill!
string=?
string<?
string>?
string<=?
string>=?)
(export make-dictionary
dictionary?
dictionary-ref
dictionary-set!
dictionary-delete
dictionary-size)
(export make-record
record?
record-type
record-ref
record-set!)
(export current-input-port
current-output-port
current-error-port
port?
input-port?
output-port?
textual-port?
binary-port?
port-open?
close-port
open-input-file
open-output-file
open-binary-input-file
open-binary-output-file
open-input-string
open-output-string
get-output-string
open-input-bytevector
open-output-bytevector
get-output-bytevector
eof-object?
eof-object
read-char
peek-char
char-ready?
read-line
read-string
read-u8
peek-u8
u8-ready?
read-bytevector
read-bytevector!
newline
write-char
write-string
write-u8
write-bytevector
flush-output-port)
(export make-parameter
parameter-ref
parameter-set!
parameter-push!
parameter-pop!)
(export identifier?
identifier=?
make-identifier)
(export call-with-current-continuation
call/cc
dynamic-wind
values
call-with-values)
(export with-exception-handler
raise
raise-continuable
error
error-object?
error-object-message
error-object-irritants
read-error?
file-error?)
(export procedure?
apply
map
for-each
attribute)
(export read)
(export write
write-simple
write-shared
display)
(export command-line
exit
emergency-exit
file-exists?
delete-file
get-environment-variable
get-environment-variables)
(export current-second
current-jiffy
jiffies-per-second)
(export eval)
(export load))

35
piclib/picrin/dictionary.scm
View File

@ -1,21 +1,5 @@
(define-library (picrin dictionary)
(import (scheme base))
(define (dictionary-map proc dict)
(let ((kvs '()))
(dictionary-for-each
(lambda (key val)
(set! kvs (cons (proc key val) kvs)))
dict)
(reverse kvs)))
(define (dictionary->plist dict)
(let ((kvs '()))
(dictionary-for-each
(lambda (key val)
(set! kvs (cons val (cons key kvs))))
dict)
(reverse kvs)))
(import (picrin base))
(define (plist->dictionary plist)
(let ((dict (make-dictionary)))
@ -24,12 +8,6 @@
dict)
(dictionary-set! dict (car kv) (cadr kv)))))
(define (dictionary->alist dict)
(dictionary-map
(lambda (key val)
(cons key val))
dict))
(define (alist->dictionary alist)
(let ((dict (make-dictionary)))
(do ((kv alist (cdr kv)))
@ -40,9 +18,12 @@
(define (dictionary . plist)
(plist->dictionary plist))
(export dictionary
dictionary-map
dictionary->plist
(export dictionary?
dictionary
make-dictionary
dictionary-ref
dictionary-set!
dictionary-delete
dictionary-size
plist->dictionary
dictionary->alist
alist->dictionary))

1
piclib/picrin/experimental/lambda.scm
View File

@ -1,5 +1,6 @@
(define-library (picrin experimental lambda)
(import (scheme base)
(picrin base)
(picrin macro))
(define-syntax destructuring-bind

30
piclib/picrin/list.scm
View File

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

27
piclib/picrin/macro.scm
View File

@ -1,12 +1,5 @@
;;; Hygienic Macros
(define-library (picrin macro)
(import (picrin base macro)
(picrin base)
(picrin list)
(picrin symbol)
(scheme base)
(picrin dictionary))
(import (picrin base))
;; assumes no derived expressions are provided yet
@ -36,18 +29,6 @@
(dictionary-set! cache sym val)
val))))))
(define (identifier=? env1 sym1 env2 sym2)
(define (resolve sym env)
(define x (make-identifier sym env))
(define y (make-identifier sym env))
(if (eq? x y)
x
sym)) ; resolved to no variable
(eq? (resolve sym1 env1)
(resolve sym2 env2)))
(define (make-syntactic-closure env free form)
(define resolve
@ -126,8 +107,8 @@
(rename sym)))))
(f (walk inject expr) inject compare))))
(define (strip-syntax form)
(walk ungensym form))
;; (define (strip-syntax form)
;; (walk ungensym form))
(define-syntax define-macro
(er-macro-transformer
@ -153,5 +134,5 @@
rsc-macro-transformer
er-macro-transformer
ir-macro-transformer
strip-syntax
;; strip-syntax
define-macro))

114
piclib/picrin/record.scm
View File

@ -1,17 +1,109 @@
(define-library (picrin record)
(import (scheme base))
(import (picrin base)
(picrin macro))
(define (define-record-writer* record-type writer)
;; define-record-writer
(define (set-record-writer! record-type writer)
(record-set! record-type 'writer writer))
(define-syntax define-record-writer
(syntax-rules ()
((_ (type obj) body ...)
(define-record-writer* type
(lambda (obj)
body ...)))
((_ type writer)
(define-record-writer* type
writer))))
(er-macro-transformer
(lambda (form r compare)
(let ((formal (cadr form)))
(if (pair? formal)
`(,(r 'set-record-writer!) ,(car formal)
(,(r 'lambda) (,(cadr formal))
,@(cddr form)))
`(,(r 'set-record-writer!) ,formal
,@(cddr form)))))))
(export define-record-writer))
;; define-record-type
(define ((default-record-writer ctor) obj)
(let ((port (open-output-string)))
(display "#.(" port)
(display (car ctor) port)
(for-each
(lambda (field)
(display " " port)
(write (record-ref obj field) port))
(cdr ctor))
(display ")" port)
(get-output-string port)))
(define ((boot-make-record-type <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))

7
piclib/picrin/symbol.scm
View File

@ -1,7 +0,0 @@
(define-library (picrin symbol)
(import (picrin base symbol))
(export symbol?
symbol=?
symbol->string
string->symbol))

347
piclib/picrin/syntax-rules.scm Normal file
View File

@ -0,0 +1,347 @@
(define-library (picrin syntax-rules)
(import (picrin base)
(picrin macro))
(define-syntax define-auxiliary-syntax
(er-macro-transformer
(lambda (expr r c)
(list (r 'define-syntax) (cadr expr)
(list (r 'lambda) '_
(list (r 'error) "invalid use of auxiliary syntax"))))))
(define-auxiliary-syntax _)
(define-auxiliary-syntax ...)
(define (walk proc expr)
(cond
((null? expr)
'())
((pair? expr)
(cons (walk proc (car expr))
(walk proc (cdr expr))))
((vector? expr)
(list->vector (map proc (vector->list expr))))
(else
(proc expr))))
(define (flatten expr)
(let ((list '()))
(walk
(lambda (x)
(set! list (cons x list)))
expr)
(reverse list)))
(define (reverse* l)
;; (reverse* '(a b c d . e)) => (e d c b a)
(let loop ((a '())
(d l))
(if (pair? d)
(loop (cons (car d) a) (cdr d))
(cons d a))))
(define (every? pred l)
(if (null? l)
#t
(and (pred (car l)) (every? pred (cdr l)))))
(define-syntax syntax-rules
(er-macro-transformer
(lambda (form r compare)
(define _define (r 'define))
(define _let (r 'let))
(define _if (r 'if))
(define _begin (r 'begin))
(define _lambda (r 'lambda))
(define _set! (r 'set!))
(define _not (r 'not))
(define _and (r 'and))
(define _car (r 'car))
(define _cdr (r 'cdr))
(define _cons (r 'cons))
(define _pair? (r 'pair?))
(define _null? (r 'null?))
(define _symbol? (r 'symbol?))
(define _vector? (r 'vector?))
(define _eqv? (r 'eqv?))
(define _string=? (r 'string=?))
(define _map (r 'map))
(define _vector->list (r 'vector->list))
(define _list->vector (r 'list->vector))
(define _quote (r 'quote))
(define _quasiquote (r 'quasiquote))
(define _unquote (r 'unquote))
(define _unquote-splicing (r 'unquote-splicing))
(define _syntax-error (r 'syntax-error))
(define _call/cc (r 'call/cc))
(define _er-macro-transformer (r 'er-macro-transformer))
(define (var->sym v)
(let loop ((cnt 0)
(v v))
(if (symbol? v)
(string->symbol
(string-append (symbol->string v) "/" (number->string cnt)))
(loop (+ 1 cnt) (car v)))))
(define push-var list)
(define (compile-match ellipsis literals pattern)
(letrec ((compile-match-base
(lambda (pattern)
(cond ((member pattern literals compare)
(values
`(,_if (,_and (,_symbol? expr) (cmp expr (rename ',pattern)))
#f
(exit #f))
'()))
((compare pattern (r '_)) (values #f '()))
((and ellipsis (compare pattern ellipsis))
(values `(,_syntax-error "invalid pattern") '()))
((symbol? pattern)
(values `(,_set! ,(var->sym pattern) expr) (list pattern)))
((pair? pattern)
(compile-match-list pattern))
((vector? pattern)
(compile-match-vector pattern))
((string? pattern)
(values
`(,_if (,_not (,_string=? ',pattern expr))
(exit #f))
'()))
(else
(values
`(,_if (,_not (,_eqv? ',pattern expr))
(exit #f))
'())))))
(compile-match-list
(lambda (pattern)
(let loop ((pattern pattern)
(matches '())
(vars '())
(accessor 'expr))
(cond ;; (hoge)
((not (pair? (cdr pattern)))
(let*-values (((match1 vars1) (compile-match-base (car pattern)))
((match2 vars2) (compile-match-base (cdr pattern))))
(values
`(,_begin ,@(reverse matches)
(,_if (,_pair? ,accessor)
(,_begin
(,_let ((expr (,_car ,accessor)))
,match1)
(,_let ((expr (,_cdr ,accessor)))
,match2))
(exit #f)))
(append vars (append vars1 vars2)))))
;; (hoge ... rest args)
((and ellipsis (compare (cadr pattern) ellipsis))
(let-values (((match-r vars-r) (compile-match-list-reverse pattern)))
(values
`(,_begin ,@(reverse matches)
(,_let ((expr (,_let loop ((a ())
(d ,accessor))
(,_if (,_pair? d)
(loop (,_cons (,_car d) a) (,_cdr d))
(,_cons d a)))))
,match-r))
(append vars vars-r))))
(else
(let-values (((match1 vars1) (compile-match-base (car pattern))))
(loop (cdr pattern)
(cons `(,_if (,_pair? ,accessor)
(,_let ((expr (,_car ,accessor)))
,match1)
(exit #f))
matches)
(append vars vars1)
`(,_cdr ,accessor))))))))
(compile-match-list-reverse
(lambda (pattern)
(let loop ((pattern (reverse* pattern))
(matches '())
(vars '())
(accessor 'expr))
(cond ((and ellipsis (compare (car pattern) ellipsis))
(let-values (((match1 vars1) (compile-match-ellipsis (cadr pattern))))
(values
`(,_begin ,@(reverse matches)
(,_let ((expr ,accessor))
,match1))
(append vars vars1))))
(else
(let-values (((match1 vars1) (compile-match-base (car pattern))))
(loop (cdr pattern)
(cons `(,_let ((expr (,_car ,accessor))) ,match1) matches)
(append vars vars1)
`(,_cdr ,accessor))))))))
(compile-match-ellipsis
(lambda (pattern)
(let-values (((match vars) (compile-match-base pattern)))
(values
`(,_let loop ((expr expr))
(,_if (,_not (,_null? expr))
(,_let ,(map (lambda (var) `(,(var->sym var) '())) vars)
(,_let ((expr (,_car expr)))
,match)
,@(map
(lambda (var)
`(,_set! ,(var->sym (push-var var))
(,_cons ,(var->sym var) ,(var->sym (push-var var)))))
vars)
(loop (,_cdr expr)))))
(map push-var vars)))))
(compile-match-vector
(lambda (pattern)
(let-values (((match vars) (compile-match-base (vector->list pattern))))
(values
`(,_if (,_vector? expr)
(,_let ((expr (,_vector->list expr)))
,match)
(exit #f))
vars)))))
(let-values (((match vars) (compile-match-base (cdr pattern))))
(values `(,_let ((expr (,_cdr expr)))
,match
#t)
vars))))
;;; compile expand
(define (compile-expand ellipsis reserved template)
(letrec ((compile-expand-base
(lambda (template ellipsis-valid)
(cond ((member template reserved eq?)
(values (var->sym template) (list template)))
((symbol? template)
(values `(rename ',template) '()))
((pair? template)
(compile-expand-list template ellipsis-valid))
((vector? template)
(compile-expand-vector template ellipsis-valid))
(else
(values `',template '())))))
(compile-expand-list
(lambda (template ellipsis-valid)
(let loop ((template template)
(expands '())
(vars '()))
(cond ;; (... hoge)
((and ellipsis-valid
(pair? template)
(compare (car template) ellipsis))
(if (and (pair? (cdr template)) (null? (cddr template)))
(compile-expand-base (cadr template) #f)
(values '(,_syntax-error "invalid template") '())))
;; hoge
((not (pair? template))
(let-values (((expand1 vars1)
(compile-expand-base template ellipsis-valid)))
(values
`(,_quasiquote (,@(reverse expands) . (,_unquote ,expand1)))
(append vars vars1))))
;; (a ... rest syms)
((and ellipsis-valid
(pair? (cdr template))
(compare (cadr template) ellipsis))
(let-values (((expand1 vars1)
(compile-expand-base (car template) ellipsis-valid)))
(loop (cddr template)
(cons
`(,_unquote-splicing
(,_map (,_lambda ,(map var->sym vars1) ,expand1)
,@(map (lambda (v) (var->sym (push-var v))) vars1)))
expands)
(append vars (map push-var vars1)))))
(else
(let-values (((expand1 vars1)
(compile-expand-base (car template) ellipsis-valid)))
(loop (cdr template)
(cons
`(,_unquote ,expand1)
expands)
(append vars vars1))))))))
(compile-expand-vector
(lambda (template ellipsis-valid)
(let-values (((expand1 vars1)
(compile-expand-base (vector->list template) ellipsis-valid)))
(values
`(,_list->vector ,expand1)
vars1)))))
(compile-expand-base template ellipsis)))
(define (check-vars vars-pattern vars-template)
;;fixme
#t)
(define (compile-rule ellipsis literals rule)
(let ((pattern (car rule))
(template (cadr rule)))
(let*-values (((match vars-match)
(compile-match ellipsis literals pattern))
((expand vars-expand)
(compile-expand ellipsis (flatten vars-match) template)))
(if (check-vars vars-match vars-expand)
(list vars-match match expand)
'mismatch))))
(define (expand-clauses clauses rename)
(cond ((null? clauses)
`(,_quote (syntax-error "no matching pattern")))
((compare (car clauses) 'mismatch)
`(,_syntax-error "invalid rule"))
(else
(let ((vars (list-ref (car clauses) 0))
(match (list-ref (car clauses) 1))
(expand (list-ref (car clauses) 2)))
`(,_let ,(map (lambda (v) (list (var->sym v) '())) vars)
(,_let ((result (,_call/cc (,_lambda (exit) ,match))))
(,_if result
,expand
,(expand-clauses (cdr clauses) rename))))))))
(define (normalize-form form)
(if (and (list? form) (>= (length form) 2))
(let ((ellipsis '...)
(literals (cadr form))
(rules (cddr form)))
(when (symbol? literals)
(set! ellipsis literals)
(set! literals (car rules))
(set! rules (cdr rules)))
(if (and (symbol? ellipsis)
(list? literals)
(every? symbol? literals)
(list? rules)
(every? (lambda (l) (and (list? l) (= (length l) 2))) rules))
(if (member ellipsis literals compare)
`(syntax-rules #f ,literals ,@rules)
`(syntax-rules ,ellipsis ,literals ,@rules))
#f))
#f))
(let ((form (normalize-form form)))
(if form
(let ((ellipsis (list-ref form 1))
(literals (list-ref form 2))
(rules (list-tail form 3)))
(let ((clauses (map (lambda (rule) (compile-rule ellipsis literals rule))
rules)))
`(,_er-macro-transformer
(,_lambda (expr rename cmp)
,(expand-clauses clauses r)))))
`(,_syntax-error "malformed syntax-rules"))))))
(export syntax-rules
_
...))

9
piclib/picrin/test.scm
View File

@ -1,8 +1,7 @@
(define-library (picrin test)
(import (scheme base)
(scheme write)
(scheme read)
(scheme process-context))
(import (picrin base)
(picrin syntax-rules))
(define test-counter 0)
(define counter 0)
(define failure-counter 0)
@ -77,7 +76,7 @@
(length fails))
(define (test-exit)
(exit (zero? (test-failure-count))))
(exit (= (test-failure-count) 0)))
(define-syntax test-syntax-error
(syntax-rules ()

1089
piclib/scheme/base.scm
View File

File diff suppressed because it is too large Load Diff

16
piclib/scheme/eval.scm
View File

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

11
piclib/scheme/file.scm
View File

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

15
piclib/scheme/inexact.scm Normal file
View File

@ -0,0 +1,15 @@
(define-library (scheme inexact)
(import (picrin base))
(export acos
asin
atan
cos
exp
finite?
infinite?
log
nan?
sin
sqrt
tan))

4
piclib/scheme/load.scm Normal file
View File

@ -0,0 +1,4 @@
(define-library (scheme load)
(import (picrin base))
(export load))

8
piclib/scheme/process-context.scm Normal file
View File

@ -0,0 +1,8 @@
(define-library (scheme process-context)
(import (picrin base))
(export command-line
emergency-exit
exit
get-environment-variable
get-environment-variables))

10
piclib/scheme/r5rs.scm
View File

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

4
piclib/scheme/read.scm Normal file
View File

@ -0,0 +1,4 @@
(define-library (scheme read)
(import (picrin base))
(export read))

6
piclib/scheme/time.scm Normal file
View File

@ -0,0 +1,6 @@
(define-library (scheme time)
(import (picrin base))
(export current-jiffy
current-second
jiffies-per-second))

7
piclib/scheme/write.scm Normal file
View File

@ -0,0 +1,7 @@
(define-library (scheme write)
(import (picrin base))
(export write
write-simple
write-shared
display))

2
piclib/srfi/17.scm
View File

@ -3,7 +3,7 @@
(import (except (scheme base) set!)
(prefix (only (scheme base) set!) %)
(picrin dictionary)
(picrin attribute)
(except (picrin base) set!)
(srfi 1)
(srfi 8))

27
src/CMakeLists.txt
View File

@ -1,7 +1,12 @@
### libpicrin ###
find_package(Perl REQUIRED)
# xfile
set(XFILE_SOURCES extlib/xfile/xfile.c)
# benz
file(GLOB BENZ_SOURCES extlib/benz/*.c)
# srcs
file(GLOB PICRIN_SOURCES src/*.c)
# piclib
set(PICLIB_SOURCE ${PROJECT_SOURCE_DIR}/src/load_piclib.c)
@ -21,12 +26,22 @@ add_custom_command(
WORKING_DIRECTORY ${PROJECT_SOURCE_DIR}
)
# build!
file(GLOB PICRIN_SOURCES ${PROJECT_SOURCE_DIR}/src/*.c)
add_library(picrin SHARED ${PICRIN_SOURCES} ${PICLIB_SOURCE} ${XFILE_SOURCES} ${PICRIN_CONTRIB_SOURCES} ${CONTRIB_INIT})
add_library(picrin SHARED ${BENZ_SOURCES} ${PICRIN_SOURCES} ${PICLIB_SOURCE} ${PICRIN_CONTRIB_SOURCES} ${CONTRIB_INIT})
target_link_libraries(picrin m ${PICRIN_CONTRIB_LIBRARIES})
# install
set(CMAKE_INSTALL_RPATH ${CMAKE_INSTALL_PREFIX}/lib)
install(TARGETS picrin DESTINATION lib)
install(DIRECTORY include/ DESTINATION include FILES_MATCHING PATTERN "*.h")
install(DIRECTORY extlib/benz/include/ DESTINATION include FILES_MATCHING PATTERN "*.h")
### picrin ###
list(APPEND REPL_LIBRARIES picrin)
# build
add_executable(repl src/main.c)
set_target_properties(repl PROPERTIES OUTPUT_NAME picrin)
target_link_libraries(repl ${REPL_LIBRARIES})
# install
install(TARGETS repl RUNTIME DESTINATION bin)

196
src/blob.c
View File

@ -1,196 +0,0 @@
/**
* See Copyright Notice in picrin.h
*/
#include <string.h>
#include "picrin.h"
#include "picrin/blob.h"
char *
pic_strndup(pic_state *pic, const char *s, size_t n)
{
char *r;
r = pic_alloc(pic, n + 1);
memcpy(r, s, n);
r[n] = '\0';
return r;
}
char *
pic_strdup(pic_state *pic, const char *s)
{
return pic_strndup(pic, s, strlen(s));
}
struct pic_blob *
pic_blob_new(pic_state *pic, size_t len)
{
struct pic_blob *bv;
bv = (struct pic_blob *)pic_obj_alloc(pic, sizeof(struct pic_blob), PIC_TT_BLOB);
bv->data = pic_alloc(pic, len);
bv->len = len;
return bv;
}
static pic_value
pic_blob_bytevector_p(pic_state *pic)
{
pic_value v;
pic_get_args(pic, "o", &v);
return pic_bool_value(pic_blob_p(v));
}
static pic_value
pic_blob_make_bytevector(pic_state *pic)
{
pic_blob *blob;
int k, b = 0, i;
pic_get_args(pic, "i|i", &k, &b);
if (b < 0 || b > 255)
pic_error(pic, "byte out of range");
blob = pic_blob_new(pic, k);
for (i = 0; i < k; ++i) {
blob->data[i] = b;
}
return pic_obj_value(blob);
}
static pic_value
pic_blob_bytevector_length(pic_state *pic)
{
struct pic_blob *bv;
pic_get_args(pic, "b", &bv);
return pic_int_value(bv->len);
}
static pic_value
pic_blob_bytevector_u8_ref(pic_state *pic)
{
struct pic_blob *bv;
int k;
pic_get_args(pic, "bi", &bv, &k);
return pic_int_value(bv->data[k]);
}
static pic_value
pic_blob_bytevector_u8_set(pic_state *pic)
{
struct pic_blob *bv;
int k, v;
pic_get_args(pic, "bii", &bv, &k, &v);
if (v < 0 || v > 255)
pic_error(pic, "byte out of range");
bv->data[k] = v;
return pic_none_value();
}
static pic_value
pic_blob_bytevector_copy_i(pic_state *pic)
{
pic_blob *to, *from;
int n, at, start, end;
n = pic_get_args(pic, "bib|ii", &to, &at, &from, &start, &end);
switch (n) {
case 3:
start = 0;
case 4:
end = from->len;
}
if (to == from && (start <= at && at < end)) {
/* copy in reversed order */
at += end - start;
while (start < end) {
to->data[--at] = from->data[--end];
}
return pic_none_value();
}
while (start < end) {
to->data[at++] = from->data[start++];
}
return pic_none_value();
}
static pic_value
pic_blob_bytevector_copy(pic_state *pic)
{
pic_blob *from, *to;
int n, start, end, i = 0;
n = pic_get_args(pic, "b|ii", &from, &start, &end);
switch (n) {
case 1:
start = 0;
case 2:
end = from->len;
}
to = pic_blob_new(pic, end - start);
while (start < end) {
to->data[i++] = from->data[start++];
}
return pic_obj_value(to);
}
static pic_value
pic_blob_bytevector_append(pic_state *pic)
{
size_t argc, i, j, len;
pic_value *argv;
pic_blob *blob;
pic_get_args(pic, "*", &argc, &argv);
len = 0;
for (i = 0; i < argc; ++i) {
pic_assert_type(pic, argv[i], blob);
len += pic_blob_ptr(argv[i])->len;
}
blob = pic_blob_new(pic, len);
len = 0;
for (i = 0; i < argc; ++i) {
for (j = 0; j < pic_blob_ptr(argv[i])->len; ++j) {
blob->data[len + j] = pic_blob_ptr(argv[i])->data[j];
}
len += pic_blob_ptr(argv[i])->len;
}
return pic_obj_value(blob);
}
void
pic_init_blob(pic_state *pic)
{
pic_defun(pic, "bytevector?", pic_blob_bytevector_p);
pic_defun(pic, "make-bytevector", pic_blob_make_bytevector);
pic_defun(pic, "bytevector-length", pic_blob_bytevector_length);
pic_defun(pic, "bytevector-u8-ref", pic_blob_bytevector_u8_ref);
pic_defun(pic, "bytevector-u8-set!", pic_blob_bytevector_u8_set);
pic_defun(pic, "bytevector-copy!", pic_blob_bytevector_copy_i);
pic_defun(pic, "bytevector-copy", pic_blob_bytevector_copy);
pic_defun(pic, "bytevector-append", pic_blob_bytevector_append);
}

201
src/bool.c
View File

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

43
src/char.c
View File

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

1458
src/codegen.c
View File

File diff suppressed because it is too large Load Diff

371
src/cont.c
View File

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

15
src/data.c
View File

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

74
src/debug.c
View File

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

169
src/dict.c
View File

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

286
src/error.c
View File

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

39
src/eval.c
View File

@ -1,39 +0,0 @@
/**
* See Copyright Notice in picrin.h
*/
#include "picrin.h"
#include "picrin/macro.h"
pic_value
pic_eval(pic_state *pic, pic_value program, struct pic_lib *lib)
{
struct pic_proc *proc;
proc = pic_compile(pic, program, lib);
return pic_apply(pic, proc, pic_nil_value());
}
static pic_value
pic_eval_eval(pic_state *pic)
{
pic_value program, spec;
struct pic_lib *lib;
pic_get_args(pic, "oo", &program, &spec);
lib = pic_find_library(pic, spec);
if (lib == NULL) {
pic_errorf(pic, "no library found: ~s", spec);
}
return pic_eval(pic, program, lib);
}
void
pic_init_eval(pic_state *pic)
{
pic_deflibrary (pic, "(scheme eval)") {
pic_defun(pic, "eval", pic_eval_eval);
}
}

119
src/file.c
View File

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

872
src/gc.c
View File

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

125
src/init.c
View File

@ -1,125 +0,0 @@
/**
* See Copyright Notice in picrin.h
*/
#include <stdlib.h>
#include "picrin.h"
#include "picrin/pair.h"
#include "picrin/read.h"
#include "picrin/lib.h"
#include "picrin/macro.h"
#include "picrin/error.h"
static pic_value
pic_features(pic_state *pic)
{
pic_value features = pic_nil_value();
pic_get_args(pic, "");
pic_push(pic, pic_sym_value(pic_intern_cstr(pic, "r7rs")), features);
pic_push(pic, pic_sym_value(pic_intern_cstr(pic, "ieee-float")), features);
pic_push(pic, pic_sym_value(pic_intern_cstr(pic, "picrin")), features);
return features;
}
static pic_value
pic_libraries(pic_state *pic)
{
pic_value libs = pic_nil_value(), lib;
pic_get_args(pic, "");
pic_for_each (lib, pic->libs) {
libs = pic_cons(pic, pic_car(pic, lib), libs);
}
return libs;
}
void pic_init_bool(pic_state *);
void pic_init_pair(pic_state *);
void pic_init_port(pic_state *);
void pic_init_number(pic_state *);
void pic_init_time(pic_state *);
void pic_init_system(pic_state *);
void pic_init_file(pic_state *);
void pic_init_proc(pic_state *);
void pic_init_symbol(pic_state *);
void pic_init_vector(pic_state *);
void pic_init_blob(pic_state *);
void pic_init_cont(pic_state *);
void pic_init_char(pic_state *);
void pic_init_error(pic_state *);
void pic_init_str(pic_state *);
void pic_init_macro(pic_state *);
void pic_init_var(pic_state *);
void pic_init_load(pic_state *);
void pic_init_write(pic_state *);
void pic_init_read(pic_state *);
void pic_init_dict(pic_state *);
void pic_init_record(pic_state *);
void pic_init_eval(pic_state *);
void pic_init_lib(pic_state *);
void pic_init_contrib(pic_state *);
void pic_load_piclib(pic_state *);
#define DONE pic_gc_arena_restore(pic, ai);
void
pic_init_core(pic_state *pic)
{
size_t ai = pic_gc_arena_preserve(pic);
pic_init_reader(pic);
pic_deflibrary (pic, "(picrin base core)") {
pic_define_syntactic_keyword(pic, pic->lib->env, pic->sDEFINE, pic->rDEFINE);
pic_define_syntactic_keyword(pic, pic->lib->env, pic->sSETBANG, pic->rSETBANG);
pic_define_syntactic_keyword(pic, pic->lib->env, pic->sQUOTE, pic->rQUOTE);
pic_define_syntactic_keyword(pic, pic->lib->env, pic->sLAMBDA, pic->rLAMBDA);
pic_define_syntactic_keyword(pic, pic->lib->env, pic->sIF, pic->rIF);
pic_define_syntactic_keyword(pic, pic->lib->env, pic->sBEGIN, pic->rBEGIN);
pic_define_syntactic_keyword(pic, pic->lib->env, pic->sDEFINE_SYNTAX, pic->rDEFINE_SYNTAX);
}
pic_deflibrary (pic, "(picrin library)") {
pic_defun(pic, "libraries", pic_libraries);
}
pic_deflibrary (pic, "(scheme base)") {
pic_defun(pic, "features", pic_features);
pic_init_bool(pic); DONE;
pic_init_pair(pic); DONE;
pic_init_port(pic); DONE;
pic_init_number(pic); DONE;
pic_init_time(pic); DONE;
pic_init_system(pic); DONE;
pic_init_file(pic); DONE;
pic_init_proc(pic); DONE;
pic_init_symbol(pic); DONE;
pic_init_vector(pic); DONE;
pic_init_blob(pic); DONE;
pic_init_cont(pic); DONE;
pic_init_char(pic); DONE;
pic_init_error(pic); DONE;
pic_init_str(pic); DONE;
pic_init_macro(pic); DONE;
pic_init_var(pic); DONE;
pic_init_load(pic); DONE;
pic_init_write(pic); DONE;
pic_init_read(pic); DONE;
pic_init_dict(pic); DONE;
pic_init_record(pic); DONE;
pic_init_eval(pic); DONE;
pic_init_lib(pic); DONE;
pic_init_contrib(pic); DONE;
pic_load_piclib(pic); DONE;
}
}

273
src/lib.c
View File

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

87
src/load.c
View File

@ -1,87 +0,0 @@
/**
* See Copyright Notice in picrin.h
*/
#include "picrin.h"
#include "picrin/pair.h"
pic_value
pic_load_cstr(pic_state *pic, const char *src)
{
size_t ai;
pic_value v, exprs;
struct pic_proc *proc;
exprs = pic_parse_cstr(pic, src);
if (pic_undef_p(exprs)) {
pic_errorf(pic, "load: read failure (%s)", pic_errmsg(pic));
}
pic_for_each (v, exprs) {
ai = pic_gc_arena_preserve(pic);
proc = pic_compile(pic, v, pic->lib);
if (proc == NULL) {
pic_error(pic, "load: compilation failure");
}
pic_apply(pic, proc, pic_nil_value());
pic_gc_arena_restore(pic, ai);
}
return pic_none_value();
}
pic_value
pic_load(pic_state *pic, const char *fn)
{
FILE *file;
size_t ai;
pic_value v, exprs;
struct pic_proc *proc;
file = fopen(fn, "r");
if (file == NULL) {
pic_errorf(pic, "load: could not read file \"%s\"", fn);
}
exprs = pic_parse_file(pic, file);
if (pic_undef_p(exprs)) {
pic_errorf(pic, "load: read failure (%s)", pic_errmsg(pic));
}
pic_for_each (v, exprs) {
ai = pic_gc_arena_preserve(pic);
proc = pic_compile(pic, v, pic->lib);
if (proc == NULL) {
pic_error(pic, "load: compilation failure");
}
pic_apply(pic, proc, pic_nil_value());
pic_gc_arena_restore(pic, ai);
}
return pic_none_value();
}
static pic_value
pic_load_load(pic_state *pic)
{
pic_value envid;
char *fn;
pic_get_args(pic, "z|o", &fn, &envid);
return pic_load(pic, fn);
}
void
pic_init_load(pic_state *pic)
{
pic_deflibrary (pic, "(scheme load)") {
pic_defun(pic, "load", pic_load_load);
}
}

494
src/macro.c
View File

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

77
src/main.c Normal file
View File

@ -0,0 +1,77 @@
/**
* See Copyright Notice in picrin.h
*/
#include "picrin.h"
#include "picrin/pair.h"
#include "picrin/error.h"
void pic_init_contrib(pic_state *);
void pic_load_piclib(pic_state *);
static pic_value
pic_features(pic_state *pic)
{
pic_value features = pic_nil_value();
pic_get_args(pic, "");
pic_push(pic, pic_sym_value(pic_intern_cstr(pic, "r7rs")), features);
pic_push(pic, pic_sym_value(pic_intern_cstr(pic, "ieee-float")), features);
pic_push(pic, pic_sym_value(pic_intern_cstr(pic, "picrin")), features);
return features;
}
static pic_value
pic_libraries(pic_state *pic)
{
pic_value libs = pic_nil_value(), lib;
pic_get_args(pic, "");
pic_for_each (lib, pic->libs) {
libs = pic_cons(pic, pic_car(pic, lib), libs);
}
return libs;
}
void
pic_init_picrin(pic_state *pic)
{
pic_deflibrary (pic, "(picrin library)") {
pic_defun(pic, "libraries", pic_libraries);
}
pic_deflibrary (pic, "(scheme base)") {
pic_defun(pic, "features", pic_features);
pic_init_contrib(pic);
pic_load_piclib(pic);
}
}
int
main(int argc, char *argv[], char **envp)
{
pic_state *pic;
int status = 0;
pic = pic_open(argc, argv, envp);
pic_init_picrin(pic);
pic_try {
pic_import(pic, pic_read_cstr(pic, "(picrin main)"));
pic_funcall(pic, "main", pic_nil_value());
}
pic_catch {
pic_print_backtrace(pic, pic->err);
status = 1;
}
pic_close(pic);
return status;
}

944
src/number.c
View File

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

767
src/pair.c
View File

@ -1,767 +0,0 @@
/**
* See Copyright Notice in picrin.h
*/
#include <stdarg.h>
#include "picrin.h"
#include "picrin/pair.h"
pic_value
pic_cons(pic_state *pic, pic_value car, pic_value cdr)
{
struct pic_pair *pair;
pair = (struct pic_pair *)pic_obj_alloc(pic, sizeof(struct pic_pair), PIC_TT_PAIR);
pair->car = car;
pair->cdr = cdr;
return pic_obj_value(pair);
}
pic_value
pic_car(pic_state *pic, pic_value obj)
{
struct pic_pair *pair;
if (! pic_pair_p(obj)) {
pic_errorf(pic, "pair required, but got ~s", obj);
}
pair = pic_pair_ptr(obj);
return pair->car;
}
pic_value
pic_cdr(pic_state *pic, pic_value obj)
{
struct pic_pair *pair;
if (! pic_pair_p(obj)) {
pic_errorf(pic, "pair required, but got ~s", obj);
}
pair = pic_pair_ptr(obj);
return pair->cdr;
}
void
pic_set_car(pic_state *pic, pic_value obj, pic_value val)
{
struct pic_pair *pair;
if (! pic_pair_p(obj)) {
pic_error(pic, "pair required");
}
pair = pic_pair_ptr(obj);
pair->car = val;
}
void
pic_set_cdr(pic_state *pic, pic_value obj, pic_value val)
{
struct pic_pair *pair;
if (! pic_pair_p(obj)) {
pic_error(pic, "pair required");
}
pair = pic_pair_ptr(obj);
pair->cdr = val;
}
bool
pic_list_p(pic_value obj)
{
pic_value local, rapid;
int i;
/* Floyd's cycle-finding algorithm. */
local = rapid = obj;
while (true) {
/* advance rapid fast-forward; runs 2x faster than local */
for (i = 0; i < 2; ++i) {
if (pic_pair_p(rapid)) {
rapid = pic_pair_ptr(rapid)->cdr;
}
else {
return pic_nil_p(rapid);
}
}
/* advance local */
local = pic_pair_ptr(local)->cdr;
if (pic_eq_p(local, rapid)) {
return false;
}
}
}
pic_value
pic_list1(pic_state *pic, pic_value obj1)
{
return pic_cons(pic, obj1, pic_nil_value());
}
pic_value
pic_list2(pic_state *pic, pic_value obj1, pic_value obj2)
{
size_t ai = pic_gc_arena_preserve(pic);
pic_value val;
val = pic_cons(pic, obj1, pic_list1(pic, obj2));
pic_gc_arena_restore(pic, ai);
pic_gc_protect(pic, val);
return val;
}
pic_value
pic_list3(pic_state *pic, pic_value obj1, pic_value obj2, pic_value obj3)
{
size_t ai = pic_gc_arena_preserve(pic);
pic_value val;
val = pic_cons(pic, obj1, pic_list2(pic, obj2, obj3));
pic_gc_arena_restore(pic, ai);
pic_gc_protect(pic, val);
return val;
}
pic_value
pic_list4(pic_state *pic, pic_value obj1, pic_value obj2, pic_value obj3, pic_value obj4)
{
size_t ai = pic_gc_arena_preserve(pic);
pic_value val;
val = pic_cons(pic, obj1, pic_list3(pic, obj2, obj3, obj4));
pic_gc_arena_restore(pic, ai);
pic_gc_protect(pic, val);
return val;
}
pic_value
pic_list5(pic_state *pic, pic_value obj1, pic_value obj2, pic_value obj3, pic_value obj4, pic_value obj5)
{
size_t ai = pic_gc_arena_preserve(pic);
pic_value val;
val = pic_cons(pic, obj1, pic_list4(pic, obj2, obj3, obj4, obj5));
pic_gc_arena_restore(pic, ai);
pic_gc_protect(pic, val);
return val;
}
pic_value
pic_list6(pic_state *pic, pic_value obj1, pic_value obj2, pic_value obj3, pic_value obj4, pic_value obj5, pic_value obj6)
{
size_t ai = pic_gc_arena_preserve(pic);
pic_value val;
val = pic_cons(pic, obj1, pic_list5(pic, obj2, obj3, obj4, obj5, obj6));
pic_gc_arena_restore(pic, ai);
pic_gc_protect(pic, val);
return val;
}
pic_value
pic_list7(pic_state *pic, pic_value obj1, pic_value obj2, pic_value obj3, pic_value obj4, pic_value obj5, pic_value obj6, pic_value obj7)
{
size_t ai = pic_gc_arena_preserve(pic);
pic_value val;
val = pic_cons(pic, obj1, pic_list6(pic, obj2, obj3, obj4, obj5, obj6, obj7));
pic_gc_arena_restore(pic, ai);
pic_gc_protect(pic, val);
return val;
}
pic_value
pic_list_by_array(pic_state *pic, size_t c, pic_value *vs)
{
pic_value v;
v = pic_nil_value();
while (c--) {
v = pic_cons(pic, vs[c], v);
}
return v;
}
pic_value
pic_make_list(pic_state *pic, int k, pic_value fill)
{
pic_value list;
int i;
list = pic_nil_value();
for (i = 0; i < k; ++i) {
list = pic_cons(pic, fill, list);
}
return list;
}
int
pic_length(pic_state *pic, pic_value obj)
{
int c = 0;
if (! pic_list_p(obj)) {
pic_errorf(pic, "length: expected list, but got ~s", obj);
}
while (! pic_nil_p(obj)) {
obj = pic_cdr(pic, obj);
++c;
}
return c;
}
pic_value
pic_reverse(pic_state *pic, pic_value list)
{
size_t ai = pic_gc_arena_preserve(pic);
pic_value v, acc;
acc = pic_nil_value();
pic_for_each(v, list) {
acc = pic_cons(pic, v, acc);
pic_gc_arena_restore(pic, ai);
pic_gc_protect(pic, acc);
}
return acc;
}
pic_value
pic_append(pic_state *pic, pic_value xs, pic_value ys)
{
size_t ai = pic_gc_arena_preserve(pic);
pic_value x;
xs = pic_reverse(pic, xs);
pic_for_each (x, xs) {
ys = pic_cons(pic, x, ys);
pic_gc_arena_restore(pic, ai);
pic_gc_protect(pic, xs);
pic_gc_protect(pic, ys);
}
return ys;
}
pic_value
pic_memq(pic_state *pic, pic_value key, pic_value list)
{
enter:
if (pic_nil_p(list))
return pic_false_value();
if (pic_eq_p(key, pic_car(pic, list)))
return list;
list = pic_cdr(pic, list);
goto enter;
}
pic_value
pic_memv(pic_state *pic, pic_value key, pic_value list)
{
enter:
if (pic_nil_p(list))
return pic_false_value();
if (pic_eqv_p(key, pic_car(pic, list)))
return list;
list = pic_cdr(pic, list);
goto enter;
}
pic_value
pic_member(pic_state *pic, pic_value key, pic_value list, struct pic_proc *compar)
{
enter:
if (pic_nil_p(list))
return pic_false_value();
if (compar == NULL) {
if (pic_equal_p(pic, key, pic_car(pic, list)))
return list;
} else {
if (pic_test(pic_apply2(pic, compar, key, pic_car(pic, list))))
return list;
}
list = pic_cdr(pic, list);
goto enter;
}
pic_value
pic_assq(pic_state *pic, pic_value key, pic_value assoc)
{
pic_value cell;
enter:
if (pic_nil_p(assoc))
return pic_false_value();
cell = pic_car(pic, assoc);
if (pic_eq_p(key, pic_car(pic, cell)))
return cell;
assoc = pic_cdr(pic, assoc);
goto enter;
}
pic_value
pic_assv(pic_state *pic, pic_value key, pic_value assoc)
{
pic_value cell;
enter:
if (pic_nil_p(assoc))
return pic_false_value();
cell = pic_car(pic, assoc);
if (pic_eqv_p(key, pic_car(pic, cell)))
return cell;
assoc = pic_cdr(pic, assoc);
goto enter;
}
pic_value
pic_assoc(pic_state *pic, pic_value key, pic_value assoc, struct pic_proc *compar)
{
pic_value cell;
enter:
if (pic_nil_p(assoc))
return pic_false_value();
cell = pic_car(pic, assoc);
if (compar == NULL) {
if (pic_equal_p(pic, key, pic_car(pic, cell)))
return cell;
} else {
if (pic_test(pic_apply2(pic, compar, key, pic_car(pic, cell))))
return cell;
}
assoc = pic_cdr(pic, assoc);
goto enter;
}
pic_value
pic_acons(pic_state *pic, pic_value key, pic_value val, pic_value assoc)
{
return pic_cons(pic, pic_cons(pic, key, val), assoc);
}
pic_value
pic_caar(pic_state *pic, pic_value v)
{
return pic_car(pic, pic_car(pic, v));
}
pic_value
pic_cadr(pic_state *pic, pic_value v)
{
return pic_car(pic, pic_cdr(pic, v));
}
pic_value
pic_cdar(pic_state *pic, pic_value v)
{
return pic_cdr(pic, pic_car(pic, v));
}
pic_value
pic_cddr(pic_state *pic, pic_value v)
{
return pic_cdr(pic, pic_cdr(pic, v));
}
pic_value
pic_list_tail(pic_state *pic, pic_value list, int i)
{
while (i-- > 0) {
list = pic_cdr(pic, list);
}
return list;
}
pic_value
pic_list_ref(pic_state *pic, pic_value list, int i)
{
return pic_car(pic, pic_list_tail(pic, list, i));
}
void
pic_list_set(pic_state *pic, pic_value list, int i, pic_value obj)
{
pic_pair_ptr(pic_list_tail(pic, list, i))->car = obj;
}
pic_value
pic_list_copy(pic_state *pic, pic_value obj)
{
if (pic_pair_p(obj)) {
return pic_cons(pic, pic_car(pic, obj), pic_list_copy(pic, pic_cdr(pic, obj)));
}
else {
return obj;
}
}
static pic_value
pic_pair_pair_p(pic_state *pic)
{
pic_value v;
pic_get_args(pic, "o", &v);
return pic_bool_value(pic_pair_p(v));
}
static pic_value
pic_pair_cons(pic_state *pic)
{
pic_value v,w;
pic_get_args(pic, "oo", &v, &w);
return pic_cons(pic, v, w);
}
static pic_value
pic_pair_car(pic_state *pic)
{
pic_value v;
pic_get_args(pic, "o", &v);
return pic_car(pic, v);
}
static pic_value
pic_pair_cdr(pic_state *pic)
{
pic_value v;
pic_get_args(pic, "o", &v);
return pic_cdr(pic, v);
}
static pic_value
pic_pair_caar(pic_state *pic)
{
pic_value v;
pic_get_args(pic, "o", &v);
return pic_caar(pic, v);
}
static pic_value
pic_pair_cadr(pic_state *pic)
{
pic_value v;
pic_get_args(pic, "o", &v);
return pic_cadr(pic, v);
}
static pic_value
pic_pair_cdar(pic_state *pic)
{
pic_value v;
pic_get_args(pic, "o", &v);
return pic_cdar(pic, v);
}
static pic_value
pic_pair_cddr(pic_state *pic)
{
pic_value v;
pic_get_args(pic, "o", &v);
return pic_cddr(pic, v);
}
static pic_value
pic_pair_set_car(pic_state *pic)
{
pic_value v,w;
pic_get_args(pic, "oo", &v, &w);
if (! pic_pair_p(v))
pic_error(pic, "pair expected");
pic_pair_ptr(v)->car = w;
return pic_none_value();
}
static pic_value
pic_pair_set_cdr(pic_state *pic)
{
pic_value v,w;
pic_get_args(pic, "oo", &v, &w);
if (! pic_pair_p(v))
pic_error(pic, "pair expected");
pic_pair_ptr(v)->cdr = w;
return pic_none_value();
}
static pic_value
pic_pair_null_p(pic_state *pic)
{
pic_value v;
pic_get_args(pic, "o", &v);
return pic_bool_value(pic_nil_p(v));
}
static pic_value
pic_pair_list_p(pic_state *pic)
{
pic_value v;
pic_get_args(pic, "o", &v);
return pic_bool_value(pic_list_p(v));
}
static pic_value
pic_pair_make_list(pic_state *pic)
{
int i;
pic_value fill = pic_none_value();
pic_get_args(pic, "i|o", &i, &fill);
return pic_make_list(pic, i, fill);
}
static pic_value
pic_pair_list(pic_state *pic)
{
size_t argc;
pic_value *argv;
pic_get_args(pic, "*", &argc, &argv);
return pic_list_by_array(pic, argc, argv);
}
static pic_value
pic_pair_length(pic_state *pic)
{
pic_value list;
pic_get_args(pic, "o", &list);
return pic_int_value(pic_length(pic, list));
}
static pic_value
pic_pair_append(pic_state *pic)
{
size_t argc;
pic_value *args, list;
pic_get_args(pic, "*", &argc, &args);
if (argc == 0) {
return pic_nil_value();
}
list = args[--argc];
while (argc-- > 0) {
list = pic_append(pic, args[argc], list);
}
return list;
}
static pic_value
pic_pair_reverse(pic_state *pic)
{
pic_value list;
pic_get_args(pic, "o", &list);
return pic_reverse(pic, list);
}
static pic_value
pic_pair_list_tail(pic_state *pic)
{
pic_value list;
int i;
pic_get_args(pic, "oi", &list, &i);
return pic_list_tail(pic, list, i);
}
static pic_value
pic_pair_list_ref(pic_state *pic)
{
pic_value list;
int i;
pic_get_args(pic, "oi", &list, &i);
return pic_list_ref(pic, list, i);
}
static pic_value
pic_pair_list_set(pic_state *pic)
{
pic_value list, obj;
int i;
pic_get_args(pic, "oio", &list, &i, &obj);
pic_list_set(pic, list, i, obj);
return pic_none_value();
}
static pic_value
pic_pair_list_copy(pic_state *pic)
{
pic_value obj;
pic_get_args(pic, "o", &obj);
return pic_list_copy(pic, obj);
}
static pic_value
pic_pair_memq(pic_state *pic)
{
pic_value key, list;
pic_get_args(pic, "oo", &key, &list);
return pic_memq(pic, key, list);
}
static pic_value
pic_pair_memv(pic_state *pic)
{
pic_value key, list;
pic_get_args(pic, "oo", &key, &list);
return pic_memv(pic, key, list);
}
static pic_value
pic_pair_member(pic_state *pic)
{
struct pic_proc *proc = NULL;
pic_value key, list;
pic_get_args(pic, "oo|l", &key, &list, &proc);
return pic_member(pic, key, list, proc);
}
static pic_value
pic_pair_assq(pic_state *pic)
{
pic_value key, list;
pic_get_args(pic, "oo", &key, &list);
return pic_assq(pic, key, list);
}
static pic_value
pic_pair_assv(pic_state *pic)
{
pic_value key, list;
pic_get_args(pic, "oo", &key, &list);
return pic_assv(pic, key, list);
}
static pic_value
pic_pair_assoc(pic_state *pic)
{
struct pic_proc *proc = NULL;
pic_value key, list;
pic_get_args(pic, "oo|l", &key, &list, &proc);
return pic_assoc(pic, key, list, proc);
}
void
pic_init_pair(pic_state *pic)
{
pic_deflibrary (pic, "(picrin base list)") {
pic_defun(pic, "pair?", pic_pair_pair_p);
pic_defun(pic, "cons", pic_pair_cons);
pic_defun(pic, "car", pic_pair_car);
pic_defun(pic, "cdr", pic_pair_cdr);
pic_defun(pic, "set-car!", pic_pair_set_car);
pic_defun(pic, "set-cdr!", pic_pair_set_cdr);
pic_defun(pic, "null?", pic_pair_null_p);
}
pic_deflibrary (pic, "(picrin list)") {
pic_defun(pic, "caar", pic_pair_caar);
pic_defun(pic, "cadr", pic_pair_cadr);
pic_defun(pic, "cdar", pic_pair_cdar);
pic_defun(pic, "cddr", pic_pair_cddr);
pic_defun(pic, "list?", pic_pair_list_p);
pic_defun(pic, "make-list", pic_pair_make_list);
pic_defun(pic, "list", pic_pair_list);
pic_defun(pic, "length", pic_pair_length);
pic_defun(pic, "append", pic_pair_append);
pic_defun(pic, "reverse", pic_pair_reverse);
pic_defun(pic, "list-tail", pic_pair_list_tail);
pic_defun(pic, "list-ref", pic_pair_list_ref);
pic_defun(pic, "list-set!", pic_pair_list_set);
pic_defun(pic, "list-copy", pic_pair_list_copy);
pic_defun(pic, "memq", pic_pair_memq);
pic_defun(pic, "memv", pic_pair_memv);
pic_defun(pic, "member", pic_pair_member);
pic_defun(pic, "assq", pic_pair_assq);
pic_defun(pic, "assv", pic_pair_assv);
pic_defun(pic, "assoc", pic_pair_assoc);
}
}

749
src/port.c
View File

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

183
src/proc.c
View File

@ -1,183 +0,0 @@
/**
* See Copyright Notice in picrin.h
*/
#include "picrin.h"
#include "picrin/pair.h"
#include "picrin/proc.h"
#include "picrin/irep.h"
#include "picrin/dict.h"
struct pic_proc *
pic_proc_new(pic_state *pic, pic_func_t func, const char *name)
{
struct pic_proc *proc;
assert(name != NULL);
proc = (struct pic_proc *)pic_obj_alloc(pic, sizeof(struct pic_proc), PIC_TT_PROC);
proc->kind = PIC_PROC_KIND_FUNC;
proc->u.func.f = func;
proc->u.func.name = pic_intern_cstr(pic, name);
proc->env = NULL;
proc->attr = NULL;
return proc;
}
struct pic_proc *
pic_proc_new_irep(pic_state *pic, struct pic_irep *irep, struct pic_env *env)
{
struct pic_proc *proc;
proc = (struct pic_proc *)pic_obj_alloc(pic, sizeof(struct pic_proc), PIC_TT_PROC);
proc->kind = PIC_PROC_KIND_IREP;
proc->u.irep = irep;
proc->env = env;
proc->attr = NULL;
return proc;
}
pic_sym
pic_proc_name(struct pic_proc *proc)
{
switch (proc->kind) {
case PIC_PROC_KIND_FUNC:
return proc->u.func.name;
case PIC_PROC_KIND_IREP:
return proc->u.irep->name;
}
UNREACHABLE();
}
struct pic_dict *
pic_attr(pic_state *pic, struct pic_proc *proc)
{
if (proc->attr == NULL) {
proc->attr = pic_dict_new(pic);
}
return proc->attr;
}
pic_value
pic_attr_ref(pic_state *pic, struct pic_proc *proc, const char *key)
{
return pic_dict_ref(pic, pic_attr(pic, proc), pic_intern_cstr(pic, key));
}
void
pic_attr_set(pic_state *pic, struct pic_proc *proc, const char *key, pic_value v)
{
pic_dict_set(pic, pic_attr(pic, proc), pic_intern_cstr(pic, key), v);
}
static pic_value
pic_proc_proc_p(pic_state *pic)
{
pic_value v;
pic_get_args(pic, "o", &v);
return pic_bool_value(pic_proc_p(v));
}
static pic_value
pic_proc_apply(pic_state *pic)
{
struct pic_proc *proc;
pic_value *args;
size_t argc;
pic_value arg_list;
pic_get_args(pic, "l*", &proc, &argc, &args);
if (argc == 0) {
pic_error(pic, "apply: wrong number of arguments");
}
arg_list = args[--argc];
while (argc--) {
arg_list = pic_cons(pic, args[argc], arg_list);
}
return pic_apply_trampoline(pic, proc, arg_list);
}
static pic_value
pic_proc_map(pic_state *pic)
{
struct pic_proc *proc;
size_t argc;
pic_value *args;
int i;
pic_value cars, ret;
pic_get_args(pic, "l*", &proc, &argc, &args);
ret = pic_nil_value();
do {
cars = pic_nil_value();
for (i = argc - 1; i >= 0; --i) {
if (! pic_pair_p(args[i])) {
break;
}
cars = pic_cons(pic, pic_car(pic, args[i]), cars);
args[i] = pic_cdr(pic, args[i]);
}
if (i >= 0)
break;
ret = pic_cons(pic, pic_apply(pic, proc, cars), ret);
} while (1);
return pic_reverse(pic, ret);
}
static pic_value
pic_proc_for_each(pic_state *pic)
{
struct pic_proc *proc;
size_t argc;
pic_value *args;
int i;
pic_value cars;
pic_get_args(pic, "l*", &proc, &argc, &args);
do {
cars = pic_nil_value();
for (i = argc - 1; i >= 0; --i) {
if (! pic_pair_p(args[i])) {
break;
}
cars = pic_cons(pic, pic_car(pic, args[i]), cars);
args[i] = pic_cdr(pic, args[i]);
}
if (i >= 0)
break;
pic_apply(pic, proc, cars);
} while (1);
return pic_none_value();
}
static pic_value
pic_proc_attribute(pic_state *pic)
{
struct pic_proc *proc;
pic_get_args(pic, "l", &proc);
return pic_obj_value(pic_attr(pic, proc));
}
void
pic_init_proc(pic_state *pic)
{
pic_defun(pic, "procedure?", pic_proc_proc_p);
pic_defun(pic, "apply", pic_proc_apply);
pic_defun(pic, "map", pic_proc_map);
pic_defun(pic, "for-each", pic_proc_for_each);
pic_deflibrary (pic, "(picrin attribute)") {
pic_defun(pic, "attribute", pic_proc_attribute);
}
}

976
src/read.c
View File

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

115
src/record.c
View File

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

205
src/state.c
View File

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

424
src/string.c
View File

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

161
src/symbol.c
View File

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

136
src/system.c
View File

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

49
src/time.c
View File

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

134
src/var.c
View File

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

283
src/vector.c
View File

@ -1,283 +0,0 @@
/**
* See Copyright Notice in picrin.h
*/
#include "picrin.h"
#include "picrin/vector.h"
#include "picrin/pair.h"
struct pic_vector *
pic_vec_new(pic_state *pic, size_t len)
{
struct pic_vector *vec;
size_t i;
vec = (struct pic_vector *)pic_obj_alloc(pic, sizeof(struct pic_vector), PIC_TT_VECTOR);
vec->len = len;
vec->data = (pic_value *)pic_alloc(pic, sizeof(pic_value) * len);
for (i = 0; i < len; ++i) {
vec->data[i] = pic_none_value();
}
return vec;
}
struct pic_vector *
pic_vec_new_from_list(pic_state *pic, pic_value data)
{
struct pic_vector *vec;
size_t i, len;
len = pic_length(pic, data);
vec = pic_vec_new(pic, len);
for (i = 0; i < len; ++i) {
vec->data[i] = pic_car(pic, data);
data = pic_cdr(pic, data);
}
return vec;
}
void
pic_vec_extend_ip(pic_state *pic, struct pic_vector *vec, size_t size)
{
size_t len, i;
len = vec->len;
vec->len = size;
vec->data = (pic_value *)pic_realloc(pic, vec->data, sizeof(pic_value) * size);
for (i = len; i < size; ++i) {
vec->data[i] = pic_none_value();
}
}
static pic_value
pic_vec_vector_p(pic_state *pic)
{
pic_value v;
pic_get_args(pic, "o", &v);
return pic_bool_value(pic_vec_p(v));
}
static pic_value
pic_vec_make_vector(pic_state *pic)
{
pic_value v;
int n, k;
size_t i;
struct pic_vector *vec;
n = pic_get_args(pic, "i|o", &k, &v);
vec = pic_vec_new(pic, k);
if (n == 2) {
for (i = 0; i < (size_t)k; ++i) {
vec->data[i] = v;
}
}
return pic_obj_value(vec);
}
static pic_value
pic_vec_vector_length(pic_state *pic)
{
struct pic_vector *v;
pic_get_args(pic, "v", &v);
return pic_int_value(v->len);
}
static pic_value
pic_vec_vector_ref(pic_state *pic)
{
struct pic_vector *v;
int k;
pic_get_args(pic, "vi", &v, &k);
if (k < 0 || v->len <= (size_t)k) {
pic_error(pic, "vector-ref: index out of range");
}
return v->data[k];
}
static pic_value
pic_vec_vector_set(pic_state *pic)
{
struct pic_vector *v;
int k;
pic_value o;
pic_get_args(pic, "vio", &v, &k, &o);
if (k < 0 || v->len <= (size_t)k) {
pic_error(pic, "vector-set!: index out of range");
}
v->data[k] = o;
return pic_none_value();
}
static pic_value
pic_vec_vector_copy_i(pic_state *pic)
{
pic_vec *to, *from;
int n, at, start, end;
n = pic_get_args(pic, "viv|ii", &to, &at, &from, &start, &end);
switch (n) {
case 3:
start = 0;
case 4:
end = from->len;
}
if (to == from && (start <= at && at < end)) {
/* copy in reversed order */
at += end - start;
while (start < end) {
to->data[--at] = from->data[--end];
}
return pic_none_value();
}
while (start < end) {
to->data[at++] = from->data[start++];
}
return pic_none_value();
}
static pic_value
pic_vec_vector_copy(pic_state *pic)
{
pic_vec *vec, *to;
int n, start, end, i = 0;
n = pic_get_args(pic, "v|ii", &vec, &start, &end);
switch (n) {
case 1:
start = 0;
case 2:
end = vec->len;
}
to = pic_vec_new(pic, end - start);
while (start < end) {
to->data[i++] = vec->data[start++];
}
return pic_obj_value(to);
}
static pic_value
pic_vec_vector_append(pic_state *pic)
{
size_t argc, i, j, len;
pic_value *argv;
pic_vec *vec;
pic_get_args(pic, "*", &argc, &argv);
len = 0;
for (i = 0; i < argc; ++i) {
pic_assert_type(pic, argv[i], vec);
len += pic_vec_ptr(argv[i])->len;
}
vec = pic_vec_new(pic, len);
len = 0;
for (i = 0; i < argc; ++i) {
for (j = 0; j < pic_vec_ptr(argv[i])->len; ++j) {
vec->data[len + j] = pic_vec_ptr(argv[i])->data[j];
}
len += pic_vec_ptr(argv[i])->len;
}
return pic_obj_value(vec);
}
static pic_value
pic_vec_vector_fill_i(pic_state *pic)
{
pic_vec *vec;
pic_value obj;
int n, start, end;
n = pic_get_args(pic, "vo|ii", &vec, &obj, &start, &end);
switch (n) {
case 2:
start = 0;
case 3:
end = vec->len;
}
while (start < end) {
vec->data[start++] = obj;
}
return pic_none_value();
}
static pic_value
pic_vec_list_to_vector(pic_state *pic)
{
struct pic_vector *vec;
pic_value list, e, *data;
pic_get_args(pic, "o", &list);
vec = pic_vec_new(pic, pic_length(pic, list));
data = vec->data;
pic_for_each (e, list) {
*data++ = e;
}
return pic_obj_value(vec);
}
static pic_value
pic_vec_vector_to_list(pic_state *pic)
{
struct pic_vector *vec;
pic_value list;
int n, start, end, i;
n = pic_get_args(pic, "v|ii", &vec, &start, &end);
switch (n) {
case 1:
start = 0;
case 2:
end = vec->len;
}
list = pic_nil_value();
for (i = start; i < end; ++i) {
pic_push(pic, vec->data[i], list);
}
return pic_reverse(pic, list);
}
void
pic_init_vector(pic_state *pic)
{
pic_defun(pic, "vector?", pic_vec_vector_p);
pic_defun(pic, "make-vector", pic_vec_make_vector);
pic_defun(pic, "vector-length", pic_vec_vector_length);
pic_defun(pic, "vector-ref", pic_vec_vector_ref);
pic_defun(pic, "vector-set!", pic_vec_vector_set);
pic_defun(pic, "vector-copy!", pic_vec_vector_copy_i);
pic_defun(pic, "vector-copy", pic_vec_vector_copy);
pic_defun(pic, "vector-append", pic_vec_vector_append);
pic_defun(pic, "vector-fill!", pic_vec_vector_fill_i);
pic_defun(pic, "list->vector", pic_vec_list_to_vector);
pic_defun(pic, "vector->list", pic_vec_vector_to_list);
}

1069
src/vm.c
View File

File diff suppressed because it is too large Load Diff

506
src/write.c
View File

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

1
t/r7rs-tests.scm
View File

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

9
tools/CMakeLists.txt
View File

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

28
tools/main.c
View File

@ -1,28 +0,0 @@
/**
* See Copyright Notice in picrin.h
*/
#include "picrin.h"
#include "picrin/error.h"
int
main(int argc, char *argv[], char **envp)
{
pic_state *pic;
int status = 0;
pic = pic_open(argc, argv, envp);
pic_try {
pic_import(pic, pic_read_cstr(pic, "(picrin main)"));
pic_funcall(pic, "main", pic_nil_value());
}
pic_catch {
pic_print_backtrace(pic, pic->err);
status = 1;
}
pic_close(pic);
return status;
}