Plaster

(defun lambda-list-to-arglist-form (lambda-list) (multiple-value-bind (requireds optionals rest keywords) (alexandria:parse-ordinary-lambda-list lambda-list) (if (and (endp optionals) (null rest) (endp keywords)) `(list ,@requireds) (alexandria:with-unique-names (arglist) `(let ((,arglist ())) ,@(unless rest (mapcan (alexandria:rcurry 'add-key-forms arglist) (reverse keywords))) ,@(when rest `((setq ,arglist ,rest))) ,@(mapcan (alexandria:rcurry 'add-optional-forms arglist) (reverse optionals)) ,@(loop for required in (reverse requireds) collect `(push ,required ,arglist)) ,arglist))))) (defun add-optional-forms (optional-spec acc) (destructuring-bind (var init-form suppliedp) optional-spec (declare (ignore init-form)) (if suppliedp `((push (when ,suppliedp ,var) ,acc)) `((push ,var ,acc))))) (defun add-key-forms (keyword-spec acc) (destructuring-bind ((keyword var) init-form suppliedp) keyword-spec (declare (ignore init-form)) (if suppliedp `((when ,suppliedp (push ,var ,acc) (push ,keyword ,acc))) `((push ,var ,acc) (push ,keyword ,acc))))) ;;;; Tests (assert (equal (lambda-list-to-arglist-form '(a b c)) '(list a b c))) (let* ((lambda-list '(x &optional (o nil op) &rest r &key ((:k k) nil kp))) (arglist '(0 1 :k 3)) (arglist2 (apply (compile nil `(lambda ,lambda-list ,(try::lambda-list-to-arglist-form lambda-list))) arglist))) (assert (equal arglist2 arglist))) (let* ((lambda-list '(&optional o &key k l)) (arglist '(0 :k 1 :l 2)) (arglist2 (apply (compile nil `(lambda ,lambda-list ,(try::lambda-list-to-arglist-form lambda-list))) arglist))) (assert (equal arglist2 arglist)))