Skip to content
Browse files

generic: Add synrules automatic binding renamer

Adding a feature to add automatic binding renaming to make
pseudo-syntax-rules in Generic Runtime a bit more Hygine.

Currently, following syntax are supported:

- lambda
- define
- let
- letrec
- let*
- letrec*

Caveat: These forms MUST be appear in synrule template in complete form.
Perhaps we would have a bit more "manual" variant that would be
(with-temporary-bindings (b ...) body ...)
  • Loading branch information
okuoku committed Dec 9, 2018
1 parent 103a39f commit 19495050f7ea03e9f461be43a2007e6e925351d6
Showing with 98 additions and 5 deletions.
  1. +16 −5 external/yuni-synrules.scm
  2. +82 −0 lib-runtime/generic/synrules.scm
@@ -45,13 +45,13 @@
(define (next-symbol s)
(set! count (+ count 1))
(rename (string->symbol (string-append s (%number->string count)))))
(define (expand-pattern pat tmpl)
(define (expand-pattern pat tmpl temps)
(let lp ((p (cdr pat))
(x (list _cdr _expr))
(dim 0)
(vars '())
(k (lambda (vars)
(list _cons (expand-template tmpl vars) #f))))
(list _cons (expand-template tmpl vars temps) #f))))
(let ((v (next-symbol "v.")))
_let (list (list v x))
@@ -194,7 +194,9 @@
((pair? x) (lp (car x) (lp (cdr x) free)))
((vector? x) (lp (vector->list x) free))
(else free))))
(define (expand-template tmpl vars)
(define (expand-template tmpl vars temps)
(define tempbinds (map (lambda (e) (cons e (list _quote (rename e))))
(let lp ((t tmpl) (dim 0))
((identifier? t)
@@ -212,7 +214,10 @@
(if (<= (cdr cell) dim)
(error "two few ...'s"))
(list _baselib (list _quote t)))))
(let ((vn (find (lambda (v) (eq? t (car v))) tempbinds)))
(if vn
(cdr vn)
(list _baselib (list _quote t)))))))
((pair? t)
((ellipsis-escape? t)
@@ -258,7 +263,13 @@
(lambda (clause) (expand-pattern (car clause) (cadr clause)))
(lambda (clause)
(let* ((pat (car clause))
(tmpl (cadr clause))
(potential-binds (yuni/synrule-prescan-template
(expand-pattern pat tmpl potential-binds)))
(list _cons
@@ -73,6 +73,88 @@

(define (yuni/synrule-compare x y) (eq? x y))

(define (yuni/synrule-prescan-lambda-frm ellipsis? frm)
(define (itr l cur)
((and (yuni/identifier? l) (not (ellipsis? l)))
(cons l cur))
((pair? l)
(let ((a (car l))
(d (cdr l)))
((and (yuni/identifier? a) (not (ellipsis? a)))
(itr d (cons a cur)))
(itr d cur)))))
(else cur)))
(itr frm '()))

(define (yuni/synrule-prescan-lambda ellipsis? frm)
(yuni/synrule-prescan-lambda-frm ellipsis? (cadr frm)))

(define (yuni/synrule-prescan-let ellipsis? frm)
(define (itr bind* cur)
((pair? bind*)
(let ((a (car bind*))
(d (cdr bind*)))
((and (list? a) (yuni/identifier? (car a)))
(itr d (cons (car a) cur)))
(itr d cur)))))
(else cur)))
((and (yuni/identifier? (cadr frm)) (not (ellipsis? (cadr frm))))
(cons (cadr frm)
(itr (caddr frm) '())))
(itr (cadr frm) '()))))

(define (yuni/synrule-prescan-define ellipsis? frm)
(yuni/synrule-prescan-lambda-frm ellipsis? (cadr frm)))

(define (yuni/synrule-prescan-template ellipsis? tmpl) ;; => (sym ...)
;; Scan syntax-rules template and emit "to-be-bound" symbols
;; (let ((a 10) (b 20)) body ...) => (a b)
;; (let loop ((a 10)) body ...) => (loop a)
(define templates
(list '(let letrec let* letrec*) yuni/synrule-prescan-let)
(list '(define) yuni/synrule-prescan-define)
(list '(lambda) yuni/synrule-prescan-lambda)))

(define (match? sym* sym)
(yuni/find1 (lambda (s) (eq? s sym)) sym*))
(define (lookup sym)
(yuni/find1 (lambda (e) (match? (car e) sym)) templates))
(define (can-be-a-binder? frm)
(define (itr cur cnt)
((= cnt 2) #t)
((pair? cur)
(itr (cdr cur) (+ 1 cnt)))
(else #f)))
(itr frm 0))
(define ret '())
(define (pass! frm)
((pair? frm)
(let ((sym (car frm)))
((and (yuni/identifier? sym) (can-be-a-binder? frm))
(let ((trans (lookup sym)))
(let ((syms ((cadr trans) ellipsis? frm)))
(set! ret (append syms ret))))))))
((list? frm)
(for-each pass! frm)))))))
(pass! tmpl)

(define-macro (define-syntax name synrule)
(let ((tran (yuni/syntax-rules-transformer

0 comments on commit 1949505

Please sign in to comment.
You can’t perform that action at this time.