Skip to content

Instantly share code, notes, and snippets.

@iambrj
Created February 8, 2023 15:20
Show Gist options
  • Save iambrj/eaa22b646d0db0efc7c17ec31b37139f to your computer and use it in GitHub Desktop.
Save iambrj/eaa22b646d0db0efc7c17ec31b37139f to your computer and use it in GitHub Desktop.
#lang racket
(provide (all-defined-out))
#|
(define x ...)
(define-syntax (premade-or e)
(or e x))
(define-syntax (premade-or-2 e)
(let ([y e])
(or y x)))
(let ([x (quote 5)]) sc1
(let ([y (quote 10)]) sc2
(premade-or-2 x))) (sc1 sc2)
|#
#|
L
<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
|#
#|
(define-syntax (premade-or-2 e)
(let ([y e]) ; sc3
(or y x)))
(let ([x (quote 5)]) ; sc1
(let ([y (quote 10)]) ; sc2
(premade-or-2 x))) ; x -> (sc1 sc2), y -> (sc2)
=>
(let ([x (quote 5)]) ; sc1
(let ([y (quote 10)]) ; sc1, sc2
(let ([y y]) ; (car y) -> sc1, sc2, sc3, (cdr y) -> sc3
(or y x))))
|#
; binding as set of scopes
(struct syntax (e scopes))
; helpers: identifer?, datum->syntax, syntax->datum
(define identifer? syntax?)
(define (datum->syntax s)
(syntax s (set)))
(define (syntax->datum s)
(syntax-e s))
; scope & helpers: adjust-scope (add, flip)
(struct scope ())
; Either syntax (list syntax) -> (set scope -> scope -> (set scope)) -> scope -> Either syntax (list syntax)
(define (adjust-scope expr op sc)
(cond
[(identifier? expr) (syntax (syntax-e expr) (op (syntax-scopes expr) sc))]
[(list? expr) (map (lambda (e) (adjust-scope e op sc)) expr)]
[else (error "Invalid adjust-scope call")]))
(define (set-flip s e)
(if (set-member? s e) (set-remove s e) (set-add s e)))
(define (flip-scope expr sc) (adjust-scope expr set-flip sc))
(define (add-scope expr sc) (adjust-scope expr set-add sc))
; global binding table: add-binding!, resolve
; (syntax -> gensym'd symbol)
(define all-bindings (make-hash))
(define (add-binding! id sym) (hash-set! all-bindings id sym))
; (let ([a a-rhs]) (a sc1) -> loc/a
; (let ([b b-rhs]) (a sc1) (b sc1 sc2)
; body)) (a sc1 sc2) -> loc/a
; (let ([c ...]) body) (sc1) -> loc/c1
; (let ([c ...]) body) (sc2) -> loc/c2
; resolve (syntax 'c (sc1 sc2)) => error
; resolve (syntax 'c (sc1)) => loc/c1
; resolve (syntax 'c (sc2)) => loc/c2
(define (resolve id)
(let ([candidate-bindings (get-candidate-bindings id)])
(let ([max-binding (argmax (compose set-count syntax-scopes) candidate-bindings)])
(if (ambiguous? max-binding candidate-bindings)
(error "Bad resolution")
(hash-ref all-bindings max-binding)))))
(define (get-candidate-bindings id)
(filter (lambda (cid)
(and (eq? (syntax-e id) (syntax-e cid))
(subset? (syntax-scopes cid)
(syntax-scopes id))))
(hash-keys all-bindings)))
(define (ambiguous? max-binding candidate-bindings)
(let ([sz (set-count (syntax-scopes max-binding))])
(not (= 1 (length (filter (lambda (c-bind)
(= sz (set-count (syntax-scopes c-bind))))
candidate-bindings))))))
; core-scope, core-forms, core-primitives, add-scope
(define core-scope (scope))
(define core-forms '(lambda quote let-syntax quote-syntax))
(define core-primitives '(datum->syntax syntax->datum cons car cdr pair? syntax-e))
(map (lambda (core-x)
(add-binding! core-x (gensym core-x)))
(append core-forms core-primitives))
; empty-env, variable, env-extend, env-lookup, add-local-binding!
(define empty-env (make-hash))
(define (env-extend env key val) (hash-set env key val))
(define (env-lookup env key) (hash-ref env key #f))
(define (add-local-binding! id)
(let ([binding (gensym id)])
(add-binding! id binding)
binding))
; expand, expand-identifier, expand-id-app, apply-transformer, expand-lambda,
(define (expand expr [env empty-env])
(cond
; (lambda (x) *x*)
[(identifier? expr) (expand-identifier x env)]
; (core-form ...)
; (let-syntax ([id rhs]) body)
; (lambda (id) body)
; (quote-syntax datum)
; (quote datum)
; ((lambda (x) (mf x)) (quote 5))
; (mf ...)
[(pair? expr)
(case (car expr)
[(let-syntax) (expand-let-syntax expr env)]
[(lambda) (expand-lambda expr env)]
[(quote quote-syntax) expr]
[else (let ([expanded-car (expand (car expr) env)]
[expanded-cdr (expand (cdr expr) env)])
(if (procedure? expanded-car)
(apply-transformer expanded-car expanded-cdr env)
(cons expanded-car expanded-cdr)))])]
[(null? expr)
expr]
[else (error "Unable to expand")]))
(define (expand-identifier id env)
(let ([binding (resolve id)])
(let ([val (env-lookup env id)])
(cond
[(not val) (error "Out of scope: " id)]
[(eq? 'variable val) id]
[else (error "Unable to expand identifier: " id)]))))
; new-scope is attached to only those identifier that are introduced by mf
(define (apply-transformer mf t env)
(let ([new-scope (scope)])
(let ([t (add-scope t new-scope)])
(let ([expanded (mf t)])
(flip-scope expanded new-scope)))))
(define (expand-lambda expr env)
(match-define `(lambda (,id) ,body) expr)
(let ([new-scope (scope)])
(let ([id (add-scope id new-scope)])
(let ([binding (add-local-binding! id)])
(let ([body-env (env-extend env binding 'variable)])
(expand (add-scope body new-scope) body-env))))))
; expand-let-syntax, expand-app, compile
(define (expand-let-syntax expr env)
(match-define `(let-syntax ([,id ,rhs]) ,body) expr)
(let ([new-scope (scope)])
(let ([id (add-scope id new-scope)])
(let ([binding (add-local-binding! id)])
(let ([compiled-rhs (eval-compiled (compile (expand rhs empty-env)))])
(let ([body-env (env-extend env binding compiled-rhs)])
(expand (add-scope body new-scope) body-env)))))))
(define (compile expr)
(case (car expr)
[(lambda)
(match-define `(lambda (,id) ,body) expr)
(let ([arg (resolve id)])
`(lambda (,arg) ,(compile body)))]
[(quote)
(match-define `(quote ,datum) expr)
`(quote ,(syntax-e datum))]
[(quote-syntax)
(match-define `(quote ,datum) expr)
`(quote ,datum)]
[(list? expr) (map compile expr)]
[(identifier? expr)
(resolve expr)]))
(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