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

Fix syntax-rules on ellipsis escape templates

Browse source
This commit is contained in:
Hamayama 2018-07-03 12:41:00 +09:00
parent 0efa071672
commit fdc1f86f09
2 changed files with 31 additions and 19 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

32
lib/init-7.scm
View file

@ -820,13 +820,10 @@
((null? p) (list _and (list _null? v) (k vars)))
(else (list _and (list _equal? v p) (k vars))))))))
(define ellipsis-mark?
(if (if ellipsis-specified?
(memq ellipsis lits)
(any (lambda (x) (compare ellipsis x)) lits))
(let ((cmp (if ellipsis-specified? eq? compare)))
(if (any (lambda (x) (cmp ellipsis x)) lits)
(lambda (x) #f)
(if ellipsis-specified?
(lambda (x) (eq? ellipsis x))
(lambda (x) (compare ellipsis x)))))
(lambda (x) (cmp ellipsis x)))))
(define (ellipsis-escape? x) (and (pair? x) (ellipsis-mark? (car x))))
(define (ellipsis? x)
(and (pair? x) (pair? (cdr x)) (ellipsis-mark? (cadr x))))
@ -862,7 +859,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 +872,13 @@
(list _rename (list _quote t)))))
((pair? t)
(cond
((ellipsis-escape? t)
(list _quote
(if (pair? (cdr t))
((and (ellipsis-escape? t) (not ell-esc))
(lp (if (pair? (cdr t))
(if (pair? (cddr t)) (cddr t) (cadr t))
(cdr t))))
((ellipsis? 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 +887,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 +903,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 ()