conservatory
/
picrin
4
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

syntax-rules: support tail pattern

This commit is contained in:
Yuichi Nishiwaki 2015-06-16 19:08:34 +09:00
parent 02d75b4283
commit dbba29a5a8
1 changed files with 29 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

43
piclib/picrin/syntax-rules.scm
View File

@ -33,6 +33,18 @@
(filter f (cdr list))) (filter f (cdr list)))
(filter f (cdr list))))) (filter f (cdr list)))))
(define (take-tail n list)
(let drop ((n (- (length list) n)) (list list))
(if (= n 0)
list
(drop (- n 1) (cdr list)))))
(define (drop-tail n list)
(let take ((n (- (length list) n)) (list list))
(if (= n 0)
'()
(cons (car list) (take (- n 1) (cdr list))))))
(define (map-keys f assoc) (define (map-keys f assoc)
(map (lambda (s) `(,(f (car s)) . ,(cdr s))) assoc)) (map (lambda (s) `(,(f (car s)) . ,(cdr s))) assoc))
@ -40,20 +52,14 @@
(map (lambda (s) `(,(car s) . ,(f (cdr s)))) assoc)) (map (lambda (s) `(,(car s) . ,(f (cdr s)))) assoc))
;; TODO ;; TODO
;; - splicing
;; - placeholder ;; - placeholder
;; - vector ;; - vector
;; - (... template) pattern
;; p ::= constant ;; p ::= constant
;; | var ;; | var
;; | (p ... . p) (in input pattern, tail p should be a proper list)
;; | (p . p) ;; | (p . p)
;; | (p ...)
;; only template supports (p ... . p) pattern
;; tp := constant
;; | var
;; | (p . p)
;; | (p ... . p)
(define (compile ellipsis literals rules) (define (compile ellipsis literals rules)
@ -83,9 +89,12 @@
((variable? pat) ((variable? pat)
#t) #t)
((many? pat) ((many? pat)
(let ((validator (pattern-validator (car pat) 'it))) (let ((head #`(drop-tail #,(length (cddr pat)) #,form))
(tail #`(take-tail #,(length (cddr pat)) #,form)))
#`(and (list? #,form) #`(and (list? #,form)
(every? (map (lambda (#,'it) #,validator) #,form))))) (>= (length #,form) #,(length (cddr pat)))
(every? (map (lambda (#,'it) #,(pattern-validator (car pat) 'it)) #,head))
#,(pattern-validator (cddr pat) tail))))
((pair? pat) ((pair? pat)
#`(and (pair? #,form) #`(and (pair? #,form)
#,(pattern-validator (car pat) #`(car #,form)) #,(pattern-validator (car pat) #`(car #,form))
@ -103,7 +112,8 @@
((variable? pat) ((variable? pat)
`(,pat)) `(,pat))
((many? pat) ((many? pat)
(pattern-variables (car pat))) (append (pattern-variables (car pat))
(pattern-variables (cddr pat))))
((pair? pat) ((pair? pat)
(append (pattern-variables (car pat)) (append (pattern-variables (car pat))
(pattern-variables (cdr pat)))))) (pattern-variables (cdr pat))))))
@ -117,7 +127,8 @@
((variable? pat) ((variable? pat)
`((,pat . 0))) `((,pat . 0)))
((many? pat) ((many? pat)
(map-values succ (pattern-levels (car pat)))) (append (map-values succ (pattern-levels (car pat)))
(pattern-levels (cddr pat))))
((pair? pat) ((pair? pat)
(append (pattern-levels (car pat)) (append (pattern-levels (car pat))
(pattern-levels (cdr pat)))))) (pattern-levels (cdr pat))))))
@ -134,8 +145,12 @@
((variable? pat) ((variable? pat)
`((,pat . ,form))) `((,pat . ,form)))
((many? pat) ((many? pat)
(let ((envs (pattern-selectors (car pat) 'it))) (let ((head #`(drop-tail #,(length (cddr pat)) #,form))
(map-values (lambda (s) #`(map (lambda (#,'it) #,s) #,form)) envs))) (tail #`(take-tail #,(length (cddr pat)) #,form)))
(let ((envs (pattern-selectors (car pat) 'it)))
(append
(map-values (lambda (s) #`(map (lambda (#,'it) #,s) #,head)) envs)
(pattern-selectors (cddr pat) tail)))))
((pair? pat) ((pair? pat)
(append (pattern-selectors (car pat) #`(car #,form)) (append (pattern-selectors (car pat) #`(car #,form))
(pattern-selectors (cdr pat) #`(cdr #,form)))))))) (pattern-selectors (cdr pat) #`(cdr #,form))))))))