Skip to content

Instantly share code, notes, and snippets.

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

Embed
What would you like to do?
Hanson-Bawden syntactic closures hygienic macro expander for tiny scheme core language
; syntactic closures based on
; Alan Bawden, Jonathan Rees, ``Syntactic Closures'', 1988
; Chris Hanson, ``A Syntactic Closures Macro Facility'', 1991
; William Clinger, ``Hygienic Macros Through Explicit Renaming'', 1991
(use util.match)
(define sc-macro-proc-environment (interaction-environment))
(define sc-unique-id-counter 0)
(define (sc-reset-unique-id-counter) (set! sc-unique-id-counter 0))
; Expander
(define (sc-expand form env)
(cond
((sc-identifier? form)
(let ((denotation (sc-lookup form env)))
(cond
((sc-macro? denotation) (sc-expand-macro denotation form env))
((sc-subst? denotation) (sc-subst-name denotation))
((sc-special? denotation) (sc-special-name denotation))
(else (error "sc-expander: cannot happen" denotation)))))
((sc-syntactic-closure? form)
(sc-expand (sc-syntactic-closure-form form) (sc-syntactic-closure-extend form env)))
((and (pair? form) (sc-identifier? (car form)))
(let ((denotation (sc-lookup (car form) env)))
(cond
((sc-macro? denotation) (sc-expand-macro denotation form env))
((sc-special? denotation) (sc-expand-special denotation form env))
(else (sc-expand-list form env)))))
((pair? form) (sc-expand-list form env))
(else form)))
(define (sc-expand-list form* env)
(let ((ex (lambda (form) (sc-expand form env))))
(sc-map* ex ex form*)))
(define (sc-expand-macro mac form env)
(sc-expand ((sc-macro-proc mac) form env (sc-macro-env mac)) env))
(define (sc-expand-special denotation form env)
(let ((keyword (sc-special-name denotation)))
(case keyword
((quote) `(quote ,(sc-strip (cadr form))))
((syntax-quote) `(quote ,(cadr form)))
((lambda) (sc-expand-lambda form env))
((let-syntax) (sc-expand-let-syntax form env))
((letrec-syntax) (sc-expand-letrec-syntax form env))
((if set! begin) `(,keyword ,@(sc-expand-list (cdr form) env)))
(else (error "unknown special form" form)))))
(define (sc-expand-lambda form env)
(match form
((_ idents body ..1)
(unless (sc-every* sc-identifier? (lambda (x) (or (null? x) (sc-identifier? x))) idents)
(error "sc-expand invalid lambda form"))
(let* ((uid (sc-generate-uid))
(gen-var (lambda (x) (if (sc-identifier? x) (sc-gen-var (sc-strip x) uid) '())))
(bind (lambda (x x.i) (cons x (make-sc-subst x.i))))
(tail-bind (lambda (x x.i) (if (null? x) '() (list (bind x x.i)))))
(vars (sc-map* gen-var gen-var idents))
(frame (sc-map* bind tail-bind idents vars)))
`(lambda ,vars ,@(sc-expand-list body (cons frame env)))))))
(define (sc-expand-let-syntax form exp-env)
(match form
((_ ((keywords transformers) ...) body ...)
(let ((frame (sc-bind-syntax keywords transformers exp-env)))
(let ((exp-env (cons frame exp-env)))
(if (null? (cdr body))
(sc-expand (car body) exp-env)
`(begin ,@(sc-expand-list body exp-env))))))))
(define (sc-expand-letrec-syntax form exp-env)
(match form
((_ ((keywords transformers) ...) body ...)
(let ((exp-env (cons (sc-bind-dummy-frame keywords exp-env) exp-env)))
(set-car! exp-env (sc-bind-syntax keywords transformers exp-env))
(if (null? (cdr body))
(sc-expand (car body) exp-env)
`(begin ,@(sc-expand-list body exp-env)))))))
(define (sc-define x denotation env)
(set-car! env (cons (cons x denotation) (car env)))
x)
(define (sc-define-special kw env)
(sc-define kw (make-sc-special kw) env))
(define (sc-define-syntax kw form env)
(sc-define kw (sc-close-macro form env) env))
; Identifier
(define (sc-identifier? x)
(or (symbol? x)
(and (sc-syntactic-closure? x) (sc-identifier? (sc-syntactic-closure-form x)))))
(define (sc-identifier=? env1 x1 env2 x2)
(and (sc-identifier? x1) (sc-identifier? x2)
(let ((denotation1 (sc-lookup x1 env1))
(denotation2 (sc-lookup x2 env2)))
(or (eq? denotation1 denotation2)
(and (sc-subst? denotation1) (sc-subst? denotation2)
(eq? (sc-subst-name denotation1) (sc-subst-name denotation2)))))))
; Syntactic Closure
(define (make-sc-syntactic-closure env vars form)
(vector 'syntactic-closure env vars form))
(define make-syntactic-closure make-sc-syntactic-closure)
(define (sc-syntactic-closure? x)
(and (vector? x) (= (vector-length x) 4) (eq? (vector-ref x 0) 'syntactic-closure)))
(define (sc-syntactic-closure-env x)
(vector-ref x 1))
(define (sc-syntactic-closure-form x)
(vector-ref x 3))
(define (sc-syntactic-closure-extend x env)
(cons
(map (lambda (v) (cons v (sc-lookup v env))) (vector-ref x 2))
(sc-syntactic-closure-env x)))
(define (sc-strip form)
(cond
((pair? form)
(let ((a (sc-strip (car form)))
(b (sc-strip (cdr form))))
(if (eq? a b) form (cons a b))))
((sc-syntactic-closure? form) (sc-strip (sc-syntactic-closure-form form)))
((vector? form) (list->vector (sc-strip (vector->list form))))
(else form)))
; Syntactic Environment = (((Symbol . Denotation) ...) ...)
(define (sc-capture-syntactic-environment kont)
`(,(make-syntactic-closure
`(((foo ,@(make-sc-macro (lambda (form exp-env def-env) (kont exp-env)) '()))))
'()
'foo)))
(define (sc-lookup x env)
(cond
((not (sc-identifier? x)) (error "sc-lookup requires identifier" x))
((sc-assoc-env x env) => cdr)
((symbol? x) (make-sc-subst x))
(else (sc-lookup (sc-syntactic-closure-form x) (sc-syntactic-closure-env x)))))
(define (sc-assoc-env x env)
(let loop ((env env))
(cond
((null? env) #f)
((pair? env) (or (assq x (car env)) (loop (cdr env))))
(else (error "sc-assoc-env - cannot happen")))))
(define (sc-bind-syntax keywords transformers exp-env)
(map (lambda (keyword form) (cons keyword (sc-close-macro form exp-env)))
keywords transformers))
(define (sc-macro-unspecified x e d)
(error "letrec-syntax unspecified macro"))
(define (sc-bind-dummy-frame keywords exp-env)
(map (lambda (keyword) (cons keyword (make-sc-macro sc-macro-unspecified exp-env)))
keywords))
; Transformer
(define (sc-close-macro form exp-env)
(let ((proc (sc-eval-macro-form form exp-env)))
(if (and (procedure? proc) (eqv? (arity proc) 3))
(make-sc-macro proc exp-env)
(error "macro must be procedure" form))))
(define (sc-eval-macro-form form exp-env)
(eval (sc-expand form exp-env) sc-macro-proc-environment))
(define (sc-macro-transformer proc)
(lambda (form exp-env def-env)
(make-syntactic-closure def-env '() (proc form exp-env))))
(define (rsc-macro-transformer proc)
(lambda (form exp-env def-env)
(proc form def-env)))
(define (er-macro-transformer proc)
(lambda (form exp-env def-env)
(let ((table '()))
(let ((rename (lambda (x)
(cond
((assq x table) => cdr)
(else
(let ((alias_x (make-syntactic-closure def-env '() x)))
(set! table (cons (cons x alias_x) table))
alias_x)))))
(compare (lambda (x y) (sc-identifier=? exp-env x exp-env y))))
(proc form rename compare)))))
; Variable
(define (sc-generate-uid)
(set! sc-unique-id-counter (+ sc-unique-id-counter 1))
sc-unique-id-counter)
(define (sc-gen-var sym uid)
(string->symbol
(string-append
(symbol->string sym)
"."
(number->string uid))))
; Denotation = ('subst . binding-variable-symbol)
; | ('special . keyword)
; | ('macro macro-procedure . defined-syntactic-env)
(define (sc-record-denotation kind)
(lambda spec
(cons kind (apply cons* spec))))
(define (sc-record-denotation-kind? kind)
(lambda (x)
(and (pair? x) (eq? (car x) kind))))
(define make-sc-subst (sc-record-denotation 'subst))
(define sc-subst? (sc-record-denotation-kind? 'subst))
(define sc-subst-name cdr)
(define make-sc-special (sc-record-denotation 'special))
(define sc-special? (sc-record-denotation-kind? 'special))
(define sc-special-name cdr)
(define make-sc-macro (sc-record-denotation 'macro))
(define sc-macro? (sc-record-denotation-kind? 'macro))
(define sc-macro-proc cadr)
(define sc-macro-env cddr)
; Dotted List
;(define (sc-map* f g . a)
; (let vamap* ((a a))
; (if (every pair? a)
; (cons (apply f (map car a)) (vamap* (map cdr a)))
; (apply g a))))
(define sc-map* map*) ; Gauche 0.9.5
(define (sc-every* f g x)
(if (pair? x) (and (f (car x)) (sc-every* f g (cdr x))) (g x)))
(define (sc-match? form pattern)
(cond
((null? pattern) (null? form))
((and (pair? pattern) (pair? (cdr pattern)) (eq? (cadr pattern) '...))
(sc-every* (lambda (x) (sc-match? x (car pattern)))
(lambda (x) (sc-match? x (cddr pattern))) form))
((pair? pattern) (and (pair? form)
(sc-match? (car form) (car pattern))
(sc-match? (cdr form) (cdr pattern))))
(else #t)))
; Demos
(define (sc-core-syntactic-environment)
(let ((env (list '())))
(sc-define-special 'quote env)
(sc-define-special 'syntax-quote env)
(sc-define-special 'lambda env)
(sc-define-special 'let-syntax env)
(sc-define-special 'letrec-syntax env)
(sc-define-special 'if env)
(sc-define-special 'set! env)
(sc-define-special 'begin env)
env))
(define (er-let-macro x rename compare)
(match x
((_ (? sc-identifier? tag) ((vars args) ...) body ...)
`(((,(rename 'lambda) (,tag)
(,(rename 'set!) ,tag (,(rename 'lambda) (,@vars) ,@body)) ,tag) #f) ,@args))
((_ ((vars args) ...) body ...)
`((,(rename 'lambda) (,@vars) ,@body) ,@args))
(else (error "no matching" (sc-strip x)))))
(define (sc-scheme-syntactic-environment)
(let ((syntactic-env (sc-core-syntactic-environment)))
(sc-define-syntax 'let '(er-macro-transformer er-let-macro) syntactic-env)
(sc-reset-unique-id-counter)
syntactic-env))
(define (demo1)
(let ((syntactic-env (sc-scheme-syntactic-environment)))
(sc-expand
'(letrec-syntax
((cond
(er-macro-transformer
(lambda (form rename compare)
(if (sc-match? form '(_ (pred) . rest))
(let ((pred (caadr form)) (rest (cddr form)))
`(,(rename 'let) ((,(rename 'temp) ,pred))
(,(rename 'if) ,(rename 'temp) ,(rename 'temp) (,(rename 'cond) ,@rest))))
(if (sc-match? form '(_ (pred . form1) . rest))
(let ((pred (caadr form)) (form1 (cdadr form)) (rest (cddr form)))
(if (compare pred (rename 'else))
`(,(rename 'begin) ,@form1)
`(,(rename 'if) ,pred (,(rename 'begin) ,@form1) (,(rename 'cond) ,@rest))))
;else
(error "no matching" (sc-strip form))))))))
((lambda (x) (let ((if list) (temp x)) (cond (1) (else temp)))) 2))
syntactic-env)))
(define (demo2)
(let ((syntactic-env (sc-scheme-syntactic-environment)))
(sc-expand
'(letrec-syntax
((cond
(rsc-macro-transformer
(lambda (form def-env)
(sc-capture-syntactic-environment (lambda (exp-env)
(let ((alias_let (make-syntactic-closure def-env '() 'let))
(alias_temp (make-syntactic-closure def-env '() 'temp))
(alias_if (make-syntactic-closure def-env '() 'if))
(alias_cond (make-syntactic-closure def-env '() 'cond))
(alias_begin (make-syntactic-closure def-env '() 'begin)))
(if (sc-match? form '(_ (pred) . rest))
(let ((pred (caadr form)) (rest (cddr form)))
`(,alias_let ((,alias_temp ,pred))
(,alias_if ,alias_temp ,alias_temp (,alias_cond ,@rest))))
(if (sc-match? form '(_ (pred . form1) . rest))
(let ((pred (caadr form)) (form1 (cdadr form)) (rest (cddr form)))
(if (sc-identifier=? exp-env pred def-env 'else)
`(,alias_begin ,@form1)
`(,alias_if ,pred (,alias_begin ,@form1) (,alias_cond ,@rest))))
;else
(error "no matching" (sc-strip form)))))))))))
((lambda (x) (let ((if list) (temp x)) (cond (1) (else temp)))) 2))
syntactic-env)))
(define (demo3)
(let ((syntactic-env (sc-scheme-syntactic-environment)))
(sc-expand
'(letrec-syntax
((cond
(sc-macro-transformer
(lambda (form exp-env)
(sc-capture-syntactic-environment (lambda (def-env)
(make-syntactic-closure exp-env '()
(let ((alias_let (make-syntactic-closure def-env '() 'let))
(alias_temp (make-syntactic-closure def-env '() 'temp))
(alias_if (make-syntactic-closure def-env '() 'if))
(alias_cond (make-syntactic-closure def-env '() 'cond))
(alias_begin (make-syntactic-closure def-env '() 'begin)))
(if (sc-match? form '(_ (pred) . rest))
(let ((pred (caadr form)) (rest (cddr form)))
`(,alias_let ((,alias_temp ,pred))
(,alias_if ,alias_temp ,alias_temp (,alias_cond ,@rest))))
(if (sc-match? form '(_ (pred . form1) . rest))
(let ((pred (caadr form)) (form1 (cdadr form)) (rest (cddr form)))
(if (sc-identifier=? exp-env pred def-env 'else)
`(,alias_begin ,@form1)
`(,alias_if ,pred (,alias_begin ,@form1) (,alias_cond ,@rest))))
;else
(error "no matching" (sc-strip form))))))))))))
((lambda (x) (let ((if list) (temp x)) (cond (1) (else temp)))) 2))
syntactic-env)))
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.