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

Add procedure->method for a runtime version of the 'method-arity-error

Browse Source 
syntax property.

svn: r18501
This commit is contained in:
Stevie Strickland 2010-03-10 01:25:57 +00:00
commit 14d1760abe
8 changed files with 673 additions and 542 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
collects/scribblings/reference/procedures.scrbl
View File

@ -65,6 +65,14 @@ produced by @scheme[define-struct],
typically, however, @scheme[name] is not used for reporting errors,
since the procedure name is typically hard-wired into an internal
check.}
@defproc[(procedure->method [proc procedure?])
procedure?]{
Returns a procedure that is like @scheme[proc] except that, when applied
to the wrong number of arguments, the resulting error hides the first
argument as if the procedure had been compiled with the
@indexed-scheme['method-arity-error] syntax property.}
@; ----------------------------------------
@section{Keywords and Arity}

20
collects/tests/mzscheme/object.ss
View File

@ -1285,7 +1285,25 @@
(test 1 (mk-f) 1 2)
(let ([f (mk-f)])
(test 1 (mk-f) 1 2)
(check-arity-error (mk-f) #t))))))
(check-arity-error (mk-f) #t))))
(let* ([f (lambda (a b) a)]
[meth (procedure->method f)]
[check-arity-error
(lambda (f cl?)
(test (if cl? '("no clause matching 0 arguments") '("expects 1 argument") )
regexp-match #rx"expects 1 argument|no clause matching 0 arguments"
(exn-message (with-handlers ([values values])
;; Use `apply' to avoid triggering
;; compilation of f:
(apply f '(1))))))])
(test 2 procedure-arity meth)
(check-arity-error meth #f)
(test 1 meth 1 2)
(let* ([f (case-lambda [(a b) a] [(c d) c])]
[meth (procedure->method f)])
(test 2 procedure-arity meth)
(check-arity-error meth #t)
(test 1 meth 1 2)))))
'(#t #f))
;; ------------------------------------------------------------

1133
src/mzscheme/src/cstartup.inc
View File

File diff suppressed because it is too large Load Diff

3
src/mzscheme/src/error.c
View File

@ -1006,7 +1006,8 @@ static char *make_arity_expect_string(const char *name, int namelen,
Scheme_Object *arity;
arity = scheme_arity((Scheme_Object *)name);
if (SCHEME_INTP(arity)) {
xminc = xmaxc = minc = maxc = SCHEME_INT_VAL(arity);
minc = maxc = SCHEME_INT_VAL(arity);
xmaxc = xminc = minc - (is_method ? 1 : 0);
name = scheme_get_proc_name((Scheme_Object *)name, &namelen, 1);
if (!name) {
name = "#<procedure>";

33
src/mzscheme/src/fun.c
View File

@ -167,6 +167,7 @@ static Scheme_Object *procedure_arity_p(int argc, Scheme_Object *argv[]);
static Scheme_Object *procedure_arity_includes(int argc, Scheme_Object *argv[]);
static Scheme_Object *procedure_reduce_arity(int argc, Scheme_Object *argv[]);
static Scheme_Object *procedure_rename(int argc, Scheme_Object *argv[]);
static Scheme_Object *procedure_to_method(int argc, Scheme_Object *argv[]);
static Scheme_Object *procedure_equal_closure_p(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[]);
@ -500,6 +501,11 @@ scheme_init_fun (Scheme_Env *env)
"procedure-rename",
2, 2),
env);
scheme_add_global_constant("procedure->method",
scheme_make_prim_w_arity(procedure_to_method,
"procedure->method",
1, 1),
env);
scheme_add_global_constant("procedure-closure-contents-eq?",
scheme_make_folding_prim(procedure_equal_closure_p,
"procedure-closure-contents-eq?",
@ -3651,30 +3657,33 @@ void scheme_init_reduced_proc_struct(Scheme_Env *env)
scheme_reduced_procedure_struct = scheme_make_proc_struct_type(NULL,
NULL,
(Scheme_Object *)insp,
3, 0,
4, 0,
scheme_false,
scheme_make_integer(0),
NULL);
}
}
static Scheme_Object *make_reduced_proc(Scheme_Object *proc, Scheme_Object *aty, Scheme_Object *name)
static Scheme_Object *make_reduced_proc(Scheme_Object *proc, Scheme_Object *aty, Scheme_Object *name, Scheme_Object *is_meth)
{
Scheme_Object *a[3];
Scheme_Object *a[4];
if (SCHEME_STRUCTP(proc)
&& scheme_is_struct_instance(scheme_reduced_procedure_struct, proc)) {
/* Don't need the intermediate layer */
if (!name)
name = ((Scheme_Structure *)proc)->slots[2];
if (!is_meth)
is_meth = ((Scheme_Structure *)proc)->slots[3];
proc = ((Scheme_Structure *)proc)->slots[0];
}
a[0] = proc;
a[1] = aty;
a[2] = (name ? name : scheme_false);
a[3] = (is_meth ? is_meth : scheme_false);
return scheme_make_struct_instance(scheme_reduced_procedure_struct, 3, a);
return scheme_make_struct_instance(scheme_reduced_procedure_struct, 4, a);
}
static Scheme_Object *procedure_reduce_arity(int argc, Scheme_Object *argv[])
@ -3819,7 +3828,7 @@ static Scheme_Object *procedure_reduce_arity(int argc, Scheme_Object *argv[])
}
/* Construct a procedure that has the given arity. */
return make_reduced_proc(argv[0], aty, NULL);
return make_reduced_proc(argv[0], aty, NULL, NULL);
}
static Scheme_Object *procedure_rename(int argc, Scheme_Object *argv[])
@ -3836,7 +3845,19 @@ static Scheme_Object *procedure_rename(int argc, Scheme_Object *argv[])
aty = get_or_check_arity(argv[0], -1, NULL);
return make_reduced_proc(argv[0], aty, argv[1]);
return make_reduced_proc(argv[0], aty, argv[1], NULL);
}
static Scheme_Object *procedure_to_method(int argc, Scheme_Object *argv[])
{
Scheme_Object *aty;
if (!SCHEME_PROCP(argv[0]))
scheme_wrong_type("procedure->method", "procedure", 0, argc, argv);
aty = get_or_check_arity(argv[0], -1, NULL);
return make_reduced_proc(argv[0], aty, NULL, scheme_true);
}
static Scheme_Object *procedure_equal_closure_p(int argc, Scheme_Object *argv[])

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

@ -13,7 +13,7 @@
#define USE_COMPILED_STARTUP 1
#define EXPECTED_PRIM_COUNT 965
#define EXPECTED_PRIM_COUNT 966
#define EXPECTED_UNSAFE_COUNT 58
#define EXPECTED_FLFXNUM_COUNT 53

4
src/mzscheme/src/schvers.h
View File

@ -13,12 +13,12 @@
consistently.)
*/
#define MZSCHEME_VERSION "4.2.4.5"
#define MZSCHEME_VERSION "4.2.4.6"
#define MZSCHEME_VERSION_X 4
#define MZSCHEME_VERSION_Y 2
#define MZSCHEME_VERSION_Z 4
#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)

12
src/mzscheme/src/struct.c
View File

@ -3717,6 +3717,7 @@ Scheme_Object *scheme_extract_struct_procedure(Scheme_Object *obj, int num_rands
{
Scheme_Struct_Type *stype;
Scheme_Object *a, *proc;
int meth_wrap = 0;
stype = ((Scheme_Structure *)obj)->stype;
a = stype->proc_attr;
@ -3728,14 +3729,21 @@ Scheme_Object *scheme_extract_struct_procedure(Scheme_Object *obj, int num_rands
*is_method = 1;
proc = a;
}
if (num_rands >= 0) {
/* num_rands is non-negative => do arity check */
if (!SCHEME_PROCP(proc)
|| !scheme_check_proc_arity(NULL, num_rands, -1, 0, &obj)) {
/* If we're wrapping the result of procedure->method, we need to
* account for that.
*/
if (scheme_reduced_procedure_struct
&& scheme_is_struct_instance(scheme_reduced_procedure_struct, obj))
meth_wrap = SCHEME_TRUEP(((Scheme_Structure *)obj)->slots[3]);
scheme_wrong_count_m((char *)obj,
-1 /* means "name argument is really a proc struct" */, 0,
num_rands, rands, 0 /* methodness internally handled */);
num_rands, rands, meth_wrap);
return NULL;
}
}