Merge remote-tracking branch 'origin/master'

.gitmodules

@@ -0,0 +1,3 @@
+[submodule "extlib/xhash"]
+	path = extlib/xhash
+	url = git://github.com/wasabiz/xhash.git

.travis.yml

@@ -0,0 +1,5 @@
+language: c
+compiler:
+  - gcc
+  - clang
+script: make && make no-act

Makefile

@@ -36,3 +36,6 @@ run:
 
 tak: release
 	bin/picrin etc/tak.scm
+
+no-act:
+	bin/picrin -e ''

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
 

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.

extlib/xhash

@@ -0,0 +1 @@
+Subproject commit 350f8895bf888aceea87c38e38e19adfd604f9d2

extlib/xhash/xhash.h

@@ -1,100 +0,0 @@
-#ifndef XHASH_H__
-#define XHASH_H__
-
-/*
- * Copyright (c) 2013 by Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
- */
-
-#include <stdlib.h>
-#include <string.h>
-
-/* 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

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 pic_senv *global_senv;
-  struct xhash *var_tbl;
-  struct pic_syntax **stx;
-  size_t xlen, xcapa;
 
   struct pic_irep **irep;
   size_t ilen, icapa;

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

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 '()))

src/gc.c

@@ -458,8 +458,8 @@ gc_mark_phase(pic_state *pic)
   }
 
   /* macros */
-  for (i = 0; i < pic->xlen; ++i) {
+  if (pic->global_senv) {
-    gc_mark_object(pic, (struct pic_object *)pic->stx[i]);
+    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);
-      xh_destory(senv->tbl);
+    if (senv->stx)
-      if (senv->stx)
+      pic_free(pic, senv->stx);
-	pic_free(pic, senv->stx);
-    }
     break;
   }
   case PIC_TT_SYNTAX: {

src/macro.c

@@ -29,20 +29,42 @@ new_uniq_sym(pic_state *pic, pic_sym base)
   return uniq;
 }
 
-static struct pic_senv *
+struct pic_senv *
-new_global_senv(pic_state *pic)
+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->tbl = xh_new();
-  senv->stx = pic->stx;
+  senv->stx = (struct pic_syntax **)pic_calloc(pic, PIC_MACROS_SIZE, sizeof(struct pic_syntax *));
-  senv->xlen = pic->xlen;
+  senv->xlen = 0;
-  senv->xcapa = pic->xcapa;
+  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;
+  idx = pic->global_senv->xlen;
-  if (idx >= pic->xcapa) {
+  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);
+  pic->global_senv->stx[idx] = pic_syntax_new_macro(pic, pic_intern_cstr(pic, name), macro, mac_env);
-  xh_put(pic->var_tbl, name, ~idx);
+  xh_put(pic->global_senv->tbl, name, ~idx);
-  pic->xlen++;
+  pic->global_senv->xlen++;
 }
 
 void

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 */
+  /* syntactic env */
-  pic->var_tbl = xh_new();
+  pic->global_senv = NULL;      /* prevent gc from hanging during marking phase */
-  pic->stx = (struct pic_syntax **)calloc(PIC_MACROS_SIZE, sizeof(struct pic_syntax *));
+  pic->global_senv = pic_core_syntactic_env(pic);
-  pic->xlen = 0;
-  pic->xcapa = PIC_MACROS_SIZE;
 
   /* 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;

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);
-  }
+    break;
-  else {
+  case FILE_EXEC_MODE:
     res = exec_file(pic, fname);
+    break;
+  case ONE_LINER_MODE:
+    res = exec_string(pic, one_liner);
+    break;
   }
 
   pic_close(pic);