diff options
Diffstat (limited to 'stdlib')
| -rw-r--r-- | stdlib/keyparams.tl | 55 |
1 files changed, 21 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))))) |