[WIP] syntax-rules: rewrite syntax-rules.scm
[syntax-rules] bugfix s/generate-representation/template-representation/g [WIP] rewrite syntax-rules [syntax-rules] bugfix s/generate-representation/template-representation/g [syntax-rules] bugfix
This commit is contained in:
Yuichi Nishiwaki
parent
d741efe294
commit
43f1f6bb70
|
|
@ -1,348 +1,194 @@
|
||||||
(define-library (picrin syntax-rules)
|
(define-library (picrin syntax-rules)
|
||||||
(import (picrin base)
|
(import (picrin base)
|
||||||
(picrin control)
|
|
||||||
(picrin macro))
|
(picrin macro))
|
||||||
|
|
||||||
(define-syntax define-auxiliary-syntax
|
(define-syntax (define-auxiliary-syntax var)
|
||||||
(er-macro-transformer
|
#`(define-macro #,var
|
||||||
(lambda (expr r c)
|
(lambda _
|
||||||
(list (r 'define-syntax) (cadr expr)
|
(error "invalid use of auxiliary syntax" '#,var))))
|
||||||
(list (r 'lambda) '_
|
|
||||||
(list (r 'lambda) '_
|
|
||||||
(list (r 'error) (list (r 'string-append) "invalid use of auxiliary syntax: '" (symbol->string (cadr expr)) "'"))))))))
|
|
||||||
|
|
||||||
(define-auxiliary-syntax _)
|
(define-auxiliary-syntax _)
|
||||||
(define-auxiliary-syntax ...)
|
(define-auxiliary-syntax ...)
|
||||||
|
|
||||||
(define (walk proc expr)
|
(define (succ n)
|
||||||
(cond
|
(+ n 1))
|
||||||
((null? expr)
|
|
||||||
'())
|
|
||||||
((pair? expr)
|
|
||||||
(cons (walk proc (car expr))
|
|
||||||
(walk proc (cdr expr))))
|
|
||||||
((vector? expr)
|
|
||||||
(list->vector (map proc (vector->list expr))))
|
|
||||||
(else
|
|
||||||
(proc expr))))
|
|
||||||
|
|
||||||
(define (flatten expr)
|
(define (pred n)
|
||||||
(let ((list '()))
|
(if (= n 0)
|
||||||
(walk
|
0
|
||||||
(lambda (x)
|
(- n 1)))
|
||||||
(set! list (cons x list)))
|
|
||||||
expr)
|
|
||||||
(reverse list)))
|
|
||||||
|
|
||||||
(define (reverse* l)
|
(define (every? args)
|
||||||
;; (reverse* '(a b c d . e)) => (e d c b a)
|
(if (null? args)
|
||||||
(let loop ((a '())
|
|
||||||
(d l))
|
|
||||||
(if (pair? d)
|
|
||||||
(loop (cons (car d) a) (cdr d))
|
|
||||||
(cons d a))))
|
|
||||||
|
|
||||||
(define (every? pred l)
|
|
||||||
(if (null? l)
|
|
||||||
#t
|
#t
|
||||||
(and (pred (car l)) (every? pred (cdr l)))))
|
(if (car args)
|
||||||
|
(every? (cdr args))
|
||||||
|
#f)))
|
||||||
|
|
||||||
(define-syntax syntax-rules
|
(define (filter f list)
|
||||||
(er-macro-transformer
|
(if (null? list)
|
||||||
(lambda (form r compare)
|
'()
|
||||||
(define _define (r 'define))
|
(if (f (car list))
|
||||||
(define _let (r 'let))
|
(cons (car list)
|
||||||
(define _if (r 'if))
|
(filter f (cdr list)))
|
||||||
(define _begin (r 'begin))
|
(filter f (cdr list)))))
|
||||||
(define _lambda (r 'lambda))
|
|
||||||
(define _set! (r 'set!))
|
|
||||||
(define _not (r 'not))
|
|
||||||
(define _and (r 'and))
|
|
||||||
(define _car (r 'car))
|
|
||||||
(define _cdr (r 'cdr))
|
|
||||||
(define _cons (r 'cons))
|
|
||||||
(define _pair? (r 'pair?))
|
|
||||||
(define _null? (r 'null?))
|
|
||||||
(define _symbol? (r 'symbol?))
|
|
||||||
(define _vector? (r 'vector?))
|
|
||||||
(define _eqv? (r 'eqv?))
|
|
||||||
(define _string=? (r 'string=?))
|
|
||||||
(define _map (r 'map))
|
|
||||||
(define _vector->list (r 'vector->list))
|
|
||||||
(define _list->vector (r 'list->vector))
|
|
||||||
(define _quote (r 'quote))
|
|
||||||
(define _quasiquote (r 'quasiquote))
|
|
||||||
(define _unquote (r 'unquote))
|
|
||||||
(define _unquote-splicing (r 'unquote-splicing))
|
|
||||||
(define _syntax-error (r 'syntax-error))
|
|
||||||
(define _escape (r 'escape))
|
|
||||||
(define _er-macro-transformer (r 'er-macro-transformer))
|
|
||||||
|
|
||||||
(define (var->sym v)
|
(define (map-keys f assoc)
|
||||||
(let loop ((cnt 0)
|
(map (lambda (s) `(,(f (car s)) . ,(cdr s))) assoc))
|
||||||
(v v))
|
|
||||||
(if (symbol? v)
|
|
||||||
(string->symbol
|
|
||||||
(string-append (symbol->string v) "/" (number->string cnt)))
|
|
||||||
(loop (+ 1 cnt) (car v)))))
|
|
||||||
|
|
||||||
(define push-var list)
|
(define (map-values f assoc)
|
||||||
|
(map (lambda (s) `(,(car s) . ,(f (cdr s)))) assoc))
|
||||||
|
|
||||||
(define (compile-match ellipsis literals pattern)
|
;; TODO
|
||||||
(letrec ((compile-match-base
|
;; - constants
|
||||||
(lambda (pattern)
|
;; - literals
|
||||||
(cond ((member pattern literals compare)
|
;; - custom ellipsis
|
||||||
(values
|
;; - splicing
|
||||||
`(,_if (,_and (,_symbol? expr) (cmp expr (rename ',pattern)))
|
;; - placeholder
|
||||||
#f
|
;; - vector
|
||||||
(exit #f))
|
|
||||||
'()))
|
|
||||||
((compare pattern (r '_)) (values #f '()))
|
|
||||||
((and ellipsis (compare pattern ellipsis))
|
|
||||||
(values `(,_syntax-error "invalid pattern") '()))
|
|
||||||
((symbol? pattern)
|
|
||||||
(values `(,_set! ,(var->sym pattern) expr) (list pattern)))
|
|
||||||
((pair? pattern)
|
|
||||||
(compile-match-list pattern))
|
|
||||||
((vector? pattern)
|
|
||||||
(compile-match-vector pattern))
|
|
||||||
((string? pattern)
|
|
||||||
(values
|
|
||||||
`(,_if (,_not (,_string=? ',pattern expr))
|
|
||||||
(exit #f))
|
|
||||||
'()))
|
|
||||||
(else
|
|
||||||
(values
|
|
||||||
`(,_if (,_not (,_eqv? ',pattern expr))
|
|
||||||
(exit #f))
|
|
||||||
'())))))
|
|
||||||
|
|
||||||
(compile-match-list
|
;; p ::= ()
|
||||||
(lambda (pattern)
|
;; | var
|
||||||
(let loop ((pattern pattern)
|
;; | (p . p)
|
||||||
(matches '())
|
;; | (p ...)
|
||||||
(vars '())
|
|
||||||
(accessor 'expr))
|
|
||||||
(cond ;; (hoge)
|
|
||||||
((not (pair? (cdr pattern)))
|
|
||||||
(let*-values (((match1 vars1) (compile-match-base (car pattern)))
|
|
||||||
((match2 vars2) (compile-match-base (cdr pattern))))
|
|
||||||
(values
|
|
||||||
`(,_begin ,@(reverse matches)
|
|
||||||
(,_if (,_pair? ,accessor)
|
|
||||||
(,_begin
|
|
||||||
(,_let ((expr (,_car ,accessor)))
|
|
||||||
,match1)
|
|
||||||
(,_let ((expr (,_cdr ,accessor)))
|
|
||||||
,match2))
|
|
||||||
(exit #f)))
|
|
||||||
(append vars (append vars1 vars2)))))
|
|
||||||
;; (hoge ... rest args)
|
|
||||||
((and ellipsis (compare (cadr pattern) ellipsis))
|
|
||||||
(let-values (((match-r vars-r) (compile-match-list-reverse pattern)))
|
|
||||||
(values
|
|
||||||
`(,_begin ,@(reverse matches)
|
|
||||||
(,_let ((expr (,_let loop ((a ())
|
|
||||||
(d ,accessor))
|
|
||||||
(,_if (,_pair? d)
|
|
||||||
(loop (,_cons (,_car d) a) (,_cdr d))
|
|
||||||
(,_cons d a)))))
|
|
||||||
,match-r))
|
|
||||||
(append vars vars-r))))
|
|
||||||
(else
|
|
||||||
(let-values (((match1 vars1) (compile-match-base (car pattern))))
|
|
||||||
(loop (cdr pattern)
|
|
||||||
(cons `(,_if (,_pair? ,accessor)
|
|
||||||
(,_let ((expr (,_car ,accessor)))
|
|
||||||
,match1)
|
|
||||||
(exit #f))
|
|
||||||
matches)
|
|
||||||
(append vars vars1)
|
|
||||||
`(,_cdr ,accessor))))))))
|
|
||||||
|
|
||||||
(compile-match-list-reverse
|
(define (compile ellipsis literals rules)
|
||||||
(lambda (pattern)
|
|
||||||
(let loop ((pattern (reverse* pattern))
|
|
||||||
(matches '())
|
|
||||||
(vars '())
|
|
||||||
(accessor 'expr))
|
|
||||||
(cond ((and ellipsis (compare (car pattern) ellipsis))
|
|
||||||
(let-values (((match1 vars1) (compile-match-ellipsis (cadr pattern))))
|
|
||||||
(values
|
|
||||||
`(,_begin ,@(reverse matches)
|
|
||||||
(,_let ((expr ,accessor))
|
|
||||||
,match1))
|
|
||||||
(append vars vars1))))
|
|
||||||
(else
|
|
||||||
(let-values (((match1 vars1) (compile-match-base (car pattern))))
|
|
||||||
(loop (cdr pattern)
|
|
||||||
(cons `(,_let ((expr (,_car ,accessor))) ,match1) matches)
|
|
||||||
(append vars vars1)
|
|
||||||
`(,_cdr ,accessor))))))))
|
|
||||||
|
|
||||||
(compile-match-ellipsis
|
(define (many? pat)
|
||||||
(lambda (pattern)
|
(and (pair? pat)
|
||||||
(let-values (((match vars) (compile-match-base pattern)))
|
(pair? (cdr pat))
|
||||||
(values
|
(variable? (cadr pat))
|
||||||
`(,_let loop ((expr expr))
|
(variable=? (cadr pat) ellipsis)
|
||||||
(,_if (,_not (,_null? expr))
|
(eq? (cddr pat) '())))
|
||||||
(,_let ,(map (lambda (var) `(,(var->sym var) '())) vars)
|
|
||||||
(,_let ((expr (,_car expr)))
|
|
||||||
,match)
|
|
||||||
,@(map
|
|
||||||
(lambda (var)
|
|
||||||
`(,_set! ,(var->sym (push-var var))
|
|
||||||
(,_cons ,(var->sym var) ,(var->sym (push-var var)))))
|
|
||||||
vars)
|
|
||||||
(loop (,_cdr expr)))))
|
|
||||||
(map push-var vars)))))
|
|
||||||
|
|
||||||
(compile-match-vector
|
(define (pattern-validator pat) ; pattern -> validator
|
||||||
(lambda (pattern)
|
(letrec
|
||||||
(let-values (((match vars) (compile-match-base (vector->list pattern))))
|
((pattern-validator
|
||||||
(values
|
(lambda (pat form)
|
||||||
`(,_if (,_vector? expr)
|
(cond
|
||||||
(,_let ((expr (,_vector->list expr)))
|
((null? pat)
|
||||||
,match)
|
#`(null? #,form))
|
||||||
(exit #f))
|
((variable? pat)
|
||||||
vars)))))
|
#t)
|
||||||
|
((many? pat)
|
||||||
|
(let ((validator (pattern-validator (car pat) 'it)))
|
||||||
|
#`(and (list? #,form)
|
||||||
|
(every? (map (lambda (#,'it) #,validator) #,form)))))
|
||||||
|
((pair? pat)
|
||||||
|
#`(and (pair? #,form)
|
||||||
|
#,(pattern-validator (car pat) #`(car #,form))
|
||||||
|
#,(pattern-validator (cdr pat) #`(cdr #,form))))
|
||||||
|
(else
|
||||||
|
#f)))))
|
||||||
|
(pattern-validator pat 'it)))
|
||||||
|
|
||||||
(let-values (((match vars) (compile-match-base (cdr pattern))))
|
(define (pattern-variables pat) ; pattern -> (freevar)
|
||||||
(values `(,_let ((expr (,_cdr expr)))
|
(cond
|
||||||
,match
|
((null? pat)
|
||||||
#t)
|
'())
|
||||||
vars))))
|
((variable? pat)
|
||||||
|
`(,pat))
|
||||||
|
((many? pat)
|
||||||
|
(pattern-variables (car pat)))
|
||||||
|
((pair? pat)
|
||||||
|
(append (pattern-variables (car pat))
|
||||||
|
(pattern-variables (cdr pat))))))
|
||||||
|
|
||||||
;;; compile expand
|
(define (pattern-levels pat) ; pattern -> ((var * int))
|
||||||
(define (compile-expand ellipsis reserved template)
|
(cond
|
||||||
(letrec ((compile-expand-base
|
((null? pat)
|
||||||
(lambda (template ellipsis-valid)
|
'())
|
||||||
(cond ((member template reserved eq?)
|
((variable? pat)
|
||||||
(values (var->sym template) (list template)))
|
`((,pat . 0)))
|
||||||
((symbol? template)
|
((many? pat)
|
||||||
(values `(rename ',template) '()))
|
(map-values succ (pattern-levels (car pat))))
|
||||||
((pair? template)
|
((pair? pat)
|
||||||
(compile-expand-list template ellipsis-valid))
|
(append (pattern-levels (car pat))
|
||||||
((vector? template)
|
(pattern-levels (cdr pat))))))
|
||||||
(compile-expand-vector template ellipsis-valid))
|
|
||||||
(else
|
|
||||||
(values `',template '())))))
|
|
||||||
|
|
||||||
(compile-expand-list
|
(define (pattern-selectors pat) ; pattern -> ((var * selector))
|
||||||
(lambda (template ellipsis-valid)
|
(letrec
|
||||||
(let loop ((template template)
|
((pattern-selectors
|
||||||
(expands '())
|
(lambda (pat form)
|
||||||
(vars '()))
|
(cond
|
||||||
(cond ;; (... hoge)
|
((null? pat)
|
||||||
((and ellipsis-valid
|
'())
|
||||||
(pair? template)
|
((variable? pat)
|
||||||
(compare (car template) ellipsis))
|
`((,pat . ,form)))
|
||||||
(if (and (pair? (cdr template)) (null? (cddr template)))
|
((many? pat)
|
||||||
(compile-expand-base (cadr template) #f)
|
(let ((envs (pattern-selectors (car pat) 'it)))
|
||||||
(values '(,_syntax-error "invalid template") '())))
|
(map-values (lambda (s) #`(map (lambda (#,'it) #,s) #,form)) envs)))
|
||||||
;; hoge
|
((pair? pat)
|
||||||
((not (pair? template))
|
(append (pattern-selectors (car pat) #`(car #,form))
|
||||||
(let-values (((expand1 vars1)
|
(pattern-selectors (cdr pat) #`(cdr #,form))))))))
|
||||||
(compile-expand-base template ellipsis-valid)))
|
(pattern-selectors pat 'it)))
|
||||||
(values
|
|
||||||
`(,_quasiquote (,@(reverse expands) . (,_unquote ,expand1)))
|
|
||||||
(append vars vars1))))
|
|
||||||
;; (a ... rest syms)
|
|
||||||
((and ellipsis-valid
|
|
||||||
(pair? (cdr template))
|
|
||||||
(compare (cadr template) ellipsis))
|
|
||||||
(let-values (((expand1 vars1)
|
|
||||||
(compile-expand-base (car template) ellipsis-valid)))
|
|
||||||
(loop (cddr template)
|
|
||||||
(cons
|
|
||||||
`(,_unquote-splicing
|
|
||||||
(,_map (,_lambda ,(map var->sym vars1) ,expand1)
|
|
||||||
,@(map (lambda (v) (var->sym (push-var v))) vars1)))
|
|
||||||
expands)
|
|
||||||
(append vars (map push-var vars1)))))
|
|
||||||
(else
|
|
||||||
(let-values (((expand1 vars1)
|
|
||||||
(compile-expand-base (car template) ellipsis-valid)))
|
|
||||||
(loop (cdr template)
|
|
||||||
(cons
|
|
||||||
`(,_unquote ,expand1)
|
|
||||||
expands)
|
|
||||||
(append vars vars1))))))))
|
|
||||||
|
|
||||||
(compile-expand-vector
|
(define (template-representation pat levels selectors)
|
||||||
(lambda (template ellipsis-valid)
|
(cond
|
||||||
(let-values (((expand1 vars1)
|
((null? pat)
|
||||||
(compile-expand-base (vector->list template) ellipsis-valid)))
|
'())
|
||||||
(values
|
((variable? pat)
|
||||||
`(,_list->vector ,expand1)
|
(let ((it (assq pat levels)))
|
||||||
vars1)))))
|
(if it
|
||||||
|
(if (= 0 (cdr it))
|
||||||
|
(cdr (assq pat selectors))
|
||||||
|
(error "unmatched pattern variable level" pat))
|
||||||
|
#`'#,pat)))
|
||||||
|
((many? pat)
|
||||||
|
(letrec*
|
||||||
|
((inner-pat
|
||||||
|
(car pat))
|
||||||
|
(inner-vars
|
||||||
|
(filter (lambda (v) (assq v levels)) (pattern-variables inner-pat)))
|
||||||
|
(inner-tmps
|
||||||
|
(map (lambda (v) #'it) inner-vars))
|
||||||
|
(inner-levels
|
||||||
|
(map (lambda (s) `(,(car s) . ,(pred (cdr s)))) levels))
|
||||||
|
(inner-selectors
|
||||||
|
(map cons inner-vars inner-tmps))
|
||||||
|
(inner-rep
|
||||||
|
(template-representation inner-pat inner-levels inner-selectors))
|
||||||
|
(filtered-selectors
|
||||||
|
(map (lambda (v) (assq v selectors)) inner-vars))
|
||||||
|
;; ((a . (x1 x2)) (b . (y1 y2 y3)) (c . z1)) -> ((x1 x2) (y1 y2 y3) (z1))
|
||||||
|
(list-of-selectors
|
||||||
|
(map (lambda (x) (if (list? x) x (list x))) (map cdr filtered-selectors))))
|
||||||
|
#`(map (lambda #,inner-tmps #,inner-rep) #,@list-of-selectors)))
|
||||||
|
((pair? pat)
|
||||||
|
#`(cons #,(template-representation (car pat) levels selectors)
|
||||||
|
#,(template-representation (cdr pat) levels selectors)))))
|
||||||
|
|
||||||
(compile-expand-base template ellipsis)))
|
(define (compile-rule pattern template)
|
||||||
|
(let ((levels
|
||||||
|
(pattern-levels pattern))
|
||||||
|
(selectors
|
||||||
|
(pattern-selectors pattern)))
|
||||||
|
(template-representation template levels selectors)))
|
||||||
|
|
||||||
(define (check-vars vars-pattern vars-template)
|
(define (compile-rules rules)
|
||||||
;;fixme
|
(if (null? rules)
|
||||||
#t)
|
#`(error "unmatch")
|
||||||
|
(let ((pattern (car (car rules)))
|
||||||
|
(template (cadr (car rules))))
|
||||||
|
#`(if #,(pattern-validator pattern)
|
||||||
|
#,(compile-rule pattern template)
|
||||||
|
#,(compile-rules (cdr rules))))))
|
||||||
|
|
||||||
(define (compile-rule ellipsis literals rule)
|
(define (compile rules)
|
||||||
(let ((pattern (car rule))
|
#`(lambda #,'it
|
||||||
(template (cadr rule)))
|
#,(compile-rules rules)))
|
||||||
(let*-values (((match vars-match)
|
|
||||||
(compile-match ellipsis literals pattern))
|
|
||||||
((expand vars-expand)
|
|
||||||
(compile-expand ellipsis (flatten vars-match) template)))
|
|
||||||
(if (check-vars vars-match vars-expand)
|
|
||||||
(list vars-match match expand)
|
|
||||||
'mismatch))))
|
|
||||||
|
|
||||||
(define (expand-clauses clauses rename)
|
(let ((rules (map-keys cdr rules))) ; TODO: check pattern head is a variable
|
||||||
(cond ((null? clauses)
|
(compile rules)))
|
||||||
`(,_quote (syntax-error "no matching pattern")))
|
|
||||||
((compare (car clauses) 'mismatch)
|
|
||||||
`(,_syntax-error "invalid rule"))
|
|
||||||
(else
|
|
||||||
(let ((vars (list-ref (car clauses) 0))
|
|
||||||
(match (list-ref (car clauses) 1))
|
|
||||||
(expand (list-ref (car clauses) 2)))
|
|
||||||
`(,_let ,(map (lambda (v) (list (var->sym v) '())) vars)
|
|
||||||
(,_let ((result (,_escape (,_lambda (exit) ,match))))
|
|
||||||
(,_if result
|
|
||||||
,expand
|
|
||||||
,(expand-clauses (cdr clauses) rename))))))))
|
|
||||||
|
|
||||||
(define (normalize-form form)
|
(define-syntax (syntax-rules . args)
|
||||||
(if (and (list? form) (>= (length form) 2))
|
(if (list? (car args))
|
||||||
(let ((ellipsis '...)
|
#`(syntax-rules ... #,@args)
|
||||||
(literals (cadr form))
|
(let ((ellipsis (car args))
|
||||||
(rules (cddr form)))
|
(literals (car (cdr args)))
|
||||||
|
(rules (cdr (cdr args))))
|
||||||
|
(compile ellipsis literals rules))))
|
||||||
|
|
||||||
(when (symbol? literals)
|
|
||||||
(set! ellipsis literals)
|
|
||||||
(set! literals (car rules))
|
|
||||||
(set! rules (cdr rules)))
|
|
||||||
|
|
||||||
(if (and (symbol? ellipsis)
|
|
||||||
(list? literals)
|
|
||||||
(every? symbol? literals)
|
|
||||||
(list? rules)
|
|
||||||
(every? (lambda (l) (and (list? l) (= (length l) 2))) rules))
|
|
||||||
(if (member ellipsis literals compare)
|
|
||||||
`(syntax-rules #f ,literals ,@rules)
|
|
||||||
`(syntax-rules ,ellipsis ,literals ,@rules))
|
|
||||||
#f))
|
|
||||||
#f))
|
|
||||||
|
|
||||||
(let ((form (normalize-form form)))
|
|
||||||
(if form
|
|
||||||
(let ((ellipsis (list-ref form 1))
|
|
||||||
(literals (list-ref form 2))
|
|
||||||
(rules (list-tail form 3)))
|
|
||||||
(let ((clauses (map (lambda (rule) (compile-rule ellipsis literals rule))
|
|
||||||
rules)))
|
|
||||||
`(,_er-macro-transformer
|
|
||||||
(,_lambda (expr rename cmp)
|
|
||||||
,(expand-clauses clauses r)))))
|
|
||||||
|
|
||||||
`(,_syntax-error "malformed syntax-rules"))))))
|
|
||||||
|
|
||||||
(export syntax-rules
|
(export syntax-rules
|
||||||
_
|
_
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue