oops, forgot to push this

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)))