From dff75dc0048482195d30cf0fbb556e70907730f8 Mon Sep 17 00:00:00 2001
From: Marius Gerbershagen <marius.gerbershagen@gmail.com>
Date: Thu, 31 May 2018 19:48:48 +0200
Subject: [PATCH] cmp: push the generic function name in the IHS for CLOS
 methods

    Makes debugging easier, since now the backtrace prints the correct
    generic function name instead of some symbol generated by gensym.
---
 src/cmp/cmplam.lsp | 15 +++++++++++----
 src/cmp/cmptop.lsp |  1 +
 2 files changed, 12 insertions(+), 4 deletions(-)

diff --git a/src/cmp/cmplam.lsp b/src/cmp/cmplam.lsp
index f3843e2a3..39360a702 100644
--- a/src/cmp/cmplam.lsp
+++ b/src/cmp/cmplam.lsp
@@ -97,6 +97,13 @@ The function thus belongs to the type of functions that ecl_make_cfun accepts."
                (setf (fun-referenced-funs fun) new-funs)
                (return t))))
 
+;;; 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)))
+
 (defun c1compile-function (lambda-list-and-body
                            &key (fun (make-fun)) (name (fun-name fun)))
   (let ((lambda (if name
@@ -147,7 +154,7 @@ The function thus belongs to the type of functions that ecl_make_cfun accepts."
             (fun-closure fun) nil
             (fun-minarg fun) minarg
             (fun-maxarg fun) maxarg
-            (fun-description fun) name
+            (fun-description fun) (or (function-block-name-declaration decl) name)
             (fun-no-entry fun) no-entry
             (fun-optional-type-check-forms fun) optional-type-checks
             (fun-keyword-type-check-forms fun) keyword-type-checks)
@@ -324,7 +331,7 @@ The function thus belongs to the type of functions that ecl_make_cfun accepts."
 |#
 
 (defun c2lambda-expr
-    (lambda-list body cfun fname use-narg required-lcls closure-type
+    (lambda-list body cfun fname description use-narg required-lcls closure-type
                  optional-type-check-forms keyword-type-check-forms
                  &aux (requireds (first lambda-list))
                  (optionals (second lambda-list))
@@ -337,7 +344,7 @@ The function thus belongs to the type of functions that ecl_make_cfun accepts."
                  (varargs (or optionals rest keywords allow-other-keys))
                  (fname-in-ihs-p (or (policy-debug-variable-bindings)
                                      (and (policy-debug-ihs-frame)
-                                          fname)))
+                                          (or description fname))))
                  simple-varargs
                  (*permanent-data* t)
                  (*unwind-exit* *unwind-exit*)
@@ -439,7 +446,7 @@ The function thus belongs to the type of functions that ecl_make_cfun accepts."
     (push 'IHS *unwind-exit*)
     (when (policy-debug-variable-bindings)
       (build-debug-lexical-env (reverse requireds) t))
-    (wt-nl "ecl_ihs_push(cl_env_copy,&ihs," (add-symbol fname)
+    (wt-nl "ecl_ihs_push(cl_env_copy,&ihs," (add-symbol (or description fname))
            ",_ecl_debug_env);"))
 
   ;; Bind optional parameters as long as there remain arguments.
diff --git a/src/cmp/cmptop.lsp b/src/cmp/cmptop.lsp
index 2c13507d1..37a5ea560 100644
--- a/src/cmp/cmptop.lsp
+++ b/src/cmp/cmptop.lsp
@@ -705,6 +705,7 @@
                        (c1form-arg 2 lambda-expr)
                        (fun-cfun fun)
                        (fun-name fun)
+                       (fun-description fun)
                        (fun-needs-narg fun)
                        (fun-required-lcls fun)
                        (fun-closure fun)