Hi guile, Attached is a fix for <https://debbugs.gnu.org/cgi/bugreport.cgi?bug=50608> and a similar issue for 'procedure-name'.
Greetings, Maxime.
From fe518ed4fb2c7e55f69a229349e3183ccfdcfc97 Mon Sep 17 00:00:00 2001
From: Maxime Devos <maximede...@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 <e...@unice.fr>
+;;;; Copyright (C) 2021 Maxime Devos <maximede...@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 <maximede...@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
From 4e1c9e9d5f90f39f2bec033399c3e77127aa5e1f Mon Sep 17 00:00:00 2001
From: Maxime Devos <maximede...@telenet.be>
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 <maximede...@telenet.be>
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 <l...@gnu.org>
;;;;
;;;; Copyright (C) 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
+;;;; Copyright (C) 2021 Maxime Devos <maximede...@telenet.be>
;;;;
;;;; 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
signature.asc
Description: This is a digitally signed message part
