chased after lexical scoping bug introduced by combination of let1 + multiple values.

compiler/bootstrapped-primitives.rkt

@@ -252,17 +252,17 @@
 
        ;; Common case: we're running multiple values.  Put the first in the val register
        ;; and go to the multiple value return.
-       ,(make-AssignImmediateStatement 'proc (make-ControlStackLabel/MultipleValueReturn))
        ,(make-AssignImmediateStatement 'val (make-EnvLexicalReference 0 #f))
        ,(make-PopEnvironment (make-Const 1) (make-Const 0))
+       ,(make-AssignImmediateStatement 'proc (make-ControlStackLabel/MultipleValueReturn))
        ,(make-PopControlFrame)
        ,(make-GotoStatement (make-Reg 'proc))
 
        ;; Special case: on a single value, just use the regular return address
        ,on-single-value
-       ,(make-AssignImmediateStatement 'proc (make-ControlStackLabel))
        ,(make-AssignImmediateStatement 'val (make-EnvLexicalReference 0 #f))
        ,(make-PopEnvironment (make-Const 1) (make-Const 0))
+       ,(make-AssignImmediateStatement 'proc (make-ControlStackLabel))
        ,(make-PopControlFrame)
        ,(make-GotoStatement (make-Reg 'proc))
 

compiler/compiler.rkt

@@ -1680,9 +1680,11 @@
                              (make-EnvLexicalReference 0 #f)
                              next-linkage/expects-single)]
           [after-body-code : Symbol (make-label 'afterLetBody)]
-          [extended-cenv : CompileTimeEnvironment (cons (extract-static-knowledge (Let1-rhs exp)
+          [extended-cenv : CompileTimeEnvironment 
+                         (cons (extract-static-knowledge (Let1-rhs exp)
                                                          (cons '? cenv))
                                cenv)]
+          [context : ValuesContext (linkage-context linkage)]
           [let-linkage : Linkage
                        (cond
                          [(NextLinkage? linkage)
@@ -1694,6 +1696,7 @@
                                  (make-LabelLinkage after-body-code (linkage-context linkage))])]
                          [(LabelLinkage? linkage)
                           (make-LabelLinkage after-body-code (LabelLinkage-context linkage))])]
+
           [body-target : Target (adjust-target-depth target 1)]
           [body-code : InstructionSequence
                      (compile (Let1-body exp) extended-cenv body-target let-linkage)])
@@ -1706,7 +1709,42 @@
       rhs-code
       body-code
       after-body-code
-      (make-PopEnvironment (make-Const 1) (make-Const 0))))))
+      
+      ;; We want to clear out the scratch space introduced by the
+      ;; let1.  However, there may be multiple values coming
+      ;; back at this point, from the evaluation of the body.  We
+      ;; look at the context and route around those values
+      ;; appropriate.
+      (cond
+        [(eq? context 'tail)
+         empty-instruction-sequence]
+        [(eq? context 'drop-multiple)
+         (make-PopEnvironment (make-Const 1)
+                              (new-SubtractArg
+                               (make-Reg 'argcount)
+                               (make-Const 1)))]
+        [(eq? context 'keep-multiple)
+         ;; dynamic number of arguments that need
+         ;; to be preserved
+
+         (make-PopEnvironment (make-Const 1)
+                              (new-SubtractArg
+                               (make-Reg 'argcount)
+                               (make-Const 1)))]
+        [else
+         (cond [(= context 0)
+                (make-PopEnvironment (make-Const 1)                                  
+                                     (make-Const 0))]
+               [(= context 1)
+                (make-PopEnvironment (make-Const 1)
+                                     (make-Const 0))]
+               [else
+                ;; n-1 values on stack that we need to route
+                ;; around
+                (make-PopEnvironment (make-Const 1)
+                                     (new-SubtractArg
+                                      (make-Const context)
+                                      (make-Const 1)))])])))))
 
 
 

tests/more-tests/isolating-bug.rkt

@@ -4,6 +4,37 @@
 
 
 (define-syntax (my-define-struct stx)
+  (syntax-case stx ()
+    [(_ name (fields ...) kw ...)
+     (with-syntax ([(names ...)
+                    (build-struct-names #'name
+                                        (syntax->list #'(fields ...))
+                                        #f
+                                        #f)])
+       (with-syntax ([cnstr (syntax-case #'(names ...) ()
+                              [(struct:name-id constructor misc ...)
+                               #'constructor])])
+         #'(begin
+             (define-values (names ...)
+               (let ()
+                 (define-struct name (fields ...) kw ...)
+                 (call-with-values (lambda ()
+                                     (let ([cnstr (lambda args
+                                                    (apply cnstr args))])
+                                       (displayln names) ...
+                                       (values names ...)))
+                                   (lambda args
+                                     (displayln "in the result of call-with-values")
+                                     (displayln args)
+                                     (apply values args))))))))]))
+
+
+
+
+
+
+
+(define-syntax (my-define-struct2 stx)
   (syntax-case stx ()
     [(_ name (fields ...) kw ...)
      (with-syntax ([(names ...)
@@ -23,6 +54,9 @@
                                  (apply cnstr args))])
                      (displayln names) ...
                      (values names ...))))))))]))
+
+
+
 (my-define-struct swf (f) #:mutable)
 (displayln "---")
 struct:swf
@@ -30,3 +64,15 @@ make-swf
 swf?
 swf-f
 set-swf-f!
+
+
+(displayln "***")
+
+
+(my-define-struct swf2 (f) #:mutable)
+(displayln "---")
+struct:swf2
+make-swf2
+swf2?
+swf2-f
+set-swf2-f!

version.rkt

@@ -6,4 +6,4 @@
 
 (provide version)
 (: version String)
-(define version "1.41")
+(define version "1.42")