Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-19 05:39:18 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

Merge pull request #480 from Hamayama/synrule

Browse source 
Fix syntax-rules on ellipsis escape templates
This commit is contained in:
Alex Shinn 2018-07-08 22:25:04 +08:00 • committed by GitHub
commit b52df76e8a
No known key found for this signature in database
GPG key ID: 4AEE18F83AFDEB23
2 changed files with 23 additions and 12 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

21
lib/init-7.scm
View file

@ -862,7 +862,7 @@
((vector? x) (lp (vector->list x) free))
(else free))))
(define (expand-template tmpl vars)
(let lp ((t tmpl) (dim 0))
(let lp ((t tmpl) (dim 0) (ell-esc #f))
(cond
((identifier? t)
(cond
@ -875,12 +875,9 @@
(list _rename (list _quote t)))))
((pair? t)
(cond
((ellipsis-escape? t)
(list _quote
(if (pair? (cdr t))
(if (pair? (cddr t)) (cddr t) (cadr t))
(cdr t))))
((ellipsis? t)
((and (ellipsis-escape? t) (not ell-esc))
(lp (if (and (pair? (cdr t)) (null? (cddr t))) (cadr t) (cdr t)) dim #t))
((and (ellipsis? t) (not ell-esc))
(let* ((depth (ellipsis-depth t))
(ell-dim (+ dim depth))
(ell-vars (free-vars (car t) vars ell-dim)))
@ -889,9 +886,9 @@
(error "too many ...'s"))
((and (null? (cdr (cdr t))) (identifier? (car t)))
;; shortcut for (var ...)
(lp (car t) ell-dim))
(lp (car t) ell-dim ell-esc))
(else
(let* ((once (lp (car t) ell-dim))
(let* ((once (lp (car t) ell-dim ell-esc))
(nest (if (and (null? (cdr ell-vars))
(identifier? once)
(eq? once (car vars)))
@ -905,9 +902,9 @@
((= d 1) many))))
(if (null? (ellipsis-tail t))
many ;; shortcut
(list _append many (lp (ellipsis-tail t) dim))))))))
(else (list _cons3 (lp (car t) dim) (lp (cdr t) dim) (list _quote t)))))
((vector? t) (list _list->vector (lp (vector->list t) dim)))
(list _append many (lp (ellipsis-tail t) dim ell-esc))))))))
(else (list _cons3 (lp (car t) dim ell-esc) (lp (cdr t) dim ell-esc) (list _quote t)))))
((vector? t) (list _list->vector (lp (vector->list t) dim ell-esc)))
((null? t) (list _quote '()))
(else t))))
(list

14
tests/r7rs-tests.scm
View file

@ -447,6 +447,20 @@
(be-like-begin3 sequence3)
(test 5 (sequence3 2 3 4 5))
;; ellipsis escape
(define-syntax elli-esc-1
(syntax-rules ()
((_)
'(... ...))
((_ x)
'(... (x ...)))
((_ x y)
'(... (... x y)))))
(test '... (elli-esc-1))
(test '(100 ...) (elli-esc-1 100))
(test '(... 100 200) (elli-esc-1 100 200))
;; Syntax pattern with ellipsis in middle of proper list.
(define-syntax part-2
(syntax-rules ()