suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

add struct-type-property-predicate-procedure?

Browse Source
This commit is contained in:
Fred Fu 2019-10-21 09:00:57 -04:00 committed by Matthew Flatt
parent 56afa77a2a
commit 4405ed669f
9 changed files with 82 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/base/info.rkt
View File

@ -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]))

14
pkgs/racket-doc/scribblings/reference/struct.scrbl
View File

@ -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"]

10
pkgs/racket-test-core/tests/racket/struct.rktl
View File

@ -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)

1
racket/src/cs/primitive/kernel.ss
View File

@ -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)]

1
racket/src/cs/rumble.sls
View File

@ -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

20
racket/src/cs/rumble/struct.ss
View File

@ -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))))

2
racket/src/racket/src/schminc.h
View File

@ -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

2
racket/src/racket/src/schvers.h
View File

@ -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

36
racket/src/racket/src/struct.c
View File

@ -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[])