bug#50608: Fix for ‘, trace (method ()) --> no applicable method for ...’

From fe518ed4fb2c7e55f69a229349e3183ccfdcfc97 Mon Sep 17 00:00:00 2001
From: Maxime Devos <[email protected]>
Date: Wed, 15 Sep 2021 19:57:20 +0200
Subject: [PATCH 1/2] goops: Let 'write' succeed when objects are
 uninitialised.

* module/oop/goops.scm (generic-function-methods)[fold-upwards,fold-downward]:
Allow 'gfs' to be #f.
(write)[<method>]: Allow 'spec' to be #f.
* test-suite/tests/goops.test ("writing uninitialised objects"): New test.
---
 module/oop/goops.scm        | 18 +++++++++++++++---
 test-suite/tests/goops.test | 19 +++++++++++++++++++
 2 files changed, 34 insertions(+), 3 deletions(-)

diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index de5e8907d..4a4cdd034 100644
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@ -3,6 +3,7 @@
 ;;;; Copyright (C) 1998-2003,2006,2009-2011,2013-2015,2017-2018,2021
 ;;;;   Free Software Foundation, Inc.
 ;;;; Copyright (C) 1993-1998 Erick Gallesio - I3S-CNRS/ESSI <[email protected]>
+;;;; Copyright (C) 2021 Maxime Devos <[email protected]>
 ;;;;
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -1990,7 +1991,9 @@ function."
           (() method-lists)
           ((gf . gfs)
            (lp (fold-upward (cons (slot-ref gf 'methods) method-lists) gf)
-               gfs)))))
+               gfs))
+          ;; See 'fold-downwards'.
+          (#f '()))))
      (else method-lists)))
   (define (fold-downward method-lists gf)
     (let lp ((method-lists (cons (slot-ref gf 'methods) method-lists))
@@ -1998,7 +2001,14 @@ function."
       (match gfs
         (() method-lists)
         ((gf . gfs)
-         (lp (fold-downward method-lists gf) gfs)))))
+         (lp (fold-downward method-lists gf) gfs))
+        ;; 'write' may be called on an uninitialised <generic>
+        ;; (e.g. from ,trace in a REPL) in which case
+        ;; 'generic-function-methods' will be called
+        ;; on a <generic> whose 'extended-by' slot is #f.
+        ;; In that case, just return the empty list to make 'write'
+        ;; happy.
+        (#f '()))))
   (unless (is-a? obj <generic>)
     (scm-error 'wrong-type-arg #f "Not a generic: ~S"
                (list obj) #f))
@@ -2394,7 +2404,9 @@ function."
           (display (class-name meta) file)
           (display #\space file)
           (display (map* (lambda (spec)
-                           (if (slot-bound? spec 'name)
+                           ;; 'spec' is false if 'o' is not yet
+                           ;; initialised
+                           (if (and spec (slot-bound? spec 'name))
                                (slot-ref spec 'name)
                                spec))
                          (method-specializers o))
diff --git a/test-suite/tests/goops.test b/test-suite/tests/goops.test
index b06ba98b2..f70c1e1e4 100644
--- a/test-suite/tests/goops.test
+++ b/test-suite/tests/goops.test
@@ -1,6 +1,7 @@
 ;;;; goops.test --- test suite for GOOPS                      -*- scheme -*-
 ;;;;
 ;;;; Copyright (C) 2001,2003,2004, 2006, 2008, 2009, 2011, 2012, 2014, 2015, 2017, 2021 Free Software Foundation, Inc.
+;;;; Copyright (C) 2021 Maxime Devos <[email protected]>
 ;;;; 
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -761,3 +762,21 @@
               #:metaclass <redefinable-meta>)))
       (pass-if-equal 123 (get-the-bar (make <foo>)))
       (pass-if-equal 123 (get-the-bar (make <redefinable-foo>))))))
+
+;; 'write' can be called on initialised objects, e.g. from
+;; ,trace in a REPL.  Make sure this doesn't result in any
+;; exceptions.  The exact output doesn't matter in this case.
+(with-test-prefix "writing uninitialised objects"
+  (define (make-uninitialised class)
+    (allocate-struct class (length (class-slots class))))
+  (define (test class)
+    (pass-if (class-name class)
+      (string? (object->string (make-uninitialised class)))))
+  (module-for-each
+   (lambda (name variable)
+     (define value (and (variable-bound? variable)
+                        (variable-ref variable)))
+     (when (and (is-a? value <class>)
+                (not (eq? value <procedure-class>)))
+       (test value)))
+   (resolve-module '(oop goops))))
-- 
2.33.0

From 4e1c9e9d5f90f39f2bec033399c3e77127aa5e1f Mon Sep 17 00:00:00 2001
From: Maxime Devos <[email protected]>
Date: Wed, 15 Sep 2021 20:25:58 +0200
Subject: [PATCH 2/2] procedure-name: Allow uninitialised applicable structs.

* libguile/procproc.c (scm_procedure_name): Allow the procedure in an
applicable struct to be #f.
* test-suite/tests/procproc.test ("uninitialised applicable struct"):
Test it.
---
 libguile/procprop.c            | 21 ++++++++++++++++++---
 test-suite/tests/procprop.test | 14 ++++++++++++--
 2 files changed, 30 insertions(+), 5 deletions(-)

diff --git a/libguile/procprop.c b/libguile/procprop.c
index 89cc6c2f7..3e0a973fe 100644
--- a/libguile/procprop.c
+++ b/libguile/procprop.c
@@ -1,5 +1,6 @@
 /* Copyright 1995-1996,1998,2000-2001,2003-2004,2006,2008-2013,2018
      Free Software Foundation, Inc.
+   Copyright 2021 Maxime Devos <[email protected]>
 
    This file is part of Guile.
 
@@ -254,6 +255,7 @@ SCM_DEFINE (scm_procedure_name, "procedure-name", 1, 0, 0,
 
   SCM_VALIDATE_PROC (1, proc);
 
+ loop:
   user_props = scm_weak_table_refq (overrides, proc, SCM_BOOL_F);
   if (scm_is_true (user_props)) 
     {
@@ -265,11 +267,24 @@ SCM_DEFINE (scm_procedure_name, "procedure-name", 1, 0, 0,
     }
 
   if (SCM_PROGRAM_P (proc))
-    return scm_i_program_name (proc);
+    {
+      return scm_i_program_name (proc);
+    }
   else if (SCM_STRUCTP (proc) && SCM_STRUCT_APPLICABLE_P (proc))
-    return scm_procedure_name (SCM_STRUCT_PROCEDURE (proc));
+    {
+      proc = SCM_STRUCT_PROCEDURE (proc);
+      /* Use 'goto loop' to skip SCM_VALIDATE_PROC instead of
+         a calling scm_procedure_name on proc.
+
+         This is necessary because applicable structs sometimes do not
+         actually have a procedure, see the "uninitialised applicable struct"
+         test in procproc.test. */
+      goto loop;
+    }
   else
-    return SCM_BOOL_F;
+    {
+      return SCM_BOOL_F;
+    }
 }
 #undef FUNC_NAME
 
diff --git a/test-suite/tests/procprop.test b/test-suite/tests/procprop.test
index eee54e61e..4b8dd9432 100644
--- a/test-suite/tests/procprop.test
+++ b/test-suite/tests/procprop.test
@@ -2,6 +2,7 @@
 ;;;; Ludovic Courtès <[email protected]>
 ;;;;
 ;;;; 	Copyright (C) 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
+;;;; 	Copyright (C) 2021 Maxime Devos <[email protected]>
 ;;;;
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -18,7 +19,8 @@
 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
 
 (define-module (test-procpop)
-  :use-module (test-suite lib))
+  #:use-module (oop goops)
+  #:use-module (test-suite lib))
 
 
 (with-test-prefix "procedure-name"
@@ -31,7 +33,15 @@
   (pass-if "from eval"
     (eq? 'foobar (procedure-name
                   (eval '(begin (define (foobar) #t) foobar)
-                        (current-module))))))
+                        (current-module)))))
+
+  ;; When creating applicable structs from Scheme,
+  ;; e.g. using GOOPS, there is a short duration during which
+  ;; the struct will be applicable but not actually have a procedure.
+  ;; Usually, this is not visible to users.  However, when tracing,
+  ;; 'procedure-name' will be called on the uninitialises struct.
+  (pass-if "uninitialised applicable struct"
+    (eq? #f (procedure-name (allocate-struct <generic> 5)))))
 
 
 (with-test-prefix "procedure-arity"
-- 
2.33.0

-----BEGIN PGP SIGNATURE-----

iI0EABYKADUWIQTB8z7iDFKP233XAR9J4+4iGRcl7gUCYUJEjRccbWF4aW1lZGV2
b3NAdGVsZW5ldC5iZQAKCRBJ4+4iGRcl7rFFAP44+q7WvkgGZ6EpEr9fF9Mzr/mk
KIeU/A1wkJmY40ca+AD9FyPn46lMlRWo8/rPaRV4U8Pb9nUgQcd6dZ567L9WUwo=
=TgxA
-----END PGP SIGNATURE-----