From 4405ed669f900439703c855faa947f16d44a87cd Mon Sep 17 00:00:00 2001 From: Fred Fu Date: Mon, 21 Oct 2019 09:00:57 -0400 Subject: [PATCH] add `struct-type-property-predicate-procedure?` --- pkgs/base/info.rkt | 2 +- .../scribblings/reference/struct.scrbl | 14 ++++++++ .../racket-test-core/tests/racket/struct.rktl | 10 ++++++ racket/src/cs/primitive/kernel.ss | 1 + racket/src/cs/rumble.sls | 1 + racket/src/cs/rumble/struct.ss | 20 +++++++++++ racket/src/racket/src/schminc.h | 2 +- racket/src/racket/src/schvers.h | 2 +- racket/src/racket/src/struct.c | 36 +++++++++++++++++-- 9 files changed, 82 insertions(+), 6 deletions(-) diff --git a/pkgs/base/info.rkt b/pkgs/base/info.rkt index 7d7be55674..fbdad36318 100644 --- a/pkgs/base/info.rkt +++ b/pkgs/base/info.rkt @@ -12,7 +12,7 @@ (define collection 'multi) -(define version "7.5.0.10") +(define version "7.5.0.11") (define deps `("racket-lib" ["racket" #:version ,version])) diff --git a/pkgs/racket-doc/scribblings/reference/struct.scrbl b/pkgs/racket-doc/scribblings/reference/struct.scrbl index ff074b0fb5..1ea4b87763 100644 --- a/pkgs/racket-doc/scribblings/reference/struct.scrbl +++ b/pkgs/racket-doc/scribblings/reference/struct.scrbl @@ -392,16 +392,30 @@ impersonator. (p-ref struct:c) ]} + @defproc[(struct-type-property? [v any/c]) boolean?]{ Returns @racket[#t] if @racket[v] is a @tech{structure type property descriptor} value, @racket[#f] otherwise.} + @defproc[(struct-type-property-accessor-procedure? [v any/c]) boolean?]{ Returns @racket[#t] if @racket[v] is an accessor procedure produced by @racket[make-struct-type-property], @racket[#f] otherwise.} + +@defproc[(struct-type-property-predicate-procedure? [v any/c] + [prop (or/c struct-type-property? #f) #f]) + boolean?]{ + +Returns @racket[#t] if @racket[v] is a predicate procedure produced by +@racket[make-struct-type-property] and either @racket[prop] is +@racket[#f] or it was produced by the same call to +@racket[make-struct-type-property], @racket[#f] otherwise. + +@history[#:added "7.5.0.11"]} + @;------------------------------------------------------------------------ @include-section["generic.scrbl"] diff --git a/pkgs/racket-test-core/tests/racket/struct.rktl b/pkgs/racket-test-core/tests/racket/struct.rktl index 0b08a6002c..b7b3b735f3 100644 --- a/pkgs/racket-test-core/tests/racket/struct.rktl +++ b/pkgs/racket-test-core/tests/racket/struct.rktl @@ -8,6 +8,8 @@ [(insp1) (make-inspector)] [(insp2) (make-inspector)]) (arity-test make-struct-type-property 1 4) + (arity-test struct-type-property-accessor-procedure? 1 1) + (arity-test struct-type-property-predicate-procedure? 1 2) (test 3 primitive-result-arity make-struct-type-property) (arity-test p? 1 1) (arity-test p-ref 1 2) @@ -16,6 +18,14 @@ (test #f struct-type-property? 5) (test #t struct-type-property-accessor-procedure? p-ref) (test #t struct-type-property-accessor-procedure? p2-ref) + (test #f struct-type-property-predicate-procedure? p-ref) + (test #f struct-type-property-predicate-procedure? p? prop:p2) + (test #t struct-type-property-predicate-procedure? p?) + (test #t struct-type-property-predicate-procedure? p? #f) + (test #t struct-type-property-predicate-procedure? p? prop:p) + (err/rt-test (struct-type-property-predicate-procedure? p? 'oops)) + (err/rt-test (struct-type-property-predicate-procedure? 7 'oops)) + (err/rt-test (struct-type-property-predicate-procedure? 7 0)) (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) diff --git a/racket/src/cs/primitive/kernel.ss b/racket/src/cs/primitive/kernel.ss index 8bc2138543..bff092f910 100644 --- a/racket/src/cs/primitive/kernel.ss +++ b/racket/src/cs/primitive/kernel.ss @@ -838,6 +838,7 @@ [struct-type-make-constructor (known-procedure 6)] [struct-type-make-predicate (known-procedure 2)] [struct-type-property-accessor-procedure? (known-procedure 2)] + [struct-type-property-predicate-procedure? (known-procedure 6)] [struct-type-property? (known-procedure/no-prompt 2)] [struct-type? (known-procedure/no-prompt 2)] [struct:arity-at-least (known-constant)] diff --git a/racket/src/cs/rumble.sls b/racket/src/cs/rumble.sls index c8587dfde8..afe0b9eb39 100644 --- a/racket/src/cs/rumble.sls +++ b/racket/src/cs/rumble.sls @@ -210,6 +210,7 @@ make-struct-type-property struct-type-property? struct-type-property-accessor-procedure? + struct-type-property-predicate-procedure? make-struct-type struct-type-install-properties! ; not exported to Racket structure-type-lookup-prefab-uid ; not exported to Racket diff --git a/racket/src/cs/rumble/struct.ss b/racket/src/cs/rumble/struct.ss index 3eee810a87..8643d0d77b 100644 --- a/racket/src/cs/rumble/struct.ss +++ b/racket/src/cs/rumble/struct.ss @@ -18,6 +18,9 @@ ;; Maps a property-accessor function to `(cons predicate-proc can-impersonate)`: (define property-accessors (make-ephemeron-eq-hashtable)) +;; Maps a property-predicate function to `struct-property`: +(define property-predicates (make-ephemeron-eq-hashtable)) + (define (struct-type-property? v) (struct-type-prop? v)) @@ -96,6 +99,10 @@ (hashtable-set! property-accessors acc (cons pred can-impersonate?))) + (with-global-lock* + (hashtable-set! property-predicates + pred + st)) (values st pred acc)))])) @@ -106,6 +113,19 @@ (with-global-lock* (hashtable-ref property-accessors v #f))) #t)) +(define/who struct-type-property-predicate-procedure? + (case-lambda + [(v) (struct-type-property-predicate-procedure? v #f)] + [(v spt) + (check who struct-type-property? :or-false spt) + (and (procedure? v) + (let* ([v (strip-impersonator v)] + [spt-c (with-global-lock* (hashtable-ref property-predicates v #f))]) + (cond + [(not spt-c) #f] + [(not spt) #t] + [else (eq? spt spt-c)])))])) + (define (struct-type-property-accessor-procedure-pred v) (car (with-global-lock (hashtable-ref property-accessors v #f)))) diff --git a/racket/src/racket/src/schminc.h b/racket/src/racket/src/schminc.h index ebeb6823c0..b2532a7c1c 100644 --- a/racket/src/racket/src/schminc.h +++ b/racket/src/racket/src/schminc.h @@ -14,7 +14,7 @@ #define USE_COMPILED_STARTUP 1 -#define EXPECTED_PRIM_COUNT 1459 +#define EXPECTED_PRIM_COUNT 1460 #ifdef MZSCHEME_SOMETHING_OMITTED # undef USE_COMPILED_STARTUP diff --git a/racket/src/racket/src/schvers.h b/racket/src/racket/src/schvers.h index e7957401cb..6a9472b964 100644 --- a/racket/src/racket/src/schvers.h +++ b/racket/src/racket/src/schvers.h @@ -16,7 +16,7 @@ #define MZSCHEME_VERSION_X 7 #define MZSCHEME_VERSION_Y 5 #define MZSCHEME_VERSION_Z 0 -#define MZSCHEME_VERSION_W 10 +#define MZSCHEME_VERSION_W 11 /* A level of indirection makes `#` work as needed: */ #define AS_a_STR_HELPER(x) #x diff --git a/racket/src/racket/src/struct.c b/racket/src/racket/src/struct.c index 3494367f4f..9b993a99eb 100644 --- a/racket/src/racket/src/struct.c +++ b/racket/src/racket/src/struct.c @@ -126,12 +126,13 @@ static Scheme_Object *struct_getter_p(int argc, Scheme_Object *argv[]); static Scheme_Object *struct_pred_p(int argc, Scheme_Object *argv[]); static Scheme_Object *struct_constr_p(int argc, Scheme_Object *argv[]); static Scheme_Object *struct_prop_getter_p(int argc, Scheme_Object *argv[]); +static Scheme_Object *struct_prop_pred_p(int argc, Scheme_Object *argv[]); static Scheme_Object *chaperone_prop_getter_p(int argc, Scheme_Object *argv[]); -static Scheme_Object *make_struct_proc(Scheme_Struct_Type *struct_type, char *func_name, +static Scheme_Object *make_struct_proc(Scheme_Struct_Type *struct_type, char *func_name, Scheme_ProcT proc_type, int field_num); -static Scheme_Object *make_name(const char *pre, const char *tn, int tnl, const char *post1, +static Scheme_Object *make_name(const char *pre, const char *tn, int tnl, const char *post1, const char *fn, int fnl, const char *post2, int sym); static void get_struct_type_info(int argc, Scheme_Object *argv[], Scheme_Object **a, int always); @@ -630,12 +631,17 @@ scheme_init_struct (Scheme_Startup_Env *env) "struct-type-property-accessor-procedure?", 1, 1), env); + scheme_addto_prim_instance("struct-type-property-predicate-procedure?", + scheme_make_immed_prim(struct_prop_pred_p, + "struct-type-property-predicate-procedure?", + 1, 2), + env); scheme_addto_prim_instance("impersonator-property-accessor-procedure?", scheme_make_immed_prim(chaperone_prop_getter_p, "impersonator-property-accessor-procedure?", 1, 1), env); - + /*** Inspectors ****/ REGISTER_SO(scheme_make_inspector_proc); @@ -3340,6 +3346,30 @@ struct_prop_getter_p(int argc, Scheme_Object *argv[]) && SAME_TYPE(SCHEME_TYPE(SCHEME_PRIM_CLOSURE_ELS(v)[0]), scheme_struct_property_type)) ? scheme_true : scheme_false); } +static Scheme_Object * +struct_prop_pred_p(int argc, Scheme_Object *argv[]) +{ + Scheme_Object *v = argv[0], *prop, *prop_t; + + if (argc > 1) { + if (SCHEME_TRUEP(argv[1]) && !SAME_TYPE(SCHEME_TYPE(argv[1]), scheme_struct_property_type)) + scheme_wrong_contract("struct-type-property-predicate-procedure?", "(or/c struct-type-property? #f)", 1, argc, argv); + } + + if (SCHEME_CHAPERONEP(v)) v = SCHEME_CHAPERONE_VAL(v); + + if (!(STRUCT_mPROCP(v, SCHEME_PRIM_STRUCT_TYPE_STRUCT_PROP_PRED) + && SAME_TYPE(SCHEME_TYPE(SCHEME_PRIM_CLOSURE_ELS(v)[0]), scheme_struct_property_type))) + return scheme_false; + + if ((argc > 1) && SCHEME_TRUEP(argv[1])) { + prop = SCHEME_PRIM_CLOSURE_ELS(v)[0]; + prop_t = argv[1]; + return (SAME_OBJ(prop, prop_t) ? scheme_true : scheme_false); + } + + return scheme_true; +} static Scheme_Object * chaperone_prop_getter_p(int argc, Scheme_Object *argv[])