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

fix errortrace (required API changes), add `syntax-shift-phase-level'

Browse Source 
Also fix a bug in the `module' expander and streamline lazy
visits.
This commit is contained in:
Matthew Flatt 2011-09-13 10:15:34 -06:00
parent 437d654cc1
commit a233697f08
17 changed files with 184 additions and 110 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
collects/drracket/private/debug.rkt
View File

@ -533,7 +533,7 @@ profile todo:
;; a member of stacktrace-imports^
;; guarantees that the continuation marks associated with errortrace-key are
;; members of the debug-source type, after unwrapped with st-mark-source
(define (with-mark src-stx expr)
(define (with-mark src-stx expr phase)
(let ([source (cond
[(path? (syntax-source src-stx))
(syntax-source src-stx)]
@ -557,11 +557,13 @@ profile todo:
(if source
(with-syntax ([expr expr]
[mark (list 'dummy-thing source line column position span)]
[errortrace-key errortrace-key])
[wcm (syntax-shift-phase-level #'with-continuation-mark phase)]
[errortrace-key (syntax-shift-phase-level errortrace-key phase)]
[qte (syntax-shift-phase-level #'quote phase)])
(syntax
(with-continuation-mark 'errortrace-key
'mark
expr)))
(wcm (qte errortrace-key)
(qte mark)
expr)))
expr)))
;; current-backtrace-window : (union #f (instanceof frame:basic<%>))

5
collects/errortrace/errortrace-key-syntax.rkt
View File

@ -1,5 +0,0 @@
(module errortrace-key-syntax mzscheme
(require errortrace/errortrace-key)
(require-for-syntax errortrace/errortrace-key)
(define errortrace-key-syntax #'errortrace-key)
(provide errortrace-key-syntax))

47
collects/errortrace/errortrace-lib.rkt
View File

@ -5,6 +5,7 @@
(require "stacktrace.rkt"
"errortrace-key.rkt"
"private/utils.rkt"
racket/contract
racket/unit
racket/runtime-path
@ -198,25 +199,23 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Stacktrace instrumenter
(define-runtime-path key-syntax
'(lib "errortrace-key-syntax.rkt" "errortrace"))
(define dynamic-errortrace-key
(dynamic-require key-syntax 'errortrace-key-syntax))
(define base-phase
(variable-reference->module-base-phase (#%variable-reference)))
;; with-mark : stx stx -> stx
(define (with-mark mark expr)
(let ([loc (make-st-mark mark)])
(define (with-mark mark expr phase)
(let ([loc (make-st-mark mark phase)])
(if loc
(with-syntax ([expr expr]
[loc loc]
[et-key dynamic-errortrace-key])
[et-key (syntax-shift-phase-level #'errortrace-key (- phase base-phase))]
[wcm (syntax-shift-phase-level #'with-continuation-mark (- phase base-phase))])
(execute-point
mark
(syntax
(with-continuation-mark et-key
loc
expr))))
(wcm et-key
loc
expr))))
expr)))
(define-values/invoke-unit/infer stacktrace@)
@ -415,21 +414,17 @@
[(mod name init-import mb)
(syntax-case (disarm #'mb) (#%plain-module-begin)
[(#%plain-module-begin body ...)
(add-test-coverage-init-code
(normal
(copy-props
top-e
#`(#,(namespace-module-identifier) name init-import
#,(syntax-rearm
#`(#%plain-module-begin
#,((make-syntax-introducer)
(syntax/loc (datum->syntax #f 'x #f)
(#%require errortrace/errortrace-key)))
#,((make-syntax-introducer)
(syntax/loc (datum->syntax #f 'x #f)
(#%require (for-syntax errortrace/errortrace-key))))
body ...)
#'mb)))))])])))]
(let ([meta-depth ((count-meta-levels 0) #'(begin body ...))])
(add-test-coverage-init-code
(normal
(copy-props
top-e
#`(#,(namespace-module-identifier) name init-import
#,(syntax-rearm
#`(#%plain-module-begin
#,(generate-key-imports meta-depth)
body ...)
#'mb))))))])])))]
[_else
(normal top-e)])))

10
collects/errortrace/lang/body.rkt
View File

@ -1,7 +1,9 @@
#lang racket/base
(require (for-syntax racket/base
syntax/strip-context
"../errortrace-lib.rkt"))
racket/pretty
"../errortrace-lib.rkt"
"../private/utils.rkt"))
(provide (rename-out [module-begin #%module-begin]))
@ -9,13 +11,15 @@
(syntax-case stx ()
[(_ lang . body)
(let ([e (annotate-top
(syntax-local-introduce
(values ; syntax-local-introduce
(local-expand #`(module . #,(strip-context #`(n lang . body)))
'top-level
null))
0)])
(collect-garbage)
(syntax-case e ()
[(mod nm lang (mb . body))
#`(#%plain-module-begin
(require (only-in lang) errortrace/errortrace-key)
(require (only-in lang))
#,(generate-key-imports ((count-meta-levels 0) #'(begin . body)))
. body)]))]))

31
collects/errortrace/private/utils.rkt Normal file
View File

@ -0,0 +1,31 @@
#lang racket/base
(provide count-meta-levels
generate-key-imports)
(define base (variable-reference->module-base-phase (#%variable-reference)))
(define ((count-meta-levels phase) expr)
(syntax-case expr ()
[(bfs . exprs)
(free-identifier=? #'bfs #'begin-for-syntax phase base)
(add1 (apply max 0 (map (count-meta-levels (add1 phase)) (syntax->list #'exprs))))]
[(ds . _)
(free-identifier=? #'ds #'define-syntaxes phase base)
1]
[(b . exprs)
(free-identifier=? #'b #'begin phase base)
(apply max 0 (map (count-meta-levels phase) (syntax->list #'exprs)))]
[_ 0]))
(define (generate-key-imports meta-depth)
(syntax-shift-phase-level
(let loop ([meta-depth meta-depth])
(let ([e ((make-syntax-introducer)
#`(#%require (for-meta #,meta-depth
errortrace/errortrace-key)))])
(if (zero? meta-depth)
e
#`(begin #,e #,(loop (sub1 meta-depth))))))
(- (syntax-local-phase-level) base)))

19
collects/errortrace/scribblings/errortrace.scrbl
View File

@ -45,7 +45,7 @@ Then,
]
After starting @racketmodname[errortrace] in one of these ways, when an
exception occurs, the exception handler something like a stack trace
exception occurs, the exception handler prints something like a stack trace
with most recent contexts first.
The @racketmodname[errortrace] module is strange: Don't import it
@ -105,7 +105,7 @@ but instruments the module for debugging in the same way as if
@racketmodname[errortrace] is required before loading the module from
source. Using the @racketmodname[errortrace] meta-language is one way
to ensure that debugging instrumentation is present when the module is
compiled.}
compiled.
@; ---------------------------------------------
@ -374,8 +374,8 @@ Imports @racket[stacktrace-imports^] and exports @racket[stacktrace^].}
@defsignature[stacktrace^ ()]{
@deftogether[(
@defproc[(annotate (stx syntax?) (phase-level exact-integer?)) syntax?]
@defproc[(annotate-top (stx syntax?) (phase-level exact-integer?)) syntax?])]{
@defproc[(annotate (stx syntax?) (phase-level exact-nonnegative-integer?)) syntax?]
@defproc[(annotate-top (stx syntax?) (phase-level exact-nonnegative-integer?)) syntax?])]{
Annotate expressions with errortrace information. The
@racketout[annotate-top] function should be called with a top-level
@ -386,7 +386,7 @@ expression, typically @racket[(namespace-base-phase)] for a top-level
expression.}
@deftogether[(
@defproc[(make-st-mark (syntax syntax?)) (or/c #f st-mark?)]
@defproc[(make-st-mark [stx syntax?] [phase-level exact-nonnegative-integer?]) (or/c #f st-mark?)]
@defproc[(st-mark-source (st-mark st-mark?)) syntax?]
@defproc[(st-mark-bindings (st-mark st-mark?)) list?])]{
@ -406,12 +406,15 @@ hardwired to return @racket[null]. }
@defsignature[stacktrace-imports^ ()]{
@defproc[(with-mark (source-stx any/c) (dest-stx any/c)) any/c]{
@defproc[(with-mark [source-stx any/c]
[dest-stx any/c]
[phase nonnegative-exact-integer?])
any/c]{
Called by @racketout[annotate] and @racketout[annotate-top] to wrap
expressions with @racket[with-continuation-mark]. The first argument
is the source expression and the second argument is the expression to
be wrapped.}
is the source expression, the second argument is the expression to
be wrapped, and the last is the phase level of the expression.}
@defboolparam[test-coverage-enabled on?]{

47
collects/errortrace/stacktrace.rkt
View File

@ -52,19 +52,21 @@
[(syntax? v) (short-version (syntax-e v) depth)]
[else v]))
(define (make-st-mark stx)
(define (make-st-mark stx phase)
(unless (syntax? stx)
(error 'make-st-mark
"expected syntax object as argument, got ~e" stx))
(cond
[(syntax-source stx)
#`(quote (#,(short-version stx 10)
#,(syntax-source stx)
#,(syntax-line stx)
#,(syntax-column stx)
#,(syntax-position stx)
#,(syntax-span stx)))]
(with-syntax ([quote (syntax-shift-phase-level #'quote phase)])
#`(quote (#,(short-version stx 10)
#,(syntax-source stx)
#,(syntax-line stx)
#,(syntax-column stx)
#,(syntax-position stx)
#,(syntax-span stx))))]
[else #f]))
(define (st-mark-source src)
(and src
(datum->syntax #f (car src) (cdr src) #f)))
@ -309,6 +311,8 @@
(define (make-annotate top? name)
(lambda (expr phase)
(define disarmed-expr (disarm expr))
(define (with-mrk* mark expr)
(with-mark mark expr phase))
(test-coverage-point
(kernel-syntax-case/phase disarmed-expr phase
[_
@ -324,11 +328,11 @@
expr]
[else
;; might be undefined/uninitialized
(with-mark expr expr)]))]
(with-mrk* expr expr)]))]
[(#%top . id)
;; might be undefined/uninitialized
(with-mark expr expr)]
(with-mrk* expr expr)]
[(#%variable-reference . _)
;; no error possible
expr]
@ -337,7 +341,7 @@
top?
;; Can't put annotation on the outside
(let* ([marked
(with-mark expr
(with-mrk* expr
(annotate-named
(one-name #'names)
(syntax rhs)
@ -372,7 +376,8 @@
(annotate-named
(one-name #'(name ...))
(syntax rhs)
(add1 phase)))])
(add1 phase))
(add1 phase))])
(rearm
expr
(rebuild disarmed-expr (list (cons #'rhs marked)))))]
@ -446,7 +451,7 @@
;; Wrap RHSs and body
[(let-values ([vars rhs] ...) . body)
(with-mark expr
(with-mrk* expr
(rearm
expr
(annotate-let disarmed-expr phase
@ -466,7 +471,7 @@
(free-identifier=? #'var1 #'var2))
fm]
[_
(with-mark expr fm)]))]
(with-mrk* expr fm)]))]
;; This case is needed for `#lang errortrace ...', which uses
;; `local-expand' on the module body.
[(letrec-syntaxes+values sbindings ([vars rhs] ...) . body)
@ -476,7 +481,7 @@
(syntax (vars ...))
(syntax (rhs ...))
(syntax body)))])
(with-mark expr fm))]
(with-mrk* expr fm))]
;; Wrap RHS
[(set! var rhs)
@ -485,7 +490,7 @@
(syntax rhs)
phase)])
;; set! might fail on undefined variable, or too many values:
(with-mark expr
(with-mrk* expr
(rearm
expr
(rebuild disarmed-expr (list (cons #'rhs new-rhs))))))]
@ -497,12 +502,12 @@
expr
#`(begin #,(annotate (syntax e) phase)))]
[(begin . body)
(with-mark expr
(with-mrk* expr
(rearm
expr
(annotate-seq disarmed-expr #'body annotate phase)))]
[(begin0 . body)
(with-mark expr
(with-mrk* expr
(rearm
expr
(annotate-seq disarmed-expr #'body annotate phase)))]
@ -510,7 +515,7 @@
(let ([w-tst (annotate (syntax tst) phase)]
[w-thn (annotate (syntax thn) phase)]
[w-els (annotate (syntax els) phase)])
(with-mark expr
(with-mrk* expr
(rearm
expr
(rebuild disarmed-expr (list (cons #'tst w-tst)
@ -519,13 +524,13 @@
[(if tst thn)
(let ([w-tst (annotate (syntax tst) phase)]
[w-thn (annotate (syntax thn) phase)])
(with-mark expr
(with-mrk* expr
(rearm
expr
(rebuild disarmed-expr (list (cons #'tst w-tst)
(cons #'thn w-thn))))))]
[(with-continuation-mark . body)
(with-mark expr
(with-mrk* expr
(rearm
expr
(annotate-seq disarmed-expr (syntax body)
@ -546,7 +551,7 @@
;; It's (void):
expr]
[else
(with-mark expr (rearm
(with-mrk* expr (rearm
expr
(annotate-seq disarmed-expr (syntax body)
annotate phase)))])]

2
collects/racket/private/sandbox-coverage.rkt
View File

@ -50,7 +50,7 @@
(define register-profile-start void)
(define register-profile-done void)
;; no marks
(define (with-mark mark expr) expr)
(define (with-mark mark expr phase) expr)
(define-values/invoke-unit/infer stacktrace@)

18
collects/scribblings/reference/stx-ops.scrbl
View File

@ -3,11 +3,19 @@
@title[#:tag "stxops"]{Syntax Object Content}
@defproc[(syntax? [v any/c]) boolean?]{
Returns @racket[#t] if @racket[v] is a @tech{syntax object}, @racket[#f]
otherwise. See also @secref["stxobj-model"].}
@defproc[(identifier? [v any/c]) boolean?]{
Returns @racket[#t] if @racket[v] is a @tech{syntax object} and
@racket[(syntax-e stx)] produces a symbol.}
@defproc[(syntax-source [stx syntax?]) any]{
Returns the source for the @tech{syntax object} @racket[stx], or @racket[#f]
@ -221,10 +229,14 @@ The @racket[ignored] argument is allowed for backward compatibility
and has no effect on the returned syntax object.}
@defproc[(identifier? [v any/c]) boolean?]{
@defproc[(syntax-shift-phase-level [stx syntax?]
[shift exact-integer?])
syntax?]{
Returns @racket[#t] if @racket[v] is a @tech{syntax object} and
@racket[(syntax-e stx)] produces a symbol.}
Returns a syntax object that is like @racket[stx], but with all of its
top-level and module binding shifted by @racket[shift] @tech{phase
levels}. If @racket[shift] is @racket[0], then the result is
@racket[stx].}
@defproc[(generate-temporaries [stx-pair (or syntax? list?)])

8
doc/release-notes/racket/HISTORY.txt
View File

@ -1,3 +1,11 @@
Version 5.1.3.9
Add syntax-shift-phase-level
errortrace: with-mark and make-st-mark now take a phase level
Version 5.1.3.8
Add syntax-transforming-module-expression? and
variable-reference->module-base-phase
Version 5.1.3.7
Generalized begin-with-syntax to allow phase-N definitions,
both variable and syntax, within a module for all N >= 0;

9
src/racket/src/eval.c
View File

@ -3600,7 +3600,7 @@ static Scheme_Object *add_renames_unless_module(Scheme_Object *form, Scheme_Env
if (genv->rename_set) {
form = scheme_add_rename(form, genv->rename_set);
/* this "phase shift" just attaches the namespace's module registry: */
form = scheme_stx_phase_shift(form, 0, NULL, NULL, genv->module_registry->exports, NULL);
form = scheme_stx_phase_shift(form, NULL, NULL, NULL, genv->module_registry->exports, NULL);
}
return form;
@ -3674,7 +3674,7 @@ static void *compile_k(void)
if (rename) {
form = add_renames_unless_module(form, genv);
if (genv->module) {
form = scheme_stx_phase_shift(form, 0,
form = scheme_stx_phase_shift(form, NULL,
genv->module->me->src_modidx,
genv->module->self_modidx,
genv->module_registry->exports,
@ -4110,7 +4110,7 @@ Scheme_Object *scheme_eval_compiled_stx_string(Scheme_Object *expr, Scheme_Env *
result = scheme_make_vector(len - 1, NULL);
for (i = 0; i < len - 1; i++) {
s = scheme_stx_phase_shift(SCHEME_VEC_ELS(expr)[i], shift, orig, modidx,
s = scheme_stx_phase_shift(SCHEME_VEC_ELS(expr)[i], scheme_make_integer(shift), orig, modidx,
env->module_registry->exports, NULL);
SCHEME_VEC_ELS(result)[i] = s;
}
@ -5278,7 +5278,8 @@ Scheme_Object **scheme_push_prefix(Scheme_Env *genv, Resolve_Prefix *rp,
if (insp && SCHEME_FALSEP(insp))
insp = scheme_get_current_inspector();
i = rp->num_toplevels;
v = scheme_stx_phase_shift_as_rename(now_phase - src_phase, src_modidx, now_modidx,
v = scheme_stx_phase_shift_as_rename(scheme_make_integer(now_phase - src_phase),
src_modidx, now_modidx,
genv ? genv->module_registry->exports : NULL,
insp);
if (v || (rp->delay_info_rpair && SCHEME_CDR(rp->delay_info_rpair))) {

38
src/racket/src/module.c
View File

@ -4535,10 +4535,15 @@ static void should_run_for_compile(Scheme_Env *menv, int phase)
{
if (menv->running[phase]) return;
while (phase > 1) {
scheme_prepare_exp_env(menv);
menv = menv->exp_env;
phase--;
if (!phase) {
scheme_prepare_template_env(menv);
menv = menv->template_env;
} else {
while (phase > 1) {
scheme_prepare_exp_env(menv);
menv = menv->exp_env;
phase--;
}
}
#if 0
@ -4546,15 +4551,10 @@ static void should_run_for_compile(Scheme_Env *menv, int phase)
scheme_signal_error("internal error: inconsistent instance_env");
#endif
if (!menv->available_next[0]) {
menv->available_next[0] = MODCHAIN_AVAIL(menv->modchain, 0);
MODCHAIN_AVAIL(menv->modchain, 0) = (Scheme_Object *)menv;
}
if (!menv->available_next[1]) {
menv->available_next[1] = MODCHAIN_AVAIL(menv->modchain, 1);
MODCHAIN_AVAIL(menv->modchain, 1) = (Scheme_Object *)menv;
}
}
static void start_module(Scheme_Module *m, Scheme_Env *env, int restart,
@ -4704,13 +4704,6 @@ void scheme_prepare_compile_env(Scheme_Env *env)
that env->phase is visited. */
{
do_prepare_compile_env(env, env->phase, 0);
/* A top-level `require' can introduce in any phase with a
`for-syntax' import whose visit triggers an instantiation.
So, also check for instances at the next phase. */
if (env->exp_env) {
do_prepare_compile_env(env->exp_env, env->phase, 1);
}
}
static void *eval_module_body_k(void)
@ -5743,7 +5736,7 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env,
fm = scheme_stx_property(fm, module_name_symbol, scheme_resolved_module_path_value(m->modname));
/* phase shift to replace self_modidx of previous expansion (if any): */
fm = scheme_stx_phase_shift(fm, 0, empty_self_modidx, self_modidx, NULL, m->insp);
fm = scheme_stx_phase_shift(fm, NULL, empty_self_modidx, self_modidx, NULL, m->insp);
fm = scheme_add_rename(fm, rn_set);
@ -5852,7 +5845,7 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env,
}
/* for future expansion, shift away from self_modidx: */
fm = scheme_stx_phase_shift(fm, 0, self_modidx, empty_self_modidx, NULL, NULL);
fm = scheme_stx_phase_shift(fm, NULL, self_modidx, empty_self_modidx, NULL, NULL);
/* make self_modidx like the empty modidx */
((Scheme_Modidx *)self_modidx)->resolved = empty_self_modname;
@ -7069,7 +7062,7 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_
if (erec) {
Scheme_Expand_Info erec1;
scheme_init_expand_recs(rec, drec, &erec1, 1);
scheme_init_expand_recs(erec, derec, &erec1, 1);
erec1.value_name = scheme_false;
e = scheme_expand_expr(e, nenv, &erec1, 0);
expanded_l = scheme_make_pair(e, expanded_l);
@ -7306,7 +7299,7 @@ static Scheme_Object *fixup_expanded_provides(Scheme_Object *expanded_l,
Scheme_Object *expanded_provides,
int phase)
/* mutates `expanded_l' to find `#%provide's (possibly nested in
`begin-for-syntax') and elace them with the ones in
`begin-for-syntax') and replace them with the ones in
`expanded_provides'. The provides in `expanded_l' and
`expanded_provides' are matched up by order. */
{
@ -7325,11 +7318,12 @@ static Scheme_Object *fixup_expanded_provides(Scheme_Object *expanded_l,
e = SCHEME_CAR(p);
if (SCHEME_STX_PAIRP(e)) {
fst = SCHEME_STX_CAR(e);
if (scheme_stx_module_eq(prov_stx, fst, 0)) {
if (scheme_stx_module_eq(prov_stx, fst, phase)) {
SCHEME_CAR(p) = SCHEME_CAR(expanded_provides);
expanded_provides = SCHEME_CDR(expanded_provides);
} else if (scheme_stx_module_eq(begin_for_syntax_stx, fst, 0)) {
} else if (scheme_stx_module_eq(begin_for_syntax_stx, fst, phase)) {
l = scheme_flatten_syntax_list(e, NULL);
l = scheme_copy_list(l);
expanded_provides = fixup_expanded_provides(SCHEME_CDR(l), expanded_provides, phase + 1);
e = scheme_datum_to_syntax(l, e, e, 0, 2);
SCHEME_CAR(p) = e;

5
src/racket/src/number.c
View File

@ -1110,6 +1110,11 @@ int scheme_get_unsigned_long_long_val(Scheme_Object *o, umzlonglong *v)
return 0;
}
int scheme_exact_p(Scheme_Object *n)
{
return (SCHEME_INTP(n) || SCHEME_BIGNUMP(n));
}
int scheme_nonneg_exact_p(Scheme_Object *n)
{
return ((SCHEME_INTP(n) && (SCHEME_INT_VAL(n) >= 0))

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

@ -11,9 +11,9 @@
EXPECTED_PRIM_COUNT to the new value, and then USE_COMPILED_STARTUP
can be set to 1 again. */
#define USE_COMPILED_STARTUP 1
#define USE_COMPILED_STARTUP 0
#define EXPECTED_PRIM_COUNT 1033
#define EXPECTED_PRIM_COUNT 1034
#define EXPECTED_UNSAFE_COUNT 78
#define EXPECTED_FLFXNUM_COUNT 68
#define EXPECTED_FUTURES_COUNT 11

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

@ -1038,11 +1038,11 @@ Scheme_Object *scheme_stx_property(Scheme_Object *_stx,
Scheme_Object *key,
Scheme_Object *val);
Scheme_Object *scheme_stx_phase_shift(Scheme_Object *stx, intptr_t shift,
Scheme_Object *scheme_stx_phase_shift(Scheme_Object *stx, Scheme_Object *shift,
Scheme_Object *old_midx, Scheme_Object *new_midx,
Scheme_Hash_Table *export_registry,
Scheme_Object *insp);
Scheme_Object *scheme_stx_phase_shift_as_rename(intptr_t shift,
Scheme_Object *scheme_stx_phase_shift_as_rename(Scheme_Object *shift,
Scheme_Object *old_midx, Scheme_Object *new_midx,
Scheme_Hash_Table *export_registry,
Scheme_Object *insp);
@ -1990,6 +1990,7 @@ Scheme_Object *scheme_make_polar(int argc, Scheme_Object *argv[]);
Scheme_Object *scheme_bitwise_shift(int argc, Scheme_Object *argv[]);
Scheme_Object *scheme_bitwise_and(int argc, Scheme_Object *argv[]);
int scheme_exact_p(Scheme_Object *n);
int scheme_nonneg_exact_p(Scheme_Object *n);
#ifdef TIME_TYPE_IS_UNSIGNED

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

@ -13,12 +13,12 @@
consistently.)
*/
#define MZSCHEME_VERSION "5.1.3.8"
#define MZSCHEME_VERSION "5.1.3.9"
#define MZSCHEME_VERSION_X 5
#define MZSCHEME_VERSION_Y 1
#define MZSCHEME_VERSION_Z 3
#define MZSCHEME_VERSION_W 8
#define MZSCHEME_VERSION_W 9
#define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)

30
src/racket/src/syntax.c
View File

@ -77,6 +77,8 @@ static Scheme_Object *syntax_property(int argc, Scheme_Object **argv);
static Scheme_Object *syntax_property_keys(int argc, Scheme_Object **argv);
static Scheme_Object *syntax_track_origin(int argc, Scheme_Object **argv);
static Scheme_Object *syntax_shift_phase(int argc, Scheme_Object **argv);
static Scheme_Object *bound_eq(int argc, Scheme_Object **argv);
static Scheme_Object *module_eq(int argc, Scheme_Object **argv);
static Scheme_Object *module_trans_eq(int argc, Scheme_Object **argv);
@ -424,6 +426,7 @@ void scheme_init_stx(Scheme_Env *env)
GLOBAL_IMMED_PRIM("syntax-track-origin" , syntax_track_origin , 3, 3, env);
GLOBAL_IMMED_PRIM("make-syntax-delta-introducer" , scheme_syntax_make_transfer_intro, 2, 3, env);
GLOBAL_IMMED_PRIM("syntax-shift-phase-level" , syntax_shift_phase , 2, 2, env);
GLOBAL_IMMED_PRIM("bound-identifier=?" , bound_eq , 2, 4, env);
GLOBAL_IMMED_PRIM("free-identifier=?" , module_eq , 2, 4, env);
@ -438,7 +441,6 @@ void scheme_init_stx(Scheme_Env *env)
GLOBAL_IMMED_PRIM("identifier-prune-lexical-context" , identifier_prune , 1, 2, env);
GLOBAL_IMMED_PRIM("identifier-prune-to-source-module", identifier_prune_to_module, 1, 1, env);
GLOBAL_NONCM_PRIM("syntax-source-module" , syntax_src_module , 1, 2, env);
GLOBAL_FOLDING_PRIM("syntax-tainted?", syntax_tainted_p, 1, 1, 1, env);
@ -2136,15 +2138,18 @@ void scheme_install_free_id_rename(Scheme_Object *id,
}
}
Scheme_Object *scheme_stx_phase_shift_as_rename(intptr_t shift, Scheme_Object *old_midx, Scheme_Object *new_midx,
Scheme_Object *scheme_stx_phase_shift_as_rename(Scheme_Object *shift, Scheme_Object *old_midx, Scheme_Object *new_midx,
Scheme_Hash_Table *export_registry, Scheme_Object *insp)
{
if (shift || new_midx || export_registry || insp) {
if (!shift)
shift = scheme_make_integer(0);
if (!SCHEME_INTP(shift) || SCHEME_INT_VAL(shift) || new_midx || export_registry || insp) {
Scheme_Object *vec;
if (last_phase_shift
&& ((vec = SCHEME_BOX_VAL(last_phase_shift)))
&& (SCHEME_VEC_ELS(vec)[0] == scheme_make_integer(shift))
&& (SCHEME_VEC_ELS(vec)[0] == shift)
&& (SCHEME_VEC_ELS(vec)[1] == (new_midx ? old_midx : scheme_false))
&& (SCHEME_VEC_ELS(vec)[2] == (new_midx ? new_midx : scheme_false))
&& (SCHEME_VEC_ELS(vec)[3] == (export_registry ? (Scheme_Object *)export_registry : scheme_false))
@ -2152,7 +2157,7 @@ Scheme_Object *scheme_stx_phase_shift_as_rename(intptr_t shift, Scheme_Object *o
/* use the old one */
} else {
vec = scheme_make_vector(5, NULL);
SCHEME_VEC_ELS(vec)[0] = scheme_make_integer(shift);
SCHEME_VEC_ELS(vec)[0] = shift;
SCHEME_VEC_ELS(vec)[1] = (new_midx ? old_midx : scheme_false);
SCHEME_VEC_ELS(vec)[2] = (new_midx ? new_midx : scheme_false);
SCHEME_VEC_ELS(vec)[3] = (export_registry ? (Scheme_Object *)export_registry : scheme_false);
@ -2166,7 +2171,7 @@ Scheme_Object *scheme_stx_phase_shift_as_rename(intptr_t shift, Scheme_Object *o
return NULL;
}
Scheme_Object *scheme_stx_phase_shift(Scheme_Object *stx, intptr_t shift,
Scheme_Object *scheme_stx_phase_shift(Scheme_Object *stx, Scheme_Object *shift,
Scheme_Object *old_midx, Scheme_Object *new_midx,
Scheme_Hash_Table *export_registry,
Scheme_Object *insp)
@ -2183,6 +2188,19 @@ Scheme_Object *scheme_stx_phase_shift(Scheme_Object *stx, intptr_t shift,
return stx;
}
static Scheme_Object *syntax_shift_phase(int argc, Scheme_Object **argv)
{
if (!SCHEME_STXP(argv[0]))
scheme_wrong_type("syntax-shift-phase-level", "syntax", 0, argc, argv);
if (!scheme_exact_p(argv[1]))
scheme_wrong_type("syntax-shift-phase-level", "exact integer", 0, argc, argv);
if (SCHEME_INTP(argv[1]) && !SCHEME_INT_VAL(argv[1]))
return argv[0];
return scheme_stx_phase_shift(argv[0], argv[1], NULL, NULL, NULL, NULL);
}
void scheme_clear_shift_cache(void)
{
last_phase_shift = NULL;