From 5c73a495f9563bcccba5a5989f2ae9b50d7280bb Mon Sep 17 00:00:00 2001
From: Kaz Kylheku <kaz@kylheku.com>
Date: Thu, 15 Sep 2022 07:22:50 -0700
Subject: compiler: bug: scoping of lambda optionals.

The scoping is not behind handled correctly for optional
variables. The init-forms are being evaluated in a scope
in which all the variables are already visible, instead
of sequentially. Thus, for instance, variable rebinding
doesn't work, as in (lambda (: (x x)) ...). When the
argument is missing, x ends up with the value : because
the expression refers to the new x, rather than the
outer x.

* stdlib/compiler.tl (compiler comp-lambda-impl):
Perform the compilation of the init-forms earlier.
Use the same new trick that is used for let*:
the target for the code fragment is a locaton obtained
from get-loc, which is then attached to a variable
afterward. The spec-sub helper is extended with a loc
parameter to help with this case.

* tests/012/lambda.tl: New test case that fails without
this fix.
---
 stdlib/compiler.tl  | 32 +++++++++++++++-----------------
 tests/012/lambda.tl |  5 +++++
 2 files changed, 20 insertions(+), 17 deletions(-)

diff --git a/stdlib/compiler.tl b/stdlib/compiler.tl
index e31fa6a2..78ee5f12 100644
--- a/stdlib/compiler.tl
+++ b/stdlib/compiler.tl
@@ -1058,42 +1058,40 @@
           (when (> pars.nfix %max-lambda-fixed-args%)
             (compile-warning form "~s arguments in a lambda (max is ~s)"
                              pars.nfix %max-lambda-fixed-args%))
-          (flet ((spec-sub (sym)
+          (flet ((spec-sub (sym : (loc :))
                    (cond
                      ((special-var-p sym)
                       (let ((sub (gensym)))
                         (push (cons sym sub) specials)
                         (set need-dframe t)
-                        nenv.(extend-var sub)
+                        nenv.(extend-var sub loc)
                         sub))
                      (t
                        (push sym lexsyms)
-                       nenv.(extend-var sym)
+                       nenv.(extend-var sym loc)
                        sym))))
             (let* ((req-pars (collect-each ((rp pars.req))
                                (spec-sub rp)))
+                   (allsyms req-pars)
                    (opt-pars (collect-each ((op pars.opt))
                                (tree-bind (var-sym : init-form have-sym) op
-                                 (list (spec-sub var-sym)
-                                       init-form
-                                       (if have-sym (spec-sub have-sym))))))
-                   (rest-par (when pars.rest (spec-sub pars.rest)))
-                   (allsyms req-pars))
+                                 (let* ((loc nenv.(get-loc))
+                                        (ifrag me.(compile loc nenv init-form)))
+                                   (set fvars (uni fvars
+                                                   (diff ifrag.fvars allsyms)))
+                                   (push var-sym allsyms)
+                                   (push have-sym allsyms)
+                                   (list (spec-sub var-sym loc)
+                                         ifrag
+                                         (if have-sym (spec-sub have-sym)))))))
+                   (rest-par (when pars.rest (spec-sub pars.rest))))
               (upd specials nreverse)
               (with-closure-spy me (and (not specials)
                                         (>= *opt-level* 2))
                                 cspy (new closure-spy env nenv)
                 (let* ((col-reg (if opt-pars me.(get-dreg :)))
                        (tee-reg (if opt-pars me.(get-dreg t)))
-                       (ifrags (collect-each ((op opt-pars))
-                                 (tree-bind (var-sym init-form have-sym) op
-                                   (let* ((vbind nenv.(lookup-var var-sym))
-                                          (ifrag me.(compile vbind.loc nenv init-form)))
-                                     (set fvars (uni fvars
-                                                     (diff ifrag.fvars allsyms)))
-                                     (push var-sym allsyms)
-                                     (push have-sym allsyms)
-                                     ifrag))))
+                       (ifrags [mapcar cadr opt-pars])
                        (opt-code (append-each ((op opt-pars)
                                                (ifrg ifrags))
                                    (tree-bind (var-sym init-form have-sym) op
diff --git a/tests/012/lambda.tl b/tests/012/lambda.tl
index 96f8ba14..d298f59a 100644
--- a/tests/012/lambda.tl
+++ b/tests/012/lambda.tl
@@ -128,6 +128,11 @@
 
 (test (functionp (lambda (: (n n)))) t)
 
+(defvarl n)
+
+(ltest
+  [(lambda (: (n n)) n)] nil)
+
 (cond
   (*compile-test* (exit t))
   (t (set *compile-test* t)
-- 
cgit v1.2.3