Skip to content

Instantly share code, notes, and snippets.

@tociyuki tociyuki/rsc-rules.scm
Last active Mar 24, 2018

Embed
What would you like to do?
SRFI 149 syntax-rules for rsc-expand.scm
; SRFI 149 syntax rules
; for rsc-expand.scm
; https://gist.github.com/tociyuki/83f6a4523618e6f843549feb9186cafa
(define (sc-length* x)
(if (not (pair? x))
0
(let loop ((x x) (xx (cdr x)) (c 1))
(cond
((eq? x xx) (error "cyclic list"))
((and (pair? xx) (pair? (cdr xx))) (loop (cdr x) (cddr xx) (+ c 2)))
(else (if (pair? xx) (+ c 1) c))))))
(define (er-syntax-rules-macro expr rename compare)
(define (croak . x) (apply error (append x (list (sc-strip expr)))))
(define count 0)
(define (gen-var s)
(set! count (+ count 1))
(string->symbol (string-append s (number->string count))))
(define (expand-rules src)
(expand-heading src (lambda (dooot lits src)
(let rec ((src src))
(cond
((sc-match? src '((pattern template) . _))
(let ((pat (car (car src)))
(tmpl (cadr (car src)))
(t (rename (gen-var "t"))))
`(,(rename 'let) ((,t ,(expand-pattern dooot lits pat tmpl)))
(,(rename 'if) ,t ,t ,(rec (cdr src))))))
((null? src)
`(,(rename 'error) "no matching" (,(rename 'sc-strip) ,(rename 'expr))))
(error (croak "invalid syntax-rules")))))))
(define (expand-heading src k)
(if (sc-match? src '(_ _ . _))
(if (and (sc-identifier? (cadr src)) (pair? (cddr src)))
(k (cadr src) (check-lits (caddr src)) (cdddr src))
(k (rename '...) (check-lits (cadr src)) (cddr src)))
(croak "invalid syntax-rules")))
(define (check-lits src)
(let loop ((r '()) (x src))
(cond
((and (pair? x) (sc-identifier? (car x)))
(loop (cons (car x) r) (cdr x)))
((null? x) (reverse r))
(else (croak "invalid syntax-rules literal list")))))
(define (expand-pattern dooot lits pat tmpl)
(let conv ((p (cdr pat))
(x `(,(rename 'cdr) ,(rename 'expr)))
(dim 0)
(vars '())
(k (lambda (vars) `(,(rename 'cons) #t ,(expand-template dooot tmpl vars)))))
(cond
((sc-identifier? p)
(if (find (lambda (u) (compare p u)) lits)
`(,(rename 'and)
(,(rename 'compare) ,x (,(rename 'rename) (,(rename 'syntax-quote) ,p)))
,(k vars))
`(,(rename 'let) ((,p ,x)) ,(k (cons (cons p dim) vars)))))
((ellipsis? dooot p)
(if (find (lambda (x) (compare x dooot)) (cddr p))
(croak "multiple ellipsises"))
(let ((w (rename (gen-var "w")))
(lp (rename (gen-var "lp")))
(c (rename (gen-var "c")))
(i (sc-length* (cddr p)))
(new-vars (all-vars (car p) dooot lits (+ dim 1))))
(let ((lis-vars (map (lambda (x) (rename (gen-var "v"))) new-vars)))
`(,(rename 'let) ((,w ,x))
(,(rename 'let) ,lp ((,c (,(rename '-) (,(rename 'sc-length*) ,w) ,i))
(,w ,w)
,@(map (lambda (x) `(,x (,(rename 'quote) ()))) lis-vars))
(,(rename 'and) (,(rename '>=) ,c 0)
(,(rename 'if) (,(rename '>) ,c 0)
,(conv (car p) `(,(rename 'car) ,w) (+ dim 1) '() (lambda (_)
`(,lp (,(rename '-) ,c 1) (,(rename 'cdr) ,w)
,@(map (lambda (x v) `(,(rename 'cons) ,(car x) ,v)) new-vars lis-vars))))
(,(rename 'let)
,(map (lambda (x v) `(,(car x) (,(rename 'reverse) ,v))) new-vars lis-vars)
,(conv (cddr p) w dim (append new-vars vars) k)))))))))
((pair? p)
`(,(rename 'and) (,(rename 'pair?) ,x)
,(conv (car p) `(,(rename 'car) ,x) dim vars (lambda (vars)
(conv (cdr p) `(,(rename 'cdr) ,x) dim vars k)))))
((vector? p)
`(,(rename 'and) (,(rename 'vector?) ,x)
,(conv (vector->list p) `(,(rename 'vector->list) ,x) dim vars k)))
((null? p) `(,(rename 'and) (,(rename 'null?) ,x) ,(k vars)))
(else `(,(rename 'and) (,(rename 'equal?) ,x ,p) ,(k vars))))))
(define (expand-template dooot tmpl vars)
(define (conv t dooot dim)
(cond
((sc-identifier? t)
(cond
((find (lambda (v) (compare t (car v))) vars) => (lambda (cell)
(if (<= (cdr cell) dim)
t
(croak "too few ellipsises"))))
(else `(,(rename 'rename) (,(rename 'syntax-quote) ,t)))))
((pair? t)
(cond
((ellipsis-escape? dooot (car t))
`(,(rename 'cons) ,(conv (cadr (car t)) #f dim)
,(conv (cdr t) dooot dim)))
((ellipsis? dooot t)
(let* ((depth (ellipsis-depth dooot t))
(ell-dim (+ dim depth))
(ell-vars (free-vars (car t) vars ell-dim)))
(cond
((null? ell-vars) (croak "too many ellipsises"))
((and (null? (cddr t)) (sc-identifier? (car t)))
(conv (car t) dooot ell-dim))
(else
(let* ((once (conv (car t) dooot ell-dim))
(nest `(,(rename 'map) (,(rename 'lambda) ,ell-vars ,once) ,@ell-vars))
(many (do ((d depth (- d 1))
(many nest `(,(rename 'apply) ,(rename 'append) ,many)))
((= d 1) many))))
(if (null? (ellipsis-tail dooot t))
many
`(,(rename 'append) ,many ,(conv (ellipsis-tail dooot t) dooot dim))))))))
(else `(,(rename 'cons) ,(conv (car t) dooot dim)
,(conv (cdr t) dooot dim)))))
((vector? t) `(,(rename 'list->vector) ,(conv (vector->list t) dooot dim)))
(else t)))
(cond
((and (sc-match? tmpl '(kw . _)) (compare (rename 'syntax-error) (car tmpl)))
`(,(rename 'apply) ,(rename 'error)
(,(rename 'sc-strip) ,(conv (cdr tmpl) dooot 0))))
((ellipsis-escape? dooot tmpl) (conv tmpl #f 0))
(else (conv tmpl dooot 0))))
(define (ellipsis? dooot x)
(and (sc-identifier? dooot) (sc-match? x '(_ kw . _)) (compare dooot (cadr x))))
(define (ellipsis-escape? dooot x)
(and (sc-identifier? dooot) (sc-match? x '(kw _)) (compare dooot (car x))))
(define (ellipsis-depth dooot x)
(if (ellipsis? dooot x)
(+ 1 (ellipsis-depth dooot (cdr x)))
0))
(define (ellipsis-tail dooot x)
(if (ellipsis? dooot x)
(ellipsis-tail dooot (cdr x))
(cdr x)))
(define (all-vars x dooot lits dim)
(let rec ((x x) (dim dim) (vars '()))
(cond
((sc-identifier? x)
(if (find (lambda (lit) (compare x lit)) lits)
vars
(cons (cons x dim) vars)))
((ellipsis? dooot x) (rec (car x) (+ dim 1) (rec (cddr x) dim vars)))
((pair? x) (rec (car x) dim (rec (cdr x) dim vars)))
((vector? x) (rec (vector->list x) dim vars))
(else vars))))
(define (free-vars x vars dim)
(let rec ((x x) (free '()))
(cond
((sc-identifier? x)
(cond
((find (lambda (v) (compare v x)) free) free)
((find (lambda (v) (compare (car v) x)) vars) => (lambda (cell)
(if (>= (cdr cell) dim) (cons x free) free)))
(else free)))
((pair? x) (rec (car x) (rec (cdr x) free)))
((vector? x) (rec (vector->list x) free))
(else free))))
`(,(rename 'er-macro-transformer)
(,(rename 'lambda) (,(rename 'expr) ,(rename 'rename) ,(rename 'compare))
(,(rename 'cdr) ,(expand-rules expr)))))
(define (er-and-macro x rename compare)
(match x
((_) #t)
((_ e1) e1)
((_ #t e2 ...) `(,(rename 'and) ,@e2))
((_ e1 e2 ...) `(,(rename 'if) ,e1 (,(rename 'and) ,@e2) #f))
(else (error "no matching" (sc-strip x)))))
(define (sc-rules-syntactic-environment)
(let ((syntactic-env (sc-core-syntactic-environment)))
(sc-define-syntax 'let '(er-macro-transformer er-let-macro) syntactic-env)
(sc-define-syntax 'and '(er-macro-transformer er-and-macro) syntactic-env)
(sc-define-syntax 'syntax-rules '(er-macro-transformer er-syntax-rules-macro) syntactic-env)
(sc-reset-unique-id-counter)
syntactic-env))
(define (demo)
(sc-expand
'(letrec-syntax
((or (syntax-rules ()
((or) #f)
((or e1) e1)
((or e1 e2 ...) (let ((t e1)) (if t t (or e2 ...)))))))
((lambda (x) (let ((if list) (t x)) (or 1 t))) 2))
(sc-rules-syntactic-environment)))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.