diff --git a/hygiene.zp b/hygiene.zp index b8e325b..db3c8ae 100644 --- a/hygiene.zp +++ b/hygiene.zp @@ -1,3 +1,11 @@ +(define GSYM-STATE 0) + +; ugly hacked gensym +(define (gensym) + (begin + (set! GSYM-STATE (add1 GSYM-STATE)) + (string->symbol (++ "GENSYM-GENERATED:" (->string GSYM-STATE))))) + (define-struct syntax (e scopes)) (define (identifier? s) (syntax:syntax? s)) @@ -5,13 +13,13 @@ (define (datum->syntax v) (cond ((syntax:syntax? v) v) - ((symbol? v) (syntax:make-syntax v [])) + ((symbol? v) (syntax:make-syntax (->string v) [])) ((list? v) (map datum->syntax v)) (else v))) (define (syntax->datum s) (cond - ((syntax:syntax? s) (syntax:get-e s)) + ((syntax:syntax? s) (string->symbol (syntax:get-e s))) ((list? s) (map syntax->datum s)) (else s))) @@ -66,4 +74,167 @@ (define all-bindings #{}) (define (add-binding! id binding) - (hash:set! all-bindings id binding)) + (hash:set! all-bindings binding id)) + +(define (resolve id) + (define candidate-ids (find-all-matching-bindings id)) + (cond + ((> (length candidate-ids) 0) + (begin + (define max-id (reduce (lambda (x y) + (if (< (length (syntax:get-scopes x)) + (length (syntax:get-scopes y))) + y + x)) + (head candidate-ids) + (tail candidate-ids))) + (check-unambiguous max-id candidate-ids) + (caar (hash:kv-filter ($ (eq? max-id (cadr %))) all-bindings)))) + (else #f))) + +(define (find-all-matching-bindings id) + (hash:values-filter ($ (and (eq? (syntax:get-e %) (syntax:get-e id)) + (all? (curry in? (syntax:get-scopes id)) + (syntax:get-scopes %)))) + all-bindings)) + +(define (check-unambiguous max-id candidate-ids) + (map ($ (unless (all? (curry in? (syntax:get-scopes max-id)) + (syntax:get-scopes %)) + (error:from-string "ambiguous:" (->string max-id)))) + candidate-ids)) + +(define core-scope (scope:new-scope)) + +(define core-forms (list "lambda" "let-syntax" "quote" "quote-syntax")) +(define core-primitives (list "datum->syntax" "syntax->datum" "syntax:get-e" + "list" "cons" "head" "cadr" "tail" "map")) + +(map ($ (add-binding! (syntax:make-syntax % (list core-scope)) %)) + (++ core-forms core-primitives)) + +(write (resolve (datum->syntax 'lambda))) +(write (resolve (add-scope (datum->syntax 'lambda) core-scope))) + +(define (introduce s) + (add-scope s core-scope)) + +(write (->string (introduce (datum->syntax 'cons)))) + +(define one-prog (introduce (datum->syntax + '(let-syntax ((one (lambda (stx) (quote-syntax '1)))) + (one))))) + +(write (->string one-prog)) + +(define (env-extend env key val) + (hash:set env (symbol->string key) val)) + +(define (env-lookup env binding) + (env binding)) + +(define variable (gensym)) + +(define (expand- s env) + (cond + ((identifier? s) (expand-identifier s env)) + ((and (list? s) (> (length s) 0) (identifier? (head s))) + (expand-id-application-form s env)) + ((list? s) (expand-app s env)) + (else (error:from-string "bad syntax:" s)))) + +(define (expand stx) (expand- stx #{})) + +(define (expand-identifier s env) + (define binding (resolve s)) + (cond + ((falsy? binding) (error:from-string "free variable:" s)) + ((in? core-primitives binding) s) + ((in? core-forms binding) (error:from-string "bad syntax:" s)) + (else + (define v (env-lookup env binding)) + (cond + ((eq? v variable) s) + ((falsy? v) (error:from-string "out of context:" s)) + (else (error:from-string "bad syntax:" s)))))) + +(define (expand-id-application-form s env) + (define binding (resolve (head s))) + (case binding + (("lambda") (expand-lambda s env)) + (("let-syntax") (expand-let-syntax s env)) + (("quote") s) + (("quote-syntax") s) + (else + (define v (env-lookup env binding)) + (cond + ((procedure? v) (expand- (apply-transformer v s) env)) + (else (expand-app s env)))))) + +(define (apply-transformer t s) + (define intro-scope (scope:new-scope)) + (define intro-s (add-scope s intro-scope)) + (define transformed-s (t intro-s)) + (flip-scope transformed-s intro-scope)) + +(define (expand-app s env) + (map (lambda (sub-s) (expand- sub-s env)) s)) + +(define (expand-lambda s env) + (begin + (define lambda-id (car s)) + (define arg-id (caadr s)) + (define body (caddr s)) + (define sc (scope:new-scope)) + (define id (add-scope arg-id sc)) + (define binding (gensym)) + (add-binding! id (symbol->string binding)) + (define body-env (env-extend env binding variable)) + (define exp-body (expand- (add-scope body sc) body-env)) + `(,lambda-id (,id) ,exp-body))) + +(define (expand-let-syntax s env) + (begin + (define lhs-id (caaadr s)) + (define rhs (car (cdaadr s))) + (define body (caddr s)) + (define sc (scope:new-scope)) + (define id (add-scope lhs-id sc)) + (define binding (gensym)) + (add-binding! id (symbol->string binding)) + (define rhs-eval (eval-for-syntax-binding rhs)) + (define body-env (env-extend env binding rhs-eval)) + (expand- (add-scope body sc) body-env))) + +(define (eval-for-syntax-binding rhs) + (eval-compiled (compile (expand- rhs #{})))) + +(define (compile s) + (cond + ((identifier? s) (resolve s)) + (else + (case (and (identifier? (head s)) (resolve (head s))) + (("lambda") + (begin + (define id (caadr s)) + (define body (caddr s)) + `(lambda (,(resolve id)) ,(compile body)))) + (("quote") + (begin + (define datum (cadr s)) + `(quote ,(syntax->datum datum)))) + (("quote-syntax") + (begin + (define datum (cadr s)) + `(quote ,datum))) + (else (map compile s)))))) + +(define env (make-base-env)) + +(eval `(define datum->syntax ,datum->syntax) env) +(eval `(define syntax->datum ,syntax->datum) env) +(eval `(define syntax:get-e ,syntax:get-e) env) + +(define (eval-compiled s) (eval s env)) + +(write (syntax->datum (expand one-prog)))