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

add procedure-result-arity

Browse Source
This commit is contained in:
Robby Findler 2016-01-15 21:31:28 -06:00
parent 308c918a42
commit 579d50b2d8
8 changed files with 1179 additions and 1053 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
pkgs/racket-doc/scribblings/reference/procedures.scrbl
View File

@ -230,6 +230,24 @@ list is also in the second list.
(procedure-keywords (lambda (#:tag t #:mode [m #f]) t))
]}
@defproc[(procedure-result-arity [proc procedure?]) (or/c #f procedure-arity?)]{
Returns the arity of the result of the procedure @racket[proc] or
@racket[#f] if the number of results are not known, perhaps due to shortcomings
in the implementation of @racket[procedure-result-arity] or
because @racket[proc]'s behavior is not sufficiently simple.
@mz-examples[(procedure-result-arity car)
(procedure-result-arity values)
(procedure-result-arity
(λ (x)
(apply
values
(let loop ()
(cond
[(zero? (random 10)) '()]
[else (cons 1 (loop))])))))]
}
@defproc[(make-keyword-procedure
[proc (((listof keyword?) list?) () #:rest list? . ->* . any)]
[plain-proc procedure? (lambda args (apply proc null null args))])

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

@ -106,6 +106,49 @@
(arity-test compose1 0 -1)
(arity-test compose 0 -1))
;; ---------- procedure-result-arity ----------
(test 1 procedure-result-arity car)
(test 1 procedure-result-arity list)
(test (arity-at-least 0) procedure-result-arity values)
(test (arity-at-least 0) procedure-result-arity call/cc)
(let ()
(struct s (x))
(test 1 procedure-result-arity s-x)
(test 1 procedure-result-arity s?)
(test 1 procedure-result-arity s))
(test 1 procedure-result-arity (λ (x) 0))
(test 1 procedure-result-arity (let ([f 1]) (λ (x) (+ f x))))
(test #f procedure-result-arity
(λ ()
(if (= 0 (random 1))
1
(values 1 2))))
(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)))
(test #f procedure-result-arity (λ (x) (values x x)))
(test 1 procedure-result-arity (parameterize ([eval-jit-enabled #f])
(eval '(λ (x) x))))
(test 1 procedure-result-arity (parameterize ([eval-jit-enabled #f])
(eval '(case-lambda
[(x) x]
[(x y) x]
[(a b c d e f) a]
[(a b . whatever) a]))))
(test #f procedure-result-arity (parameterize ([eval-jit-enabled #f])
(eval '(case-lambda
[(x) x]
[(x y) (values x y)]
[(a b c d e f) (values 1 2 3 4 5 6 7 8)]
[(a b . whatever) a]))))
;; hopefully this test will start failing at
;; some point and return 1 instead of #f
(let ()
(struct s (f) #:property prop:procedure 0)
(test #f procedure-result-arity (s car)))
;; ---------- identity ----------
(let ()
(test 'foo identity 'foo)

2082
racket/src/racket/src/cstartup.inc
View File

File diff suppressed because it is too large Load Diff

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

@ -190,6 +190,7 @@ static Scheme_Object *impersonate_procedure_star(int argc, Scheme_Object *argv[]
static Scheme_Object *primitive_p(int argc, Scheme_Object *argv[]);
static Scheme_Object *primitive_closure_p(int argc, Scheme_Object *argv[]);
static Scheme_Object *primitive_result_arity (int argc, Scheme_Object *argv[]);
static Scheme_Object *procedure_result_arity (int argc, Scheme_Object *argv[]);
static Scheme_Object *call_with_values(int argc, Scheme_Object *argv[]);
Scheme_Object *scheme_values(int argc, Scheme_Object *argv[]);
static Scheme_Object *current_print(int argc, Scheme_Object **argv);
@ -653,6 +654,12 @@ scheme_init_fun (Scheme_Env *env)
1, 1, 1),
env);
scheme_add_global_constant("procedure-result-arity",
scheme_make_folding_prim(procedure_result_arity,
"procedure-result-arity",
1, 1, 1),
env);
scheme_add_global_constant("current-print",
scheme_register_parameter(current_print,
"current-print",
@ -2885,13 +2892,61 @@ static Scheme_Object *primitive_result_arity(int argc, Scheme_Object *argv[])
return scheme_make_arity(p->minr, p->maxr);
}
} else {
scheme_wrong_contract("primitive-result_arity", "primitive?", 0, argc, argv);
scheme_wrong_contract("primitive-result-arity", "primitive?", 0, argc, argv);
return NULL;
}
return scheme_make_integer(1);
}
static Scheme_Object *procedure_result_arity(int argc, Scheme_Object *argv[])
{
Scheme_Object *o, *orig_o;
orig_o = argv[0];
o = orig_o;
if (SCHEME_CHAPERONEP(o))
o = SCHEME_CHAPERONE_VAL(o);
/* Struct procedures could be keyword-accepting and that
requires additional complication; defer for now */
if (SAME_TYPE(SCHEME_TYPE(o), scheme_proc_struct_type)) {
return scheme_false;
}
if (SAME_TYPE(SCHEME_TYPE(o), scheme_closure_type)) {
if ((SCHEME_CLOSURE_DATA_FLAGS(SCHEME_COMPILED_CLOS_CODE(o)) & CLOS_SINGLE_RESULT)) {
return scheme_make_integer(1);
}
#ifdef MZ_USE_JIT
} else if (SAME_TYPE(SCHEME_TYPE(o), scheme_native_closure_type)) {
if (scheme_native_closure_is_single_result(o))
return scheme_make_integer(1);
#endif
} else if (SAME_TYPE(SCHEME_TYPE(o), scheme_case_closure_type)) {
Scheme_Case_Lambda *cl = (Scheme_Case_Lambda *)o;
int i;
for (i = cl->count; i--; ) {
if (!(SCHEME_CLOSURE_DATA_FLAGS(SCHEME_COMPILED_CLOS_CODE(cl->array[i])) & CLOS_SINGLE_RESULT))
break;
}
if (i < 0)
return scheme_make_integer(1);
} else if (SCHEME_PRIMP(o)) {
if (((Scheme_Primitive_Proc *)o)->pp.flags & SCHEME_PRIM_IS_MULTI_RESULT) {
Scheme_Prim_W_Result_Arity *p = (Scheme_Prim_W_Result_Arity *)o;
return scheme_make_arity(p->minr, p->maxr);
}
return scheme_make_integer(1);
} else if (!SCHEME_PROCP(o)) {
scheme_wrong_contract("procedure-result-arity", "procedure?", 0, argc, argv);
return NULL;
}
return scheme_false;
}
Scheme_Object *scheme_object_name(Scheme_Object *a)
{
Scheme_Object *v;

25
racket/src/racket/src/jit.c
View File

@ -928,17 +928,21 @@ int scheme_needs_only_target_register(Scheme_Object *obj, int and_can_reorder)
return (t >= _scheme_compiled_values_types_);
}
int scheme_native_closure_is_single_result(Scheme_Object *rator)
{
Scheme_Native_Closure *nc = (Scheme_Native_Closure *)rator;
if (nc->code->start_code == scheme_on_demand_jit_code)
return (SCHEME_CLOSURE_DATA_FLAGS(nc->code->u2.orig_code) & CLOS_SINGLE_RESULT);
else
return (SCHEME_NATIVE_CLOSURE_DATA_FLAGS(nc->code) & NATIVE_IS_SINGLE_RESULT);
}
static int produces_single_value(Scheme_Object *rator, int num_args, mz_jit_state *jitter)
{
rator = scheme_specialize_to_constant(rator, jitter, num_args);
if (SAME_TYPE(SCHEME_TYPE(rator), scheme_native_closure_type)) {
Scheme_Native_Closure *nc = (Scheme_Native_Closure *)rator;
if (nc->code->start_code == scheme_on_demand_jit_code)
return (SCHEME_CLOSURE_DATA_FLAGS(nc->code->u2.orig_code) & CLOS_SINGLE_RESULT);
else
return (SCHEME_NATIVE_CLOSURE_DATA_FLAGS(nc->code) & NATIVE_IS_SINGLE_RESULT);
}
if (SAME_TYPE(SCHEME_TYPE(rator), scheme_native_closure_type))
return scheme_native_closure_is_single_result(rator);
if (SCHEME_PRIMP(rator)) {
int opt;
@ -4278,7 +4282,7 @@ static void generate_case_lambda(Scheme_Case_Lambda *c, Scheme_Native_Closure_Da
Generate_Case_Dispatch_Data gdata;
Scheme_Closure_Data *data;
Scheme_Object *o;
int i, cnt, num_params, has_rest;
int i, cnt, num_params, has_rest, single_result = 1;
mzshort *arities;
gdata.c = c;
@ -4302,6 +4306,8 @@ static void generate_case_lambda(Scheme_Case_Lambda *c, Scheme_Native_Closure_Da
has_rest = ((SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_REST) ? 1 : 0);
if (has_rest && num_params)
--num_params;
if (!(SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_SINGLE_RESULT))
single_result = 0;
if (!has_rest)
arities[i] = num_params;
@ -4309,6 +4315,9 @@ static void generate_case_lambda(Scheme_Case_Lambda *c, Scheme_Native_Closure_Da
arities[i] = -(num_params+1);
}
ndata->u.arities = arities;
if (single_result)
SCHEME_NATIVE_CLOSURE_DATA_FLAGS(ndata) |= NATIVE_IS_SINGLE_RESULT;
}
/*========================================================================*/

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

@ -14,7 +14,7 @@
#define USE_COMPILED_STARTUP 1
#define EXPECTED_PRIM_COUNT 1143
#define EXPECTED_PRIM_COUNT 1144
#define EXPECTED_UNSAFE_COUNT 106
#define EXPECTED_FLFXNUM_COUNT 69
#define EXPECTED_EXTFL_COUNT 45

1
racket/src/racket/src/schpriv.h
View File

@ -3332,6 +3332,7 @@ int scheme_check_structure_shape(Scheme_Object *e, Scheme_Object *expected);
int scheme_decode_struct_shape(Scheme_Object *shape, intptr_t *_v);
int scheme_closure_preserves_marks(Scheme_Object *p);
int scheme_native_closure_preserves_marks(Scheme_Object *p);
int scheme_native_closure_is_single_result(Scheme_Object *rator);
int scheme_is_env_variable_boxed(Scheme_Comp_Env *env, int which);

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

@ -13,7 +13,7 @@
consistently.)
*/
#define MZSCHEME_VERSION "6.4.0.2"
#define MZSCHEME_VERSION "6.4.0.3"
#define MZSCHEME_VERSION_X 6
#define MZSCHEME_VERSION_Y 4