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

Generalize procedure-result-arity to work on reduced-arity procedures.

Browse Source
This commit is contained in:
Vincent St-Amour 2016-03-07 16:11:46 -06:00
parent c1d44cedba
commit e90e587a91
2 changed files with 20 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
pkgs/racket-test-core/tests/racket/function.rktl
View File

@ -110,7 +110,9 @@
(test 1 procedure-result-arity car)
(test 1 procedure-result-arity list)
(test 1 procedure-result-arity (procedure-reduce-arity car 1))
(test (arity-at-least 0) procedure-result-arity values)
(test (arity-at-least 0) procedure-result-arity (procedure-reduce-arity values 1))
(test (arity-at-least 0) procedure-result-arity call/cc)
(let ()
(struct s (x))
@ -124,6 +126,13 @@
(if (= 0 (random 1))
1
(values 1 2))))
(test #f procedure-result-arity
(procedure-reduce-arity
(λ ()
(if (= 0 (random 1))
1
(values 1 2)))
0))
(err/rt-test (procedure-result-arity 1) exn:fail?)
(test 1 procedure-result-arity (chaperone-procedure car values))
(test 1 procedure-result-arity (impersonate-procedure car (λ (x) 1)))

15
racket/src/racket/src/fun.c
View File

@ -2909,7 +2909,10 @@ static Scheme_Object *procedure_result_arity(int argc, Scheme_Object *argv[])
/* Struct procedures could be keyword-accepting and that
requires additional complication; defer for now */
if (SAME_TYPE(SCHEME_TYPE(o), scheme_proc_struct_type)) {
if (SAME_TYPE(SCHEME_TYPE(o), scheme_proc_struct_type)
/* Structs corresponding to reduced-arity procedures are ok, though.
Their result arity is just that of the underlying procedure. */
&& !scheme_is_struct_instance(scheme_reduced_procedure_struct, o)) {
return scheme_false;
}
@ -2939,6 +2942,9 @@ static Scheme_Object *procedure_result_arity(int argc, Scheme_Object *argv[])
return scheme_make_arity(p->minr, p->maxr);
}
return scheme_make_integer(1);
} else if (SCHEME_STRUCTP(o)
&& scheme_is_struct_instance(scheme_reduced_procedure_struct, o)) {
return ((Scheme_Structure *)o)->slots[4];
} else if (!SCHEME_PROCP(o)) {
scheme_wrong_contract("procedure-result-arity", "procedure?", 0, argc, argv);
return NULL;
@ -3132,7 +3138,7 @@ void scheme_init_reduced_proc_struct(Scheme_Env *env)
scheme_reduced_procedure_struct = scheme_make_struct_type2(NULL,
NULL,
(Scheme_Object *)insp,
4, 0,
5, 0,
scheme_false,
scheme_null,
scheme_make_integer(0),
@ -3142,7 +3148,7 @@ void scheme_init_reduced_proc_struct(Scheme_Env *env)
static Scheme_Object *make_reduced_proc(Scheme_Object *proc, Scheme_Object *aty, Scheme_Object *name, Scheme_Object *is_meth)
{
Scheme_Object *a[4];
Scheme_Object *a[5];
if (SCHEME_STRUCTP(proc)
&& scheme_is_struct_instance(scheme_reduced_procedure_struct, proc)) {
@ -3158,8 +3164,9 @@ static Scheme_Object *make_reduced_proc(Scheme_Object *proc, Scheme_Object *aty,
a[1] = aty;
a[2] = (name ? name : scheme_false);
a[3] = (is_meth ? is_meth : scheme_false);
a[4] = procedure_result_arity(1, &proc);
return scheme_make_struct_instance(scheme_reduced_procedure_struct, 4, a);
return scheme_make_struct_instance(scheme_reduced_procedure_struct, 5, a);
}
static int is_subarity(Scheme_Object *req, Scheme_Object *orig, int req_delta)