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

371.3

Browse Source 
svn: r7350
This commit is contained in:
Matthew Flatt 2007-09-15 22:27:14 +00:00
parent 7846afa7c1
commit 001404dec0
19 changed files with 2353 additions and 2100 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/mzscheme/lang/info.ss Normal file
View File

@ -0,0 +1,2 @@
(module info (lib "infotab.ss" "setup")
(define name "MzScheme #lang"))

26
collects/mzscheme/lang/reader.ss Normal file
View File

@ -0,0 +1,26 @@
(module reader mzscheme
(provide (rename *read read)
(rename *read-syntax read-syntax))
(define (*read in)
(wrap in read))
(define (*read-syntax src in)
(wrap in (lambda (in)
(read-syntax src in))))
(define (wrap port read)
(let ([body
(let loop ([a null])
(let ([v (read port)])
(if (eof-object? v)
(reverse a)
(loop (cons v a)))))])
(let* ([p-name (object-name port)]
[name (if (path? p-name)
(let-values ([(base name dir?) (split-path p-name)])
(string->symbol (path->string (path-replace-suffix name #""))))
'page)]
[id 'doc])
`(module ,name mzscheme
. ,body)))))

4
collects/scribble/doc/lang/reader.ss Normal file
View File

@ -0,0 +1,4 @@
(module reader mzscheme
(require (prefix doc: (lib "docreader.ss" "scribble")))
(provide (rename doc:read read)
(rename doc:read-syntax read-syntax)))

2
collects/scribblings/reference/syntax.scrbl
View File

@ -1172,7 +1172,7 @@ Legal only in a @tech{module begin context}, and handled by the
@section-index["modules" "imports"]
@defform/subs[#:literals (only only-rename prefix all-except prefix-all-except rename lib file planet)
@defform/subs[#:literals (only only-rename prefix except rename lib file planet)
(require require-spec ...)
([require-spec module-path
(only require-spec id-maybe-renamed ...)

26
collects/scribblings/scribble/how-to.scrbl
View File

@ -1,4 +1,4 @@
#reader(lib "docreader.ss" "scribble")
#lang scribble/doc
@require[(lib "manual.ss" "scribble")
(lib "bnf.ss" "scribble")]
@require["utils.ss"]
@ -18,7 +18,7 @@ To document a collection or @|PLaneT| package:
@item{Start @file{manual.scrbl} like this:
@verbatim[#<<EOS
#reader(lib "docreader.ss" "scribble")
#lang scribble/doc
@begin[(require (lib "manual.ss" "scribble"))]
@title{My Library}
@ -125,7 +125,7 @@ means
For more information on the syntax of @litchar["@"], see
@secref["reader"].
In a document that starts @tt{#reader(lib "docreader.ss" "scribble")},
In a document that starts @tt{#lang scribble/doc},
the top level is a text-mode sequence. The parsed sequence is further
decoded to turn it into a hierarchy of sections and paragraphs. For
example, a linear sequence of @scheme[section] declarations with
@ -161,7 +161,7 @@ document. Such links require no information about where and how a
binding is documented elsewhere:
@verbatim[#<<EOS
#reader(lib "docreader.ss" "scribble")
#lang scribble/doc
@begin[(require (lib "manual.ss" "scribble"))
(require-for-label (lib "lang.ss" "big"))]
@ -177,7 +177,7 @@ so it ignores the source formatting of the expression. The
and it preserves the expression's formatting from the document source.
@verbatim[#<<EOS
#reader(lib "docreader.ss" "scribble")
#lang scribble/doc
@begin[(require (lib "manual.ss" "scribble"))
(require-for-label (lib "lang.ss" "big"))]
@ -208,7 +208,7 @@ hyperlink with text other than the section title.
The following example illustrates section hyperlinks:
@verbatim[#<<EOS
#reader(lib "docreader.ss" "scribble")
#lang scribble/doc
@begin[(require (lib "manual.ss" "scribble"))
(require-for-label (lib "lang.ss" "big"))]
@ -248,7 +248,7 @@ following example links to a section in the PLT Scheme reference
manual:
@verbatim[#<<EOS
#reader(lib "docreader.ss" "scribble")
#lang scribble/doc
@begin[(require (lib "manual.ss" "scribble"))
(require-for-label (lib "lang.ss" "big"))
(define ref-src
@ -281,7 +281,7 @@ of @file{helper.ss}. Then use @scheme[defproc] to document the
procedure:
@verbatim[#<<EOS
#reader(lib "docreader.ss" "scribble")
#lang scribble/doc
@begin[(require (lib "manual.ss" "scribble"))
(require-for-label (lib "lang.ss" "big")
"helper.ss")]
@ -349,7 +349,7 @@ from the previous section, then @file{helper.ss} must be imported both
via @scheme[require-for-label] and @scheme[require]:
@verbatim[#<<EOS
#reader(lib "docreader.ss" "scribble")
#lang scribble/doc
@begin[(require (lib "manual.ss" "scribble")
(lib "eval.ss" "scribble") ; <--- added
"helper.ss") ; <--- added
@ -383,7 +383,7 @@ as a sub-part of the enclosing part.
In @file{manual.scrbl}:
@verbatim[#<<EOS
#reader(lib "docreader.ss" "scribble")
#lang scribble/doc
@begin[(require (lib "manual.ss" "scribble"))]
@title{My Library}
@ -396,7 +396,7 @@ EOS
In @file{cows.scrbl}:
@verbatim[#<<EOS
#reader(lib "docreader.ss" "scribble")
#lang scribble/doc
@begin[(require (lib "manual.ss" "scribble"))]
@title{Cows}
@ -408,7 +408,7 @@ EOS
In @file{aardvarks.scrbl}:
@verbatim[#<<EOS
#reader(lib "docreader.ss" "scribble")
#lang scribble/doc
@begin[(require (lib "manual.ss" "scribble"))
(require-for-label (lib "lang.ss" "big")
"helper.ss")]
@ -440,7 +440,7 @@ sub-sections.
Revising @file{cows.scrbl} from the previous section:
@verbatim[#<<EOS
#reader(lib "docreader.ss" "scribble")
#lang scribble/doc
@begin[(require (lib "manual.ss" "scribble"))]
@title[#:style '(toc)]{Cows}

2
collects/scribblings/scribble/scribble.scrbl
View File

@ -1,4 +1,4 @@
#reader(lib "docreader.ss" "scribble")
#lang scribble/doc
@require[(lib "manual.ss" "scribble")]
@require[(lib "bnf.ss" "scribble")]
@require["utils.ss"]

10
collects/tests/mzscheme/optimize.ss
View File

@ -530,6 +530,16 @@
'(let ([f (lambda (x) x)])
(list f)))
(test-comp '(procedure-arity-includes? integer? 1)
#t)
(test-comp '(module m mzscheme
(define foo integer?)
(display (procedure-arity-includes? foo 1)))
'(module m mzscheme
(define foo integer?)
(display #t)))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Check bytecode verification of lifted functions

19
collects/tests/mzscheme/stx.ss
View File

@ -914,12 +914,15 @@
;; lifting expressions
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define prev-ctx #f)
(define-syntax (@@foo stx)
(syntax-case stx ()
[(_ n)
(if (zero? (syntax-e #'n))
#'0
(with-syntax ([m (sub1 (syntax-e #'n))])
(eval `(set! prev-ctx ',(syntax-local-lift-context)))
(syntax-local-lift-expression #'(add1 (@@foo m)))))]))
(define lifted-output #f)
@ -931,6 +934,7 @@
#'(list lifted-output id))]))
(test 2 '@@foo (@@foo 2))
(test #t values prev-ctx)
(test 2 eval (expand-once #'(@@foo 2)))
(test 2 eval (expand #'(@@foo 2)))
(test 2 eval (expand-to-top-form #'(@@foo 2)))
@ -990,6 +994,8 @@
(require @@p)
(test 10 '@@goo (@@goo))
(set! prev-ctx #f)
(module @@m mzscheme
(define-syntax (@@foo stx)
(syntax-case stx ()
@ -997,6 +1003,11 @@
(if (zero? (syntax-e #'n))
#'0
(with-syntax ([m (sub1 (syntax-e #'n))])
(let ([prev (eval 'prev-ctx)])
(if prev
(unless (eq? prev (syntax-local-lift-context))
(error "context mismatch!"))
(eval `(set! prev-ctx ',(syntax-local-lift-context)))))
(syntax-local-lift-expression #'(add1 (@@foo m)))))]))
(define @@local #f)
(define (set-local v)
@ -1006,18 +1017,24 @@
(require @@m)
(test 2 '@@local @@local)
(test #t symbol? prev-ctx)
(set! prev-ctx #f)
(define-syntax (@@local-top stx)
(syntax-case stx ()
[(_ expr)
(local-expand/capture-lifts #'expr
(list (gensym))
(list #'begin #'#%top))]))
(list #'begin #'#%top)
#f
'the-key)]))
(test 1 'let-foo (let ([x 5]) (@@foo 1)))
(test 1 eval (expand #'(let ([x 5]) (@@foo 1))))
(test 1 'local-foo (let ([x 5]) (@@local-top (@@foo 1))))
(test 'the-key values prev-ctx)
(test 1 eval (expand #'(let ([x 5]) (@@local-top (@@foo 1)))))
(test 'the-key values prev-ctx)
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Check interaction of macro-introduced/lifted names and

4
doc/release-notes/mzscheme/HISTORY
View File

@ -1,3 +1,7 @@
Version 371.3
Added syntax-local-lift-context
Added #lang
Version 371.2
Added require-for-label, provide-for-syntax, provide-for-label,
identifier-label-binding, module-label-identifier=?

7
src/mred/wxme/wx_media.cxx
View File

@ -2622,6 +2622,9 @@ wxchar *wxMediaEdit::GetText(long start, long end, Bool flatt, Bool forceCR, lon
if (end < start)
end = start;
if (end > len)
end = len;
count = end - start;
if (!flatt) {
@ -2903,7 +2906,9 @@ void StandardWordbreak(wxMediaEdit *win, long *startp, long *endp,
if (lstart < 0)
lstart = 0;
}
lend = start + 1;
lend = win->LastPosition();
if (start + 1 < lend)
lend = start + 1;
if (start - lstart > MAX_DIST_TRY)
tstart = start - MAX_DIST_TRY;

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

File diff suppressed because it is too large Load Diff

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

@ -86,6 +86,7 @@ static Scheme_Object *local_module_introduce(int argc, Scheme_Object *argv[]);
static Scheme_Object *local_get_shadower(int argc, Scheme_Object *argv[]);
static Scheme_Object *local_certify(int argc, Scheme_Object *argv[]);
static Scheme_Object *local_lift_expr(int argc, Scheme_Object *argv[]);
static Scheme_Object *local_lift_context(int argc, Scheme_Object *argv[]);
static Scheme_Object *local_lift_end_statement(int argc, Scheme_Object *argv[]);
static Scheme_Object *make_introducer(int argc, Scheme_Object *argv[]);
static Scheme_Object *make_set_transformer(int argc, Scheme_Object *argv[]);
@ -582,6 +583,11 @@ static void make_init_env(void)
"syntax-local-lift-expression",
1, 1),
env);
scheme_add_global_constant("syntax-local-lift-context",
scheme_make_prim_w_arity(local_lift_context,
"syntax-local-lift-context",
0, 0),
env);
scheme_add_global_constant("syntax-local-lift-module-end-declaration",
scheme_make_prim_w_arity(local_lift_end_statement,
@ -1248,7 +1254,8 @@ scheme_add_compilation_binding(int index, Scheme_Object *val, Scheme_Comp_Env *f
frame->skip_table = NULL;
}
void scheme_frame_captures_lifts(Scheme_Comp_Env *env, Scheme_Lift_Capture_Proc cp, Scheme_Object *data, Scheme_Object *end_stmts)
void scheme_frame_captures_lifts(Scheme_Comp_Env *env, Scheme_Lift_Capture_Proc cp, Scheme_Object *data,
Scheme_Object *end_stmts, Scheme_Object *context_key)
{
Scheme_Lift_Capture_Proc *pp;
Scheme_Object *vec;
@ -1256,11 +1263,12 @@ void scheme_frame_captures_lifts(Scheme_Comp_Env *env, Scheme_Lift_Capture_Proc
pp = (Scheme_Lift_Capture_Proc *)scheme_malloc_atomic(sizeof(Scheme_Lift_Capture_Proc));
*pp = cp;
vec = scheme_make_vector(4, NULL);
vec = scheme_make_vector(5, NULL);
SCHEME_VEC_ELS(vec)[0] = scheme_null;
SCHEME_VEC_ELS(vec)[1] = (Scheme_Object *)pp;
SCHEME_VEC_ELS(vec)[2] = data;
SCHEME_VEC_ELS(vec)[3] = end_stmts;
SCHEME_VEC_ELS(vec)[4] = context_key;
COMPILE_DATA(env)->lifts = vec;
}
@ -4166,6 +4174,27 @@ local_lift_expr(int argc, Scheme_Object *argv[])
return id;
}
static Scheme_Object *
local_lift_context(int argc, Scheme_Object *argv[])
{
Scheme_Comp_Env *env;
env = scheme_current_thread->current_local_env;
if (!env)
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"syntax-local-lift-context: not currently transforming");
while (env && !COMPILE_DATA(env)->lifts) {
env = env->next;
}
if (!env)
return scheme_false;
return SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[4];
}
static Scheme_Object *
local_lift_end_statement(int argc, Scheme_Object *argv[])
{

73
src/mzscheme/src/eval.c
View File

@ -402,7 +402,7 @@ scheme_init_eval (Scheme_Env *env)
scheme_add_global_constant("local-expand/capture-lifts",
scheme_make_prim_w_arity(local_expand_catch_lifts,
"local-expand/capture-lifts",
3, 4),
3, 5),
env);
scheme_add_global_constant("local-transformer-expand",
scheme_make_prim_w_arity(local_transformer_expand,
@ -412,7 +412,7 @@ scheme_init_eval (Scheme_Env *env)
scheme_add_global_constant("local-transformer-expand/capture-lifts",
scheme_make_prim_w_arity(local_transformer_expand_catch_lifts,
"local-transformer-expand/capture-lifts",
3, 4),
3, 5),
env);
scheme_add_global_constant("expand-once",
scheme_make_prim_w_arity(expand_once,
@ -3772,7 +3772,7 @@ static void *compile_k(void)
find one, break it up to eval first expression
before the rest. */
while (1) {
scheme_frame_captures_lifts(cenv, scheme_make_lifted_defn, scheme_sys_wraps(cenv), scheme_false);
scheme_frame_captures_lifts(cenv, scheme_make_lifted_defn, scheme_sys_wraps(cenv), scheme_false, scheme_true);
form = scheme_check_immediate_macro(form,
cenv, &rec, 0,
0, &gval, NULL, NULL);
@ -3809,7 +3809,7 @@ static void *compile_k(void)
Scheme_Object *l, *prev_o = NULL;
while (1) {
scheme_frame_captures_lifts(cenv, scheme_make_lifted_defn, scheme_sys_wraps(cenv), scheme_false);
scheme_frame_captures_lifts(cenv, scheme_make_lifted_defn, scheme_sys_wraps(cenv), scheme_false, scheme_true);
scheme_init_compile_recs(&rec, 0, &rec2, 1);
@ -4843,7 +4843,7 @@ compile_expand_expr_lift_to_let(Scheme_Object *form, Scheme_Comp_Env *env,
Scheme_Expand_Info *rec, int drec)
{
Scheme_Expand_Info recs[2];
Scheme_Object *l, *orig_form = form;
Scheme_Object *l, *orig_form = form, *context_key;
Scheme_Comp_Env *inserted, **ip;
/* This function only works when `env' has no lexical bindings,
@ -4897,7 +4897,9 @@ compile_expand_expr_lift_to_let(Scheme_Object *form, Scheme_Comp_Env *env,
ip = MALLOC_N(Scheme_Comp_Env *, 1);
*ip = inserted;
scheme_frame_captures_lifts(inserted, pair_lifted, (Scheme_Object *)ip, scheme_false);
context_key = scheme_generate_lifts_key();
scheme_frame_captures_lifts(inserted, pair_lifted, (Scheme_Object *)ip, scheme_false, context_key);
if (rec[drec].comp) {
scheme_init_compile_recs(rec, drec, recs, 2);
@ -7443,22 +7445,23 @@ Scheme_Object *scheme_eval_compiled_stx_string(Scheme_Object *expr, Scheme_Env *
static void *expand_k(void)
{
Scheme_Thread *p = scheme_current_thread;
Scheme_Object *obj, *certs, *observer;
Scheme_Object *obj, *certs, *observer, *catch_lifts_key;
Scheme_Comp_Env *env;
Scheme_Expand_Info erec1;
int depth, rename, just_to_top, catch_lifts;
int depth, rename, just_to_top;
obj = (Scheme_Object *)p->ku.k.p1;
env = (Scheme_Comp_Env *)p->ku.k.p2;
depth = p->ku.k.i1;
rename = p->ku.k.i2;
just_to_top = p->ku.k.i3;
catch_lifts = p->ku.k.i4;
catch_lifts_key = p->ku.k.p4;
certs = (Scheme_Object *)p->ku.k.p3;
p->ku.k.p1 = NULL;
p->ku.k.p2 = NULL;
p->ku.k.p3 = NULL;
p->ku.k.p4 = NULL;
if (!SCHEME_STXP(obj))
obj = scheme_datum_to_syntax(obj, scheme_false, scheme_false, 1, 0);
@ -7479,8 +7482,8 @@ static void *expand_k(void)
erec1.certs = certs;
erec1.observer = observer;
if (catch_lifts)
scheme_frame_captures_lifts(env, scheme_make_lifted_defn, scheme_sys_wraps(env), scheme_false);
if (catch_lifts_key)
scheme_frame_captures_lifts(env, scheme_make_lifted_defn, scheme_sys_wraps(env), scheme_false, catch_lifts_key);
if (just_to_top) {
Scheme_Object *gval;
@ -7488,7 +7491,7 @@ static void *expand_k(void)
} else
obj = scheme_expand_expr(obj, env, &erec1, 0);
if (catch_lifts) {
if (catch_lifts_key) {
Scheme_Object *l;
l = scheme_frame_get_lifts(env);
if (SCHEME_PAIRP(l)) {
@ -7514,7 +7517,7 @@ static void *expand_k(void)
static Scheme_Object *_expand(Scheme_Object *obj, Scheme_Comp_Env *env,
int depth, int rename, int just_to_top,
int catch_lifts, int eb,
Scheme_Object *catch_lifts_key, int eb,
Scheme_Object *certs)
{
Scheme_Thread *p = scheme_current_thread;
@ -7524,7 +7527,7 @@ static Scheme_Object *_expand(Scheme_Object *obj, Scheme_Comp_Env *env,
p->ku.k.i1 = depth;
p->ku.k.i2 = rename;
p->ku.k.i3 = just_to_top;
p->ku.k.i4 = catch_lifts;
p->ku.k.p4 = catch_lifts_key;
p->ku.k.p3 = certs;
return (Scheme_Object *)scheme_top_level_do(expand_k, eb);
@ -7533,7 +7536,7 @@ static Scheme_Object *_expand(Scheme_Object *obj, Scheme_Comp_Env *env,
Scheme_Object *scheme_expand(Scheme_Object *obj, Scheme_Env *env)
{
return _expand(obj, scheme_new_expand_env(env, NULL, SCHEME_TOPLEVEL_FRAME),
-1, 1, 0, 1, -1, NULL);
-1, 1, 0, scheme_true, -1, NULL);
}
Scheme_Object *scheme_tail_eval_expr(Scheme_Object *obj)
@ -7701,7 +7704,8 @@ static Scheme_Object *expand(int argc, Scheme_Object **argv)
env = scheme_get_env(NULL);
return _expand(argv[0], scheme_new_expand_env(env, NULL, SCHEME_TOPLEVEL_FRAME), -1, 1, 0, 1, 0, NULL);
return _expand(argv[0], scheme_new_expand_env(env, NULL, SCHEME_TOPLEVEL_FRAME),
-1, 1, 0, scheme_true, 0, NULL);
}
static Scheme_Object *expand_stx(int argc, Scheme_Object **argv)
@ -7712,8 +7716,9 @@ static Scheme_Object *expand_stx(int argc, Scheme_Object **argv)
scheme_wrong_type("expand-syntax", "syntax", 0, argc, argv);
env = scheme_get_env(NULL);
return _expand(argv[0], scheme_new_expand_env(env, NULL, SCHEME_TOPLEVEL_FRAME), -1, -1, 0, 1, 0, NULL);
return _expand(argv[0], scheme_new_expand_env(env, NULL, SCHEME_TOPLEVEL_FRAME),
-1, -1, 0, scheme_true, 0, NULL);
}
static Scheme_Object *stop_syntax(Scheme_Object *form, Scheme_Comp_Env *env,
@ -7740,6 +7745,14 @@ Scheme_Object *scheme_get_stop_expander(void)
return stop_expander;
}
Scheme_Object *scheme_generate_lifts_key(void)
{
static int cnt = 0;
char buf[20];
sprintf(buf, "lifts%d", cnt++);
return scheme_make_symbol(buf); /* uninterned */
}
Scheme_Object *
scheme_make_lifted_defn(Scheme_Object *sys_wraps, Scheme_Object **_id, Scheme_Object *expr, Scheme_Comp_Env *env)
{
@ -7763,7 +7776,7 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, in
Scheme_Object *l, *local_mark, *renaming = NULL, *orig_l, *exp_expr = NULL;
int cnt, pos, kind;
int bad_sub_env = 0;
Scheme_Object *observer;
Scheme_Object *observer, *catch_lifts_key = NULL;
env = scheme_current_thread->current_local_env;
orig_env = env;
@ -7806,8 +7819,16 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, in
env = stx_env;
}
}
if (argc > 4) {
/* catch_lifts */
catch_lifts_key = argv[4];
}
}
if (catch_lifts && !catch_lifts_key)
catch_lifts_key = scheme_generate_lifts_key();
/* For each given stop-point identifier, shadow any potential syntax
in the environment with an identity-expanding syntax expander. */
@ -7911,7 +7932,7 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, in
} else {
/* Expand the expression. depth = -2 means expand all the way, but
preserve letrec-syntax. */
l = _expand(l, env, -2, 0, 0, catch_lifts, 0, scheme_current_thread->current_local_certs);
l = _expand(l, env, -2, 0, 0, catch_lifts_key, 0, scheme_current_thread->current_local_certs);
}
SCHEME_EXPAND_OBSERVE_LOCAL_POST(observer, l);
@ -7991,7 +8012,8 @@ expand_once(int argc, Scheme_Object **argv)
env = scheme_get_env(NULL);
return _expand(argv[0], scheme_new_expand_env(env, NULL, SCHEME_TOPLEVEL_FRAME), 1, 1, 0, 1, 0, NULL);
return _expand(argv[0], scheme_new_expand_env(env, NULL, SCHEME_TOPLEVEL_FRAME),
1, 1, 0, scheme_true, 0, NULL);
}
static Scheme_Object *
@ -8004,7 +8026,8 @@ expand_stx_once(int argc, Scheme_Object **argv)
env = scheme_get_env(NULL);
return _expand(argv[0], scheme_new_expand_env(env, NULL, SCHEME_TOPLEVEL_FRAME), 1, -1, 0, 1, 0, NULL);
return _expand(argv[0], scheme_new_expand_env(env, NULL, SCHEME_TOPLEVEL_FRAME),
1, -1, 0, scheme_true, 0, NULL);
}
static Scheme_Object *
@ -8014,7 +8037,8 @@ expand_to_top_form(int argc, Scheme_Object **argv)
env = scheme_get_env(NULL);
return _expand(argv[0], scheme_new_expand_env(env, NULL, SCHEME_TOPLEVEL_FRAME), 1, 1, 1, 1, 0, NULL);
return _expand(argv[0], scheme_new_expand_env(env, NULL, SCHEME_TOPLEVEL_FRAME),
1, 1, 1, scheme_true, 0, NULL);
}
static Scheme_Object *
@ -8027,7 +8051,8 @@ expand_stx_to_top_form(int argc, Scheme_Object **argv)
env = scheme_get_env(NULL);
return _expand(argv[0], scheme_new_expand_env(env, NULL, SCHEME_TOPLEVEL_FRAME), 1, -1, 1, 1, 0, NULL);
return _expand(argv[0], scheme_new_expand_env(env, NULL, SCHEME_TOPLEVEL_FRAME),
1, -1, 1, scheme_true, 0, NULL);
}
static Scheme_Object *do_eval_string_all(const char *str, Scheme_Env *env, int cont, int w_prompt)

6
src/mzscheme/src/module.c
View File

@ -4300,6 +4300,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
Scheme_Object *exclude_hint = scheme_false, *lift_data;
Scheme_Hash_Table *et_mn;
Scheme_Object **exis;
Scheme_Object *lift_ctx;
int exicount;
char *exps;
int all_simple_renames = 1, et_all_simple_renames = 1, tt_all_simple_renames = 1, dt_all_simple_renames = 1;
@ -4464,6 +4465,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
form = scheme_add_rename(form, post_ex_dt_rn);
maybe_has_lifts = 0;
lift_ctx = scheme_generate_lifts_key();
/* Pass 1 */
@ -4485,7 +4487,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
p = (maybe_has_lifts
? scheme_frame_get_end_statement_lifts(xenv)
: scheme_null);
scheme_frame_captures_lifts(xenv, scheme_make_lifted_defn, scheme_sys_wraps(xenv), p);
scheme_frame_captures_lifts(xenv, scheme_make_lifted_defn, scheme_sys_wraps(xenv), p, lift_ctx);
maybe_has_lifts = 1;
{
@ -4980,7 +4982,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
l = (maybe_has_lifts
? scheme_frame_get_end_statement_lifts(cenv)
: scheme_null);
scheme_frame_captures_lifts(cenv, add_lifted_defn, lift_data, l);
scheme_frame_captures_lifts(cenv, add_lifted_defn, lift_data, l, lift_ctx);
maybe_has_lifts = 1;
if (kind == 2)

1
src/mzscheme/src/port.c
View File

@ -4146,6 +4146,7 @@ scheme_file_position(int argc, Scheme_Object *argv[])
nll = -1;
}
} else {
whence = SEEK_SET; /* not used */
nll = -1;
}

155
src/mzscheme/src/read.c
View File

@ -213,6 +213,11 @@ static Scheme_Object *read_reader(Scheme_Object *port, Scheme_Object *stxsrc,
Scheme_Hash_Table **ht,
Scheme_Object *indentation,
ReadParams *params);
static Scheme_Object *read_lang(Scheme_Object *port, Scheme_Object *stxsrc,
long line, long col, long pos,
Scheme_Hash_Table **ht,
Scheme_Object *indentation,
ReadParams *params);
static Scheme_Object *read_compiled(Scheme_Object *port, Scheme_Object *stxsrc,
long line, long col, long pos,
Scheme_Hash_Table **ht,
@ -1305,6 +1310,46 @@ read_inner_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_Table *
}
}
break;
case 'l':
{
mzchar found[5];
int fl = 1;
found[0] = 'l';
ch = scheme_getc_special_ok(port);
found[fl] = ch;
if (ch == 'a') {
ch = scheme_getc_special_ok(port);
found[fl++] = ch;
if (ch == 'n') {
ch = scheme_getc_special_ok(port);
found[fl++] = ch;
if (ch == 'g') {
ch = scheme_getc_special_ok(port);
found[fl++] = ch;
if (ch == ' ') {
/* #lang */
Scheme_Object *v;
if (!params->can_read_reader) {
scheme_read_err(port, stxsrc, line, col, pos, 6, 0, indentation,
"read: #lang expressions not currently enabled");
return NULL;
}
v = read_lang(port, stxsrc, line, col, pos, ht, indentation, params);
if (!v) {
if (comment_mode & RETURN_FOR_SPECIAL_COMMENT)
return NULL;
goto start_over;
}
return v;
}
}
}
}
scheme_read_err(port, stxsrc, line, col, pos, fl, ch, indentation,
"read: bad input: `%u'",
found, fl);
}
break;
case 'r':
case 'p':
if (!params->honu_mode) {
@ -5731,21 +5776,13 @@ static Scheme_Object *current_reader_guard(int argc, Scheme_Object **argv)
1, NULL, NULL, 0);
}
/* "#reader" has been read */
static Scheme_Object *read_reader(Scheme_Object *port,
Scheme_Object *stxsrc, long line, long col, long pos,
Scheme_Hash_Table **ht,
Scheme_Object *indentation, ReadParams *params)
static Scheme_Object *do_reader(Scheme_Object *modpath,
Scheme_Object *port,
Scheme_Object *stxsrc, long line, long col, long pos,
Scheme_Hash_Table **ht,
Scheme_Object *indentation, ReadParams *params)
{
Scheme_Object *modpath, *name, *a[2], *proc, *v;
modpath = scheme_read(port);
if (SCHEME_EOFP(modpath)) {
scheme_read_err(port, stxsrc, line, col, pos, 1, EOF, indentation,
"read: expected a datum after #reader, found end-of-file");
return NULL;
}
Scheme_Object *name, *a[2], *proc, *v;
proc = scheme_get_param(scheme_current_config(), MZCONFIG_READER_GUARD);
@ -5779,6 +5816,96 @@ static Scheme_Object *read_reader(Scheme_Object *port,
return v;
}
/* "#reader" has been read */
static Scheme_Object *read_reader(Scheme_Object *port,
Scheme_Object *stxsrc, long line, long col, long pos,
Scheme_Hash_Table **ht,
Scheme_Object *indentation, ReadParams *params)
{
Scheme_Object *modpath;
modpath = scheme_read(port);
if (SCHEME_EOFP(modpath)) {
scheme_read_err(port, stxsrc, line, col, pos, 1, EOF, indentation,
"read: expected a datum after #reader, found end-of-file");
return NULL;
}
return do_reader(modpath, port, stxsrc, line, col, pos, ht, indentation, params);
}
/* "#lang" has been read */
static Scheme_Object *read_lang(Scheme_Object *port,
Scheme_Object *stxsrc, long line, long col, long pos,
Scheme_Hash_Table **ht,
Scheme_Object *indentation, ReadParams *params)
{
int size, len;
mzchar *buf, *naya, ch;
Scheme_Object *modpath;
size = 32;
buf = MALLOC_N_ATOMIC(mzchar, size);
len = 0;
while (1) {
ch = scheme_getc_special_ok(port);
if (ch == EOF) {
break;
} else if (ch == SCHEME_SPECIAL) {
scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), ch, indentation,
"read: found non-character while reading `#lang'");
} else if (scheme_isspace(ch)) {
break;
} else {
if ((ch < 128)
&& (scheme_isalpha(ch)
|| scheme_isdigit(ch)
|| (ch == '-')
|| (ch == '+')
|| (ch == '_')
|| (ch == '/'))) {
if (len + 1 >= size) {
size *= 2;
naya = MALLOC_N_ATOMIC(mzchar, size);
memcpy(naya, buf, len);
buf = naya;
}
buf[len++] = ch;
} else {
scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), ch, indentation,
"read: expected alphanumberic, `-', `+', `_', or `/' for `#lang', found %c",
ch);
return NULL;
}
}
}
if (!len) {
scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), ch, indentation,
"read: a non-empty sequence of alphanumberic, `-', `+', `_', or `/' after `#lang '");
return NULL;
}
if (buf[0] == '/') {
scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), ch, indentation,
"read: a name that does not start `/' after `#lang'");
return NULL;
}
if (buf[len - 1] == '/') {
scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), ch, indentation,
"read: a name that does not end `/' after `#lang'");
return NULL;
}
modpath = scheme_make_pair(scheme_intern_symbol("lib"),
scheme_make_pair(scheme_make_utf8_string("lang/reader.ss"),
scheme_make_pair(scheme_make_sized_char_string(buf, len, 0),
scheme_null)));
return do_reader(modpath, port, stxsrc, line, col, pos, ht, indentation, params);
}
static int is_placeholder(Scheme_Object *a, Scheme_Object *src)
{
if (src && SCHEME_STXP(a))

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

@ -13,7 +13,7 @@
#define USE_COMPILED_STARTUP 1
#define EXPECTED_PRIM_COUNT 910
#define EXPECTED_PRIM_COUNT 911
#ifdef MZSCHEME_SOMETHING_OMITTED
# undef USE_COMPILED_STARTUP

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

@ -1892,9 +1892,11 @@ Scheme_Object *scheme_add_env_renames(Scheme_Object *stx, Scheme_Comp_Env *env,
Scheme_Object *scheme_env_frame_uid(Scheme_Comp_Env *env);
typedef Scheme_Object *(*Scheme_Lift_Capture_Proc)(Scheme_Object *, Scheme_Object **, Scheme_Object *, Scheme_Comp_Env *);
void scheme_frame_captures_lifts(Scheme_Comp_Env *env, Scheme_Lift_Capture_Proc cp, Scheme_Object *data, Scheme_Object *end_stmts);
void scheme_frame_captures_lifts(Scheme_Comp_Env *env, Scheme_Lift_Capture_Proc cp, Scheme_Object *data,
Scheme_Object *end_stmts, Scheme_Object *context_key);
Scheme_Object *scheme_frame_get_lifts(Scheme_Comp_Env *env);
Scheme_Object *scheme_frame_get_end_statement_lifts(Scheme_Comp_Env *env);
Scheme_Object *scheme_generate_lifts_key(void);
void scheme_add_local_syntax(int cnt, Scheme_Comp_Env *env);
void scheme_set_local_syntax(int pos, Scheme_Object *name, Scheme_Object *val,

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

@ -9,6 +9,6 @@
#define MZSCHEME_VERSION_MAJOR 371
#define MZSCHEME_VERSION_MINOR 2
#define MZSCHEME_VERSION_MINOR 3
#define MZSCHEME_VERSION "371.2" _MZ_SPECIAL_TAG
#define MZSCHEME_VERSION "371.3" _MZ_SPECIAL_TAG