From 05ee7c6725894ea8970e6de9bdee149c321a8a25 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 26 Dec 2009 02:07:18 +0900 Subject: [PATCH] adding (... ...) escapes and SRFI-46 ellipse specifiers to syntax-rules --- TODO | 28 ++++++++++++++++----- lib/init.scm | 58 +++++++++++++++++++++++++------------------- tests/r5rs-tests.scm | 6 +++++ 3 files changed, 61 insertions(+), 31 deletions(-) diff --git a/TODO b/TODO index 0468bee3..8cb51490 100644 --- a/TODO +++ b/TODO @@ -39,9 +39,10 @@ - State "DONE" [2009-12-08 Tue 14:41] ** DONE macroexpand utility - State "DONE" [2009-12-08 Tue 14:41] -** TODO compiler macros ** TODO SRFI-46 basic syntax-rules extensions -** TODO (... ...) support +** DONE (... ...) support + - State "DONE" [2009-12-26 Sat 02:06] +** TODO compiler macros ** TODO syntax-rules common pattern reduction ** TODO syntax-rules loop optimization @@ -61,6 +62,9 @@ - State "DONE" [2009-07-07 Tue 14:42] ** TODO unicode ** TODO threads +** DONE dynamic-wind + - State "DONE" [2009-12-26 Sat 01:51] + Adapted a version from Scheme48. ** DONE recursive disasm - State "DONE" [2009-12-18 Fri 14:15] @@ -69,13 +73,16 @@ - State "DONE" [2009-12-08 Tue 14:45] ** DONE opcode generation interface - State "DONE" [2009-11-15 Sun 14:45] -** TODO stub generator +** DONE stub generator + - State "DONE" [2009-12-26 Sat 01:50] *** DONE define-c-struct - State "DONE" [2009-11-29 Sun 14:48] *** DONE define-c - State "DONE" [2009-11-29 Sun 14:48] -*** TODO array return types -*** TODO pre-buffered string types (like getcwd) +*** DONE array return types + - State "DONE" [2009-12-26 Sat 01:49] +*** DONE pre-buffered string types (like getcwd) + - State "DONE" [2009-12-26 Sat 01:49] * module system ** DONE scheme48-like config language @@ -85,7 +92,8 @@ ** DONE only/except/rename/prefix modifiers - State "DONE" [2009-12-16 Wed 18:57] ** TODO scheme-complete.el support -** TODO access individual modules from repl +** DONE access individual modules from repl + - State "DONE" [2009-12-26 Sat 01:49] * core modules ** DONE SRFI-0 cond-expand @@ -100,6 +108,14 @@ - State "DONE" [2009-12-08 Tue 14:54] ** TODO network interface ** TODO posix interface + Splitting this into several parts. +*** DONE filesystem interface + - State "DONE" [2009-12-26 Sat 01:50] +*** DONE process interface + - State "DONE" [2009-12-26 Sat 01:50] +*** DONE time interface + - State "DONE" [2009-12-26 Sat 01:50] +*** TODO host system interface ** DONE pathname library - State "DONE" [2009-12-16 Wed 18:58] ** DONE uri library diff --git a/lib/init.scm b/lib/init.scm index 75217d71..3c4f9491 100644 --- a/lib/init.scm +++ b/lib/init.scm @@ -615,8 +615,7 @@ (define-syntax syntax-rules (er-macro-transformer (lambda (expr rename compare) - (let ((lits (cadr expr)) - (forms (cddr expr)) + (let ((ellipse-specified? (identifier? (cadr expr))) (count 0) (_er-macro-transformer (rename 'er-macro-transformer)) (_lambda (rename 'lambda)) (_let (rename 'let)) @@ -634,6 +633,9 @@ (_error (rename 'error)) (_vector->list (rename 'vector->list)) (_list->vector (rename 'list->vector))) + (define ellipse (rename (if ellipse-specified? (cadr expr) '...))) + (define lits (if ellipse-specified? (caddr expr) (cadr expr))) + (define forms (if ellipse-specified? (cdddr expr) (cddr expr))) (define (next-v) (set! count (+ count 1)) (rename (string->symbol (string-append "v." (number->string count))))) @@ -708,8 +710,9 @@ (lp (vector->list p) (list _vector->list v) dim vars k))) ((null? p) (list _and (list _null? v) (k vars))) (else (list _and (list _equal? v p) (k vars)))))))) + (define (ellipse-escape? x) (and (pair? x) (compare ellipse (car x)))) (define (ellipse? x) - (and (pair? x) (pair? (cdr x)) (compare (rename '...) (cadr x)))) + (and (pair? x) (pair? (cdr x)) (compare ellipse (cadr x)))) (define (ellipse-depth x) (if (ellipse? x) (+ 1 (ellipse-depth (cdr x))) @@ -753,28 +756,33 @@ (else (list _rename (list _quote t))))) ((pair? t) - (if (ellipse? t) - (let* ((depth (ellipse-depth t)) - (ell-dim (+ dim depth)) - (ell-vars (free-vars (car t) vars ell-dim))) - (if (null? ell-vars) - (error "too many ...'s") - (let* ((once (lp (car t) ell-dim)) - (nest (if (and (null? (cdr ell-vars)) - (identifier? once) - (eq? once (car vars))) - once ;; shortcut - (cons _map - (cons (list _lambda ell-vars once) - ell-vars)))) - (many (do ((d depth (- d 1)) - (many nest - (list _apply _append many))) - ((= d 1) many)))) - (if (null? (ellipse-tail t)) - many ;; shortcut - (list _append many (lp (ellipse-tail t) dim)))))) - (list _cons (lp (car t) dim) (lp (cdr t) dim)))) + (cond + ((ellipse-escape? t) + (if (pair? (cdr t)) + (if (pair? (cddr t)) (cddr t) (cadr t)) + (cdr t))) + ((ellipse? t) + (let* ((depth (ellipse-depth t)) + (ell-dim (+ dim depth)) + (ell-vars (free-vars (car t) vars ell-dim))) + (if (null? ell-vars) + (error "too many ...'s") + (let* ((once (lp (car t) ell-dim)) + (nest (if (and (null? (cdr ell-vars)) + (identifier? once) + (eq? once (car vars))) + once ;; shortcut + (cons _map + (cons (list _lambda ell-vars once) + ell-vars)))) + (many (do ((d depth (- d 1)) + (many nest + (list _apply _append many))) + ((= d 1) many)))) + (if (null? (ellipse-tail t)) + many ;; shortcut + (list _append many (lp (ellipse-tail t) dim))))))) + (else (list _cons (lp (car t) dim) (lp (cdr t) dim))))) ((vector? t) (list _list->vector (lp (vector->list t) dim))) ((null? t) (list _quote '())) (else t)))) diff --git a/tests/r5rs-tests.scm b/tests/r5rs-tests.scm index cf6bc8ab..c657be99 100644 --- a/tests/r5rs-tests.scm +++ b/tests/r5rs-tests.scm @@ -459,6 +459,12 @@ (c 'talk2) (reverse path))))) +(test 2 (let-syntax + ((foo (syntax-rules ::: () + ((foo ... args :::) + (args ::: ...))))) + (foo 3 - 5))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (test-report)