`procedure-arity-includes?' reports #f for keyword-requiring procs
by default; a new optional argument restores the old behavior (but the default behavior is consistent with the old docs and with the vast majority of existing uses) The implementation is ugly for performance reasons. A new primitive `prop:arity-incomplete' property determines when to return #f for `procedure-arity-includes?' in default mode. A nicer implementation would be to redefine `procedure-arity-includes?' at the kw-proc level, but the bytecode optimizer's and JIT's treatment of the built-in `procedure-arity-includes?' is important. The implementation choice could be revisited after cross-module inlining is implemented. Closes PR 11978
This commit is contained in:
Matthew Flatt
parent
649fe2f276
commit
56423f330e
|
|
@ -425,7 +425,7 @@ v4 todo:
|
|||
(and (procedure? x)
|
||||
(if (base->-dom-rest/c ctc)
|
||||
(procedure-accepts-and-more? x l)
|
||||
(procedure-arity-includes? x l))
|
||||
(procedure-arity-includes? x l #t))
|
||||
(keywords-match (base->-mandatory-kwds ctc) (base->-optional-kwds ctc) x)
|
||||
#t))))
|
||||
|
||||
|
|
@ -1720,8 +1720,8 @@ v4 todo:
|
|||
|
||||
(define (procedure-arity-includes?/optionals f base optionals)
|
||||
(cond
|
||||
[(zero? optionals) (procedure-arity-includes? f base)]
|
||||
[else (and (procedure-arity-includes? f (+ base optionals))
|
||||
[(zero? optionals) (procedure-arity-includes? f base #t)]
|
||||
[else (and (procedure-arity-includes? f (+ base optionals) #t)
|
||||
(procedure-arity-includes?/optionals f base (- optionals 1)))]))
|
||||
|
||||
(define (keywords-match mandatory-kwds optional-kwds val)
|
||||
|
|
|
|||
|
|
@ -145,7 +145,9 @@
|
|||
(list (cons prop:arity-string
|
||||
generate-arity-string)
|
||||
(cons prop:named-keyword-procedure
|
||||
(cons name fail-proc)))
|
||||
(cons name fail-proc))
|
||||
(cons prop:incomplete-arity
|
||||
#t))
|
||||
(current-inspector) fail-proc)])
|
||||
mk))
|
||||
|
||||
|
|
|
|||
|
|
@ -134,7 +134,8 @@
|
|||
procedure-arity procedure-reduce-arity raise-arity-error
|
||||
procedure->method procedure-rename
|
||||
chaperone-procedure impersonate-procedure
|
||||
assq assv assoc)
|
||||
assq assv assoc
|
||||
prop:incomplete-arity)
|
||||
(all-from "reqprov.rkt")
|
||||
(all-from-except "for.rkt"
|
||||
define-in-vector-like
|
||||
|
|
|
|||
|
|
@ -63,7 +63,8 @@
|
|||
hash-iterate-first hash-iterate-next
|
||||
hash-iterate-value hash-iterate-key
|
||||
log-message log-level? make-logger logger? current-logger logger-name
|
||||
make-log-receiver log-receiver?)
|
||||
make-log-receiver log-receiver?
|
||||
prop:incomplete-arity)
|
||||
(rename syntax->datum syntax-object->datum)
|
||||
(rename datum->syntax datum->syntax-object)
|
||||
(rename free-identifier=? module-identifier=?)
|
||||
|
|
|
|||
|
|
@ -168,15 +168,21 @@ elements.
|
|||
(procedure-arity (case-lambda [(x) 0] [(x y) 1]))
|
||||
]}
|
||||
|
||||
@defproc[(procedure-arity-includes? [proc procedure?] [k exact-nonnegative-integer?])
|
||||
@defproc[(procedure-arity-includes? [proc procedure?]
|
||||
[k exact-nonnegative-integer?]
|
||||
[kws-ok? any/c #f])
|
||||
boolean?]{
|
||||
|
||||
Returns @scheme[#t] if the procedure can accept @scheme[k] arguments
|
||||
when no keyword arguments are supplied, @scheme[#f] otherwise.
|
||||
Returns @scheme[#t] if the procedure can accept @scheme[k] by-position
|
||||
arguments, @scheme[#f] otherwise. If @racket[kws-ok?] is @racket[#f],
|
||||
the result is @racket[#t] only if @racket[proc] has no required
|
||||
keyword arguments.
|
||||
|
||||
@mz-examples[
|
||||
(procedure-arity-includes? cons 2)
|
||||
(procedure-arity-includes? display 3)
|
||||
(procedure-arity-includes? (lambda (x #:y y) x) 1)
|
||||
(procedure-arity-includes? (lambda (x #:y y) x) 1 #t)
|
||||
]}
|
||||
|
||||
@defproc[(procedure-reduce-arity [proc procedure?]
|
||||
|
|
|
|||
|
|
@ -1992,7 +1992,7 @@
|
|||
(err/rt-test (procedure-arity-includes? cons 1.0))
|
||||
(err/rt-test (procedure-arity-includes? 'cons 1))
|
||||
|
||||
(arity-test procedure-arity-includes? 2 2)
|
||||
(arity-test procedure-arity-includes? 2 3)
|
||||
|
||||
(newline)
|
||||
(display ";testing scheme 4 functions; ")
|
||||
|
|
|
|||
|
|
@ -93,7 +93,7 @@
|
|||
((arity-at-least-value a) . <= . 1))
|
||||
(and (list? a)
|
||||
(ormap loop a))))])
|
||||
(test 1-ok? procedure-arity-includes? (car p) 1)
|
||||
(test 1-ok? procedure-arity-includes? (car p) 1 #t)
|
||||
;; While we're here test renaming, etc.:
|
||||
(test 'other object-name (procedure-rename (car p) 'other))
|
||||
(test (procedure-arity (car p)) procedure-arity (procedure-rename (car p) 'other))
|
||||
|
|
@ -165,10 +165,10 @@
|
|||
(let ([p (car p)])
|
||||
(let-values ([(req allowed) (procedure-keywords p)])
|
||||
(if (null? allowed)
|
||||
(if (procedure-arity-includes? p 1)
|
||||
(if (procedure-arity-includes? p 1 #t)
|
||||
(list (procedure-reduce-arity p 1) 1 req allowed p)
|
||||
(list (procedure-reduce-arity p '()) '() req allowed p))
|
||||
(if (procedure-arity-includes? p 1)
|
||||
(if (procedure-arity-includes? p 1 #t)
|
||||
(list (procedure-reduce-keyword-arity p 1 req allowed) 1 req allowed p)
|
||||
(list (procedure-reduce-keyword-arity p '() req allowed) '() req allowed p))))))
|
||||
procs)
|
||||
|
|
@ -177,10 +177,10 @@
|
|||
(let ([p (car p)])
|
||||
(let-values ([(req allowed) (procedure-keywords p)])
|
||||
(if (null? allowed)
|
||||
(if (procedure-arity-includes? p 0)
|
||||
(if (procedure-arity-includes? p 0 #t)
|
||||
(list (procedure-reduce-arity p 0) 0 req allowed p)
|
||||
(list (procedure-reduce-arity p '()) '() req allowed p))
|
||||
(if (procedure-arity-includes? p 0)
|
||||
(if (procedure-arity-includes? p 0 #t)
|
||||
(list (procedure-reduce-keyword-arity p 0 req allowed) 0 req allowed p)
|
||||
(list (procedure-reduce-keyword-arity p '() req allowed) '() req allowed p))))))
|
||||
procs)
|
||||
|
|
@ -188,8 +188,7 @@
|
|||
(map (lambda (p)
|
||||
(let ([p (car p)])
|
||||
(let-values ([(req allowed) (procedure-keywords p)])
|
||||
(if (and (procedure-arity-includes? p 1)
|
||||
(null? req))
|
||||
(if (procedure-arity-includes? p 1)
|
||||
(list* (procedure-reduce-arity p 1) 1 '() '() p
|
||||
(if (null? allowed)
|
||||
null
|
||||
|
|
@ -200,8 +199,7 @@
|
|||
(map (lambda (p)
|
||||
(let ([p (car p)])
|
||||
(let-values ([(req allowed) (procedure-keywords p)])
|
||||
(if (and (procedure-arity-includes? p 0)
|
||||
(null? req))
|
||||
(if (procedure-arity-includes? p 0)
|
||||
(list (procedure-reduce-arity p 0) 0 '() '() p)
|
||||
(list (procedure-reduce-arity p '()) '() '() '() p)))))
|
||||
procs)
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load Diff
|
|
@ -501,7 +501,7 @@ scheme_init_fun (Scheme_Env *env)
|
|||
|
||||
o = scheme_make_folding_prim(scheme_procedure_arity_includes,
|
||||
"procedure-arity-includes?",
|
||||
2, 2, 1);
|
||||
2, 3, 1);
|
||||
SCHEME_PRIM_PROC_FLAGS(o) |= SCHEME_PRIM_IS_BINARY_INLINED;
|
||||
scheme_procedure_arity_includes_proc = o;
|
||||
scheme_add_global_constant("procedure-arity-includes?", o, env);
|
||||
|
|
@ -1854,7 +1854,7 @@ static Scheme_Object *clone_arity(Scheme_Object *a, int delta)
|
|||
return a;
|
||||
}
|
||||
|
||||
static Scheme_Object *get_or_check_arity(Scheme_Object *p, intptr_t a, Scheme_Object *bign)
|
||||
static Scheme_Object *get_or_check_arity(Scheme_Object *p, intptr_t a, Scheme_Object *bign, int inc_ok)
|
||||
/* a == -1 => get arity
|
||||
a == -2 => check for allowing bignum */
|
||||
{
|
||||
|
|
@ -1932,6 +1932,10 @@ static Scheme_Object *get_or_check_arity(Scheme_Object *p, intptr_t a, Scheme_Ob
|
|||
return first;
|
||||
} else if (type == scheme_proc_struct_type) {
|
||||
int is_method;
|
||||
if (!inc_ok
|
||||
&& scheme_no_arity_property
|
||||
&& scheme_struct_type_property_ref(scheme_no_arity_property, p))
|
||||
return scheme_false;
|
||||
if (scheme_reduced_procedure_struct
|
||||
&& scheme_is_struct_instance(scheme_reduced_procedure_struct, p)) {
|
||||
if (a >= 0) {
|
||||
|
|
@ -2183,7 +2187,7 @@ static Scheme_Object *get_or_check_arity(Scheme_Object *p, intptr_t a, Scheme_Ob
|
|||
|
||||
Scheme_Object *scheme_get_or_check_arity(Scheme_Object *p, intptr_t a)
|
||||
{
|
||||
return get_or_check_arity(p, a, NULL);
|
||||
return get_or_check_arity(p, a, NULL, 1);
|
||||
}
|
||||
|
||||
int scheme_check_proc_arity2(const char *where, int a,
|
||||
|
|
@ -2200,7 +2204,7 @@ int scheme_check_proc_arity2(const char *where, int a,
|
|||
if (false_ok && SCHEME_FALSEP(p))
|
||||
return 1;
|
||||
|
||||
if (!SCHEME_PROCP(p) || SCHEME_FALSEP(get_or_check_arity(p, a, NULL))) {
|
||||
if (!SCHEME_PROCP(p) || SCHEME_FALSEP(get_or_check_arity(p, a, NULL, 1))) {
|
||||
if (where) {
|
||||
char buffer[60];
|
||||
|
||||
|
|
@ -2522,7 +2526,7 @@ static Scheme_Object *object_name(int argc, Scheme_Object **argv)
|
|||
|
||||
Scheme_Object *scheme_arity(Scheme_Object *p)
|
||||
{
|
||||
return get_or_check_arity(p, -1, NULL);
|
||||
return get_or_check_arity(p, -1, NULL, 1);
|
||||
}
|
||||
|
||||
static Scheme_Object *procedure_arity(int argc, Scheme_Object *argv[])
|
||||
|
|
@ -2530,7 +2534,7 @@ static Scheme_Object *procedure_arity(int argc, Scheme_Object *argv[])
|
|||
if (!SCHEME_PROCP(argv[0]))
|
||||
scheme_wrong_type("procedure-arity", "procedure", 0, argc, argv);
|
||||
|
||||
return get_or_check_arity(argv[0], -1, NULL);
|
||||
return get_or_check_arity(argv[0], -1, NULL, 1);
|
||||
}
|
||||
|
||||
static Scheme_Object *procedure_arity_p(int argc, Scheme_Object *argv[])
|
||||
|
|
@ -2569,6 +2573,7 @@ static Scheme_Object *procedure_arity_p(int argc, Scheme_Object *argv[])
|
|||
Scheme_Object *scheme_procedure_arity_includes(int argc, Scheme_Object *argv[])
|
||||
{
|
||||
intptr_t n;
|
||||
int inc_ok;
|
||||
|
||||
if (!SCHEME_PROCP(argv[0]))
|
||||
scheme_wrong_type("procedure-arity-includes?", "procedure", 0, argc, argv);
|
||||
|
|
@ -2576,7 +2581,9 @@ Scheme_Object *scheme_procedure_arity_includes(int argc, Scheme_Object *argv[])
|
|||
n = scheme_extract_index("procedure-arity-includes?", 1, argc, argv, -2, 0);
|
||||
/* -2 means a bignum */
|
||||
|
||||
return get_or_check_arity(argv[0], n, argv[1]);
|
||||
inc_ok = ((argc > 2) && SCHEME_TRUEP(argv[2]));
|
||||
|
||||
return get_or_check_arity(argv[0], n, argv[1], inc_ok);
|
||||
}
|
||||
|
||||
static int is_arity(Scheme_Object *a, int at_least_ok, int list_ok)
|
||||
|
|
@ -2788,7 +2795,7 @@ static Scheme_Object *procedure_reduce_arity(int argc, Scheme_Object *argv[])
|
|||
a bit complicated, because both the source and target can be
|
||||
lists that include arity-at-least records. */
|
||||
|
||||
orig = get_or_check_arity(argv[0], -1, NULL);
|
||||
orig = get_or_check_arity(argv[0], -1, NULL, 1);
|
||||
aty = clone_arity(argv[1], 0);
|
||||
|
||||
if (!is_subarity(aty, orig)) {
|
||||
|
|
@ -2816,7 +2823,7 @@ static Scheme_Object *procedure_rename(int argc, Scheme_Object *argv[])
|
|||
p = scheme_rename_struct_proc(argv[0], argv[1]);
|
||||
if (p) return p;
|
||||
|
||||
aty = get_or_check_arity(argv[0], -1, NULL);
|
||||
aty = get_or_check_arity(argv[0], -1, NULL, 1);
|
||||
|
||||
return make_reduced_proc(argv[0], aty, argv[1], NULL);
|
||||
}
|
||||
|
|
@ -2828,7 +2835,7 @@ static Scheme_Object *procedure_to_method(int argc, Scheme_Object *argv[])
|
|||
if (!SCHEME_PROCP(argv[0]))
|
||||
scheme_wrong_type("procedure->method", "procedure", 0, argc, argv);
|
||||
|
||||
aty = get_or_check_arity(argv[0], -1, NULL);
|
||||
aty = get_or_check_arity(argv[0], -1, NULL, 1);
|
||||
|
||||
return make_reduced_proc(argv[0], aty, NULL, scheme_true);
|
||||
}
|
||||
|
|
@ -2957,8 +2964,8 @@ static Scheme_Object *do_chaperone_procedure(const char *name, const char *whati
|
|||
if (!SCHEME_PROCP(argv[1]))
|
||||
scheme_wrong_type(name, "procedure", 1, argc, argv);
|
||||
|
||||
orig = get_or_check_arity(val, -1, NULL);
|
||||
naya = get_or_check_arity(argv[1], -1, NULL);
|
||||
orig = get_or_check_arity(val, -1, NULL, 1);
|
||||
naya = get_or_check_arity(argv[1], -1, NULL, 1);
|
||||
|
||||
if (!is_subarity(orig, naya))
|
||||
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
|
||||
|
|
@ -8331,7 +8338,7 @@ static Scheme_Object *time_apply(int argc, Scheme_Object *argv[])
|
|||
num_rands++;
|
||||
}
|
||||
|
||||
if (SCHEME_FALSEP(get_or_check_arity(argv[0], num_rands, NULL))) {
|
||||
if (SCHEME_FALSEP(get_or_check_arity(argv[0], num_rands, NULL, 1))) {
|
||||
char *s;
|
||||
intptr_t aelen;
|
||||
|
||||
|
|
|
|||
|
|
@ -13,7 +13,7 @@
|
|||
|
||||
#define USE_COMPILED_STARTUP 1
|
||||
|
||||
#define EXPECTED_PRIM_COUNT 1022
|
||||
#define EXPECTED_PRIM_COUNT 1023
|
||||
#define EXPECTED_UNSAFE_COUNT 76
|
||||
#define EXPECTED_FLFXNUM_COUNT 68
|
||||
#define EXPECTED_FUTURES_COUNT 11
|
||||
|
|
|
|||
|
|
@ -406,6 +406,8 @@ extern Scheme_Object *scheme_impersonator_of_property;
|
|||
|
||||
extern Scheme_Object *scheme_app_mark_impersonator_property;
|
||||
|
||||
extern Scheme_Object *scheme_no_arity_property;
|
||||
|
||||
extern Scheme_Object *scheme_reduced_procedure_struct;
|
||||
|
||||
/*========================================================================*/
|
||||
|
|
|
|||
|
|
@ -13,12 +13,12 @@
|
|||
consistently.)
|
||||
*/
|
||||
|
||||
#define MZSCHEME_VERSION "5.1.1.5"
|
||||
#define MZSCHEME_VERSION "5.1.1.6"
|
||||
|
||||
#define MZSCHEME_VERSION_X 5
|
||||
#define MZSCHEME_VERSION_Y 1
|
||||
#define MZSCHEME_VERSION_Z 1
|
||||
#define MZSCHEME_VERSION_W 5
|
||||
#define MZSCHEME_VERSION_W 6
|
||||
|
||||
#define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
|
||||
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)
|
||||
|
|
|
|||
|
|
@ -32,6 +32,7 @@ READ_ONLY Scheme_Object *scheme_source_property;
|
|||
READ_ONLY Scheme_Object *scheme_input_port_property;
|
||||
READ_ONLY Scheme_Object *scheme_output_port_property;
|
||||
READ_ONLY Scheme_Object *scheme_equal_property;
|
||||
READ_ONLY Scheme_Object *scheme_no_arity_property;
|
||||
READ_ONLY Scheme_Object *scheme_impersonator_of_property;
|
||||
READ_ONLY Scheme_Object *scheme_make_struct_type_proc;
|
||||
READ_ONLY Scheme_Object *scheme_current_inspector_proc;
|
||||
|
|
@ -337,6 +338,12 @@ scheme_init_struct (Scheme_Env *env)
|
|||
scheme_add_global_constant("prop:procedure", proc_property, env);
|
||||
}
|
||||
|
||||
{
|
||||
REGISTER_SO(scheme_no_arity_property);
|
||||
scheme_no_arity_property = scheme_make_struct_type_property(scheme_intern_symbol("incomplete-arity"));
|
||||
scheme_add_global_constant("prop:incomplete-arity", scheme_no_arity_property, env);
|
||||
}
|
||||
|
||||
{
|
||||
guard = scheme_make_prim_w_arity(check_equal_property_value_ok,
|
||||
"guard-for-prop:equal+hash",
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user