From 46a73b3d3659b34b00ebd45e5ba8e4545cc9346e Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 12 Nov 2019 08:52:43 -0700 Subject: [PATCH] expose `custom-{write,print-quotable}-accessor` as accessor Revert the part of 39a96dd699 that hides the provenance of these accessors. Although exposing the fact that the predicates are for structure properties constrains some internal representations, that constraint seems unlikely to matter, and exposing the procedures as property predicates is more consistent with the documentation and the implementation (especially for Racket CS). Closes #2904 --- .../racket-test-core/tests/racket/struct.rktl | 7 ++++++ racket/src/racket/src/struct.c | 25 ++----------------- 2 files changed, 9 insertions(+), 23 deletions(-) diff --git a/pkgs/racket-test-core/tests/racket/struct.rktl b/pkgs/racket-test-core/tests/racket/struct.rktl index 806e358ee3..4ccbb57ca5 100644 --- a/pkgs/racket-test-core/tests/racket/struct.rktl +++ b/pkgs/racket-test-core/tests/racket/struct.rktl @@ -14,6 +14,8 @@ (arity-test struct-type-property? 1 1) (test #t struct-type-property? prop:p) (test #f struct-type-property? 5) + (test #t struct-type-property-accessor-procedure? p-ref) + (test #t struct-type-property-accessor-procedure? p2-ref) (let-values ([(type make pred sel set) (make-struct-type 'a #f 2 1 'un (list (cons prop:p 87)) (make-inspector insp1))] [(typex makex predx selx setx) (make-struct-type 'ax #f 0 5 #f null (make-inspector insp2))]) (arity-test make-struct-type 4 11) @@ -1337,4 +1339,9 @@ ;; ---------------------------------------- +(test #t struct-type-property-accessor-procedure? custom-write-accessor) +(test #t struct-type-property-accessor-procedure? custom-print-quotable-accessor) + +;; ---------------------------------------- + (report-errs) diff --git a/racket/src/racket/src/struct.c b/racket/src/racket/src/struct.c index 14ae50d51b..3494367f4f 100644 --- a/racket/src/racket/src/struct.c +++ b/racket/src/racket/src/struct.c @@ -96,8 +96,6 @@ static Scheme_Object *check_output_port_property_value_ok(int argc, Scheme_Objec static Scheme_Object *check_cpointer_property_value_ok(int argc, Scheme_Object *argv[]); static Scheme_Object *check_checked_proc_property_value_ok(int argc, Scheme_Object *argv[]); -static Scheme_Object *unary_acc(int argc, Scheme_Object **argv, Scheme_Object *self); - static Scheme_Object *make_struct_type(int argc, Scheme_Object *argv[]); static Scheme_Object *make_struct_field_accessor(int argc, Scheme_Object *argv[]); @@ -322,13 +320,7 @@ scheme_init_struct (Scheme_Startup_Env *env) scheme_struct_property_type); scheme_addto_prim_instance("prop:custom-write", write_property, env); scheme_addto_prim_instance("custom-write?", pred, env); - - a[0] = access; - scheme_addto_prim_instance("custom-write-accessor", - scheme_make_prim_closure_w_arity(unary_acc, 1, a, - "custom-write-accessor", - 1, 1), - env); + scheme_addto_prim_instance("custom-write-accessor", access, env); } REGISTER_SO(print_attribute_property); @@ -344,13 +336,7 @@ scheme_init_struct (Scheme_Startup_Env *env) scheme_struct_property_type); scheme_addto_prim_instance("prop:custom-print-quotable", print_attribute_property, env); scheme_addto_prim_instance("custom-print-quotable?", pred, env); - - a[0] = access; - scheme_addto_prim_instance("custom-print-quotable-accessor", - scheme_make_prim_closure_w_arity(unary_acc, 1, a, - "custom-print-quotable-accessor", - 1, 1), - env); + scheme_addto_prim_instance("custom-print-quotable-accessor", access, env); } REGISTER_SO(evt_property); @@ -1872,13 +1858,6 @@ Scheme_Object *scheme_print_attribute_ref(Scheme_Object *s) return scheme_struct_type_property_ref(print_attribute_property, s); } -static Scheme_Object *unary_acc(int argc, Scheme_Object **argv, Scheme_Object *self) -{ - Scheme_Object *acc = SCHEME_PRIM_CLOSURE_ELS(self)[0]; - - return _scheme_apply(acc, argc, argv); -} - /*========================================================================*/ /* checked-proc property */ /*========================================================================*/