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..0b94d488 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 @@ -1412,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)) 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; 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 ()