need help with macros (again)

[Doug Orleans <dougo@ccs.neu.edu>]

I'm trying to make a little reflection system for procedures-- you can
get the source expression for a procedure definition, and you get the
lexical environment of the procedure, which you can query to find the
current values of the free variables in the procedure expression.  I'm
implementing this as two modules, one to build the environment syntax,
and one to store the exp and env for each lambda:

  (module env mzscheme
    (provide make-environment-syntax environment-value)

    ;; An "environment" that can be queried for the current bindings of
    ;; the free variables of the expression in stx.
    (define (make-environment-syntax stx)
      (let ((fv (free-variables-syntax stx)))
	(with-syntax (((var ...) fv))
	  (syntax (lambda (msg)
		    (case msg
		      ((var) var)
		      ...
		      ))))))

    (define (environment-value env var)
      (env var))

    ;; The free variables in a syntax object.
    ;; FIXME: handle other binding constructs besides lambda.
    (define (free-variables-syntax stx)
      (let loop ((stx stx) (b '()))
	(let ((e (syntax-e stx)))
	  (cond ((pair? e)
		 (if (memq (syntax-e (car e)) '(lambda))
		     (let* ((l (syntax->list stx))
			    (formals (cadr l))
			    (body (cddr l))
			    (b (union (formal-bindings
				       (syntax-object->datum formals))
				      b)))
		       (mappend (lambda (stx) (loop stx b)) body))
		     (union (loop (car e) b)
			    (mappend (lambda (stx) (loop stx b)) (cdr e)))))
		((and (symbol? e) (not (memq e b))) (list stx))
		(else '())))))

    ;; The list of symbols bound by a formal parameter list.
    (define (formal-bindings f)
      (cond ((null? f) '())
	    ((symbol? f) (list f))
	    (else (cons (car f) (formal-bindings (cdr f))))))

    (define (mappend f l) (apply append (map f l)))

    (define (union s1 s2)
      (if (null? s1)
	  s2
	  (union (cdr s1) (adjoin (car s1) s2))))

    (define (adjoin x s)
      (if (memq x s)
	  s
	  (cons x s)))

  )

  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;; Keep the source code around for procedure definitions.
  ;; Adapted from a post to the plt-scheme mailing list by Matthew Flatt.

  (module keep-source mzscheme
    (require-for-syntax env)

    (define *info* (make-hash-table 'weak))
    (define (set-procedure-info! proc exp env)
      (hash-table-put! *info* proc (cons exp env))
      proc)
    (define (get-procedure-info proc)
      (hash-table-get *info* proc
	(lambda () (error 'procedure-info "primitive procedure: ~a" proc))))

    (define (procedure-expression proc) (car (get-procedure-info proc)))
    (define (procedure-environment proc) (cdr (get-procedure-info proc)))

    (define-syntax (wrapper-lambda stx)
      (syntax-case stx ()
	((_ . rest)
	 (with-syntax ((env (make-environment-syntax (syntax (lambda . rest)))))
	   (syntax (set-procedure-info! (lambda . rest) '(lambda . rest) env))))))

    (provide procedure-expression
	     procedure-environment
	     (rename wrapper-lambda lambda))
  )

(Feel free to comment on my coding style... I'm sure
free-variables-syntax could be written more elegantly somehow.)

Okay, so the env module seems to work okay:

  Welcome to MzScheme version 200alpha15, Copyright (c) 1995-2002 PLT
  > (load "proc-info.scm")
  > (require-for-syntax env)
  > (require env)
  > (define foo (eval (with-syntax ((env (make-environment-syntax
					   (syntax (lambda (y) (+ x y))))))
			 (syntax (let ((x 3)) (cons (lambda (y) (+ x y)) env))))))
  > foo
  (#<procedure:STDIN::200> . #<procedure:...ed/proc-info.scm:9:9>)
  > ((car foo) 4)
  7
  > (environment-value (cdr foo) 'x)
  3

But the keep-source module produces an error that I can't explain:

  > (require keep-source)
  > (define foo (let ((x 3)) (lambda (y) (+ x y))))
  proc-info.scm:9:9: compile: bad syntax; function application is not allowed, because no #%app syntax transformer is bound in: (lambda (msg) (case msg ((+) +) ((x) x)))

What's going on here?  What am I doing wrong?  The expansion of lambda 
seems to be what I want it to be:

  > (syntax-object->datum (expand-once '(lambda (y) (+ x y))))
  (set-procedure-info! (lambda (y) (+ x y)) (quote (lambda (y) (+ x y))) (lambda (msg) (case msg ((+) +) ((x) x))))

I'm puzzled...

--dougo@ccs.neu.edu