add more support for continuation marks in procedure impersonators
Allow a more dynamic (than `impersonator-prop:application-mark`) determination of continuation marks and associated values to wrap the call of an impersonated procedure.
This commit is contained in:
Matthew Flatt
parent
69b8b2be35
commit
8e46e46d40
|
|
@ -191,18 +191,31 @@ required keyword arguments of @racket[wrapper-proc] must be a subset
|
|||
of the required keywords of @racket[proc].
|
||||
|
||||
For applications without keywords, the result of @racket[wrapper-proc]
|
||||
must be either the same number of values as supplied to it or one more
|
||||
than the number of supplied values, where an extra result is supplied
|
||||
before the others. The additional result, if any, must be a procedure
|
||||
must be at least the same number of values as supplied to it.
|
||||
Additional results can be supplied---before the values that correspond
|
||||
to the supplied values---in the following pattern:
|
||||
|
||||
@itemlist[
|
||||
|
||||
@item{An optional procedure, @racket[_result-wrapper-proc], which
|
||||
will be applied to the results of @racket[proc]; followed by}
|
||||
|
||||
@item{any number of repetitions of @racket['mark _key _val] (i.e.,
|
||||
three values), where the call @racket[_proc] is wrapped to
|
||||
install a @tech{continuation mark} @racket[_key] and @racket[_val].}
|
||||
|
||||
]
|
||||
|
||||
If @racket[_result-wrapper-proc] is produced, it must be a procedure
|
||||
that accepts as many results as produced by @racket[proc]; it must
|
||||
return the same number of results. If @racket[wrapper-proc] returns
|
||||
the same number of values as it is given (i.e., it does not return a
|
||||
procedure to impersonator @racket[proc]'s result), then @racket[proc] is
|
||||
called in @tech{tail position} with respect to the call to the impersonator.
|
||||
return the same number of results. If @racket[_result-wrapper-proc] is
|
||||
not supplied, then @racket[proc] is called in @tech{tail position}
|
||||
with respect to the call to the impersonator.
|
||||
|
||||
For applications that include keyword arguments, @racket[wrapper-proc]
|
||||
must return an additional value before any other values but after the
|
||||
result-impersonating procedure (if any). The additional value must be a
|
||||
must return an additional value before any other values but after
|
||||
@racket[_result-wrapper-proc] and @racket['mark _key _val]
|
||||
sequences (if any). The additional value must be a
|
||||
list of replacements for the keyword arguments that were supplied to the
|
||||
impersonator (i.e., not counting optional arguments that were
|
||||
not supplied). The arguments must be ordered according to the sorted
|
||||
|
|
@ -229,7 +242,11 @@ for @racket[(car prop-val)] in the call's continuation---then the value is
|
|||
also installed as an immediate value for @racket[(car prop-val)] as a
|
||||
mark during the call to @racket[wrapper-proc] (which allows tail-calls
|
||||
of impersonators with respect to wrapping impersonators to be detected within
|
||||
@racket[wrapper-proc]).}
|
||||
@racket[wrapper-proc]).
|
||||
|
||||
@history[#:changed "6.3.0.5" @elem{Added support for @racket['mark
|
||||
_key _val] results from
|
||||
@racket[wrapper-proc].}]}
|
||||
|
||||
@defproc[(impersonate-procedure* [proc procedure?]
|
||||
[wrapper-proc (or/c procedure? #f)]
|
||||
|
|
|
|||
|
|
@ -348,6 +348,28 @@
|
|||
(test (vector 1110 1111) values in)
|
||||
(check-proc-prop f mk)))
|
||||
|
||||
;; Single argument, no post filter, set continuation mark:
|
||||
(as-chaperone-or-impersonator
|
||||
([chaperone-procedure impersonate-procedure
|
||||
chaperone-procedure**
|
||||
impersonate-procedure**])
|
||||
(let* ([f (lambda (x) (list x (continuation-mark-set-first #f 'the-mark)))]
|
||||
[in #f]
|
||||
[mk (lambda (f)
|
||||
(chaperone-procedure
|
||||
f
|
||||
(lambda (x)
|
||||
(set! in x)
|
||||
(values 'mark 'the-mark 8 x))))]
|
||||
[f2 (mk f)])
|
||||
(with-continuation-mark 'the-mark
|
||||
7
|
||||
(test '(110 7) f 110))
|
||||
(test #f values in)
|
||||
(test '(111 8) f2 111)
|
||||
(test 111 values in)
|
||||
(check-proc-prop f mk)))
|
||||
|
||||
;; Single argument, post filter on single value:
|
||||
(as-chaperone-or-impersonator
|
||||
([chaperone-procedure impersonate-procedure
|
||||
|
|
@ -400,6 +422,42 @@
|
|||
(test (vector 'b '(a c)) values out)
|
||||
(check-proc-prop f mk)))
|
||||
|
||||
;; Multiple arguments, post filter on multiple values
|
||||
;; and set multiple continuation marks:
|
||||
(as-chaperone-or-impersonator
|
||||
([chaperone-procedure impersonate-procedure
|
||||
chaperone-procedure**
|
||||
impersonate-procedure**])
|
||||
(let* ([f (lambda (x y z) (values y (list x z
|
||||
(continuation-mark-set-first #f 'the-mark)
|
||||
(continuation-mark-set-first #f 'the-other-mark))))]
|
||||
[in #f]
|
||||
[out #f]
|
||||
[mk (lambda (f)
|
||||
(chaperone-procedure
|
||||
f
|
||||
(lambda (x y z)
|
||||
(set! in (vector x y z))
|
||||
(values (lambda (y z)
|
||||
(set! out (vector y z))
|
||||
(values y z))
|
||||
'mark 'the-mark 88
|
||||
'mark 'the-other-mark 86
|
||||
x y z))))]
|
||||
[f2 (mk f)])
|
||||
(with-continuation-mark 'the-mark
|
||||
77
|
||||
(with-continuation-mark 'the-other-mark
|
||||
79
|
||||
(begin
|
||||
(test-values '(b (a c 77 79)) (lambda () (f 'a 'b 'c)))
|
||||
(test #f values in)
|
||||
(test #f values out)
|
||||
(test-values '(b (a c 88 86)) (lambda () (f2 'a 'b 'c)))
|
||||
(test (vector 'a 'b 'c) values in)
|
||||
(test (vector 'b '(a c 88 86)) values out)
|
||||
(check-proc-prop f mk))))))
|
||||
|
||||
;; Optional keyword arguments:
|
||||
(as-chaperone-or-impersonator
|
||||
([chaperone-procedure impersonate-procedure
|
||||
|
|
@ -432,6 +490,43 @@
|
|||
(test-values '(() (#:a #:b)) (lambda () (procedure-keywords f2)))
|
||||
(check-proc-prop f mk)))
|
||||
|
||||
;; Optional keyword arguments with mark:
|
||||
(as-chaperone-or-impersonator
|
||||
([chaperone-procedure impersonate-procedure
|
||||
chaperone-procedure**/kw
|
||||
impersonate-procedure**/kw])
|
||||
(let* ([f (lambda (x #:a [a 'a] #:b [b 'b]) (list x a b (continuation-mark-set-first #f 'the-mark)))]
|
||||
[in #f]
|
||||
[mk (lambda (f)
|
||||
(chaperone-procedure
|
||||
f
|
||||
(lambda (x #:a [a 'nope] #:b [b 'nope])
|
||||
(if (and (eq? a 'nope) (eq? b 'nope))
|
||||
(values 'mark 'the-mark 8
|
||||
x)
|
||||
(values
|
||||
'mark 'the-mark 8
|
||||
(append
|
||||
(if (eq? a 'nope) null (list a))
|
||||
(if (eq? b 'nope) null (list b)))
|
||||
x)))))]
|
||||
[f2 (mk f)])
|
||||
(with-continuation-mark 'the-mark
|
||||
7
|
||||
(begin
|
||||
(test '(1 a b 7) f 1)
|
||||
(test '(1 a b 8) f2 1)
|
||||
(test '(1 2 b 7) f 1 #:a 2)
|
||||
(test '(1 2 b 8) f2 1 #:a 2)
|
||||
(test '(1 a 3 7) f 1 #:b 3)
|
||||
(test '(1 a 3 8) f2 1 #:b 3)
|
||||
(test '(1 2 3 7) f 1 #:a 2 #:b 3)
|
||||
(test '(1 2 3 8) f2 1 #:a 2 #:b 3)
|
||||
(test 1 procedure-arity f2)
|
||||
(test 'f object-name f2)
|
||||
(test-values '(() (#:a #:b)) (lambda () (procedure-keywords f2)))
|
||||
(check-proc-prop f mk)))))
|
||||
|
||||
;; Optional keyword arguments with result chaperone:
|
||||
(as-chaperone-or-impersonator
|
||||
([chaperone-procedure impersonate-procedure
|
||||
|
|
@ -502,7 +597,7 @@
|
|||
(test-values '((#:b) (#:a #:b)) (lambda () (procedure-keywords f2)))
|
||||
(check-proc-prop f mk)))
|
||||
|
||||
;; Required keyword arguments:
|
||||
;; Required keyword arguments with result chaperone:
|
||||
(as-chaperone-or-impersonator
|
||||
([chaperone-procedure impersonate-procedure
|
||||
chaperone-procedure**/kw
|
||||
|
|
@ -538,6 +633,46 @@
|
|||
(test-values '((#:b) (#:a #:b)) (lambda () (procedure-keywords f2)))
|
||||
(check-proc-prop f mk)))
|
||||
|
||||
;; Required keyword arguments with result chaperone and marks:
|
||||
(as-chaperone-or-impersonator
|
||||
([chaperone-procedure impersonate-procedure
|
||||
chaperone-procedure**/kw
|
||||
impersonate-procedure**/kw])
|
||||
(let* ([f (lambda (x #:a [a 'a] #:b b) (list x a b (continuation-mark-set-first #f 'the-mark)))]
|
||||
[in #f]
|
||||
[out #f]
|
||||
[mk (lambda (f)
|
||||
(chaperone-procedure
|
||||
f
|
||||
(lambda (x #:a [a 'nope] #:b [b 'nope])
|
||||
(set! in (list x a b))
|
||||
(if (and (eq? a 'nope) (eq? b 'nope))
|
||||
x
|
||||
(values
|
||||
(lambda (z) (set! out z) z)
|
||||
'mark 'the-mark 9
|
||||
(append
|
||||
(if (eq? a 'nope) null (list a))
|
||||
(if (eq? b 'nope) null (list b)))
|
||||
x)))))]
|
||||
[f2 (mk f)])
|
||||
(with-continuation-mark 'the-mark
|
||||
7
|
||||
(begin
|
||||
(err/rt-test (f 1))
|
||||
(err/rt-test (f2 1))
|
||||
(err/rt-test (f 1 #:a 2))
|
||||
(err/rt-test (f2 1 #:a 2))
|
||||
(test '(1 a 3 7) f 1 #:b 3)
|
||||
(test '(1 a 3 9) f2 1 #:b 3)
|
||||
(test '((1 nope 3) (1 a 3 9)) list in out)
|
||||
(test '(1 2 3 7) f 1 #:a 2 #:b 3)
|
||||
(test '(1 2 3 9) f2 1 #:a 2 #:b 3)
|
||||
(test 1 procedure-arity f2)
|
||||
(test 'f object-name f2)
|
||||
(test-values '((#:b) (#:a #:b)) (lambda () (procedure-keywords f2)))
|
||||
(check-proc-prop f mk)))))
|
||||
|
||||
(err/rt-test ((chaperone-procedure (lambda (x) x) (lambda (y) (values y y))) 1))
|
||||
(err/rt-test ((impersonate-procedure (lambda (x) x) (lambda (y) (values y y))) 1))
|
||||
(err/rt-test ((chaperone-procedure (lambda (x) x) (lambda (y) (values y y y))) 1))
|
||||
|
|
|
|||
|
|
@ -1611,16 +1611,15 @@
|
|||
(lambda results
|
||||
(let* ([len (length results)]
|
||||
[alen (length rest)])
|
||||
(unless (<= (+ alen 1) len (+ alen 2))
|
||||
(when (< len (+ alen 1))
|
||||
(raise-arguments-error
|
||||
'|keyword procedure chaperone|
|
||||
"wrong number of results from wrapper procedure"
|
||||
"expected minimum number of results" (+ alen 1)
|
||||
"expected maximum number of results" (+ alen 2)
|
||||
"received number of results" len
|
||||
"wrapper procedure" wrap-proc))
|
||||
(let ([extra? (= len (+ alen 2))])
|
||||
(let ([new-args ((if extra? cadr car) results)])
|
||||
(let ([num-extra (- len (+ alen 1))])
|
||||
(let ([new-args (list-ref results num-extra)])
|
||||
(unless (and (list? new-args)
|
||||
(= (length new-args) (length args)))
|
||||
(raise-arguments-error
|
||||
|
|
@ -1629,7 +1628,7 @@
|
|||
"expected a list of keyword-argument values as first result~a from wrapper procedure"
|
||||
(if (= len alen)
|
||||
""
|
||||
" (after the result-wrapper procedure)"))
|
||||
" (after the result-wrapper procedure or mark specifications)"))
|
||||
"first result" new-args
|
||||
"wrapper procedure" wrap-proc))
|
||||
(for-each
|
||||
|
|
@ -1646,9 +1645,13 @@
|
|||
kws
|
||||
new-args
|
||||
args))
|
||||
(if extra?
|
||||
(apply values (car results) kws (cdr results))
|
||||
(apply values kws results))))))]
|
||||
(case num-extra
|
||||
[(0) (apply values kws results)]
|
||||
[(1) (apply values (car results) kws (cdr results))]
|
||||
[else (apply values (let loop ([results results] [c num-extra])
|
||||
(if (zero? c)
|
||||
(cons kws results)
|
||||
(cons (car results) (loop (cdr results) (sub1 c))))))])))))]
|
||||
;; The following case exists only to make sure that the arity of
|
||||
;; any procedure passed to `make-keyword-args' is covered
|
||||
;; by this procedure's arity.
|
||||
|
|
|
|||
|
|
@ -104,6 +104,7 @@ ROSYM static Scheme_Object *is_method_symbol;
|
|||
ROSYM static Scheme_Object *cont_key; /* uninterned */
|
||||
ROSYM static Scheme_Object *barrier_prompt_key; /* uninterned */
|
||||
ROSYM static Scheme_Object *prompt_cc_guard_key; /* uninterned */
|
||||
ROSYM static Scheme_Object *mark_symbol;
|
||||
READ_ONLY static Scheme_Prompt *original_default_prompt; /* for escapes, represents the implicit initial prompt */
|
||||
READ_ONLY static Scheme_Object *call_with_prompt_proc;
|
||||
READ_ONLY static Scheme_Object *abort_continuation_proc;
|
||||
|
|
@ -676,6 +677,9 @@ scheme_init_fun (Scheme_Env *env)
|
|||
barrier_prompt_key = scheme_make_symbol("bar"); /* uninterned */
|
||||
prompt_cc_guard_key = scheme_make_symbol("cc"); /* uninterned */
|
||||
|
||||
REGISTER_SO(mark_symbol);
|
||||
mark_symbol = scheme_intern_symbol("mark");
|
||||
|
||||
REGISTER_SO(scheme_default_prompt_tag);
|
||||
{
|
||||
Scheme_Object *a[1];
|
||||
|
|
@ -3591,6 +3595,104 @@ Scheme_Object *_scheme_apply_native(Scheme_Object *obj, int num_rands, Scheme_Ob
|
|||
return _apply_native(obj, num_rands, rands);
|
||||
}
|
||||
|
||||
Scheme_Object *extract_impersonator_results(int c, int argc, Scheme_Object **argv2,
|
||||
const char *what, Scheme_Object *o,
|
||||
Scheme_Chaperone *px,
|
||||
Scheme_Cont_Frame_Data *cframe, int *_need_pop)
|
||||
{
|
||||
int extra = c - argc;
|
||||
int i, fail_reason = 0;
|
||||
Scheme_Object *post;
|
||||
char nth[32];
|
||||
Scheme_Config *config = NULL;
|
||||
|
||||
if (!extra)
|
||||
return NULL;
|
||||
|
||||
post = NULL;
|
||||
for (i = 0; i < extra; ) {
|
||||
if (!i && SCHEME_PROCP(argv2[0])) {
|
||||
post = argv2[i];
|
||||
i++;
|
||||
} else if (SAME_OBJ(argv2[i], mark_symbol)) {
|
||||
if (i + 3 > extra) {
|
||||
fail_reason = 2;
|
||||
break;
|
||||
}
|
||||
if (post && !*_need_pop) {
|
||||
scheme_push_continuation_frame(cframe);
|
||||
*_need_pop = 1;
|
||||
}
|
||||
scheme_set_cont_mark(argv2[i+1], argv2[i+2]);
|
||||
i += 3;
|
||||
} else {
|
||||
fail_reason = 1;
|
||||
break;
|
||||
}
|
||||
}
|
||||
|
||||
if (!fail_reason) {
|
||||
if (config) {
|
||||
if (post && !*_need_pop) {
|
||||
scheme_push_continuation_frame(cframe);
|
||||
*_need_pop = 1;
|
||||
}
|
||||
scheme_set_cont_mark(scheme_parameterization_key, (Scheme_Object *)config);
|
||||
}
|
||||
return post;
|
||||
}
|
||||
|
||||
/* Failure at argument i */
|
||||
|
||||
switch (i % 10) {
|
||||
case 1:
|
||||
sprintf(nth, "%dst", i);
|
||||
break;
|
||||
case 2:
|
||||
sprintf(nth, "%dnd", i);
|
||||
break;
|
||||
case 3:
|
||||
sprintf(nth, "%drd", i);
|
||||
break;
|
||||
default:
|
||||
sprintf(nth, "%dth", i);
|
||||
}
|
||||
|
||||
if (fail_reason == 1) {
|
||||
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
|
||||
"procedure %s: wrapper's %s result is not valid;\n"
|
||||
" %s extra result (before original argument count) should be\n"
|
||||
" 'mark%s'parameter%s\n"
|
||||
" original: %V\n"
|
||||
" wrapper: %V\n"
|
||||
" received: %V",
|
||||
what,
|
||||
nth,
|
||||
nth,
|
||||
(i ? " or " : ", "),
|
||||
(i ? "" : ", or a wrapper for the original procedure's result"),
|
||||
o,
|
||||
SCHEME_VEC_ELS(px->redirects)[0],
|
||||
argv2[i]);
|
||||
} else if (fail_reason == 2) {
|
||||
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
|
||||
"procedure %s: wrapper's %s result needs addition extra results;\n"
|
||||
" %s extra result (before original argument count) needs an\n"
|
||||
" additional %s after %V\n"
|
||||
" original: %V\n"
|
||||
" wrapper: %V",
|
||||
what,
|
||||
nth,
|
||||
nth,
|
||||
((i + 1 < extra) ? "result" : "two results"),
|
||||
argv2[i],
|
||||
o,
|
||||
SCHEME_VEC_ELS(px->redirects)[0]);
|
||||
}
|
||||
|
||||
return NULL;
|
||||
}
|
||||
|
||||
/* must be at least 3: */
|
||||
#define MAX_QUICK_CHAP_ARGV 5
|
||||
|
||||
|
|
@ -3736,13 +3838,16 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
|
|||
MZ_CONT_MARK_POS += 2;
|
||||
scheme_pop_continuation_frame(&cframe);
|
||||
}
|
||||
|
||||
if ((c == argc) || (c == (argc + 1))) {
|
||||
if (c > argc) {
|
||||
post = argv2[0];
|
||||
memmove(argv2, argv2 + 1, sizeof(Scheme_Object*)*argc);
|
||||
} else
|
||||
post = NULL;
|
||||
|
||||
if (c >= argc) {
|
||||
int need_pop = 0;
|
||||
post = extract_impersonator_results(c, argc, argv2,
|
||||
what, o, px,
|
||||
&cframe, &need_pop);
|
||||
need_pop_mark = need_pop;
|
||||
|
||||
if (c > argc)
|
||||
memmove(argv2, argv2 + (c - argc), sizeof(Scheme_Object*)*argc);
|
||||
if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_IMPERSONATOR)) {
|
||||
for (i = 0; i < argc; i++) {
|
||||
if (!SAME_OBJ(argv2[i], argv[i])
|
||||
|
|
@ -3764,12 +3869,12 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
|
|||
" procedure's arguments\n"
|
||||
" original: %V\n"
|
||||
" wrapper: %V\n"
|
||||
" expected: %d or %d\n"
|
||||
" expected: %d or more\n"
|
||||
" received: %d",
|
||||
what,
|
||||
o,
|
||||
SCHEME_VEC_ELS(px->redirects)[0],
|
||||
argc, argc + 1,
|
||||
argc,
|
||||
c);
|
||||
return NULL;
|
||||
}
|
||||
|
|
@ -3784,7 +3889,7 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
|
|||
} else
|
||||
argv = NULL;
|
||||
|
||||
if (c == argc) {
|
||||
if (!post) {
|
||||
/* No filter for the result, so tail call: */
|
||||
if (app_mark)
|
||||
scheme_set_cont_mark(SCHEME_CAR(app_mark), SCHEME_CDR(app_mark));
|
||||
|
|
@ -3794,7 +3899,7 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
|
|||
}
|
||||
if (auto_val) {
|
||||
if (SCHEME_CHAPERONEP(px->prev))
|
||||
return do_apply_chaperone(px->prev, c, argv2, auto_val, 0);
|
||||
return do_apply_chaperone(px->prev, argc, argv2, auto_val, 0);
|
||||
else
|
||||
return argv2[0];
|
||||
} else {
|
||||
|
|
@ -3807,40 +3912,29 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
|
|||
/* cannot return a tail call */
|
||||
MZ_CONT_MARK_POS -= 2;
|
||||
if (checks & 0x1) {
|
||||
v = _scheme_apply(orig_obj, c, argv2);
|
||||
v = _scheme_apply(orig_obj, argc, argv2);
|
||||
} else if (SAME_TYPE(SCHEME_TYPE(orig_obj), scheme_native_closure_type)) {
|
||||
v = _apply_native(orig_obj, c, argv2);
|
||||
v = _apply_native(orig_obj, argc, argv2);
|
||||
} else {
|
||||
v = _scheme_apply_multi(orig_obj, c, argv2);
|
||||
v = _scheme_apply_multi(orig_obj, argc, argv2);
|
||||
}
|
||||
MZ_CONT_MARK_POS += 2;
|
||||
return v;
|
||||
} else
|
||||
return scheme_tail_apply(orig_obj, c, argv2);
|
||||
return scheme_tail_apply(orig_obj, argc, argv2);
|
||||
}
|
||||
} else {
|
||||
/* First element is a filter for the result(s) */
|
||||
if (!SCHEME_PROCP(post))
|
||||
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
|
||||
"procedure %s: wrapper's first result is not a procedure;\n"
|
||||
" extra result compared to original argument count should be\n"
|
||||
" a wrapper for the original procedure's result\n"
|
||||
" original: %V\n"
|
||||
" wrapper: %V\n"
|
||||
" received: %V",
|
||||
what,
|
||||
o,
|
||||
SCHEME_VEC_ELS(px->redirects)[0],
|
||||
post);
|
||||
|
||||
if (app_mark) {
|
||||
scheme_push_continuation_frame(&cframe);
|
||||
if (!need_pop_mark)
|
||||
scheme_push_continuation_frame(&cframe);
|
||||
scheme_set_cont_mark(SCHEME_CAR(app_mark), SCHEME_CDR(app_mark));
|
||||
MZ_CONT_MARK_POS -= 2;
|
||||
need_pop_mark = 1;
|
||||
}else
|
||||
need_pop_mark = 0;
|
||||
|
||||
if (need_pop_mark)
|
||||
MZ_CONT_MARK_POS -= 2;
|
||||
|
||||
if (SCHEME_CHAPERONEP(px->prev)) {
|
||||
/* commuincate `self_proc` to the next layer: */
|
||||
scheme_current_thread->self_for_proc_chaperone = self_proc;
|
||||
|
|
|
|||
|
|
@ -831,6 +831,9 @@ extern Scheme_Object *scheme_parameterization_key;
|
|||
extern Scheme_Object *scheme_exn_handler_key;
|
||||
extern Scheme_Object *scheme_break_enabled_key;
|
||||
|
||||
Scheme_Object *scheme_extend_parameterization(int argc, Scheme_Object *args[]);
|
||||
XFORM_NONGCING int scheme_is_parameter(Scheme_Object *o);
|
||||
|
||||
extern void scheme_flatten_config(Scheme_Config *c);
|
||||
|
||||
extern Scheme_Object *scheme_apply_thread_thunk(Scheme_Object *rator);
|
||||
|
|
|
|||
|
|
@ -391,7 +391,6 @@ static Scheme_Object *parameter_p(int argc, Scheme_Object *args[]);
|
|||
static Scheme_Object *parameter_procedure_eq(int argc, Scheme_Object *args[]);
|
||||
static Scheme_Object *make_parameter(int argc, Scheme_Object *args[]);
|
||||
static Scheme_Object *make_derived_parameter(int argc, Scheme_Object *args[]);
|
||||
static Scheme_Object *extend_parameterization(int argc, Scheme_Object *args[]);
|
||||
static Scheme_Object *parameterization_p(int argc, Scheme_Object *args[]);
|
||||
static Scheme_Object *reparameterize(int argc, Scheme_Object **argv);
|
||||
|
||||
|
|
@ -708,7 +707,7 @@ void scheme_init_paramz(Scheme_Env *env)
|
|||
scheme_add_global_constant("parameterization-key" , scheme_parameterization_key, newenv);
|
||||
scheme_add_global_constant("break-enabled-key" , scheme_break_enabled_key , newenv);
|
||||
|
||||
GLOBAL_PRIM_W_ARITY("extend-parameterization" , extend_parameterization , 1, -1, newenv);
|
||||
GLOBAL_PRIM_W_ARITY("extend-parameterization" , scheme_extend_parameterization , 1, -1, newenv);
|
||||
GLOBAL_PRIM_W_ARITY("check-for-break" , check_break_now , 0, 0, newenv);
|
||||
GLOBAL_PRIM_W_ARITY("reparameterize" , reparameterize , 1, 1, newenv);
|
||||
GLOBAL_PRIM_W_ARITY("make-custodian-from-main", make_custodian_from_main, 0, 0, newenv);
|
||||
|
|
@ -7633,7 +7632,7 @@ static Scheme_Object *parameterization_p(int argc, Scheme_Object **argv)
|
|||
&& ((((Scheme_Primitive_Proc *)v)->pp.flags & SCHEME_PRIM_OTHER_TYPE_MASK) \
|
||||
== SCHEME_PRIM_TYPE_PARAMETER))
|
||||
|
||||
static Scheme_Object *extend_parameterization(int argc, Scheme_Object *argv[])
|
||||
Scheme_Object *scheme_extend_parameterization(int argc, Scheme_Object *argv[])
|
||||
{
|
||||
Scheme_Object *key, *a[2], *param;
|
||||
Scheme_Config *c;
|
||||
|
|
@ -7719,13 +7718,16 @@ static Scheme_Object *reparameterize(int argc, Scheme_Object **argv)
|
|||
return (Scheme_Object *)naya;
|
||||
}
|
||||
|
||||
static Scheme_Object *parameter_p(int argc, Scheme_Object **argv)
|
||||
int scheme_is_parameter(Scheme_Object *v)
|
||||
{
|
||||
Scheme_Object *v = argv[0];
|
||||
|
||||
if (SCHEME_CHAPERONEP(v)) v = SCHEME_CHAPERONE_VAL(v);
|
||||
|
||||
return (SCHEME_PARAMETERP(v)
|
||||
return SCHEME_PARAMETERP(v);
|
||||
}
|
||||
|
||||
static Scheme_Object *parameter_p(int argc, Scheme_Object **argv)
|
||||
{
|
||||
return (scheme_is_parameter(argv[0])
|
||||
? scheme_true
|
||||
: scheme_false);
|
||||
}
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user