keyparams: fix broken.

Issues reported by user vapnik spaknik. The evaluation of init
forms is incorrect. Init forms like '(x) evaluate to
'(x) rather than (x), Also, init forms are evaluated even when
the argument is present, so the entire current approach is
wrong.

* stdlib/keyparams.tl (extract-keys, extract-keys-p,
build-key-list-expr): Functions removed.
(stuff-key-params): New function.
(:key): Rework using simplified approach, with just the
stuff-key-params helper. All variables from the keyword
parameter list are bound with let. Generated code searches
the keyword parameters for values and assigns the variables as
needed, evaluating default init forms in the not-found cases.

* tests/011/keyparams.tl: New file.

2 files changed, 59 insertions, 34 deletions

diff --git a/stdlib/keyparams.tl b/stdlib/keyparams.tl
index eaaebc6c..6e161643 100644
--- a/stdlib/keyparams.tl
+++ b/stdlib/keyparams.tl
@@ -24,28 +24,23 @@
 ;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
 ;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
 ;; POSSIBILITY OF SUCH DAMAGE.
-(defun sys:extract-keys (keys args)
-  (build
-    (each ((k keys))
-      (iflet ((f (memp (car k) args)))
-        (add (cadr f))
-        (add (cdr k))))))
 
-(defun sys:extract-keys-p (keys args)
-  (build
-    (each ((k keys))
-      (add (if (memp k args) t)))))
-
-(defun sys:build-key-list-expr (key-params menv)
-  (let ((exprs (collect-each ((kp key-params))
-                 (let ((kw (intern (symbol-name (first kp)) 'keyword))
-                       (ex (second kp)))
-                   (if (constantp ex menv)
-                     ^(quote (,kw . ,(second kp)))
-                     ^(cons ,kw ,(second kp)))))))
-    (if [all exprs (op eq 'quote) car]
-      ^(quote ,[mapcar cadr exprs])
-      ^(list ,*exprs))))
+(defun sys:stuff-key-params (keys args)
+  (with-gensyms (cell)
+    (collect-each ((k keys))
+      (tree-bind (sym : init sym-p) k
+        (let ((kw (intern (symbol-name sym) :keyword)))
+          ^(let ((,cell (memp ,kw ,args)))
+             ,(if init
+               ^(cond
+                  (,cell
+                    (set ,sym (cadr ,cell))
+                    ,*(if sym-p ^((set ,sym-p t))))
+                  (t
+                    (set ,sym ,init)))
+               ^(when ,cell
+                  (set ,sym (cadr ,cell))
+                  ,*(if sym-p ^((set ,sym-p t)))))))))))
 
 (define-param-expander :key (param body menv form)
   (let* ((excluding-rest (butlastn 0 param))
@@ -74,17 +69,9 @@
            (compile-error form "invalid dotted form ~s" key-spec))
          (unless (bindable sym)
            (compile-error form "~s isn't a bindable symbol" sym)))))
-    (let* ((key-params-p [keep-if third key-params])
-           (key-vars [mapcar first key-params])
-           (key-vars-p [mapcar third key-params-p])
-           (keys (sys:build-key-list-expr key-params menv))
-           (keys-p (mapcar (op intern (symbol-name (first @1)) 'keyword)
-                           key-params-p)))
+    (let* ((key-syms [mapcar first key-params])
+           (key-syms-p (remq nil [mapcar third key-params])))
       (list eff-param
-            ^(tree-bind ,key-vars
-                        (sys:extract-keys ,keys ,rest-param)
-               ,*(if keys-p
-                   ^((tree-bind ,key-vars-p
-                                (sys:extract-keys-p ',keys-p ,rest-param)
-                        ,*body))
-                   body))))))
+            ^(let (,*key-syms ,*key-syms-p)
+               ,*(sys:stuff-key-params key-params rest-param)
+               ,*body)))))
diff --git a/tests/011/keyparams.tl b/tests/011/keyparams.tl
new file mode 100644
index 00000000..e2f8baf2
--- /dev/null
+++ b/tests/011/keyparams.tl
@@ -0,0 +1,38 @@
+(load "../common")
+
+(defvarl v :v)
+(defsymacro u (identity :u))
+
+(mtest
+  [(lambda (:key))] nil
+  [(lambda (:key a))] :error
+  [(lambda (:key a) a) 1] 1)
+
+(mtest
+  [(lambda (:key -- (a v)) a)] :v
+  [(lambda (:key -- (a 'v)) a)] v
+  [(lambda (:key -- (a v a-p)) (list a a-p))] (:v nil)
+  [(lambda (:key -- (a 'v a-p)) (list a a-p))] (v nil))
+
+(mtest
+  [(lambda (:key -- (a v)) a) :a 1] 1
+  [(lambda (:key -- (a 'v)) a) :a 1] 1
+  [(lambda (:key -- (a v a-p)) (list a a-p)) :a 1] (1 t)
+  [(lambda (:key -- (a 'v a-p)) (list a a-p)) :a 1] (1 t))
+
+(mtest
+  [(lambda (:key -- (a v) (b u)) (list a b)) :a 1] (1 :u)
+  [(lambda (:key -- (a 'v) (b 'u)) (list a b)) :b 1] (v 1)
+  [(lambda (:key -- (a v a-p) (b u b-p)) (list a a-p b b-p)) :a 1] (1 t :u nil)
+  [(lambda (:key -- (a v a-p) (b u b-p)) (list a a-p b b-p)) :b 1] (:v nil 1 t))
+
+(test
+  [(lambda (:key -- (a v) . r) (list a r)) :a 1] (1 (:a 1)))
+
+(defun key-place (:key -- x y (s nil s-p)) ^(,x ,y ,s ,s-p))
+
+(defset key-place (:key -- x y) s
+  ^(key-place :x ,x :y ,y :s ,s))
+
+(test
+  (set (key-place :x 3 :y 4) 42) (3 4 42 t))