From faebc7b266483f7cd173fe98346490cc95b4c7ec Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= <daniel@turtleware.eu>
Date: Thu, 29 Jun 2023 19:55:08 +0200
Subject: [PATCH] cmp: enforce valid shape of si:function-block-name
 delcaration

Also fix a declaration in clos::make-raw-lambda function.
---
 src/clos/method.lsp                     | 57 +++++++++++++------------
 src/cmp/cmpbackend-cxx/cmppass2-loc.lsp |  2 +-
 src/cmp/cmpfun.lsp                      | 10 +++--
 3 files changed, 36 insertions(+), 33 deletions(-)

diff --git a/src/clos/method.lsp b/src/clos/method.lsp
index 7d242f31b..b2ec572eb 100644
--- a/src/clos/method.lsp
+++ b/src/clos/method.lsp
@@ -143,38 +143,39 @@
                (not (member '&allow-other-keys lambda-list)))
       (let ((x (position '&aux lambda-list)))
         (setf lambda-list
-                (append (subseq lambda-list 0 x)
-                        '(&allow-other-keys)
-                        (and x (subseq lambda-list x))
-                        nil))))
+              (append (subseq lambda-list 0 x)
+                      '(&allow-other-keys)
+                      (and x (subseq lambda-list x))
+                      nil))))
     (let* ((copied-variables '())
            (ignorable `(declare (ignorable ,@required-parameters)))
+           (block-name (si:function-block-name name))
            (class-declarations
-            (nconc (when *add-method-argument-declarations*
-                     (loop for name in required-parameters
-                        for type in specializers
-                        when (and (not (eq type t)) (symbolp type))
-                        do (push `(,name ,name) copied-variables) and
-                        nconc `((type ,type ,name)
-                                (si::no-check-type ,name))))
-                   (list (list 'si::function-block-name name))
-                   (cdar declarations)))
-           (block `(block ,(si::function-block-name name) ,@real-body))
+             (nconc (when *add-method-argument-declarations*
+                      (loop for name in required-parameters
+                            for type in specializers
+                            when (and (not (eq type t)) (symbolp type))
+                              do (push `(,name ,name) copied-variables) and
+                            nconc `((type ,type ,name)
+                                    (si::no-check-type ,name))))
+                    (list (list 'si:function-block-name block-name))
+                    (cdar declarations)))
+           (block `(block ,block-name ,@real-body))
            (method-lambda
-            ;; Remove the documentation string and insert the
-            ;; appropriate class declarations.  The documentation
-            ;; string is removed to make it easy for us to insert
-            ;; new declarations later, they will just go after the
-            ;; second of the method lambda.  The class declarations
-            ;; are inserted to communicate the class of the method's
-            ;; arguments to the code walk.
-            `(lambda ,lambda-list
-               ,@(and class-declarations `((declare ,@class-declarations)))
-               ,ignorable
-               ,(if copied-variables
-                    `(let* ,copied-variables
-                       ,ignorable
-                       ,block)
+             ;; Remove the documentation string and insert the
+             ;; appropriate class declarations.  The documentation
+             ;; string is removed to make it easy for us to insert
+             ;; new declarations later, they will just go after the
+             ;; second of the method lambda.  The class declarations
+             ;; are inserted to communicate the class of the method's
+             ;; arguments to the code walk.
+             `(lambda ,lambda-list
+                ,@(and class-declarations `((declare ,@class-declarations)))
+                ,ignorable
+                ,(if copied-variables
+                     `(let* ,copied-variables
+                        ,ignorable
+                        ,block)
                      block))))
       (values method-lambda declarations documentation))))
 
diff --git a/src/cmp/cmpbackend-cxx/cmppass2-loc.lsp b/src/cmp/cmpbackend-cxx/cmppass2-loc.lsp
index 114486c96..5ef7451ad 100644
--- a/src/cmp/cmpbackend-cxx/cmppass2-loc.lsp
+++ b/src/cmp/cmpbackend-cxx/cmppass2-loc.lsp
@@ -159,7 +159,7 @@
 ;;; FDEFINITION, MAKE-CLOSURE
 ;;; 
 (defun wt-fdefinition (fun-name)
-  (let* ((name (si::function-block-name fun-name))
+  (let* ((name (si:function-block-name fun-name))
          (package (symbol-package name))
          (safe (or (not (safe-compile))
                    (and (or (eq package (find-package "CL"))
diff --git a/src/cmp/cmpfun.lsp b/src/cmp/cmpfun.lsp
index 7b1908496..dc3100892 100644
--- a/src/cmp/cmpfun.lsp
+++ b/src/cmp/cmpfun.lsp
@@ -166,10 +166,12 @@ The function thus belongs to the type of functions that ecl_make_cfun accepts."
 ;;; searches for a (FUNCTION-BLOCK-NAME ...) declaration
 (defun function-block-name-declaration (declarations)
   (loop for i in declarations
-        if (and (consp i) (eql (car i) 'si::function-block-name)
-                (consp (cdr i)))
-          return (cadr i)
-        finally (return nil)))
+        do (when (and (consp i) (eql (car i) 'si:function-block-name))
+             (let ((name (second i))
+                   (rest (cddr i)))
+               (unless (and (symbolp name) (null rest))
+                 (cmperr "Invalid ~s declaration:~%~s" 'si:function-block-name i))
+               (return name)))))
 
 (defun exported-fname (name)
   (let (cname)