From af3ad76caffe064124fa9d6686ee2972f8cbd660 Mon Sep 17 00:00:00 2001
From: Madhu <enometh@net.meer>
Date: Sun, 28 Nov 2021 07:13:08 +0530
Subject: [PATCH] define-compiler-macro: handle funcall

Tries to fix #389.  Based on a suggestion from pjb.

* lib/level-2.lisp: (parse-macro-2): new. like parse-macro-internal
but only for expanding compiler macros, and special cases the CLHS
funcall case.
* compiler/nx0.lisp: define-compiler-macro: use (parse-macro-2).

CLHS define-compiler-macro - Example 5
http://www.lispworks.com/documentation/HyperSpec/Body/m_define.htm
requires
(funcall (compiler-macro-function 'square) '(funcall #'square x) nil)
to be supported.
---
 compiler/nx0.lisp |  5 +----
 lib/level-2.lisp  | 39 +++++++++++++++++++++++++++++++++++++++
 2 files changed, 40 insertions(+), 4 deletions(-)

diff --git a/compiler/nx0.lisp b/compiler/nx0.lisp
index 2008c56fc..55808f631 100644
--- a/compiler/nx0.lisp
+++ b/compiler/nx0.lisp
@@ -185,16 +185,13 @@
 
 (defvar *compiler-macros* (make-hash-table :size 100 :test #'eq))
 
-;;; Just who was responsible for the "FUNCALL" nonsense ?
-;;; Whoever it is deserves a slow and painful death ...
-
 (defmacro define-compiler-macro  (name arglist &body body &environment env)
   "Define a compiler-macro for NAME."
   (let* ((block-name name)
          (def-name (validate-function-name name)))
     (unless (eq def-name block-name)
       (setq block-name (cadr block-name)))
-    (let ((body (parse-macro-1 block-name arglist body env)))
+    (let ((body (parse-macro-2 block-name arglist body env)))
       `(eval-when (:compile-toplevel :load-toplevel :execute)
          (eval-when (:load-toplevel :execute)
            (record-source-file ',name 'compiler-macro))
diff --git a/lib/level-2.lisp b/lib/level-2.lisp
index 7991d3ecd..070804327 100644
--- a/lib/level-2.lisp
+++ b/lib/level-2.lisp
@@ -89,6 +89,45 @@
                    ,@body)))
             doc))))))
 
+(defun parse-macro-2 (name arglist body env &aux default-initial-value)
+  "Special form of parse-macro-internal for expanding compiler macros to
+handle the CLHS funcall case."
+  (unless (verify-lambda-list arglist t t t)
+    (error "Invalid lambda list ~s" arglist))
+  (multiple-value-bind (lambda-list whole environment)
+      (normalize-lambda-list arglist t t)
+    (multiple-value-bind (body local-decs doc)
+        (parse-body body env t)
+      (let ((whole-var (gensym "WHOLE"))
+            (env-var (gensym "ENVIRONMENT")))
+        (multiple-value-bind (bindings binding-decls)
+            (%destructure-lambda-list lambda-list whole-var nil nil
+                                      :cdr-p t
+                                      :whole-p nil
+                                      :use-whole-var t
+                                      :default-initial-value default-initial-value)
+          (when environment
+            (setq bindings (nconc bindings (list `(,environment ,env-var)))))
+          (when whole
+            (setq bindings (nconc bindings (list `(,whole ,whole-var)))))
+          (values
+            `(lambda (,whole-var ,env-var)
+               (declare (ignorable ,whole-var ,env-var))
+	       (let ((form ,whole-var)
+		     (block-name ',name))
+		 (if (and (listp form)
+			  (eq (first form) 'funcall)
+			  (listp (second form))
+			  (eq 'function (first (second form)))
+			  (eq block-name (second (second form))))
+		     (setq ,whole-var `(block-name ,@(cddr form)))))
+               (block ,name
+                 (let* ,(nreverse bindings)
+                   ,@(when binding-decls `((declare ,@binding-decls)))
+                   ,@local-decs
+                   ,@body)))
+            doc))))))
+
 (defun lambda-list-bounds (lambda-list)
   (let* ((state :required)
          (min 0)