closure translation

gistfile1.scm

(define (mark e)
  (let loop ((e e) (envs '()))
    (match
     e
     (('lambda args es ...)
      `(lambda ,args ,@(map (cut loop <> (cons args envs)) es)))
     ((? symbol? s)
      (cond
       ((find
	 (lambda (e) (memq s e))
	 envs)
	=> (cut list 'lvar s <>))
       (else s)))
     ((xs ...) (map (cut loop <> envs) xs))
     (else e))))

(define (add-parameter e)
  (let1 extra-envs '()
    (let loop ((e e) (envs '()))
      (match
       e
       (('lambda args es ...)
	(push! extra-envs (list #f))
	(let ((x (map (cut loop <> (cons args envs)) es))
	      (reqenvs (remove
			(lambda (e) (equal? args e))
			(drop-right (pop! extra-envs) 1))))
	  (for-each (lambda (e) (push! (car extra-envs) e)) reqenvs)
	  `(lambda (,reqenvs ,@args) ,@x)))
       (('lvar s env)
	(unless (eq? env (car envs))
	  (update! (car #?=extra-envs) (cut lset-adjoin eq? <> env)))
	e)
       ((xs ...) (map (cut loop <> envs) xs))
       (else e)))))

(define (move-toplevel e)
  (let* ((lmds '())
	 (e (let loop ((e e))
	      (match
	       e
	       (('lambda args es ...)
		(let1 name (gensym)
		      (push! lmds `(define ,name (lambda ,args ,@(map loop es))))
		      `(closure ,name ,(car args))))
	       (('lvar _ _) e)
	       ((xs ...) (map loop xs))
	       (else e)))))
    `(,@lmds ,e)))

(define (closure-convert e)
  (move-toplevel (add-parameter (mark e))))