From 9d1c74c011c2a7f9a37ec86c7353dec0c24c34ea Mon Sep 17 00:00:00 2001
From: Kaz Kylheku <kaz@kylheku.com>
Date: Tue, 1 May 2018 21:00:18 -0700
Subject: compiler: correct semantics of special var args.

The same, correct semantics for special variables in function
arguments get implemented in the compiler.

* share/txr/stdlib/compiler.tl (compiler comp-lambda): We
stick with the strategy that each parameter which is a
special variable is aliased by an anonymous lexical
variable. The difference is that we bind the underlying
special variable from the hidden lexical's value as early as
possible.  The overall processing is rearranged. On entry
into the function, if any of the required arguments are
specials, their values are immediately bound to the special
variables in a new environment. Then the optional arguments
are processed, and they bind specials in the dynamic
environment also. Previously, the specials were bound in
one fell swoop after processing the optionals, leading to the
same incorrect semantics that the interpreter code had.
---
 share/txr/stdlib/compiler.tl | 22 +++++++++++++++-------
 1 file changed, 15 insertions(+), 7 deletions(-)

diff --git a/share/txr/stdlib/compiler.tl b/share/txr/stdlib/compiler.tl
index 2d8962e3..8af7384f 100644
--- a/share/txr/stdlib/compiler.tl
+++ b/share/txr/stdlib/compiler.tl
@@ -780,12 +780,13 @@
     (let* ((pars (new (fun-param-parser par-syntax form)))
            (need-frame (or (plusp pars.nfix) pars.rest))
            (nenv (if need-frame (new env up env co me) env))
-           lexsyms specials)
+           lexsyms specials need-dframe)
       (flet ((spec-sub (sym)
                (cond
                  ((special-var-p sym)
                   (let ((sub (gensym)))
                     (push (cons sym sub) specials)
+                    (set need-dframe t)
                     nenv.(extend-var sub)
                     sub))
                  (t
@@ -804,12 +805,12 @@
           (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
+                           (tree-bind (var-sym init-form have-sym) op
                              (let ((vbind nenv.(lookup-var var-sym)))
                                me.(compile vbind.loc nenv init-form)))))
                  (opt-code (append-each ((op opt-pars)
                                          (ifrg ifrags))
-                             (tree-bind (var-sym : init-form have-sym) op
+                             (tree-bind (var-sym init-form have-sym) op
                                (let ((vbind nenv.(lookup-var var-sym))
                                      (have-bind nenv.(lookup-var have-sym))
                                      (lskip (gensym "l")))
@@ -820,7 +821,14 @@
                                         ^((mov ,have-bind.loc nil)))
                                     ,*ifrg.code
                                     ,*(maybe-mov vbind.loc ifrg.oreg)
-                                    ,lskip)))))
+                                    ,lskip
+                                    ,*(whenlet ((spec-sub [find var-sym specials : cdr]))
+                                        (set specials [remq var-sym specials cdr])
+                                        ^((bindv ,vbind.loc ,me.(get-dreg (car spec-sub)))))
+                                    ,*(whenlet ((spec-sub [find have-sym specials : cdr]))
+                                        (prinl 'have)
+                                        (set specials [remq have-sym specials cdr])
+                                        ^((bindv ,have-bind.loc ,me.(get-dreg (car spec-sub))))))))))
                  (benv (if specials (new env up nenv co me) nenv))
                  (btreg me.(alloc-treg))
                  (bfrag me.(comp-progn btreg benv body))
@@ -837,8 +845,7 @@
                                     nenv.(lookup-var (car op)).loc)
                                 ,*(if rest-par
                                     (list nenv.(lookup-var rest-par).loc)))
-                         ,*opt-code
-                         ,*(if specials
+                         ,*(if need-dframe
                              ^((dframe ,benv.lev 0)))
                          ,*(if specials
                              (collect-each ((vs specials))
@@ -846,8 +853,9 @@
                                  (let ((sub-bind nenv.(lookup-var gensym))
                                        (dreg me.(get-dreg special)))
                                    ^(bindv ,sub-bind.loc ,dreg)))))
+                         ,*opt-code
                          ,*bfrag.code
-                         ,*(if specials
+                         ,*(if need-dframe
                              ^((end ,boreg)))
                          ,*(maybe-mov boreg bfrag.oreg)
                          (end ,boreg)
-- 
cgit v1.2.3