Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
Explicit renaming macro expander for scheme with Dybvig's syntax-object
; explicit renaming macro expander
; Hanson-Bawden alias as Dybvig syntax-object.
(use util.match)
(define so-macro-proc-environment (interaction-environment))
(define so-unique-id-counter 0)
(define (so-reset-unique-id-counter) (set! so-unique-id-counter 0))
(define (so-expand form env)
(cond
((so-identifier? form)
(let ((d (so-lookup env form)))
(cond
((so-subst? d) (so-subst-name d))
((so-special? d) (so-special-name d))
((so-macro? d) (so-expand-macro d form env))
(else (error "so-expand id cannot happen")))))
((and (pair? form) (so-identifier? (car form)))
(let ((d (so-lookup env (car form))))
(cond
((so-subst? d) (cons (so-subst-name d) (so-expand-list (cdr form) env)))
((so-special? d) (so-expand-special (so-special-name d) form env))
((so-macro? d) (so-expand-macro d form env))
(else (error "so-expand kw cannot happen")))))
((pair? form) (so-expand-list form env))
((null? form) '())
((so-self-evaluating? form) form)
(else (error "invalid syntax" (so-strip-syntax form)))))
(define (so-self-evaluating? x)
(or (boolean? x) (number? x) (char? x) (string? x)))
(define er-macro-transformer identity)
(define (so-expand-macro macro form exp-env)
(let ((mark (make-so-mark)) (table '()))
(let ((exp-env (so-extend-env mark exp-env))
(def-env (so-extend-env mark (so-macro-env macro))))
(let ((rename (lambda (x)
(cond
((assq x table) => cdr)
(else
(let ((alias (so-extend-wrap def-env x)))
(set! table (cons (cons x alias) table))
alias)))))
(compare (lambda (x y) (so-identifier=? exp-env x exp-env y))))
(so-expand ((so-macro-proc macro) form rename compare) exp-env)))))
(define (so-expand-list form env)
(let ((ex (lambda (form) (so-expand form env))))
(so-map* ex ex form)))
(define (so-expand-special keyword form env)
(case keyword
((quote) (list 'quote (so-strip-syntax (cadr form))))
((syntax-quote) (list 'quote (cadr form)))
((lambda) (so-expand-lambda form env))
((let-syntax) (so-expand-let-syntax form env))
((letrec-syntax) (so-expand-letrec-syntax form env))
((if set! begin) (cons keyword (so-expand-list (cdr form) env)))
(else (error "so-expand unknown special form" keyword))))
(define (so-expand-lambda form env)
(or
(match form
((_ idents body ..1)
(and (so-every* so-identifier? (lambda (x) (or (null? x) (so-identifier? x))) idents)
(let* ((uid (so-generate-uid))
(gen-var (lambda (id) (if (null? id) '() (so-gen-var id uid))))
(bind (lambda (id x.i) (so-bind-id-denotation id (make-so-subst x.i))))
(tail-bind (lambda (id x.i) (if (null? id) '() (list (bind id x.i)))))
(vars (so-map* gen-var gen-var idents))
(frame (make-so-frame (so-map* bind tail-bind idents vars))))
`(lambda ,vars ,@(so-expand-list body (so-extend-env frame env))))))
(else #f))
(error "so-expand invalid lambda form" (so-strip-syntax form))))
(define (so-expand-let-syntax form env)
(match form
((_ (((? so-identifier? keywords) transformers) ...) body ..1)
(let ((frame (make-so-frame '())))
(so-frame-set! frame (so-bind-let-syntax keywords transformers env))
(if (null? (cdr body))
(so-expand (car body) (so-extend-env frame env))
`(begin ,@(so-expand-list body (so-extend-env frame env))))))
(else "so-expand invalid let-syntax form" (so-strip-syntax form))))
(define (so-expand-letrec-syntax form env)
(match form
((_ (((? so-identifier? keywords) transformers) ...) body ..1)
(let* ((frame (make-so-frame '()))
(env (so-extend-env frame env)))
(so-frame-set! frame (so-dummy-letrec-syntax keywords env))
(so-frame-set! frame (so-bind-let-syntax keywords transformers env))
(if (null? (cdr body))
(so-expand (car body) env)
`(begin ,@(so-expand-list body env)))))
(else "so-expand invalid letrec-syntax form" (so-strip-syntax form))))
(define (so-define env keyword denotation)
(so-frame-set! (car env)
(cons (so-bind-id-denotation keyword denotation) (so-frame-ref (car env)))))
(define (so-define-special env keyword)
(so-define env keyword (make-so-special keyword)))
(define (so-define-syntax env keyword form)
(so-define env keyword (so-close-macro form env)))
(define (so-macro-unspecified x r c)
(error "letrec-syntax unspecified macro"))
(define (so-dummy-letrec-syntax keywords env)
(map (lambda (keyword)
(so-bind-id-denotation keyword (so-close-macro so-macro-unspecified env)))
keywords))
(define (so-bind-let-syntax keywords forms env)
(map (lambda (keyword form) (so-bind-id-denotation keyword (so-close-macro form env)))
keywords forms))
(define (so-close-macro form env)
(let ((proc (if (procedure? form) form (so-eval-macro-form form env))))
(if (and (procedure? proc) (eqv? (arity proc) 3))
(make-so-macro proc (filter so-frame? env))
(error "macro must be (procedure expr rename compare)" proc))))
(define (so-eval-macro-form form env)
(eval (so-expand form env) so-macro-proc-environment))
(define (so-vector-record-type? type len)
(lambda (x)
(and (vector? x) (= (vector-length x) len) (eq? (vector-ref x 0) type))))
(define (make-so-syntax-object form wrap) (vector 'so-syntax-object form wrap))
(define so-syntax-object? (so-vector-record-type? 'so-syntax-object 3))
(define (so-syntax-object-form x) (vector-ref x 1))
(define (so-syntax-object-wrap x) (vector-ref x 2))
(define (make-so-mark) (vector 'so-mark))
(define so-mark? (so-vector-record-type? 'so-mark 1))
(define (make-so-frame dict) (vector 'so-frame dict))
(define so-frame? (so-vector-record-type? 'so-frame 2))
(define (so-frame-ref x) (vector-ref x 1))
(define (so-frame-set! x y) (vector-set! x 1 y))
(define (make-so-binding sym mark* denotation) (vector 'so-binding sym mark* denotation))
(define so-binding? (so-vector-record-type? 'so-binding 4))
(define (so-binding-sym x) (vector-ref x 1))
(define (so-binding-mark* x) (vector-ref x 2))
(define (so-binding-denotation x) (vector-ref x 3))
(define (make-so-subst name) (vector 'so-subst name))
(define so-subst? (so-vector-record-type? 'so-subst 2))
(define (so-subst-name x) (vector-ref x 1))
(define (make-so-special name) (vector 'so-special name))
(define so-special? (so-vector-record-type? 'so-special 2))
(define (so-special-name x) (vector-ref x 1))
(define (make-so-macro proc env) (vector 'so-macro proc env))
(define so-macro? (so-vector-record-type? 'so-macro 3))
(define (so-macro-proc x) (vector-ref x 1))
(define (so-macro-env x) (vector-ref x 2))
(define (so-identifier? x)
(or (symbol? x) (and (so-syntax-object? x) (symbol? (so-syntax-object-form x)))))
(define (so-identifier-form x)
(if (symbol? x) x (so-syntax-object-form x)))
(define (so-identifier-wrap x)
(if (symbol? x) '() (so-syntax-object-wrap x)))
(define (so-identifier-mark* x)
(if (symbol? x) '() (filter so-mark? (so-syntax-object-wrap x))))
(define (so-identifier=? env1 id1 env2 id2)
(and (so-identifier? id1) (so-identifier? id2)
(let ((d1 (so-lookup env1 id1)) (d2 (so-lookup env2 id2)))
(or (eq? d1 d2)
(and (so-subst? d1) (so-subst? d2)
(eq? (so-subst-name d1) (so-subst-name d2)))))))
(define (so-bound-identifier=? id1 id2)
(and (so-identifier? id1) (so-identifier? id2)
(eq? (so-identifier-form id1) (so-identifier-form id2))
(so-same-mark? (so-identifier-mark* id1) (so-identifier-mark* id2))))
(define (so-lookup env id)
(let ((sym (so-identifier-form id)) (mark* (so-identifier-mark* id)))
(if (and (pair? mark*) (pair? (cdr mark*)) (eq? (car env) (car mark*)))
(so-lookup-expanding (cdr env) sym (cdr mark*) id)
(so-lookup-expanding env sym mark* id))))
(define (so-lookup-expanding env sym id-mark* id)
(let loop ((mark* id-mark*) (env env))
(cond
((null? env) (so-lookup-defined sym id-mark* id))
((so-frame? (car env))
(cond
((so-assoc-frame sym mark* (car env)) => so-binding-denotation)
(else (loop mark* (cdr env)))))
((so-mark? (car env))
(cond
((and (pair? mark*) (eq? (car env) (car mark*))) (so-lookup-defined sym id-mark* id))
(else (loop mark* (cdr env)))))
(else (error "cannot happen so-lookup-expanding")))))
(define (so-lookup-defined sym mark* id)
(let loop ((mark* mark*) (wrap (so-identifier-wrap id)))
(cond
((null? wrap) (make-so-subst sym))
((so-frame? (car wrap))
(cond
((so-assoc-frame sym mark* (car wrap)) => so-binding-denotation)
(else (loop mark* (cdr wrap)))))
((so-mark? (car wrap))
(cond
((and (pair? mark*) (eq? (car wrap) (car mark*))) (loop (cdr mark*) (cdr wrap)))
(else (loop mark* (cdr wrap)))))
(else (error "cannot happen so-lookup-defined")))))
(define (so-extend-env mark-or-frame env)
(cons mark-or-frame env))
(define (so-bind-id-denotation id denotation)
(let ((sym (so-identifier-form id)) (mark* (so-identifier-mark* id)))
(make-so-binding sym mark* denotation)))
(define (so-same-mark? m1* m2*)
(if (pair? m1*)
(and (pair? m2*) (eq? (car m1*) (car m2*)) (so-same-mark? (cdr m1*) (cdr m2*)))
(null? m2*)))
(define (so-assoc-frame sym mark* frame)
(let loop ((binds (so-frame-ref frame)))
(cond
((null? binds) #f)
((so-bound? sym mark* (car binds)) (car binds))
(else (loop (cdr binds))))))
(define (so-bound? sym mark* binding)
(and (eq? sym (so-binding-sym binding))
(so-same-mark? mark* (so-binding-mark* binding))))
(define (so-extend-wrap wrap x)
(if (so-syntax-object? x)
(make-so-syntax-object (so-syntax-object-form x)
(so-extend-env (car wrap) (so-syntax-object-wrap x)))
(make-so-syntax-object x wrap)))
(define (so-strip-syntax x)
(cond
((so-syntax-object? x) (so-strip-syntax (so-syntax-object-form x)))
((pair? x)
(let ((a (so-strip-syntax (car x))) (b (so-strip-syntax (cdr x))))
(if (and (eq? a (car x)) (eq? b (cdr x))) x (cons a b))))
((vector? x) (list->vector (so-strip-syntax (vector->list x))))
(else x)))
(define so-syntax->datum so-strip-syntax)
(define (so-generate-uid)
(set! so-unique-id-counter (+ so-unique-id-counter 1))
so-unique-id-counter)
(define (so-gen-var id uid)
(string->symbol
(string-append
(symbol->string (so-identifier-form id)) "." (number->string uid))))
;(define (so-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 so-map* map*) ; Gauche 0.9.5
(define (so-every* f g x)
(if (pair? x)
(and (f (car x)) (so-every* f g (cdr x)))
(g x)))
(define (so-match? form pattern)
(cond
((null? pattern) (null? form))
((and (pair? pattern) (pair? (cdr pattern)) (eq? (cadr pattern) '...))
(so-every* (lambda (x) (so-match? x (car pattern)))
(lambda (x) (so-match? x (cddr pattern))) form))
((pair? pattern) (and (pair? form)
(so-match? (car form) (car pattern))
(so-match? (cdr form) (cdr pattern))))
(else #t)))
(define (so-core-syntactic-environment)
(let ((env (list (make-so-frame '()))))
(so-define-special env 'quote)
(so-define-special env 'syntax-quote)
(so-define-special env 'lambda)
(so-define-special env 'let-syntax)
(so-define-special env 'letrec-syntax)
(so-define-special env 'if)
(so-define-special env 'begin)
(so-define-special env 'set!)
env))
(define (demo)
(so-expand
'(letrec-syntax
((or
(er-macro-transformer
(lambda (form rename compare)
(if (so-match? form '(_)) #f
(if (so-match? form '(_ e1)) (cadr form)
(if (so-match? form '(_ e1 e2 ...))
`((,(rename 'lambda) (,(rename 't))
(,(rename 'if) ,(rename 't)
,(rename 't)
(,(rename 'or) ,@(cddr form)))) ,(cadr form)))))))))
((lambda (t) (or 1 t)) #f))
(so-core-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.