From 4e1c9e9d5f90f39f2bec033399c3e77127aa5e1f Mon Sep 17 00:00:00 2001 From: Maxime Devos 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 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 ;;;; ;;;; Copyright (C) 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc. +;;;; Copyright (C) 2021 Maxime Devos ;;;; ;;;; 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 5))))) (with-test-prefix "procedure-arity" -- 2.33.0