Merge branch 'master' into libraries

Conflicts:
	src/macro.c
	src/pair.c

README.md

@@ -76,7 +76,7 @@
 | 6.11 Exceptions | yes | TODO: native error handling |
 | 6.12 Environments and evaluation | N/A | |
 | 6.13 Ports | incomplete | |
-| 6.14 System interface | incomplete | `exit` is unsafe when used with dynamic-wind |
+| 6.14 System interface | yes | |
 
 ## Homepage
 

piclib/built-in.scm

@@ -583,9 +583,6 @@
       (identifier=? use-env x use-env y))
     (make-syntactic-closure use-env '() (f expr rename compare))))
 
-(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)))
@@ -595,18 +592,33 @@
 
 (define (ir-macro-transformer f)
   (lambda (expr use-env mac-env)
-    (let ((wrapped '()))
+    (define (inject identifier)
-      (define (inject obj)
+      (make-syntactic-closure use-env '() identifier))
-        (let ((s (make-syntactic-closure use-env '() obj)))
-          (set! wrapped (acons s obj wrapped))
-          s))
-      (define (extract obj)
-        (let ((t (assq obj wrapped)))
-          (if t (cdr t) obj)))
-      (define (wrap expr)
-        (walk inject expr))
-      (define (unwrap expr)
-        (walk extract expr))
     (define (compare x y)
-        (identifier=? use-env x use-env y))
+      (identifier=? mac-env x mac-env y))
-      (make-syntactic-closure mac-env '() (unwrap (f (wrap expr) inject compare))))))
+    (let ((expr (walk (lambda (x) (if (symbol? x) (inject x) x)) expr)))
+      (make-syntactic-closure mac-env '() (f expr inject compare)))))
+
+(define-syntax or
+  (ir-macro-transformer
+   (lambda (expr inject compare)
+     (let ((exprs (cdr expr)))
+       (if (null? exprs)
+           #f
+           `(let ((it ,(car exprs)))
+              (if it
+                  it
+                  (or ,@(cdr exprs)))))))))
+
+(define-syntax case
+  (ir-macro-transformer
+   (lambda (expr inject compare)
+     (let ((key (cadr expr))
+           (clauses (cddr expr)))
+       `(let ((key ,key))
+          ,(let loop ((clauses clauses))
+               (if (null? clauses)
+                   #f
+                   `(if (or ,@(map (lambda (x) `(eqv? key ,x)) (caar clauses)))
+                        ,@(cdar clauses)
+                        ,(loop (cdr clauses))))))))))

src/macro.c

@@ -176,6 +176,20 @@ pic_identifier_p(pic_value obj)
   return false;
 }
 
+static pic_value
+strip(pic_state *pic, pic_value expr)
+{
+  if (pic_sc_p(expr)) {
+    return strip(pic, pic_sc(expr)->expr);
+  }
+  else if (pic_pair_p(expr)) {
+    return pic_cons(pic,
+                    strip(pic, pic_car(pic, expr)),
+                    strip(pic, pic_cdr(pic, expr)));
+  }
+  return expr;
+}
+
 void
 pic_export(pic_state *pic, pic_sym sym)
 {
@@ -430,6 +444,9 @@ macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv)
 
 	  /* defined symbol */
 	  a = pic_car(pic, var);
+          if (! pic_symbol_p(a)) {
+            a = macroexpand(pic, a, senv);
+          }
 	  if (! pic_symbol_p(a)) {
 	    pic_error(pic, "binding to non-symbol object");
 	  }
@@ -447,6 +464,9 @@ macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv)
 	  return v;
 	}
 
+        if (! pic_symbol_p(var)) {
+          var = macroexpand(pic, var, senv);
+        }
 	if (! pic_symbol_p(var)) {
 	  pic_error(pic, "binding to non-symbol object");
 	}
@@ -462,7 +482,7 @@ macroexpand(pic_state *pic, pic_value expr, struct pic_senv *senv)
 	pic_gc_protect(pic, v);
 	return v;
       case PIC_STX_QUOTE:
-	v = pic_cons(pic, pic_symbol_value(pic_syntax(car)->sym), pic_cdr(pic, expr));
+	v = pic_cons(pic, pic_symbol_value(pic_syntax(car)->sym), strip(pic, pic_cdr(pic, expr)));
 	pic_gc_arena_restore(pic, ai);
 	pic_gc_protect(pic, v);
 	return v;

src/system.c

@@ -26,6 +26,7 @@ pic_system_exit(pic_state *pic)
 {
   pic_value v;
   int argc, status = EXIT_SUCCESS;
+  struct pic_block *blk;
 
   argc = pic_get_args(pic, "|o", &v);
   if (argc == 1) {
@@ -41,6 +42,12 @@ pic_system_exit(pic_state *pic)
     }
   }
 
+  blk = pic->blk;
+  while (blk) {
+    pic_apply_argv(pic, blk->out, 0);
+    blk = blk->prev;
+  }
+
   exit(status);
 }
 

t/ir-macro.scm

@@ -0,0 +1,61 @@
+(define-syntax aif
+  (ir-macro-transformer
+   (lambda (form inject cmp)
+     (let ((it (inject 'it))
+           (expr (car (cdr form)))
+           (then (car (cdr (cdr form))))
+           (else (car (cdr (cdr (cdr form))))))
+       `(let ((,it ,expr))
+          (if ,it ,then ,else))))))
+
+(aif (member 'b '(a b c)) (car it) #f)
+
+;;; test hygiene begin
+
+(define-syntax mif
+  (ir-macro-transformer
+   (lambda (form inject cmp)
+     (let ((expr (car (cdr form)))
+           (then (car (cdr (cdr form))))
+           (else (car (cdr (cdr (cdr form))))))
+       `(let ((it ,expr))
+          (if it ,then ,else))))))
+
+(let ((if 42))
+  (mif 1 2 3))
+; => 2
+
+(let ((it 42))
+  (mif 1 it 2))
+; => 42
+
+;;; end
+
+
+
+;;; test core syntax begin
+
+(mif 'a 'b 'c)
+; => b
+
+(define-syntax loop
+  (ir-macro-transformer
+   (lambda (expr inject cmp)
+     (let ((body (cdr expr)))
+       `(call-with-current-continuation
+         (lambda (,(inject 'exit))
+           (let f ()
+             ,@body (f))))))))
+
+(define a 1)
+(loop
+ (if (= a 2) (exit #f))
+ (set! a 2))
+; => #f
+
+(loop
+ (define a 1)
+ (if (= a 1) (exit #f)))
+; => #f
+
+;;; end

tools/main.c

@@ -50,6 +50,10 @@ repl(pic_state *pic)
   while (1) {
     prompt = code[0] == '\0' ? "> " : "* ";
 
+#if DEBUG
+    printf("[current ai = %d]\n", ai);
+#endif
+
 #if PIC_ENABLE_READLINE
     read_line = readline(prompt);
     if (read_line == NULL) {