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

14
tests/r7rs-tests.scm
View file

@ -447,6 +447,20 @@
(be-like-begin3 sequence3) (be-like-begin3 sequence3)
(test 5 (sequence3 2 3 4 5)) (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. ;; Syntax pattern with ellipsis in middle of proper list.
(define-syntax part-2 (define-syntax part-2
(syntax-rules () (syntax-rules ()