From fe518ed4fb2c7e55f69a229349e3183ccfdcfc97 Mon Sep 17 00:00:00 2001
From: Maxime Devos <maximedevos@telenet.be>
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 <eg@unice.fr>
+;;;; Copyright (C) 2021 Maxime Devos <maximedevos@telenet.be>
 ;;;;
 ;;;; 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 <maximedevos@telenet.be>
 ;;;; 
 ;;;; 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