diff --git a/README.md b/README.md index b84b1d15..3d2f4c8f 100644 --- a/README.md +++ b/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 diff --git a/piclib/built-in.scm b/piclib/built-in.scm index 27351492..568cff08 100644 --- a/piclib/built-in.scm +++ b/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 obj) - (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)) - (make-syntactic-closure mac-env '() (unwrap (f (wrap expr) inject compare)))))) + (define (inject identifier) + (make-syntactic-closure use-env '() identifier)) + (define (compare x y) + (identifier=? mac-env x mac-env y)) + (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)))))))))) diff --git a/src/macro.c b/src/macro.c index 77e0f3b9..01d6348b 100644 --- a/src/macro.c +++ b/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; diff --git a/src/system.c b/src/system.c index 8d7f2e00..0e0fbbb1 100644 --- a/src/system.c +++ b/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); } diff --git a/t/ir-macro.scm b/t/ir-macro.scm new file mode 100644 index 00000000..28d4985c --- /dev/null +++ b/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 diff --git a/tools/main.c b/tools/main.c index 056186f6..103a3a82 100644 --- a/tools/main.c +++ b/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) {