From 4c3316acecc462283c0c853369af93776c478d44 Mon Sep 17 00:00:00 2001 From: Kaz Kylheku Date: Mon, 17 Jan 2022 06:39:43 -0800 Subject: 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. --- stdlib/keyparams.tl | 55 +++++++++++++++++++------------------------------- tests/011/keyparams.tl | 38 ++++++++++++++++++++++++++++++++++ 2 files changed, 59 insertions(+), 34 deletions(-) create mode 100644 tests/011/keyparams.tl 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)) -- cgit v1.2.3