Skip to content

Instantly share code, notes, and snippets.

@iambrj
Created February 8, 2023 15:20
Show Gist options
  • Save iambrj/f6a06b51fe2dacaafc598e8f268d0c82 to your computer and use it in GitHub Desktop.
Save iambrj/f6a06b51fe2dacaafc598e8f268d0c82 to your computer and use it in GitHub Desktop.
#lang racket
#|
- Mention that we're writing expander, the interpreter comes later
- Show example with let-syntax
|#
#|
<expr> ::= (lambda (<id>) <expr>) ; procedure
| <id> ; variable
| (<expr> ... <expr>) ; procedure call
| (quote <datum>) ; literal data
| (let-syntax ([<id> <expr>]) ; macro binding
<expr>)
| (quote-syntax <datum>) ; literal syntax
(quote '(lambda (x) x)) => list
(quote-syntax '(lambda (x) x)) => syntax (datum, syntactic info)
(let-syntax ([one (lambda (stx)
(quote-syntax (quote 1)))])
(one))
=> (quote 1)
|#
; binding as set of scopes
(struct syntax (e scopes) #:transparent)
; helpers: identifer?, datum->syntax, syntax->datum
(define identifer? syntax?)
(define (datum->syntax d)
(cond
[(syntax? d) d]
[(symbol? d) (syntax d (set))]
[(list? d) (map datum->syntax d)]
[else d]))
(define (syntax->datum s)
(cond
[(syntax? s) (syntax-e s)]
[(list? s) (map syntax->datum s)]
[else s]))
; scope & helpers: adjust-scope (add, flip)
(struct scope ())
(define (add-scope id sc)
(syntax (syntax-e id) (set-add (syntax-scopes id) sc)))
(define (adjust-scope id op sc)
(syntax (syntax-e id) (op (syntax-scopes id) sc)))
(define (flip-scope id sc)
(adjust-scope id set-flip sc))
(define (set-flip s e)
(if (set-member? s e) (set-remove s e) (set-add s e)))
; eq?
; (let ([x ...]) // sc1
; (let ([y ...]) // sc2
; ...))
; global binding table: add-binding!, resolve
(define all-bindings (make-hash))
(define (add-binding! id b)
(hash-set! all-bindings id b))
(define (resolve id)
(let ([candidate-bindings (find-all-matching-bindings id)])
(if (null? candidate-bindings)
#f
(let ([max-id (argmax (compose set-count syntax-scopes) candidate-bindings)])
(if (ambiguous? max-id candidate-bindings)
(error "Ambiguous binding")
(hash-ref all-bindings max-id))))))
(define (find-all-matching-bindings id)
(filter (lambda (binding)
(subset? (syntax-scopes binding) (syntax-scopes id)))
(hash-keys bindings)))
(define (ambiguous? max-id candidate-bindings)
(or (null? candidate-bindings)
(let ([c-bind (car candidate-bindings)]
[candidate-bindings (cdr candidate-bindings)])
(and (subset? (syntax-scopes c-bind) (syntax-scopes max-id))
(ambiguous? max-id candidate-bindings)))))
#|
(let ([a ...]) // sc1, loc/a
body) // (syntax 'a (set sc1))
(let ([a ...]) // sc1, loc/a
(let ([z ...]) // sc2 loc/z
body)) // (syntax 'a (set sc1 sc2))
(resolve (syntax 'a (set sc1 sc2))) -> loc/a
(let ([b ...]) // sc1 loc/b1
(let ([b ...]) // sc2 loc/b2 (syntax 'b (set sc1))
body)) // (syntax 'b (set sc1 sc2))
(resolve (syntax 'b (set sc1 sc2))) -> loc/b2
? Why not throw away older scopes for each identifer?
(let ([c ...]) body1) // sc1 loc/c1
(let ([c ...]) body2) // sc2 loc/c2
? Give an example of a macro which triggers ambiguous
(resolve (syntax 'c (set sc1 sc2))) -> error
binding table
c -> (set sc1 sc2 sc3)
c -> (set sc1 sc2)
c -> (set sc4)
|#
; core-scope, core-forms, core-primitives, add-scope
(define core-scope (scope))
(define core-forms (seteq lambda quote let-syntax quote-syntax))
(define core-primitives (seteq datum->syntax syntax->datum cons car cdr list syntax-e))
(for ([sym (in-set (set-union core-forms core-primitives))])
(add-binding! sym (syntax sym (set core-scope))))
; empty-env, variable, env-extend, env-lookup, add-local-binding!
(define empty-env (hasheq))
(define variable (gensym 'variable))
(define (env-extend env id proc)
(hash-set env id proc))
(define (env-lookup env id)
(hash-ref env id #f))
(define (add-local-binding! id)
(let ([bind (gensym (syntax-e id))])
(add-binding! id bind)
bind))
(define (expand s [env empty-env])
(cond
; (lambda (x) *x*)
[(identifer? s) (expand-identifier s env)]
; (x ...)
[(and (pair? s)
(identifer? s))
(expand-id-app s env)]
; ((curried f) ...)
[(or (pair? s)
(null? s))
(expand-app s env)]
[else (error "Unable to expand")]))
(define (expand-identifier s env)
(let ([binding (resolve s)])
(cond
[(not binding) (error "Unbound symbol")]
[(member? core-forms binding) (error "Syntax error")]
[(member? core-primitives binding) s]
[else
(let ([v (env-lookup env s)])
(cond
[(not v) (error "Out of context variable")]
[(eq? v 'variable) s]
[else (error "Bad syntax")]))])))
(define (expand-id-app s env)
(case (car s)
[(quote-syntax) s]
[(lambda) (expand-lambda s env)]
[(let-syntax) (expand-let-syntax s env)]
[(quote quote-syntax) s]
[else
(let ([binding (resolve (car s))])
(let ([v (env-lookup env binding)])
(cond
[(procedure? v) (expand (apply-transformer v s) env)]
[else (expand-app s env)])))]))
(define (apply-transformer t s)
(let ([newscope (scope)])
(let ([scoped-s (add-scope s newscope)])
(let ([transformed-s (t s)])
(flip-scope transformed-s newscope)))))
(define (expand-lambda s env)
(match-define `(lambda (,arg) ,body) s)
(let ([new-scope (scope)])
(let ([arg (add-scope arg new-scope)])
(let ([binding (add-local-binding! arg)])
(let ([new-env (env-extend env binding 'variable)])
(let ([expanded-body (expand (add-scope body new-scope) new-env)])
`(lambda (,arg) ,expanded-body)))))))
(define (expand-let-syntax s env)
(match-define `(let-syntax ([,id ,rhs]) ,body) s)
(define new-scope (scope))
(define id (add-scope id new-scope))
(define binding (add-local-binding! id))
(define rhs-val (eval-compiled (compile (expand rhs env))))
(define new-env (env-extend env id rhs-val))
(expand (add-scope body new-scope) new-env))
(define (expand-app s env)
(map (lambda (se) (expand se env)) s))
(define (compile s)
(cond
[(pair? s)
(let ([core-sym (and (identifier? s) (resolve (car s)))])
(case core-sym
[(lambda)
(match-define `(lambda (,id) ,body) s)
`(lambda (,(resolve id)) ,(compile body))]
[(quote)
(match-define `(quote ,d) s)
`(quote ,(syntax->datum d))]
[(quote-syntax)
(match-define `(quote-syntax ,s))
`(quote ,s)]
[else
(map compile s)]))]
[(identifier? s)
(resolve s)]
[else (error "Bad syntax after expansion: " s)]))
(define namespace (make-base-namespace))
(namespace-set-variable-value! 'datum->syntax datum->syntax #t namespace)
(namespace-set-variable-value! 'syntax->datum syntax->datum #t namespace)
(namespace-set-variable-value! 'syntax-e syntax-e #t namespace)
(define (eval-compiled s)
(eval s namespace))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment