picrin/contrib/10.macro/macro.scm

180 lines
5.7 KiB
Scheme
Raw Normal View History

2014-07-19 01:59:34 -04:00
(define-library (picrin macro)
2014-09-08 04:08:38 -04:00
(import (picrin base))
2014-07-19 01:59:34 -04:00
;; macro primitives
(export define-macro
2015-06-09 09:36:04 -04:00
make-identifier
identifier?
2016-02-06 09:15:53 -05:00
identifier=?
identifier-base
2016-02-06 09:15:53 -05:00
identifier-environment)
;; simple macro
(export define-syntax
syntax-quote
syntax-quasiquote
syntax-unquote
syntax-unquote-splicing)
;; misc transformers
(export call-with-current-environment
2015-06-09 09:36:04 -04:00
make-syntactic-closure
close-syntax
strip-syntax
2015-06-09 09:36:04 -04:00
sc-macro-transformer
rsc-macro-transformer
er-macro-transformer
ir-macro-transformer)
(define-macro call-with-current-environment
(lambda (form env)
`(,(cadr form) ',env)))
2014-07-19 05:14:11 -04:00
2014-07-19 05:26:03 -04:00
;; syntactic closure
2014-07-19 05:26:03 -04:00
(define (make-syntactic-closure env free form)
(letrec
2016-02-10 07:57:20 -05:00
((wrap (let ((ephemeron (make-ephemeron)))
(lambda (var)
2016-02-10 07:57:20 -05:00
(let ((id (ephemeron var)))
2015-07-18 02:28:53 -04:00
(if id
(cdr id)
(let ((id (make-identifier var env)))
2016-02-10 07:57:20 -05:00
(ephemeron var id)
2015-07-18 02:28:53 -04:00
id))))))
(walk (lambda (f form)
(cond
2016-02-06 09:15:53 -05:00
((identifier? 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)
2016-02-06 09:15:53 -05:00
(if (identifier=? var (car free))
var
(loop (cdr free))))))))
(walk f form))))
2014-07-19 01:59:34 -04:00
(define (close-syntax form env)
(make-syntactic-closure env '() form))
(define (strip-syntax form)
(letrec
((unwrap (lambda (var)
(identifier-base var)))
(walk (lambda (f form)
(cond
2016-02-06 09:15:53 -05:00
((identifier? 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)))
;; transformers
(define (sc-transformer f)
(lambda (form use-env mac-env)
(make-syntactic-closure mac-env '() (f form use-env))))
(define (rsc-transformer f)
(lambda (form use-env mac-env)
(make-syntactic-closure use-env '() (f form mac-env))))
(define (er-transformer f)
(lambda (form use-env mac-env)
(letrec
2016-02-10 07:57:20 -05:00
((rename (let ((ephemeron (make-ephemeron)))
(lambda (var)
2016-02-10 07:57:20 -05:00
(let ((id (ephemeron var)))
2015-07-18 02:28:53 -04:00
(if id
(cdr id)
(let ((id (make-identifier var mac-env)))
2016-02-10 07:57:20 -05:00
(ephemeron var id)
2015-07-18 02:28:53 -04:00
id))))))
(compare (lambda (x y)
2016-02-06 09:15:53 -05:00
(identifier=?
(make-identifier x use-env)
(make-identifier y use-env)))))
(f form rename compare))))
(define (ir-transformer f)
(lambda (form use-env mac-env)
2016-02-10 07:57:20 -05:00
(let ((ephemeron1 (make-ephemeron))
(ephemeron2 (make-ephemeron)))
(letrec
((inject (lambda (var1)
2016-02-10 07:57:20 -05:00
(let ((var2 (ephemeron1 var1)))
2015-07-18 02:28:53 -04:00
(if var2
(cdr var2)
(let ((var2 (make-identifier var1 use-env)))
2016-02-10 07:57:20 -05:00
(ephemeron1 var1 var2)
(ephemeron2 var2 var1)
2015-07-18 02:28:53 -04:00
var2)))))
2016-02-10 07:57:20 -05:00
(rename (let ((ephemeron (make-ephemeron)))
(lambda (var)
2016-02-10 07:57:20 -05:00
(let ((id (ephemeron var)))
2015-07-18 02:28:53 -04:00
(if id
(cdr id)
(let ((id (make-identifier var mac-env)))
2016-02-10 07:57:20 -05:00
(ephemeron var id)
2015-07-18 02:28:53 -04:00
id))))))
(flip (lambda (var2) ; unwrap if injected, wrap if not injected
2016-02-10 07:57:20 -05:00
(let ((var1 (ephemeron2 var2)))
2015-07-18 02:28:53 -04:00
(if var1
(cdr var1)
(rename var2)))))
(walk (lambda (f form)
(cond
2016-02-06 09:15:53 -05:00
((identifier? 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)
2016-02-06 09:15:53 -05:00
(identifier=?
(make-identifier x mac-env)
(make-identifier y mac-env)))))
(walk flip (f (walk inject form) inject compare))))))
(define-macro sc-macro-transformer
(lambda (f mac-env)
#`(lambda (form use-env)
((sc-transformer #,(cadr f)) form use-env #,mac-env))))
(define-macro rsc-macro-transformer
(lambda (f mac-env)
#`(lambda (form use-env)
((rsc-transformer #,(cadr f)) form use-env #,mac-env))))
(define-macro er-macro-transformer
(lambda (f mac-env)
#`(lambda (form use-env)
((er-transformer #,(cadr f)) form use-env #,mac-env))))
(define-macro ir-macro-transformer
(lambda (f mac-env)
#`(lambda (form use-env)
((ir-transformer #,(cadr f)) form use-env #,mac-env)))))