make-procedure-with-setter inherits name from getter

* libguile/procs.c (scm_make_procedure_with_setter): Patch through the
  getter's procedure name to the procedure-with-setter. Fixes part of the
  srfi-17 test, as the VM doesn't set procedure-name on define -- but
  perhaps that is the bug that should be fixed. In any case this patching
  is cheap.

* test-suite/tests/eval.test: Change so that (define name pws) is
  initially passed an anonymous procedure-with-setter, as was the case
  before the procs.c change.

diff --git a/libguile/procs.c b/libguile/procs.c
index 6b4b586..e417cca 100644 (file)
--- a/libguile/procs.c
+++ b/libguile/procs.c
@@ -31,6 +31,7 @@
 
 #include "libguile/validate.h"
 #include "libguile/procs.h"
+#include "libguile/procprop.h"
 #include "libguile/programs.h"
 \f
 
@@ -300,11 +301,25 @@ SCM_DEFINE (scm_make_procedure_with_setter, "make-procedure-with-setter", 2, 0,
            "with the associated setter @var{setter}.")
 #define FUNC_NAME s_scm_make_procedure_with_setter
 {
+  SCM name, ret;
   SCM_VALIDATE_PROC (1, procedure);
   SCM_VALIDATE_PROC (2, setter);
-  return scm_double_cell (scm_tc7_pws,
-                         SCM_UNPACK (procedure),
-                         SCM_UNPACK (setter), 0);
+  ret = scm_double_cell (scm_tc7_pws,
+                         SCM_UNPACK (procedure),
+                         SCM_UNPACK (setter), 0);
+  /* don't use procedure_name, because don't care enough to do a reverse
+     lookup */
+  switch (SCM_TYP7 (procedure)) {
+  case scm_tcs_subrs:
+    name = SCM_SNAME (procedure);
+    break;
+  default:
+    name = scm_procedure_property (procedure, scm_sym_name);
+    break;
+  }
+  if (scm_is_true (name))
+    scm_set_procedure_property_x (ret, scm_sym_name, name);
+  return ret;
 }
 #undef FUNC_NAME
 

diff --git a/test-suite/tests/eval.test b/test-suite/tests/eval.test
index b6ddb7b..52c793b 100644 (file)
--- a/test-suite/tests/eval.test
+++ b/test-suite/tests/eval.test
@@ -213,7 +213,11 @@
 ;;
 (define foo-closure (lambda () "hello"))
 (define bar-closure foo-closure)
-(define foo-pws (make-procedure-with-setter car set-car!))
+;; make sure that make-procedure-with-setter returns an anonymous
+;; procedure-with-setter by passing it an anonymous getter.
+(define foo-pws (make-procedure-with-setter
+                 (lambda (x) (car x))
+                 (lambda (x y) (set-car! x y))))
 (define bar-pws foo-pws)
 
 (with-test-prefix "define set procedure-name"
@@ -222,7 +226,7 @@
     (eq? 'foo-closure (procedure-name bar-closure)))
 
   (pass-if "procedure-with-setter"
-    (eq? 'foo-pws (pk (procedure-name bar-pws)))))
+    (eq? 'foo-pws (procedure-name bar-pws))))
 
 (if old-procnames-flag
     (debug-enable 'procnames)