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 car)
(test 1 procedure-result-arity list) (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 values)
(test (arity-at-least 0) procedure-result-arity (procedure-reduce-arity values 1))
(test (arity-at-least 0) procedure-result-arity call/cc) (test (arity-at-least 0) procedure-result-arity call/cc)
(let () (let ()
(struct s (x)) (struct s (x))
@ -124,6 +126,13 @@
(if (= 0 (random 1)) (if (= 0 (random 1))
1 1
(values 1 2)))) (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?) (err/rt-test (procedure-result-arity 1) exn:fail?)
(test 1 procedure-result-arity (chaperone-procedure car values)) (test 1 procedure-result-arity (chaperone-procedure car values))
(test 1 procedure-result-arity (impersonate-procedure car (λ (x) 1))) (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 /* Struct procedures could be keyword-accepting and that
requires additional complication; defer for now */ 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; 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_arity(p->minr, p->maxr);
} }
return scheme_make_integer(1); 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)) { } else if (!SCHEME_PROCP(o)) {
scheme_wrong_contract("procedure-result-arity", "procedure?", 0, argc, argv); scheme_wrong_contract("procedure-result-arity", "procedure?", 0, argc, argv);
return NULL; return NULL;
@ -3132,7 +3138,7 @@ void scheme_init_reduced_proc_struct(Scheme_Env *env)
scheme_reduced_procedure_struct = scheme_make_struct_type2(NULL, scheme_reduced_procedure_struct = scheme_make_struct_type2(NULL,
NULL, NULL,
(Scheme_Object *)insp, (Scheme_Object *)insp,
4, 0, 5, 0,
scheme_false, scheme_false,
scheme_null, scheme_null,
scheme_make_integer(0), 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) 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) if (SCHEME_STRUCTP(proc)
&& scheme_is_struct_instance(scheme_reduced_procedure_struct, 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[1] = aty;
a[2] = (name ? name : scheme_false); a[2] = (name ? name : scheme_false);
a[3] = (is_meth ? is_meth : 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) static int is_subarity(Scheme_Object *req, Scheme_Object *orig, int req_delta)