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

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