diff --git a/.gitmodules b/.gitmodules new file mode 100644 index 00000000..4a2a1cb8 --- /dev/null +++ b/.gitmodules @@ -0,0 +1,3 @@ +[submodule "extlib/xhash"] + path = extlib/xhash + url = git://github.com/wasabiz/xhash.git diff --git a/.travis.yml b/.travis.yml new file mode 100644 index 00000000..5d492b9d --- /dev/null +++ b/.travis.yml @@ -0,0 +1,5 @@ +language: c +compiler: + - gcc + - clang +script: make && make no-act diff --git a/Makefile b/Makefile index 0711b106..80cc860a 100644 --- a/Makefile +++ b/Makefile @@ -36,3 +36,6 @@ run: tak: release bin/picrin etc/tak.scm + +no-act: + bin/picrin -e '' diff --git a/README.md b/README.md index b070a3cf..b84b1d15 100644 --- a/README.md +++ b/README.md @@ -2,7 +2,7 @@ This product is developed at the second-grade course, Informatic Science Basic Experiment class at the University of Tokyo. -# Picrin - a lightweight scheme interpreter +# Picrin - a lightweight scheme interpreter [![Build Status](https://travis-ci.org/wasabiz/picrin.png)](https://travis-ci.org/wasabiz/picrin) ## Features diff --git a/etc/LIBRARY_IMPL.md b/etc/LIBRARY_IMPL.md new file mode 100644 index 00000000..a7933b74 --- /dev/null +++ b/etc/LIBRARY_IMPL.md @@ -0,0 +1,15 @@ +# How to implement `define-library`? + +* define-library can be nested +* expressions inside define-library are compiled and evaluated in order sequentially +* import declarations inside define-library and on the top level are semantically the same +* each define-library creates one syntactic-env +* and the body is evaluated as if it's on the top level +* so each `toplevel definitions`' results are registered to the global table +* but their renamed symbols are known only to who imported the library. + +## export table + +* import syntax destructively registers renamed symbols taken from export table of the specified library to syntactic env of the library +* export syntax registers correspoindings of original and renamed symbols to export table of the current library +* therefore, we need some kind of `forward declaration` support, because export syntax is usually placed at the beginning of source code. diff --git a/extlib/xhash b/extlib/xhash new file mode 160000 index 00000000..350f8895 --- /dev/null +++ b/extlib/xhash @@ -0,0 +1 @@ +Subproject commit 350f8895bf888aceea87c38e38e19adfd604f9d2 diff --git a/extlib/xhash/xhash.h b/extlib/xhash/xhash.h deleted file mode 100644 index b20af2c3..00000000 --- a/extlib/xhash/xhash.h +++ /dev/null @@ -1,100 +0,0 @@ -#ifndef XHASH_H__ -#define XHASH_H__ - -/* - * Copyright (c) 2013 by Yuichi Nishiwaki - */ - -#include -#include - -/* simple string to int hash table */ - -#define XHASH_INIT_SIZE 11 - -struct xh_entry { - struct xh_entry *next; - const char *key; - int val; -}; - -struct xhash { - struct xh_entry **buckets; - size_t size; -}; - -static inline struct xhash * -xh_new() -{ - struct xhash *x; - - x = (struct xhash *)malloc(sizeof(struct xhash)); - x->size = XHASH_INIT_SIZE; - x->buckets = (struct xh_entry **)calloc(XHASH_INIT_SIZE, sizeof(struct xh_entry *)); - return x; -} - -static int -xh_hash(const char *str) -{ - int hash = 0; - - while (*str) { - hash = hash * 31 + *str++; - } - return hash; -} - -static inline struct xh_entry * -xh_get(struct xhash *x, const char *key) -{ - int idx; - struct xh_entry *e; - - idx = xh_hash(key) % x->size; - for (e = x->buckets[idx]; e; e = e->next) { - if (strcmp(key, e->key) == 0) - return e; - } - return NULL; -} - -static inline struct xh_entry * -xh_put(struct xhash *x, const char *key, int val) -{ - int idx; - struct xh_entry *e; - - if ((e = xh_get(x, key))) { - e->val = val; - return e; - } - - idx = xh_hash(key) % x->size; - e = (struct xh_entry *)malloc(sizeof(struct xh_entry)); - e->next = x->buckets[idx]; - e->key = strdup(key); - e->val = val; - - return x->buckets[idx] = e; -} - -static inline void -xh_destory(struct xhash *x) -{ - int i; - struct xh_entry *e, *d; - - for (i = 0; i < x->size; ++i) { - e = x->buckets[i]; - while (e) { - d = e->next; - free((void*)e->key); - free(e); - e = d; - } - } - free(x); -} - -#endif diff --git a/include/picrin.h b/include/picrin.h index ba688f02..ff241611 100644 --- a/include/picrin.h +++ b/include/picrin.h @@ -56,10 +56,7 @@ typedef struct { pic_value *globals; size_t glen, gcapa; - /* positive for variables, negative for macros (bitwise-not) */ - struct xhash *var_tbl; - struct pic_syntax **stx; - size_t xlen, xcapa; + struct pic_senv *global_senv; struct pic_irep **irep; size_t ilen, icapa; diff --git a/include/picrin/macro.h b/include/picrin/macro.h index 17be817d..c10f1e5a 100644 --- a/include/picrin/macro.h +++ b/include/picrin/macro.h @@ -4,6 +4,7 @@ struct pic_senv { PIC_OBJECT_HEADER struct pic_senv *up; + /* positive for variables, negative for macros (bitwise-not) */ struct xhash *tbl; struct pic_syntax **stx; size_t xlen, xcapa; @@ -42,6 +43,8 @@ struct pic_sc { #define pic_senv(v) ((struct pic_senv *)pic_ptr(v)) #define pic_senv_p(v) (pic_type(v) == PIC_TT_SENV) +struct pic_senv *pic_core_syntactic_env(pic_state *pic); + struct pic_syntax *pic_syntax_new(pic_state *, int kind, pic_sym sym); struct pic_syntax *pic_syntax_new_macro(pic_state *, pic_sym, struct pic_proc *, struct pic_senv *senv); diff --git a/piclib/built-in.scm b/piclib/built-in.scm index 35c0188c..89d65e84 100644 --- a/piclib/built-in.scm +++ b/piclib/built-in.scm @@ -577,13 +577,6 @@ ;;; hygienic macros -(define (walk f obj) - (if (pair? obj) - (cons (walk f (car obj)) (walk f (cdr obj))) - (if (vector? obj) - (list->vector (map (lambda (x) (walk f x)) (vector->list obj))) - (f obj)))) - (define (sc-macro-transformer f) (lambda (expr use-env mac-env) (make-syntactic-closure mac-env '() (f expr use-env)))) @@ -603,6 +596,13 @@ (define (acons key val alist) (cons (cons key val) alist)) +(define (walk f obj) + (if (pair? obj) + (cons (walk f (car obj)) (walk f (cdr obj))) + (if (vector? obj) + (list->vector (map (lambda (x) (walk f x)) (vector->list obj))) + (f obj)))) + (define (ir-macro-transformer f) (lambda (expr use-env mac-env) (let ((wrapped '())) diff --git a/src/gc.c b/src/gc.c index b931bf75..7c03e3fd 100644 --- a/src/gc.c +++ b/src/gc.c @@ -458,8 +458,8 @@ gc_mark_phase(pic_state *pic) } /* macros */ - for (i = 0; i < pic->xlen; ++i) { - gc_mark_object(pic, (struct pic_object *)pic->stx[i]); + if (pic->global_senv) { + gc_mark_object(pic, (struct pic_object *)pic->global_senv); } /* pool */ @@ -518,11 +518,9 @@ gc_finalize_object(pic_state *pic, struct pic_object *obj) } case PIC_TT_SENV: { struct pic_senv *senv = (struct pic_senv *)obj; - if (senv->up) { - xh_destory(senv->tbl); - if (senv->stx) - pic_free(pic, senv->stx); - } + xh_destory(senv->tbl); + if (senv->stx) + pic_free(pic, senv->stx); break; } case PIC_TT_SYNTAX: { diff --git a/src/macro.c b/src/macro.c index a0417e3c..8048f4fe 100644 --- a/src/macro.c +++ b/src/macro.c @@ -29,20 +29,42 @@ new_uniq_sym(pic_state *pic, pic_sym base) return uniq; } -static struct pic_senv * -new_global_senv(pic_state *pic) +struct pic_senv * +pic_core_syntactic_env(pic_state *pic) { struct pic_senv *senv; senv = (struct pic_senv *)pic_obj_alloc(pic, sizeof(struct pic_senv), PIC_TT_SENV); senv->up = NULL; - senv->tbl = pic->var_tbl; - senv->stx = pic->stx; - senv->xlen = pic->xlen; - senv->xcapa = pic->xcapa; + senv->tbl = xh_new(); + senv->stx = (struct pic_syntax **)pic_calloc(pic, PIC_MACROS_SIZE, sizeof(struct pic_syntax *)); + senv->xlen = 0; + senv->xcapa = PIC_MACROS_SIZE; + +#define register_core_syntax(pic,senv,kind,name) do { \ + senv->stx[senv->xlen] = pic_syntax_new(pic, kind, pic_intern_cstr(pic, name)); \ + xh_put(senv->tbl, name, ~senv->xlen); \ + senv->xlen++; \ + } while (0) + + register_core_syntax(pic, senv, PIC_STX_DEFINE, "define"); + register_core_syntax(pic, senv, PIC_STX_SET, "set!"); + register_core_syntax(pic, senv, PIC_STX_QUOTE, "quote"); + register_core_syntax(pic, senv, PIC_STX_LAMBDA, "lambda"); + register_core_syntax(pic, senv, PIC_STX_IF, "if"); + register_core_syntax(pic, senv, PIC_STX_BEGIN, "begin"); + register_core_syntax(pic, senv, PIC_STX_DEFMACRO, "define-macro"); + register_core_syntax(pic, senv, PIC_STX_DEFSYNTAX, "define-syntax"); + return senv; } +static struct pic_senv * +new_global_senv(pic_state *pic) +{ + return pic->global_senv; +} + static struct pic_senv * new_local_senv(pic_state *pic, pic_value formals, struct pic_senv *up) { @@ -136,13 +158,13 @@ pic_defsyntax(pic_state *pic, const char *name, struct pic_proc *macro, struct p { int idx; - idx = pic->xlen; - if (idx >= pic->xcapa) { + idx = pic->global_senv->xlen; + if (idx >= pic->global_senv->xcapa) { pic_abort(pic, "macro table overflow"); } - pic->stx[idx] = pic_syntax_new_macro(pic, pic_intern_cstr(pic, name), macro, mac_env); - xh_put(pic->var_tbl, name, ~idx); - pic->xlen++; + pic->global_senv->stx[idx] = pic_syntax_new_macro(pic, pic_intern_cstr(pic, name), macro, mac_env); + xh_put(pic->global_senv->tbl, name, ~idx); + pic->global_senv->xlen++; } void diff --git a/src/state.c b/src/state.c index 0127f10b..51cc80f6 100644 --- a/src/state.c +++ b/src/state.c @@ -65,11 +65,9 @@ pic_open(int argc, char *argv[], char **envp) pic->glen = 0; pic->gcapa = PIC_GLOBALS_SIZE; - /* identifier table */ - pic->var_tbl = xh_new(); - pic->stx = (struct pic_syntax **)calloc(PIC_MACROS_SIZE, sizeof(struct pic_syntax *)); - pic->xlen = 0; - pic->xcapa = PIC_MACROS_SIZE; + /* syntactic env */ + pic->global_senv = NULL; /* prevent gc from hanging during marking phase */ + pic->global_senv = pic_core_syntactic_env(pic); /* pool */ pic->pool = (pic_value *)calloc(PIC_POOL_SIZE, sizeof(pic_value)); @@ -117,22 +115,6 @@ pic_open(int argc, char *argv[], char **envp) register_core_symbol(pic, sGE, ">="); pic_gc_arena_restore(pic, ai); -#define register_core_syntax(pic,kind,name) do { \ - pic->stx[pic->xlen] = pic_syntax_new(pic, kind, pic_intern_cstr(pic, name)); \ - xh_put(pic->var_tbl, name, ~pic->xlen); \ - pic->xlen++; \ - } while (0) - - register_core_syntax(pic, PIC_STX_DEFINE, "define"); - register_core_syntax(pic, PIC_STX_SET, "set!"); - register_core_syntax(pic, PIC_STX_QUOTE, "quote"); - register_core_syntax(pic, PIC_STX_LAMBDA, "lambda"); - register_core_syntax(pic, PIC_STX_IF, "if"); - register_core_syntax(pic, PIC_STX_BEGIN, "begin"); - register_core_syntax(pic, PIC_STX_DEFMACRO, "define-macro"); - register_core_syntax(pic, PIC_STX_DEFSYNTAX, "define-syntax"); - pic_gc_arena_restore(pic, ai); - pic_init_core(pic); return pic; diff --git a/tools/main.c b/tools/main.c index ff6a5545..3c2015f2 100644 --- a/tools/main.c +++ b/tools/main.c @@ -14,8 +14,6 @@ #define CODE_MAX_LENGTH 1024 #define LINE_MAX_LENGTH 256 -static char *fname; - void print_help(void) { @@ -25,35 +23,12 @@ print_help(void) "Usage: picrin [options] [file]\n" "\n" "Options:\n" - " -h show this help"; + " -e [program] run one liner ecript\n" + " -h show this help"; puts(help); } -bool -parse_opt(int argc, char *argv[]) -{ - int r; - - while (~(r = getopt(argc, argv, "h"))) { - switch (r) { - case 'h': - print_help(); - exit(0); - } - } - argc -= optind; - argv += optind; - - if (argc == 0) { - return 1; - } - else { - fname = argv[0]; - return 0; - } -} - int repl(pic_state *pic) { @@ -200,6 +175,77 @@ exec_file(pic_state *pic, const char *fname) return 0; } +static int +exec_string(pic_state *pic, const char *str) +{ + int n, i; + pic_value vs, v; + struct pic_proc *proc; + int ai = pic_gc_arena_preserve(pic); + + n = pic_parse_cstr(pic, str, &vs); + if (n < 0) { + return 1; + } + + for (i = 0; i < n; ++i) { + v = pic_car(pic, vs); + + proc = pic_codegen(pic, v); + if (proc == NULL) { + return 1; + } + v = pic_apply(pic, proc, pic_nil_value()); + if (pic_undef_p(v)) { + return 1; + } + + vs = pic_cdr(pic, vs); + + pic_gc_arena_restore(pic, ai); + } + + return 0; +} + +static char *fname; +static char *one_liner; + +enum { + NO_MODE = 0, + INTERACTIVE_MODE, + FILE_EXEC_MODE, + ONE_LINER_MODE, +} mode; + +void +parse_opt(int argc, char *argv[]) +{ + int r; + + while (~(r = getopt(argc, argv, "he:"))) { + switch (r) { + case 'h': + print_help(); + exit(0); + case 'e': + one_liner = optarg; + mode = ONE_LINER_MODE; + } + } + argc -= optind; + argv += optind; + + if (argc == 0) { + if (mode == NO_MODE) + mode = INTERACTIVE_MODE; + } + else { + fname = argv[0]; + mode = FILE_EXEC_MODE; + } +} + int main(int argc, char *argv[], char **envp) { @@ -208,11 +254,21 @@ main(int argc, char *argv[], char **envp) pic = pic_open(argc, argv, envp); - if (parse_opt(argc, argv)) { + parse_opt(argc, argv); + + switch (mode) { + case NO_MODE: + puts("logic flaw"); + abort(); + case INTERACTIVE_MODE: res = repl(pic); - } - else { + break; + case FILE_EXEC_MODE: res = exec_file(pic, fname); + break; + case ONE_LINER_MODE: + res = exec_string(pic, one_liner); + break; } pic_close(pic);