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

expander: avoid parameters for dynamic-extent indicators

Browse Source 
Using a parameter for the current expansion context means that if a
macro spawns a thread, the thread thinks that it's in an expansion
context. Switching to a raw continuation mark avoids that problem.

Along the way, bring Racket and RacketCS more in line by making both
have an internal notion of "root" prompt tag that can be used to get
all continuation marks independent of any prompts. That's not structly
necessary, since a continuation mark could be combined with a distinct
tag to make the mark always accessible, but it's simpler and more
lightweight to use a root prompt tag.
This commit is contained in:
Matthew Flatt 2018-08-21 08:00:26 -06:00
parent eed18fac93
commit 16e496b0c5
29 changed files with 285 additions and 162 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/base/info.rkt
View File

@ -12,7 +12,7 @@
(define collection 'multi)
(define version "7.0.0.13")
(define version "7.0.0.14")
(define deps `("racket-lib"
["racket" #:version ,version]))

15
pkgs/racket-test-core/tests/racket/macro.rktl
View File

@ -2293,6 +2293,21 @@
(define-syntax (f a)
(complain-about-this-one (not-about-this-one)))))
;; ----------------------------------------
;; Make sure "currently expanding" is not propagated to threads
(let ()
(define-syntax (m stx)
(syntax-case stx ()
[(_ e)
(let ([ok? #t])
(sync (thread (lambda ()
(local-expand #'e 'expression null)
(set! ok? #f))))
(if ok? #''ok #''oops))]))
(test 'ok values (m 1)))
;; ----------------------------------------
(report-errs)

15
racket/collects/racket/private/stxparam.rkt
View File

@ -64,13 +64,14 @@
(let-values ([(expr opaque-expr)
(syntax-case stx ()
[(_ ([local-key id] ...) body ...)
(parameterize ([current-parameter-environment
(extend-parameter-environment
(current-parameter-environment)
#'([local-key id] ...))])
(syntax-local-expand-expression
#'(let-values () body ...)
#t))])])
(with-continuation-mark
current-parameter-environment
(extend-parameter-environment
(current-parameter-environment)
#'([local-key id] ...))
(syntax-local-expand-expression
#'(let-values () body ...)
#t))])])
opaque-expr)
(with-syntax ([stx stx])
#'(#%expression stx)))))

9
racket/collects/racket/private/stxparamkey.rkt
View File

@ -1,11 +1,16 @@
(module stxparamkey '#%kernel
(#%require "small-scheme.rkt" "define.rkt"
"stxcase.rkt" "stxloc.rkt" "with-stx.rkt")
"stxcase.rkt" "stxloc.rkt" "with-stx.rkt"
(only '#%unsafe unsafe-root-continuation-prompt-tag))
;; Consulted before the expander's table, for use by compile-time
;; code wrapped by a run-time-phased `syntax-parameterize`:
(define current-parameter-environment (make-parameter #hasheq()))
(define (current-parameter-environment)
;; Implemented with continuation marks, not parameters, so that the
;; "state" is not inherited by new threads
(continuation-mark-set-first #f current-parameter-environment #hasheq()
(unsafe-root-continuation-prompt-tag)))
;; Wrap the value for a syntax parameter in a `parameter-value` struct,
;; so that we can distinguish it from rename transformers that arrive

29
racket/collects/racket/splicing.rkt
View File

@ -306,12 +306,13 @@
(syntax-case stx ()
[(_ binds orig-ids body)
(let ([ctx (syntax-local-make-definition-context #f #f)])
(let ([body (parameterize ([current-parameter-environment
(extend-parameter-environment (current-parameter-environment) #'binds)])
(local-expand #'(force-expand body)
(syntax-local-context)
null ;; `force-expand' actually determines stopping places
ctx))])
(let ([body (with-continuation-mark
current-parameter-environment
(extend-parameter-environment (current-parameter-environment) #'binds)
(local-expand #'(force-expand body)
(syntax-local-context)
null ;; `force-expand' actually determines stopping places
ctx))])
(let ([body
;; Extract expanded body out of `body':
(syntax-case body (quote)
@ -359,10 +360,11 @@
(unless (eq? (syntax-local-context) 'module-begin)
(raise-syntax-error #f "only allowed in module-begin context" stx))
(with-syntax ([new-binds (update-parameter-keys #'orig-ids #'binds)])
(parameterize ([current-parameter-environment
(extend-parameter-environment (current-parameter-environment)
#'new-binds)])
(let* ([forms (syntax->list #'(body-form ...))]
(with-continuation-mark
current-parameter-environment
(extend-parameter-environment (current-parameter-environment)
#'new-binds)
(let* ([forms (syntax->list #'(body-form ...))]
;; emulate how the macroexpander expands module bodies and introduces #%module-begin
[body (if (= (length forms) 1)
(let ([body (local-expand (car forms) 'module-begin #f)])
@ -407,9 +409,10 @@
[(_ e binds)
(let ([as-expression
(lambda ()
#'(parameterize ([current-parameter-environment
(extend-parameter-environment (current-parameter-environment) (quote-syntax binds))])
e))])
#'(with-continuation-mark
current-parameter-environment
(extend-parameter-environment (current-parameter-environment) (quote-syntax binds))
e))])
(if (eq? (syntax-local-context) 'expression)
(as-expression)
(let ([e (local-expand #'e

1
racket/collects/racket/unsafe/ops.rkt
View File

@ -37,6 +37,7 @@
unsafe-set-on-atomic-timeout!
unsafe-abort-current-continuation/no-wind
unsafe-call-with-composable-continuation/no-wind
unsafe-root-continuation-prompt-tag
unsafe-os-thread-enabled?
unsafe-call-in-os-thread
unsafe-make-os-semaphore

2
racket/src/cs/primitive/kernel.ss
View File

@ -267,7 +267,7 @@
[date? (known-procedure/succeeds 2)]
[datum->syntax (known-procedure 60)]
[datum-intern-literal (known-procedure 2)]
[default-continuation-prompt-tag (known-procedure 1)]
[default-continuation-prompt-tag (known-procedure/succeeds 1)]
[delete-directory (known-procedure 2)]
[delete-file (known-procedure 2)]
[denominator (known-procedure 2)]

1
racket/src/cs/primitive/unsafe.ss
View File

@ -125,6 +125,7 @@
[unsafe-port->socket (known-procedure 2)]
[unsafe-register-process-global (known-procedure 4)]
[unsafe-remove-collect-callbacks (known-procedure 2)]
[unsafe-root-continuation-prompt-tag (known-procedure/succeeds 1)]
[unsafe-s16vector-ref (known-procedure 4)]
[unsafe-s16vector-set! (known-procedure 8)]
[unsafe-set-box! (known-procedure 4)]

2
racket/src/cs/rumble.sls
View File

@ -15,7 +15,7 @@
make-continuation-prompt-tag
continuation-prompt-tag?
default-continuation-prompt-tag
root-continuation-prompt-tag
unsafe-root-continuation-prompt-tag
call-with-continuation-prompt
call-with-continuation-barrier
abort-current-continuation

2
racket/src/cs/rumble/control.ss
View File

@ -134,7 +134,7 @@
(create-continuation-prompt-tag name)]))
(define (default-continuation-prompt-tag) the-default-continuation-prompt-tag)
(define (root-continuation-prompt-tag) the-root-continuation-prompt-tag)
(define (unsafe-root-continuation-prompt-tag) the-root-continuation-prompt-tag)
;; To support special treatment of break parameterizations, and also
;; to initialize disabled breaks for `dynamic-wind` pre and post

4
racket/src/cs/thread.sls
View File

@ -26,7 +26,7 @@
[threaded? rumble:threaded?]
[get-thread-id rumble:get-thread-id]
[set-ctl-c-handler! rumble:set-ctl-c-handler!]
[root-continuation-prompt-tag rumble:root-continuation-prompt-tag]
[unsafe-root-continuation-prompt-tag rumble:unsafe-root-continuation-prompt-tag]
[set-break-enabled-transition-hook! rumble:set-break-enabled-transition-hook!]))
;; Special handling of `current-atomic`: use the last virtual register.
@ -69,7 +69,7 @@
'engine-return rumble:engine-return
'current-engine-state (lambda (v) (rumble:current-engine-state v))
'set-ctl-c-handler! rumble:set-ctl-c-handler!
'root-continuation-prompt-tag rumble:root-continuation-prompt-tag
'root-continuation-prompt-tag rumble:unsafe-root-continuation-prompt-tag
'poll-will-executors poll-will-executors
'make-will-executor rumble:make-will-executor
'make-stubborn-will-executor rumble:make-stubborn-will-executor

25
racket/src/expander/common/parameter-like.rkt Normal file
View File

@ -0,0 +1,25 @@
#lang racket/base
(require (only-in '#%unsafe
unsafe-root-continuation-prompt-tag))
(provide define-parameter-like
parameterize-like)
;; A parameter-like function differs from a parameter by not being
;; mutable and not being propagated to a new thread. It's just a
;; continuation mark.
(define root-tag (unsafe-root-continuation-prompt-tag))
(define-syntax-rule (define-parameter-like id val)
(begin
(define default-val val)
(define (id)
(continuation-mark-set-first #f id default-val root-tag))))
(define-syntax parameterize-like
(syntax-rules ()
[(_ #:with () body0 body ...)
(let () body0 body ...)]
[(_ #:with ([key0 val0] [key val] ...) body0 body ...)
(with-continuation-mark key0 val0 (parameterize-like #:with ([key val] ...) body0 body ...))]))

7
racket/src/expander/eval/main.rkt
View File

@ -11,7 +11,8 @@
"../common/phase.rkt"
"../syntax/match.rkt"
"../expand/context.rkt"
(rename-in "../expand/main.rkt" [expand expand-in-context])
(rename-in "../expand/main.rkt"
[expand expand-in-context])
"../compile/main.rkt"
"../compile/compiled-in-memory.rkt"
"top.rkt"
@ -134,7 +135,7 @@
(define (expand s [ns (current-namespace)] [observable? #f] [to-parsed? #f] [serializable? #f])
(define observer (and observable? (current-expand-observe)))
(when observer (...log-expand observer ['start-top]))
(parameterize ((current-expand-observe #f))
(parameterize ([current-expand-observe #f])
(per-top-level s ns
#:single (lambda (s ns as-tail?) (expand-single s ns observer to-parsed? serializable?))
#:combine cons
@ -201,7 +202,7 @@
;; but `#:single #f` makes it return immediately
(define observer (current-expand-observe))
(when observer (...log-expand observer ['start-top]))
(parameterize ((current-expand-observe #f))
(parameterize ([current-expand-observe #f])
(per-top-level s ns
#:single #f
#:quick-immediate? #f

12
racket/src/expander/eval/module.rkt
View File

@ -1,6 +1,7 @@
#lang racket/base
(require "../common/promise.rkt"
"../common/performance.rkt"
"../common/parameter-like.rkt"
"../namespace/namespace.rkt"
"../namespace/module.rkt"
"../namespace/inspector.rkt"
@ -211,11 +212,12 @@
;; For phase level 1 and up, set the expansion context
;; to point back to the module's info:
(define ns-1 (namespace->namespace-at-phase ns (phase+ phase-shift (sub1 phase-level))))
(parameterize ([current-expand-context (delay (make-expand-context ns-1))]
[current-namespace ns]
[current-module-code-inspector insp])
(instantiate-body))]))))))
(parameterize ([current-namespace ns])
(parameterize-like
#:with ([current-expand-context (delay (make-expand-context ns-1))]
[current-module-code-inspector insp])
(instantiate-body)))]))))))
(define declare-name (substitute-module-declare-name default-name))
(when with-submodules?

8
racket/src/expander/eval/top.rkt
View File

@ -2,6 +2,7 @@
(require "../common/set.rkt"
"../common/phase.rkt"
"../common/performance.rkt"
"../common/parameter-like.rkt"
"../namespace/namespace.rkt"
"../namespace/module.rkt"
"../compile/module-use.rkt"
@ -167,9 +168,10 @@
[else
(define ns-1 (namespace->namespace-at-phase phase-ns (sub1 phase)))
(lambda (tail?)
(parameterize ([current-expand-context (make-expand-context ns-1)]
[current-namespace phase-ns])
(instantiate tail?)))])]
(parameterize ([current-namespace phase-ns])
(parameterize-like
#:with ([current-expand-context (make-expand-context ns-1)])
(instantiate tail?))))])]
[else void])))
;; Call last thunk tail position --- maybe, since using a prompt if not `as-tail?`

3
racket/src/expander/expand/context.rkt
View File

@ -1,6 +1,7 @@
#lang racket/base
(require "../common/promise.rkt"
"../common/struct-star.rkt"
"../common/parameter-like.rkt"
"../syntax/syntax.rkt"
"../syntax/scope.rkt"
"../syntax/binding.rkt"
@ -130,7 +131,7 @@
[binding-layer (root-expand-context-frame-id root-ctx)]))
;; An expand-context or a delayed expand context (so use `force`):
(define current-expand-context (make-parameter #f))
(define-parameter-like current-expand-context #f)
(define (get-current-expand-context [who 'unexpected]
#:fail-ok? [fail-ok? #f])

1
racket/src/expander/expand/local-expand.rkt
View File

@ -7,6 +7,7 @@
"../syntax/binding.rkt"
"../namespace/core.rkt"
"../namespace/module.rkt"
"../namespace/namespace.rkt"
"context.rkt"
"main.rkt"
"syntax-local.rkt"

39
racket/src/expander/expand/main.rkt
View File

@ -1,6 +1,7 @@
#lang racket/base
(require "../common/set.rkt"
"../common/struct-star.rkt"
"../common/parameter-like.rkt"
"../syntax/syntax.rkt"
"../syntax/property.rkt"
"../syntax/scope.rkt"
@ -427,15 +428,16 @@
;; lose them at the point where expansion stops
(expand-context-def-ctx-scopes ctx))]))
(define transformed-s
(parameterize ([current-expand-context m-ctx]
[current-namespace (namespace->namespace-at-phase
(parameterize ([current-namespace (namespace->namespace-at-phase
(expand-context-namespace ctx)
(add1 (expand-context-phase ctx)))]
[current-module-code-inspector (or insp-of-t #;(current-module-code-inspector))])
(call-with-continuation-barrier
(lambda ()
;; Call the transformer!
((transformer->procedure t) cleaned-s)))))
(add1 (expand-context-phase ctx)))])
(parameterize-like
#:with ([current-expand-context m-ctx]
[current-module-code-inspector (or insp-of-t #;(current-module-code-inspector))])
(call-with-continuation-barrier
(lambda ()
;; Call the transformer!
((transformer->procedure t) cleaned-s))))))
(log-expand ctx 'macro-post-x transformed-s cleaned-s)
(unless (syntax? transformed-s)
(raise-arguments-error (syntax-e id)
@ -671,12 +673,13 @@
#:phase phase))))
(define vals
(call-with-values (lambda ()
(parameterize ([current-expand-context ctx]
[current-namespace ns]
(parameterize ([current-namespace ns]
[eval-jit-enabled #f])
(if compiled
(eval-single-top compiled ns)
(direct-eval p ns (root-expand-context-self-mpi ctx)))))
(parameterize-like
#:with ([current-expand-context ctx])
(if compiled
(eval-single-top compiled ns)
(direct-eval p ns (root-expand-context-self-mpi ctx))))))
list))
(unless (= (length vals) (length ids))
(apply raise-result-arity-error
@ -772,16 +775,18 @@
;; as a function, and that fnuction might want to use
;; `syntax-local-value`, etc.
(define (rename-transformer-target-in-context t ctx)
(parameterize ([current-expand-context ctx])
(rename-transformer-target t)))
(parameterize-like
#:with ([current-expand-context ctx])
(rename-transformer-target t)))
;; In case the rename-transformer has a callback, ensure that the
;; current expansion context is available while installing a
;; `free-identifier=?` equivalence
(define (maybe-install-free=id-in-context! val id phase ctx)
(when (rename-transformer? val)
(parameterize ([current-expand-context ctx])
(maybe-install-free=id! val id phase))))
(parameterize-like
#:with ([current-expand-context ctx])
(maybe-install-free=id! val id phase))))
;; Transfer the original ID's source location, if any, when expanding
;; a reference to a rename transformer

16
racket/src/expander/expand/module.rkt
View File

@ -2,6 +2,7 @@
(require "../common/promise.rkt"
"../common/struct-star.rkt"
"../common/performance.rkt"
"../common/parameter-like.rkt"
"../syntax/syntax.rkt"
"../syntax/debug.rkt"
"../syntax/property.rkt"
@ -1300,13 +1301,14 @@
(void)]
[else
;; an expression
(parameterize ([current-expand-context ctx]
[current-namespace m-ns])
(eval-single-top
(compile-single p (make-compile-context
#:namespace m-ns
#:phase phase))
m-ns))])))
(parameterize ([current-namespace m-ns])
(parameterize-like
#:with ([current-expand-context ctx])
(eval-single-top
(compile-single p (make-compile-context
#:namespace m-ns
#:phase phase))
m-ns)))])))
;; ----------------------------------------

3
racket/src/expander/namespace/inspector.rkt
View File

@ -1,6 +1,7 @@
#lang racket/base
(require "../common/parameter-like.rkt")
(provide current-module-code-inspector)
;; Parameter to select inspector for functions like `syntax-arm`
(define current-module-code-inspector (make-parameter #f))
(define-parameter-like current-module-code-inspector #f)

3
racket/src/expander/read/config.rkt
View File

@ -1,5 +1,6 @@
#lang racket/base
(require "../common/struct-star.rkt"
"../common/parameter-like.rkt"
"readtable-parameter.rkt")
(provide (struct*-out read-config)
@ -36,7 +37,7 @@
(struct read-config-state ([accum-str #:mutable] ; string-buffer cache
[graph #:mutable])) ; #f or hash of number -> value
(define current-read-config (make-parameter #f)) ; for `read/recursive`
(define-parameter-like current-read-config #f) ; for `read/recursive`
(define (make-read-config
#:source [source #f]

41
racket/src/expander/read/extension.rkt
View File

@ -1,5 +1,6 @@
#lang racket/base
(require "config.rkt"
(require "../common/parameter-like.rkt"
"config.rkt"
"special.rkt"
"consume.rkt"
"error.rkt"
@ -195,16 +196,18 @@
[(and for-syntax? (not get-info?))
(cond
[(procedure-arity-includes? extension 6)
(parameterize ([current-read-config config])
(extension (read-config-source config)
in
mod-path-wrapped
(read-config-line config)
(read-config-col config)
(read-config-pos config)))]
(parameterize-like
#:with ([current-read-config config])
(extension (read-config-source config)
in
mod-path-wrapped
(read-config-line config)
(read-config-col config)
(read-config-pos config)))]
[(procedure-arity-includes? extension 2)
(parameterize ([current-read-config config])
(extension (read-config-source config) in))]
(parameterize-like
#:with ([current-read-config config])
(extension (read-config-source config) in))]
[else
(raise-argument-error who
"(or/c (procedure-arity-includes?/c 2) (procedure-arity-includes?/c 6))"
@ -212,19 +215,21 @@
[else
(cond
[(procedure-arity-includes? extension 5)
(parameterize ([current-read-config config])
(extension in
mod-path-wrapped
(read-config-line config)
(read-config-col config)
(read-config-pos config)))]
(parameterize-like
#:with ([current-read-config config])
(extension in
mod-path-wrapped
(read-config-line config)
(read-config-col config)
(read-config-pos config)))]
[get-info?
(raise-argument-error who
"(procedure-arity-includes?/c 5)"
extension)]
[(procedure-arity-includes? extension 1)
(parameterize ([current-read-config config])
(extension in))]
(parameterize-like
#:with ([current-read-config config])
(extension in))]
[else
(raise-argument-error who
"(or/c (procedure-arity-includes?/c 1) (procedure-arity-includes?/c 5))"

15
racket/src/expander/read/readtable.rkt
View File

@ -1,5 +1,6 @@
#lang racket/base
(require "../common/inline.rkt"
"../common/parameter-like.rkt"
"config.rkt"
"coerce.rkt"
"parameter.rkt"
@ -159,13 +160,15 @@
(define v
(cond
[(not for-syntax?)
(parameterize ([current-read-config config])
(if (procedure-arity-includes? handler 2)
(handler c in)
(handler c in #f line col pos)))]
(parameterize-like
#:with ([current-read-config config])
(if (procedure-arity-includes? handler 2)
(handler c in)
(handler c in #f line col pos)))]
[else
(parameterize ([current-read-config config])
(handler c in (read-config-source config) line col pos))]))
(parameterize-like
#:with ([current-read-config config])
(handler c in (read-config-source config) line col pos))]))
(if (special-comment? v)
v
(coerce v in config)))

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

@ -60,6 +60,7 @@ READ_ONLY Scheme_Object *scheme_call_with_immed_mark_proc;
READ_ONLY Scheme_Object *scheme_reduced_procedure_struct;
READ_ONLY Scheme_Object *scheme_tail_call_waiting;
READ_ONLY Scheme_Object *scheme_default_prompt_tag;
READ_ONLY Scheme_Object *scheme_root_prompt_tag;
READ_ONLY Scheme_Object *scheme_chaperone_undefined_property;
/* READ ONLY SHARABLE GLOBALS */
@ -177,6 +178,7 @@ static Scheme_Object *chaperone_unsafe_undefined(int argc, Scheme_Object **argv)
static Scheme_Object *unsafe_abort_continuation_no_dws(int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_call_with_control_no_dws(int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_root_continuation_prompt_tag(int argc, Scheme_Object *argv[]);
static Scheme_Object *
scheme_extract_one_cc_mark_with_meta(Scheme_Object *mark_set, Scheme_Object *key,
@ -689,6 +691,14 @@ scheme_init_fun (Scheme_Startup_Env *env)
(void)scheme_hash_key(SCHEME_PTR_VAL(scheme_default_prompt_tag));
}
REGISTER_SO(scheme_root_prompt_tag);
{
Scheme_Object *a[1];
a[0] = scheme_intern_symbol("root");
scheme_root_prompt_tag = make_prompt_tag(1, a);
(void)scheme_hash_key(SCHEME_PTR_VAL(scheme_root_prompt_tag));
}
REGISTER_SO(original_default_prompt);
original_default_prompt = MALLOC_ONE_TAGGED(Scheme_Prompt);
original_default_prompt->so.type = scheme_prompt_type;
@ -736,6 +746,8 @@ scheme_init_unsafe_fun (Scheme_Startup_Env *env)
ADD_PRIM_W_ARITY("unsafe-abort-current-continuation/no-wind", unsafe_abort_continuation_no_dws, 2, 2, env);
ADD_PRIM_W_ARITY("unsafe-call-with-composable-continuation/no-wind", unsafe_call_with_control_no_dws, 2, 2, env);
ADD_PRIM_W_ARITY("unsafe-root-continuation-prompt-tag", unsafe_root_continuation_prompt_tag, 0, 0, env);
}
void
@ -5314,6 +5326,11 @@ static MZ_MARK_STACK_TYPE exec_dyn_wind_pres(Scheme_Dynamic_Wind_List *dwl,
return copied_cms;
}
static void root_prompt_tag_misuse(const char *who)
{
scheme_signal_error("%s: misuse of root prompt tag", who);
}
static Scheme_Object *
call_cc (int argc, Scheme_Object *argv[])
{
@ -5924,6 +5941,13 @@ internal_call_cc (int argc, Scheme_Object *argv[])
composable = (argc > 2);
if (SAME_OBJ(pt, scheme_root_prompt_tag)) {
root_prompt_tag_misuse(composable
? "call-with-composable-continuation"
: "call-with-current-continuation");
return NULL;
}
prompt = scheme_get_prompt(SCHEME_PTR_VAL(pt), &prompt_cont, &prompt_pos);
if (!prompt && !SAME_OBJ(scheme_default_prompt_tag, pt)) {
scheme_raise_exn(MZEXN_FAIL_CONTRACT_CONTINUATION,
@ -6974,11 +6998,15 @@ static Scheme_Object *call_with_prompt (int in_argc, Scheme_Object *in_argv[])
prompt_tag = SCHEME_CHAPERONE_VAL(in_argv[1]);
} else {
scheme_wrong_contract("call-with-continuation-prompt", "continuation-prompt-tag?",
1, in_argc, in_argv);
1, in_argc, in_argv);
return NULL;
}
} else
prompt_tag = in_argv[1];
if (SAME_OBJ(prompt_tag, scheme_root_prompt_tag)) {
root_prompt_tag_misuse("call-with-continuation-prompt");
return NULL;
}
} else
prompt_tag = scheme_default_prompt_tag;
@ -7426,12 +7454,17 @@ static Scheme_Object *do_abort_continuation (int argc, Scheme_Object *argv[], in
prompt_tag = SCHEME_CHAPERONE_VAL(argv[0]);
} else {
scheme_wrong_contract("abort-current-continuation", "continuation-prompt-tag?",
0, argc, argv);
0, argc, argv);
return NULL;
}
} else
prompt_tag = argv[0];
if (SAME_OBJ(prompt_tag, scheme_root_prompt_tag)) {
root_prompt_tag_misuse("abort-current-continuation");
return NULL;
}
prompt = (Scheme_Prompt *)scheme_extract_one_cc_mark(NULL, SCHEME_PTR_VAL(prompt_tag));
if (!prompt && SAME_OBJ(scheme_default_prompt_tag, prompt_tag))
prompt = original_default_prompt;
@ -7518,10 +7551,14 @@ static Scheme_Object *do_call_with_control (int argc, Scheme_Object *argv[], int
prompt_tag = SCHEME_CHAPERONE_VAL(prompt_tag);
else {
scheme_wrong_contract("call-with-composable-continuation", "continuation-prompt-tag?",
1, argc, argv);
1, argc, argv);
return NULL;
}
}
}
if (SAME_OBJ(prompt_tag, scheme_root_prompt_tag)) {
root_prompt_tag_misuse("abort-current-continuation");
return NULL;
}
} else
prompt_tag = scheme_default_prompt_tag;
@ -7556,6 +7593,11 @@ static Scheme_Object *unsafe_call_with_control_no_dws(int argc, Scheme_Object *a
return do_call_with_control(argc, argv, 1);
}
static Scheme_Object *unsafe_root_continuation_prompt_tag(int argc, Scheme_Object *argv[])
{
return scheme_root_prompt_tag;
}
static Scheme_Cont_Mark *copy_cm_shared_on_write(Scheme_Meta_Continuation *mc)
{
Scheme_Cont_Mark *cp;
@ -7585,6 +7627,9 @@ static Scheme_Object *continuation_marks(Scheme_Thread *p,
intptr_t cmpos, first_cmpos = 0, cdelta = 0;
int found_tag = 0, at_mc_boundary = 0;
if (SAME_OBJ(prompt_tag, scheme_root_prompt_tag))
prompt_tag = NULL;
if (cont && SAME_OBJ(cont->prompt_tag, prompt_tag))
found_tag = 1;
if (!prompt_tag)
@ -7903,10 +7948,11 @@ cc_marks(int argc, Scheme_Object *argv[])
prompt_tag = SCHEME_CHAPERONE_VAL(prompt_tag);
else
scheme_wrong_contract("current-continuation-marks", "continuation-prompt-tag?",
0, argc, argv);
0, argc, argv);
}
if (!SAME_OBJ(scheme_default_prompt_tag, prompt_tag))
if (!SAME_OBJ(scheme_default_prompt_tag, prompt_tag)
&& !SAME_OBJ(scheme_root_prompt_tag, prompt_tag))
if (!scheme_extract_one_cc_mark(NULL, SCHEME_PTR_VAL(prompt_tag))) {
scheme_raise_exn(MZEXN_FAIL_CONTRACT_CONTINUATION,
"current-continuation-marks: no corresponding prompt in the continuation\n"
@ -8023,7 +8069,7 @@ extract_cc_marks(int argc, Scheme_Object *argv[])
prompt_tag = SCHEME_CHAPERONE_VAL(argv[2]);
else {
scheme_wrong_contract("continuation-mark-set->list", "continuation-prompt-tag?",
2, argc, argv);
2, argc, argv);
return NULL;
}
} else
@ -8274,6 +8320,9 @@ scheme_extract_one_cc_mark_with_meta(Scheme_Object *mark_set, Scheme_Object *key
{
Scheme_Object *key = key_arg;
if (prompt_tag && SAME_OBJ(prompt_tag, SCHEME_PTR_VAL(scheme_root_prompt_tag)))
prompt_tag = NULL;
if (SCHEME_NP_CHAPERONEP(key)
&& SCHEME_CONTINUATION_MARK_KEYP(SCHEME_CHAPERONE_VAL(key))) {
key = SCHEME_CHAPERONE_VAL(key);
@ -8470,7 +8519,7 @@ extract_one_cc_mark_fast(Scheme_Object *key, int *_conclusive)
Scheme_Cont_Mark *seg;
Scheme_Thread *p = scheme_current_thread;
Scheme_Meta_Continuation *mc = NULL;
do {
if (mc) {
startpos = mc->cont_mark_total;
@ -8612,7 +8661,7 @@ Scheme_Object *
scheme_extract_one_cc_mark(Scheme_Object *mark_set, Scheme_Object *key)
{
Scheme_Object *v;
if (!mark_set) {
int conclusive = 0;
v = extract_one_cc_mark_fast(key, &conclusive);
@ -8661,7 +8710,8 @@ extract_one_cc_mark(int argc, Scheme_Object *argv[])
} else
prompt_tag = argv[3];
if (!SAME_OBJ(scheme_default_prompt_tag, prompt_tag)) {
if (!SAME_OBJ(scheme_default_prompt_tag, prompt_tag)
&& !SAME_OBJ(scheme_root_prompt_tag, prompt_tag)) {
if (SCHEME_FALSEP(argv[0])) {
if (!scheme_extract_one_cc_mark(NULL, SCHEME_PTR_VAL(prompt_tag))) {
scheme_raise_exn(MZEXN_FAIL_CONTRACT_CONTINUATION,
@ -8723,7 +8773,8 @@ static Scheme_Object *continuation_prompt_available(int argc, Scheme_Object *arg
} else {
Scheme_Meta_Continuation *mc;
if (SAME_OBJ(scheme_default_prompt_tag, prompt_tag))
if (SAME_OBJ(scheme_default_prompt_tag, prompt_tag)
|| SAME_OBJ(scheme_root_prompt_tag, prompt_tag))
return scheme_true;
mc = scheme_get_meta_continuation(argv[1]);
@ -8740,7 +8791,8 @@ static Scheme_Object *continuation_prompt_available(int argc, Scheme_Object *arg
1, argc, argv);
}
} else {
if (SAME_OBJ(scheme_default_prompt_tag, prompt_tag))
if (SAME_OBJ(scheme_default_prompt_tag, prompt_tag)
|| SAME_OBJ(scheme_root_prompt_tag, prompt_tag))
return scheme_true;
if (scheme_extract_one_cc_mark(NULL, SCHEME_PTR_VAL(prompt_tag)))

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

@ -14,7 +14,7 @@
#define USE_COMPILED_STARTUP 1
#define EXPECTED_PRIM_COUNT 1440
#define EXPECTED_PRIM_COUNT 1441
#ifdef MZSCHEME_SOMETHING_OMITTED
# undef USE_COMPILED_STARTUP

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

@ -676,6 +676,7 @@ extern Scheme_Hash_Tree *scheme_source_stx_props;
extern Scheme_Object *scheme_stack_dump_key;
extern Scheme_Object *scheme_root_prompt_tag;
extern Scheme_Object *scheme_default_prompt_tag;
THREAD_LOCAL_DECL(extern Scheme_Object *scheme_system_idle_channel);

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

@ -13,12 +13,12 @@
consistently.)
*/
#define MZSCHEME_VERSION "7.0.0.13"
#define MZSCHEME_VERSION "7.0.0.14"
#define MZSCHEME_VERSION_X 7
#define MZSCHEME_VERSION_Y 0
#define MZSCHEME_VERSION_Z 0
#define MZSCHEME_VERSION_W 13
#define MZSCHEME_VERSION_W 14
#define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)

108
racket/src/racket/src/startup.inc
View File

@ -15392,6 +15392,7 @@ static const char *startup_source =
"(if(syntax-tainted?$1 id_0)"
" (let-values () (raise-syntax-error$1 #f \"cannot use identifier tainted by macro transformation\" id_0))"
"(void)))))"
"(define-values(root-tag)(unsafe-root-continuation-prompt-tag))"
"(define-values(cons-ish)(lambda(a_0 b_0)(begin(if(null? b_0) a_0(cons a_0 b_0)))))"
"(define-values"
"(to-syntax-list.1)"
@ -16184,7 +16185,10 @@ static const char *startup_source =
"(expand-context/outer-current-use-scopes the-struct_0)"
"(expand-context/outer-name the-struct_0)))"
" (raise-argument-error 'struct-copy \"expand-context/outer?\" the-struct_0)))))))"
"(define-values(current-expand-context)(make-parameter #f))"
"(define-values(default-val.1$2) #f)"
"(define-values"
"(current-expand-context)"
"(lambda()(begin(continuation-mark-set-first #f current-expand-context default-val.1$2 root-tag))))"
"(define-values"
"(get-current-expand-context16.1)"
"(lambda(fail-ok?13_0 who15_0)"
@ -16644,7 +16648,10 @@ static const char *startup_source =
"(define-values"
"(syntax-remove-taint-dispatch-properties)"
"(lambda(s_0)(begin(1/syntax-property-remove(1/syntax-property-remove s_0 'taint-mode) 'certify-mode))))"
"(define-values(current-module-code-inspector)(make-parameter #f))"
"(define-values(default-val.1$1) #f)"
"(define-values"
"(current-module-code-inspector)"
"(lambda()(begin(continuation-mark-set-first #f current-module-code-inspector default-val.1$1 root-tag))))"
"(define-values"
"(syntax-debug-info$1)"
"(lambda(s_0 phase_0 all-bindings?_0)"
@ -34824,6 +34831,10 @@ static const char *startup_source =
"(continuation-mark-set-first"
" #f"
" parameterization-key)"
" 1/current-namespace"
" ns_2)"
"(let-values()"
"(with-continuation-mark"
" current-expand-context"
"(promise1.1"
"(lambda()"
@ -34835,12 +34846,11 @@ static const char *startup_source =
" #f"
" ns-153_0)))"
" #f)"
" 1/current-namespace"
" ns_2"
"(with-continuation-mark"
" current-module-code-inspector"
" insp_0)"
" insp_0"
"(let-values()"
"(instantiate-body_0))))))))))))"
"(instantiate-body_0)))))))))))))))"
"(void)))))"
"(if log-performance?"
"(let-values()"
@ -37868,6 +37878,10 @@ static const char *startup_source =
"(continuation-mark-set-first"
" #f"
" parameterization-key)"
" 1/current-namespace"
" phase-ns_0)"
"(let-values()"
"(with-continuation-mark"
" current-expand-context"
"(let-values(((ns-144_0)"
" ns-1_0))"
@ -37876,11 +37890,9 @@ static const char *startup_source =
" #f"
" #f"
" ns-144_0))"
" 1/current-namespace"
" phase-ns_0)"
"(let-values()"
"(instantiate_0"
" tail?_0))))))))))))"
" tail?_0))))))))))))))"
"(let-values()"
" void)))))))))))"
"(values"
@ -39918,17 +39930,20 @@ static const char *startup_source =
" parameterization-key"
"(extend-parameterization"
"(continuation-mark-set-first #f parameterization-key)"
" current-expand-context"
" m-ctx_0"
" 1/current-namespace"
"(namespace->namespace-at-phase"
"(expand-context-namespace ctx_0)"
"(add1(expand-context-phase ctx_0)))"
"(add1(expand-context-phase ctx_0))))"
"(let-values()"
"(with-continuation-mark"
" current-expand-context"
" m-ctx_0"
"(with-continuation-mark"
" current-module-code-inspector"
" insp-of-t_0)"
" insp-of-t_0"
"(let-values()"
"(call-with-continuation-barrier"
"(lambda()((transformer->procedure t_0) cleaned-s_0)))))))"
"(lambda()((transformer->procedure t_0) cleaned-s_0))))))))))"
"(begin"
"(let-values(((obs_0)(expand-context-observer ctx_0)))"
"(if obs_0"
@ -40454,16 +40469,18 @@ static const char *startup_source =
" parameterization-key"
"(extend-parameterization"
"(continuation-mark-set-first #f parameterization-key)"
" current-expand-context"
" ctx_0"
" 1/current-namespace"
" ns_0"
" eval-jit-enabled"
" #f)"
"(let-values()"
"(with-continuation-mark"
" current-expand-context"
" ctx_0"
"(let-values()"
"(if compiled_0"
"(eval-single-top compiled_0 ns_0)"
"(direct-eval p_0 ns_0(root-expand-context-self-mpi ctx_0))))))"
"(direct-eval p_0 ns_0(root-expand-context-self-mpi ctx_0))))))))"
" list)))"
"(begin"
"(if(=(length vals_0)(length ids_0))"
@ -40645,11 +40662,7 @@ static const char *startup_source =
"(define-values"
"(rename-transformer-target-in-context)"
"(lambda(t_0 ctx_0)"
"(begin"
"(with-continuation-mark"
" parameterization-key"
"(extend-parameterization(continuation-mark-set-first #f parameterization-key) current-expand-context ctx_0)"
"(let-values()(1/rename-transformer-target t_0))))))"
"(begin(with-continuation-mark current-expand-context ctx_0(let-values()(1/rename-transformer-target t_0))))))"
"(define-values"
"(maybe-install-free=id-in-context!)"
"(lambda(val_0 id_0 phase_0 ctx_0)"
@ -40657,8 +40670,8 @@ static const char *startup_source =
"(if(1/rename-transformer? val_0)"
"(let-values()"
"(with-continuation-mark"
" parameterization-key"
"(extend-parameterization(continuation-mark-set-first #f parameterization-key) current-expand-context ctx_0)"
" current-expand-context"
" ctx_0"
"(let-values()(maybe-install-free=id! val_0 id_0 phase_0))))"
"(void)))))"
"(define-values"
@ -48176,7 +48189,10 @@ static const char *startup_source =
"(make-struct-field-accessor -ref_0 1 'graph)"
"(make-struct-field-mutator -set!_0 0 'accum-str)"
"(make-struct-field-mutator -set!_0 1 'graph))))"
"(define-values(current-read-config)(make-parameter #f))"
"(define-values(default-val.1) #f)"
"(define-values"
"(current-read-config)"
"(lambda()(begin(continuation-mark-set-first #f current-read-config default-val.1 root-tag))))"
"(define-values"
"(make-read-config26.1)"
"(lambda(coerce12_0"
@ -48826,22 +48842,16 @@ static const char *startup_source =
"(if(not for-syntax?_0)"
"(let-values()"
"(with-continuation-mark"
" parameterization-key"
"(extend-parameterization"
"(continuation-mark-set-first #f parameterization-key)"
" current-read-config"
" config_0)"
" config_0"
"(let-values()"
"(if(procedure-arity-includes? handler_0 2)"
"(handler_0 c_0 in_0)"
"(handler_0 c_0 in_0 #f line_0 col_0 pos_0)))))"
"(let-values()"
"(with-continuation-mark"
" parameterization-key"
"(extend-parameterization"
"(continuation-mark-set-first #f parameterization-key)"
" current-read-config"
" config_0)"
" config_0"
"(let-values()(handler_0 c_0 in_0(read-config-source config_0) line_0 col_0 pos_0)))))))"
"(if(1/special-comment? v_0) v_0(coerce v_0 in_0 config_0)))))))"
"(define-values"
@ -55456,11 +55466,8 @@ static const char *startup_source =
"(if(procedure-arity-includes? extension_0 6)"
"(let-values()"
"(with-continuation-mark"
" parameterization-key"
"(extend-parameterization"
"(continuation-mark-set-first #f parameterization-key)"
" current-read-config"
" config_0)"
" config_0"
"(let-values()"
"(extension_0"
"(read-config-source config_0)"
@ -55472,13 +55479,8 @@ static const char *startup_source =
"(if(procedure-arity-includes? extension_0 2)"
"(let-values()"
"(with-continuation-mark"
" parameterization-key"
"(extend-parameterization"
"(continuation-mark-set-first"
" #f"
" parameterization-key)"
" current-read-config"
" config_0)"
" config_0"
"(let-values()"
"(extension_0(read-config-source config_0) in_0))))"
"(let-values()"
@ -55490,11 +55492,8 @@ static const char *startup_source =
"(if(procedure-arity-includes? extension_0 5)"
"(let-values()"
"(with-continuation-mark"
" parameterization-key"
"(extend-parameterization"
"(continuation-mark-set-first #f parameterization-key)"
" current-read-config"
" config_0)"
" config_0"
"(let-values()"
"(extension_0"
" in_0"
@ -55511,13 +55510,8 @@ static const char *startup_source =
"(if(procedure-arity-includes? extension_0 1)"
"(let-values()"
"(with-continuation-mark"
" parameterization-key"
"(extend-parameterization"
"(continuation-mark-set-first"
" #f"
" parameterization-key)"
" current-read-config"
" config_0)"
" config_0"
"(let-values()(extension_0 in_0))))"
"(let-values()"
"(raise-argument-error"
@ -77134,11 +77128,13 @@ static const char *startup_source =
"(continuation-mark-set-first"
" #f"
" parameterization-key)"
" current-expand-context"
" ctx_0"
" 1/current-namespace"
" m-ns_0)"
"(let-values()"
"(with-continuation-mark"
" current-expand-context"
" ctx_0"
"(let-values()"
"(eval-single-top"
"(compile-single"
" p_0"
@ -77153,7 +77149,7 @@ static const char *startup_source =
" m-ns672_0"
" phase673_0"
" unsafe-undefined)))"
" m-ns_0)))))))))"
" m-ns_0)))))))))))"
"(values)))))"
"(values)))))"
"(if(not #f)(for-loop_0 rest_0)(values))))"

1
racket/src/racket/src/thread.c
View File

@ -8766,7 +8766,6 @@ static Scheme_Object *unsafe_remove_collect_callbacks(int argc, Scheme_Object *a
return scheme_void;
}
#if defined(_MSC_VER) || defined(__MINGW32__)
# define mzOSAPI WINAPI
#else