diff --git a/src/code/defmacro.lisp b/src/code/defmacro.lisp index 7dc01b7156a4f9a3f73ebeecd633eaee321972d3..094f8e40deb5fbbc3fd97d9adccdfb2f4ee9befb 100644 --- a/src/code/defmacro.lisp +++ b/src/code/defmacro.lisp @@ -151,7 +151,12 @@ (not (and (listp ,arg-list-name) (eq 'funcall (car ,arg-list-name))))) `(progn - (setf ,arg-list-name (cdr ,arg-list-name))))) + (setf ,arg-list-name + ;; Handle the case (funcall #'foo args) + (if (consp (second ,arg-list-name)) + (list* (second (second ,arg-list-name)) + (cddr ,arg-list-name)) + (cdr ,arg-list-name)))))) (push-let-binding (car rest-of-args) arg-list-name nil)) ((and (cdr rest-of-args) (consp (cadr rest-of-args))) (pop rest-of-args) diff --git a/tests/issues.lisp b/tests/issues.lisp new file mode 100644 index 0000000000000000000000000000000000000000..97d3dc9e8e4c9fb7250a2aa42eb3705863f25337 --- /dev/null +++ b/tests/issues.lisp @@ -0,0 +1,25 @@ +;;; Tests from gitlab issues + +(defpackage :issues-tests + (:use :cl :lisp-unit)) + +(in-package "ISSUES-TESTS") + +(defun square (x) + (expt x 2)) + +(define-compiler-macro square (&whole form arg) + (declare (ignore arg)) + form) + +(define-test issue.1.a + (:tag :issues) + (assert-equal + '(square x) + (funcall (compiler-macro-function 'square) '(square x) nil))) + +(define-test issue.1.b + (:tag :issues) + (assert-equal + '(square x) + (funcall (compiler-macro-function 'square) '(funcall #'square x) nil)))