monreflect.scm

(define (s:reify thunk)
  (reset-at 'state (s:return (thunk))))

(define (s:reflect m)
  (shift-at 'state k (s:>>= m k)))

(define (r:reify thunk)
  (reset-at 'reader (return (thunk))))

(define (r:reflect m)
  (shift-at 'reader k (>>= m k)))


;;; renaming
(define (incr)
  (s:reflect (s:modify 1+)))

(define (uniquify name)
  (string-append name "." (number->string (incr))))

(define (lookup name)
  (r:reflect (asks (lambda (env)
                     (and=> (assoc name env) cdr)))))

(define (with-extended-environment var val m)
  (r:reflect (local (lambda (env)
                      (cons (cons var val) env))
                    (r:reify m))))

(define (rename exp)
  (type-case expr exp
    [Id (x)
        (if-let [v (lookup x)]
                (Id v)
                (Id (uniquify x)))]     ; free variable
    [Apply (p a)
           (Apply (rename p)
                  (rename a))]
    [Lambda (v b)
       (let ((v* (uniquify v)))
         (Lambda v*
            (with-extended-environment v v*
              (lambda ()
                (rename b)))))]))

(define (do-rename expr)
  (let ((pair
         ((s:reify (lambda ()
                     ((r:reify (lambda () (rename expr)))
                      ;; initial env
                      '())))
          ;; initial state
          0)))
    (car pair)))