diff options
| -rw-r--r-- | share/txr/stdlib/keyparams.tl | 28 |
1 files changed, 11 insertions, 17 deletions
diff --git a/share/txr/stdlib/keyparams.tl b/share/txr/stdlib/keyparams.tl index 7ee2d8f5..82899f2f 100644 --- a/share/txr/stdlib/keyparams.tl +++ b/share/txr/stdlib/keyparams.tl @@ -36,22 +36,16 @@ (each ((k keys)) (add (if (memp k args) t))))) -(defun sys:build-key-list (key-params menv) - (let ((constant (group-by (opip second (constantp @1 menv)) key-params))) - (let ((var-keys (mapcar (ret ^(cons ',(intern (symbol-name (first @1)) - 'keyword) - ,(second @1))) - [constant nil])) - (const-keys (mapcar (op cons - (intern (symbol-name (first @1)) 'keyword) - (second @1)) - [constant t]))) - (cond - ((empty const-keys) - ^(list ,*var-keys)) - ((empty var-keys) - ^',const-keys) - (t ^(list* ,*var-keys ',const-keys)))))) +(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)))) (define-param-expander :key (param body menv form) (let* ((excluding-rest (butlastn 0 param)) @@ -83,7 +77,7 @@ (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 key-params menv)) + (keys (sys:build-key-list-expr key-params menv)) (keys-p (mapcar (op intern (symbol-name (first @1)) 'keyword) key-params-p))) (list eff-param |