From b86d010b76ca276ae2e595c1d962084a744c3af3 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 16 Jul 2014 14:30:45 +0900 Subject: [PATCH 1/4] add letrec-syntax --- docs/lang.rst | 2 +- piclib/built-in.scm | 13 +++++++++++++ 2 files changed, 14 insertions(+), 1 deletion(-) diff --git a/docs/lang.rst b/docs/lang.rst index 6a68fed7..9c4152ff 100644 --- a/docs/lang.rst +++ b/docs/lang.rst @@ -58,7 +58,7 @@ section status comments 5.3.1 Top level definitions yes 5.3.2 Internal definitions yes TODO: interreferential definitions 5.3.3 Multiple-value definitions yes -5.4 Syntax definitions yes TODO: internal macro definition is not supported. +5.4 Syntax definitions yes 5.5 Recored-type definitions yes 5.6.1 Library Syntax incomplete In picrin, libraries can be reopend and can be nested. 5.6.2 Library example N/A diff --git a/piclib/built-in.scm b/piclib/built-in.scm index 8221653e..c3c09059 100644 --- a/piclib/built-in.scm +++ b/piclib/built-in.scm @@ -292,6 +292,17 @@ `(,(r 'begin) ,@(cdar clauses))) ,(loop (cdr clauses)))))))))) + (define-syntax letrec-syntax + (er-macro-transformer + (lambda (form r c) + (let ((formal (car (cdr form))) + (body (cdr (cdr form)))) + `(let () + ,@(map (lambda (x) + `(,(r 'define-syntax) ,(car x) ,(cadr x))) + formal) + ,@body))))) + (define-syntax syntax-error (er-macro-transformer (lambda (expr rename compare) @@ -317,6 +328,7 @@ and or cond case else => do when unless + letrec-syntax _ ... syntax-error)) @@ -629,6 +641,7 @@ and or cond case else => do when unless + letrec-syntax _ ... syntax-error) (export let-values From 8e114fae6b24b78c95c0d75e38695050f7d27b3c Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 16 Jul 2014 14:32:04 +0900 Subject: [PATCH 2/4] unlock letrec-syntax test --- t/r7rs-tests.scm | 36 ++++++++++++++++++------------------ 1 file changed, 18 insertions(+), 18 deletions(-) diff --git a/t/r7rs-tests.scm b/t/r7rs-tests.scm index 0e818ca1..eeac935e 100644 --- a/t/r7rs-tests.scm +++ b/t/r7rs-tests.scm @@ -464,24 +464,24 @@ (let ((x 'inner)) (m))))) -;; (test 7 (letrec-syntax -;; ((my-or (syntax-rules () -;; ((my-or) #f) -;; ((my-or e) e) -;; ((my-or e1 e2 ...) -;; (let ((temp e1)) -;; (if temp -;; temp -;; (my-or e2 ...))))))) -;; (let ((x #f) -;; (y 7) -;; (temp 8) -;; (let odd?) -;; (if even?)) -;; (my-or x -;; (let temp) -;; (if y) -;; y)))) +(test 7 (letrec-syntax + ((my-or (syntax-rules () + ((my-or) #f) + ((my-or e) e) + ((my-or e1 e2 ...) + (let ((temp e1)) + (if temp + temp + (my-or e2 ...))))))) + (let ((x #f) + (y 7) + (temp 8) + (let odd?) + (if even?)) + (my-or x + (let temp) + (if y) + y)))) (define-syntax be-like-begin (syntax-rules () From 6ee4d49a96853e352c449dadf36bf332fc730fd6 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 16 Jul 2014 14:46:30 +0900 Subject: [PATCH 3/4] Macro-generating macro may rename symbol that will be used as a newly introduced identifier --- src/macro.c | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/src/macro.c b/src/macro.c index 5ac2e4dc..1ad56a78 100644 --- a/src/macro.c +++ b/src/macro.c @@ -34,7 +34,12 @@ pic_find_rename(pic_state *pic, struct pic_senv *senv, pic_sym sym, pic_sym *ren { xh_entry *e; - UNUSED(pic); + if (! pic_interned_p(pic, sym)) { + if (rename != NULL) { + *rename = sym; + } + return true; + } if ((e = xh_get_int(&senv->renames, sym)) == NULL) { return false; @@ -73,9 +78,6 @@ translate(pic_state *pic, pic_sym sym, struct pic_senv *senv, struct pic_dict *c { pic_sym rename; - if (! pic_interned_p(pic, sym)) { - return sym; - } while (true) { if (pic_find_rename(pic, senv, sym, &rename)) { return rename; From bdcb83296eff967a930738735b8841de1b7cdea9 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 16 Jul 2014 14:47:25 +0900 Subject: [PATCH 4/4] update case-lambda impl --- piclib/built-in.scm | 57 +++++++++++++++++---------------------------- 1 file changed, 21 insertions(+), 36 deletions(-) diff --git a/piclib/built-in.scm b/piclib/built-in.scm index c3c09059..0b94d488 100644 --- a/piclib/built-in.scm +++ b/piclib/built-in.scm @@ -1425,42 +1425,27 @@ (define-syntax case-lambda (syntax-rules () - ((case-lambda - (?a1 ?e1 ...) - ?clause1 ...) + ((case-lambda (params body0 ...) ...) (lambda args - (let ((l (length args))) - (case-lambda "CLAUSE" args l - (?a1 ?e1 ...) - ?clause1 ...)))) - ((case-lambda "CLAUSE" ?args ?l - ((?a1 ...) ?e1 ...) - ?clause1 ...) - (if (= ?l (length '(?a1 ...))) - (apply (lambda (?a1 ...) ?e1 ...) ?args) - (case-lambda "CLAUSE" ?args ?l - ?clause1 ...))) - ((case-lambda "CLAUSE" ?args ?l - ((?a1 . ?ar) ?e1 ...) - ?clause1 ...) - (case-lambda "IMPROPER" ?args ?l 1 (?a1 . ?ar) (?ar ?e1 ...) - ?clause1 ...)) - ((case-lambda "CLAUSE" ?args ?l - (?a1 ?e1 ...) - ?clause1 ...) - (let ((?a1 ?args)) - ?e1 ...)) - ((case-lambda "CLAUSE" ?args ?l) - (error "Wrong number of arguments to CASE-LAMBDA.")) - ((case-lambda "IMPROPER" ?args ?l ?k ?al ((?a1 . ?ar) ?e1 ...) - ?clause1 ...) - (case-lambda "IMPROPER" ?args ?l (+ ?k 1) ?al (?ar ?e1 ...) - ?clause1 ...)) - ((case-lambda "IMPROPER" ?args ?l ?k ?al (?ar ?e1 ...) - ?clause1 ...) - (if (>= ?l ?k) - (apply (lambda ?al ?e1 ...) ?args) - (case-lambda "CLAUSE" ?args ?l - ?clause1 ...))))) + (let ((len (length args))) + (letrec-syntax + ((cl (syntax-rules ::: () + ((cl) + (error "no matching clause")) + ((cl ((p :::) . body) . rest) + (if (= len (length '(p :::))) + (apply (lambda (p :::) + . body) + args) + (cl . rest))) + ((cl ((p ::: . tail) . body) + . rest) + (if (>= len (length '(p :::))) + (apply + (lambda (p ::: . tail) + . body) + args) + (cl . rest)))))) + (cl (params body0 ...) ...))))))) (export case-lambda))