Exercise 5.43.  We argued in section 4.1.6 that internal definitions for 
block structure should not be considered ``real'' defines. Rather, a 
procedure body should be interpreted as if the internal variables being 
defined were installed as ordinary lambda variables initialized to their 
correct values using set!. Section 4.1.6 and exercise 4.16 showed how to 
modify the metacircular interpreter to accomplish this by scanning out 
internal definitions. Modify the compiler to perform the same 
transformation before it compiles a procedure body.

————————————————————————————————————————————————————————————————————————

The compiler is in 5.43-compiler.scm, here is a transcript showing both 
a top-level define using the normal code, and a define inside a lambda 
which is scanned out:

1 ]=> (pp (compile '(define (f x) (define (g x) (* x x)) (g x)) 'val 'next))
((env)
 (val)
 ((assign val (op make-compiled-procedure) (label entry2) (reg env))
  (goto (label after-lambda1))
  entry2
  (assign env (op compiled-procedure-env) (reg proc))
  (assign env (op extend-environment) (const (x)) (reg argl) (reg env))
  (save continue)
  (assign proc (op make-compiled-procedure) (label entry7) (reg env))
  (goto (label after-lambda6))
  entry7
  (assign env (op compiled-procedure-env) (reg proc))
  (assign env (op extend-environment) (const (g)) (reg argl) (reg env))
  (assign val (op make-compiled-procedure) (label entry12) (reg env))
  (goto (label after-lambda11))
  entry12
  (assign env (op compiled-procedure-env) (reg proc))
  (assign env (op extend-environment) (const (x)) (reg argl) (reg env))
  (assign proc (op lookup-variable-value) (const *) (reg env))
  (assign val (op lookup-variable-value) (const x) (reg env))
  (assign argl (op list) (reg val))
  (assign val (op lookup-variable-value) (const x) (reg env))
  (assign argl (op cons) (reg val) (reg argl))
  (test (op primitive-procedure?) (reg proc))
  (branch (label primitive-branch15))
  compiled-branch14
  (assign val (op compiled-procedure-entry) (reg proc))
  (goto (reg val))
  primitive-branch15
  (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
  (goto (reg continue))
  after-call13
  after-lambda11
  (perform (op set-variable-value!) (const g) (reg val) (reg env))
  (assign proc (const ok))
  (save continue)
  (save proc)
  (assign proc (op lookup-variable-value) (const g) (reg env))
  (assign val (op lookup-variable-value) (const x) (reg env))
  (assign argl (op list) (reg val))
  (test (op primitive-procedure?) (reg proc))
  (branch (label primitive-branch10))
  compiled-branch9
  (assign continue (label after-call8))
  (assign val (op compiled-procedure-entry) (reg proc))
  (goto (reg val))
  primitive-branch10
  (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
  after-call8
  (assign argl (op list) (reg val))
  (restore proc)
  (restore continue)
  (test (op primitive-procedure?) (reg proc))
  (branch (label primitive-branch18))
  compiled-branch17
  (assign val (op compiled-procedure-entry) (reg proc))
  (goto (reg val))
  primitive-branch18
  (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
  (goto (reg continue))
  after-call16
  after-lambda6
  (save proc)
  (assign proc (op lookup-variable-value) (const *unassigned*) (reg env))
  (assign argl (const ()))
  (test (op primitive-procedure?) (reg proc))
  (branch (label primitive-branch5))
  compiled-branch4
  (assign continue (label after-call3))
  (assign val (op compiled-procedure-entry) (reg proc))
  (goto (reg val))
  primitive-branch5
  (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
  after-call3
  (assign argl (op list) (reg val))
  (restore proc)
  (test (op primitive-procedure?) (reg proc))
  (branch (label primitive-branch21))
  compiled-branch20
  (assign continue (label proc-return22))
  (assign val (op compiled-procedure-entry) (reg proc))
  (goto (reg val))
  proc-return22
  (assign proc (reg val))
  (goto (label after-call19))
  primitive-branch21
  (assign proc (op apply-primitive-procedure) (reg proc) (reg argl))
  after-call19
  (restore continue)
  (assign argl (const ()))
  (test (op primitive-procedure?) (reg proc))
  (branch (label primitive-branch25))
  compiled-branch24
  (assign val (op compiled-procedure-entry) (reg proc))
  (goto (reg val))
  primitive-branch25
  (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
  (goto (reg continue))
  after-call23
  after-lambda1
  (perform (op define-variable!) (const f) (reg val) (reg env))
  (assign val (const ok))))

Here are the changes made:

--- ch5-compiler.scm	2001-06-21 12:54:32.000000000 -0600
+++ 5.43-compiler.scm	2010-06-06 18:20:42.000000000 -0600
@@ -192,8 +192,34 @@
                 (const ,formals)
                 (reg argl)
                 (reg env))))
-     (compile-sequence (lambda-body exp) 'val 'return))))
+     (compile-sequence (scan-out-defines (lambda-body exp)) 'val 'return))))
 
+(define (scan-out-defines seq)
+  ; (go seq) returns a list (new-variables new-sequence)
+  (define (go seq)
+    (if (null? seq)
+        '(() ())
+        (let ((exp (first-exp seq))
+              (rest (go (rest-exps seq))))
+          (if (definition? exp)
+              (list (cons (definition-variable exp) (car rest))
+                    (cons (definition-to-set exp) (cadr rest)))
+              (list (car rest)
+                    (cons exp (cadr rest)))))))
+  (let ((vars-body (go seq)))
+    (if (null? (car vars-body))
+        seq ; if no new variables, then no defines were scanned out, return original sequence
+        ; otherwise return a sequence containing only a direct lambda application
+        (let ((vars (car vars-body))
+              (body (cadr vars-body))
+              (args (map (lambda (x) '*unassigned*) (car vars-body))))
+          (make-sequence `(((lambda ,vars ,body) ,args)))))))
+
+(define (definition-to-set exp)
+  `(set! ,(definition-variable exp)
+         ,(definition-value exp)))
+
+(define make-sequence list)
 
 ;;;SECTION 5.5.3