From 6d3e7ef4e8eadb8b0d52acd6c345dcf140c2b139 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Sat, 20 Jun 2015 21:52:27 +0200 Subject: [PATCH] clos: implicit generic function definition doesn't have &key arguments MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit According to second paragraph of http://www.lispworks.com/documentation/HyperSpec/Body/m_defmet.htm generic function should mention key (if it is in method), but now key arguments. Fixes #76. Signed-off-by: Daniel Kochmański --- src/clos/fixup.lsp | 3 ++- src/clos/method.lsp | 14 +++++++++++++- 2 files changed, 15 insertions(+), 2 deletions(-) diff --git a/src/clos/fixup.lsp b/src/clos/fixup.lsp index defa5f61d..ddece2c14 100644 --- a/src/clos/fixup.lsp +++ b/src/clos/fixup.lsp @@ -150,7 +150,8 @@ and cannot be added to ~A." method other-gf gf))) (error "Cannot add the method ~A to the generic function ~A because ~ their lambda lists ~A and ~A are not congruent." method gf old-lambda-list new-lambda-list))) - (reinitialize-instance gf :lambda-list new-lambda-list))) + (reinitialize-instance + gf :lambda-list (implicit-generic-lambda new-lambda-list)))) ;; ;; 3) Finally, it is inserted in the list of methods, and the method is ;; marked as belonging to a generic function. diff --git a/src/clos/method.lsp b/src/clos/method.lsp index 56c5c9a5d..9dd18eb3c 100644 --- a/src/clos/method.lsp +++ b/src/clos/method.lsp @@ -290,6 +290,17 @@ (values name (nreverse qualifiers) (first args) (rest args))) (push (pop args) qualifiers)))) +(defun implicit-generic-lambda (lambda-list) + "Implicit defgeneric declaration removes all &key arguments (preserving &key)" + (when lambda-list + (let (acc) + (do* ((ll lambda-list (cdr ll)) + (elt (car ll) (car ll))) + ((or (endp (rest ll)) + (eql elt '&key)) + (nreverse (cons elt acc))) + (push elt acc))))) + (defun extract-lambda-list (specialized-lambda-list) (values (parse-specialized-lambda-list specialized-lambda-list))) @@ -398,7 +409,8 @@ have disappeared." (push method (generic-function-methods gf)) (setf (method-generic-function method) gf) (unless (si::sl-boundp (generic-function-lambda-list gf)) - (setf (generic-function-lambda-list gf) (method-lambda-list method)) + (setf (generic-function-lambda-list gf) (implicit-generic-lambda + (method-lambda-list method))) (setf (generic-function-argument-precedence-order gf) (rest (si::process-lambda-list (method-lambda-list method) t)))) (compute-g-f-spec-list gf)