rewrite macro.scm.
build sc/er macro transformers on picrin's macro system [macro.scm] cleanup
This commit is contained in:
Yuichi Nishiwaki
parent
a10ac3b770
commit
4d9f5bfbcf
|
|
@ -1,141 +1,180 @@
|
||||||
(define-library (picrin macro)
|
(define-library (picrin macro)
|
||||||
(import (picrin base))
|
(import (picrin base))
|
||||||
|
|
||||||
(export identifier?
|
;; macro primitives
|
||||||
identifier=?
|
|
||||||
|
(export define-macro
|
||||||
make-identifier
|
make-identifier
|
||||||
|
identifier?
|
||||||
|
identifier-variable
|
||||||
|
identifier-environment
|
||||||
|
variable?
|
||||||
|
variable=?)
|
||||||
|
|
||||||
|
;; simple macro
|
||||||
|
|
||||||
|
(export define-syntax
|
||||||
|
syntax-quote
|
||||||
|
syntax-quasiquote
|
||||||
|
syntax-unquote
|
||||||
|
syntax-unquote-splicing)
|
||||||
|
|
||||||
|
;; misc transformers
|
||||||
|
|
||||||
|
(export call-with-current-environment
|
||||||
make-syntactic-closure
|
make-syntactic-closure
|
||||||
close-syntax
|
close-syntax
|
||||||
capture-syntactic-environment
|
strip-syntax
|
||||||
sc-macro-transformer
|
sc-macro-transformer
|
||||||
rsc-macro-transformer
|
rsc-macro-transformer
|
||||||
er-macro-transformer
|
er-macro-transformer
|
||||||
ir-macro-transformer
|
ir-macro-transformer)
|
||||||
;; strip-syntax
|
|
||||||
define-macro)
|
|
||||||
|
|
||||||
;; assumes no derived expressions are provided yet
|
|
||||||
|
|
||||||
(define (walk proc expr)
|
(define-macro call-with-current-environment
|
||||||
"walk on symbols"
|
(lambda (form env)
|
||||||
(if (null? expr)
|
`(,(cadr form) ',env)))
|
||||||
'()
|
|
||||||
(if (pair? expr)
|
|
||||||
(cons (walk proc (car expr))
|
;; syntactic closure
|
||||||
(walk proc (cdr expr)))
|
|
||||||
(if (vector? expr)
|
|
||||||
(list->vector (walk proc (vector->list expr)))
|
|
||||||
(if (symbol? expr)
|
|
||||||
(proc expr)
|
|
||||||
expr)))))
|
|
||||||
|
|
||||||
(define (memoize f)
|
|
||||||
"memoize on symbols"
|
|
||||||
(define cache (make-dictionary))
|
|
||||||
(lambda (sym)
|
|
||||||
(define value (dictionary-ref cache sym))
|
|
||||||
(if (not (undefined? value))
|
|
||||||
value
|
|
||||||
(begin
|
|
||||||
(define val (f sym))
|
|
||||||
(dictionary-set! cache sym val)
|
|
||||||
val))))
|
|
||||||
|
|
||||||
(define (make-syntactic-closure env free form)
|
(define (make-syntactic-closure env free form)
|
||||||
|
(letrec
|
||||||
(define resolve
|
((wrap (let ((register (make-register)))
|
||||||
(memoize
|
(lambda (var)
|
||||||
(lambda (sym)
|
(let ((id (register var)))
|
||||||
(make-identifier sym env))))
|
(if (undefined? id)
|
||||||
|
(let ((id (make-identifier var env)))
|
||||||
(walk
|
(register var id)
|
||||||
(lambda (sym)
|
id)
|
||||||
(if (memq sym free)
|
id)))))
|
||||||
sym
|
(walk (lambda (f form)
|
||||||
(resolve sym)))
|
(cond
|
||||||
form))
|
((variable? form)
|
||||||
|
(f form))
|
||||||
|
((pair? form)
|
||||||
|
(cons (walk f (car form)) (walk f (cdr form))))
|
||||||
|
((vector? form)
|
||||||
|
(list->vector (walk f (vector->list form))))
|
||||||
|
(else
|
||||||
|
form)))))
|
||||||
|
(letrec
|
||||||
|
((f (lambda (var)
|
||||||
|
(let loop ((free free))
|
||||||
|
(if (null? free)
|
||||||
|
(wrap free)
|
||||||
|
(if (variable=? var (car free))
|
||||||
|
var
|
||||||
|
(loop (cdr free))))))))
|
||||||
|
(walk f form))))
|
||||||
|
|
||||||
(define (close-syntax form env)
|
(define (close-syntax form env)
|
||||||
(make-syntactic-closure env '() form))
|
(make-syntactic-closure env '() form))
|
||||||
|
|
||||||
(define-syntax capture-syntactic-environment
|
(define (strip-syntax form)
|
||||||
(lambda (mac-env)
|
(letrec
|
||||||
(lambda (form use-env)
|
((unwrap (lambda (var)
|
||||||
(list (cadr form) (list (make-identifier 'quote mac-env) mac-env)))))
|
(identifier-variable var)))
|
||||||
|
(walk (lambda (f form)
|
||||||
|
(cond
|
||||||
|
((variable? form)
|
||||||
|
(f form))
|
||||||
|
((pair? form)
|
||||||
|
(cons (walk f (car form)) (walk f (cdr form))))
|
||||||
|
((vector? form)
|
||||||
|
(list->vector (walk f (vector->list form))))
|
||||||
|
(else
|
||||||
|
form)))))
|
||||||
|
(walk unwrap form)))
|
||||||
|
|
||||||
(define (sc-macro-transformer f)
|
|
||||||
(lambda (mac-env)
|
|
||||||
(lambda (expr use-env)
|
|
||||||
(make-syntactic-closure mac-env '() (f expr use-env)))))
|
|
||||||
|
|
||||||
(define (rsc-macro-transformer f)
|
;; transformers
|
||||||
(lambda (mac-env)
|
|
||||||
(lambda (expr use-env)
|
|
||||||
(make-syntactic-closure use-env '() (f expr mac-env)))))
|
|
||||||
|
|
||||||
(define (er-macro-transformer f)
|
|
||||||
(lambda (mac-env)
|
|
||||||
(lambda (expr use-env)
|
|
||||||
|
|
||||||
(define rename
|
(define (sc-transformer f)
|
||||||
(memoize
|
(lambda (form use-env mac-env)
|
||||||
(lambda (sym)
|
(make-syntactic-closure mac-env '() (f form use-env))))
|
||||||
(make-identifier sym mac-env))))
|
|
||||||
|
|
||||||
(define (compare x y)
|
(define (rsc-transformer f)
|
||||||
(if (not (symbol? x))
|
(lambda (form use-env mac-env)
|
||||||
#f
|
(make-syntactic-closure use-env '() (f form mac-env))))
|
||||||
(if (not (symbol? y))
|
|
||||||
#f
|
|
||||||
(identifier=? use-env x use-env y))))
|
|
||||||
|
|
||||||
(f expr rename compare))))
|
(define (er-transformer f)
|
||||||
|
(lambda (form use-env mac-env)
|
||||||
|
(letrec
|
||||||
|
((rename (let ((register (make-register)))
|
||||||
|
(lambda (var)
|
||||||
|
(let ((id (register var)))
|
||||||
|
(if (undefined? id)
|
||||||
|
(let ((id (make-identifier var mac-env)))
|
||||||
|
(register var id)
|
||||||
|
id)
|
||||||
|
id)))))
|
||||||
|
(compare (lambda (x y)
|
||||||
|
(variable=?
|
||||||
|
(make-identifier x use-env)
|
||||||
|
(make-identifier y use-env)))))
|
||||||
|
(f form rename compare))))
|
||||||
|
|
||||||
(define (ir-macro-transformer f)
|
(define (ir-transformer f)
|
||||||
(lambda (mac-env)
|
(lambda (form use-env mac-env)
|
||||||
(lambda (expr use-env)
|
(let ((register1 (make-register))
|
||||||
|
(register2 (make-register)))
|
||||||
|
(letrec
|
||||||
|
((inject (lambda (var1)
|
||||||
|
(let ((var2 (register1 var1)))
|
||||||
|
(if (undefined? var2)
|
||||||
|
(let ((var2 (make-identifier var1 use-env)))
|
||||||
|
(register1 var1 var2)
|
||||||
|
(register2 var2 var1)
|
||||||
|
var2)
|
||||||
|
var2))))
|
||||||
|
(rename (let ((register (make-register)))
|
||||||
|
(lambda (var)
|
||||||
|
(let ((id (register var)))
|
||||||
|
(if (undefined? id)
|
||||||
|
(let ((id (make-identifier var mac-env)))
|
||||||
|
(register var id)
|
||||||
|
id)
|
||||||
|
id)))))
|
||||||
|
(flip (lambda (var2) ; unwrap if injected, wrap if not injected
|
||||||
|
(let ((var1 (register2 var2)))
|
||||||
|
(if (undefined? var1)
|
||||||
|
(rename var2)
|
||||||
|
var1))))
|
||||||
|
(walk (lambda (f form)
|
||||||
|
(cond
|
||||||
|
((variable? form)
|
||||||
|
(f form))
|
||||||
|
((pair? form)
|
||||||
|
(cons (walk f (car form)) (walk f (cdr form))))
|
||||||
|
((vector? form)
|
||||||
|
(list->vector (walk f (vector->list form))))
|
||||||
|
(else
|
||||||
|
form))))
|
||||||
|
(compare (lambda (x y)
|
||||||
|
(variable=?
|
||||||
|
(make-identifier x mac-env)
|
||||||
|
(make-identifier y mac-env)))))
|
||||||
|
(walk flip (f (walk inject form) inject compare))))))
|
||||||
|
|
||||||
(define icache* (make-dictionary))
|
(define-macro sc-macro-transformer
|
||||||
|
(lambda (f mac-env)
|
||||||
|
#`(lambda (form use-env)
|
||||||
|
((sc-transformer #,(cadr f)) form use-env #,mac-env))))
|
||||||
|
|
||||||
(define inject
|
(define-macro rsc-macro-transformer
|
||||||
(memoize
|
(lambda (f mac-env)
|
||||||
(lambda (sym)
|
#`(lambda (form use-env)
|
||||||
(define id (make-identifier sym use-env))
|
((rsc-transformer #,(cadr f)) form use-env #,mac-env))))
|
||||||
(dictionary-set! icache* id sym)
|
|
||||||
id)))
|
|
||||||
|
|
||||||
(define rename
|
(define-macro er-macro-transformer
|
||||||
(memoize
|
(lambda (f mac-env)
|
||||||
(lambda (sym)
|
#`(lambda (form use-env)
|
||||||
(make-identifier sym mac-env))))
|
((er-transformer #,(cadr f)) form use-env #,mac-env))))
|
||||||
|
|
||||||
(define (compare x y)
|
(define-macro ir-macro-transformer
|
||||||
(if (not (symbol? x))
|
(lambda (f mac-env)
|
||||||
#f
|
#`(lambda (form use-env)
|
||||||
(if (not (symbol? y))
|
((ir-transformer #,(cadr f)) form use-env #,mac-env)))))
|
||||||
#f
|
|
||||||
(identifier=? mac-env x mac-env y))))
|
|
||||||
|
|
||||||
(walk (lambda (sym)
|
|
||||||
(let ((value (dictionary-ref icache* sym)))
|
|
||||||
(if (undefined? value)
|
|
||||||
(rename sym)
|
|
||||||
value)))
|
|
||||||
(f (walk inject expr) inject compare)))))
|
|
||||||
|
|
||||||
;; (define (strip-syntax form)
|
|
||||||
;; (walk ungensym form))
|
|
||||||
|
|
||||||
(define-syntax define-macro
|
|
||||||
(er-macro-transformer
|
|
||||||
(lambda (expr r c)
|
|
||||||
(define formal (car (cdr expr)))
|
|
||||||
(define body (cdr (cdr expr)))
|
|
||||||
(if (symbol? formal)
|
|
||||||
(list (r 'define-syntax) formal
|
|
||||||
(list (r 'lambda) (list (r 'form) '_ '_)
|
|
||||||
(list (r 'apply) (car body) (list (r 'cdr) (r 'form)))))
|
|
||||||
(list (r 'define-macro) (car formal)
|
|
||||||
(cons (r 'lambda)
|
|
||||||
(cons (cdr formal)
|
|
||||||
body))))))))
|
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue