diff options
| -rw-r--r-- | stdlib/keyparams.tl | 55 | ||||
| -rw-r--r-- | tests/011/keyparams.tl | 38 |
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)) |