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

301.5

Browse Source 
svn: r2142
This commit is contained in:
Matthew Flatt 2006-02-06 17:28:01 +00:00
parent 647fc4e58a
commit e3571e1483
32 changed files with 3467 additions and 2379 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
src/mzscheme/include/scheme.h
View File

@ -576,11 +576,14 @@ typedef void (*Scheme_Type_Printer)(Scheme_Object *v, int for_display, Scheme_Pr
#define SCHEME_PRIM_IS_STRUCT_PRED 64
#define SCHEME_PRIM_IS_STRUCT_CONSTR 128
#define SCHEME_PRIM_IS_MULTI_RESULT 256
#define SCHEME_PRIM_IS_GENERIC 512
#define SCHEME_PRIM_IS_BINARY_INLINED 512
#define SCHEME_PRIM_IS_USER_PARAMETER 1024
#define SCHEME_PRIM_IS_METHOD 2048
#define SCHEME_PRIM_IS_POST_DATA 4096
#define SCHEME_PRIM_IS_NONCM 8192
#define SCHEME_PRIM_IS_UNARY_INLINED 16384
#define SCHEME_PRIM_PROC_FLAGS(x) (((Scheme_Prim_Proc_Header *)x)->flags)
typedef struct Scheme_Object *
(Scheme_Prim)(int argc, struct Scheme_Object *argv[]);
@ -721,7 +724,6 @@ typedef struct {
#define SCHEME_CONT_MARK_SETP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_cont_mark_set_type)
#define SCHEME_PROC_STRUCTP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_proc_struct_type)
#define SCHEME_STRUCT_PROCP(obj) (SCHEME_CLSD_PRIMP(obj) && (((Scheme_Closed_Primitive_Proc *)(obj))->pp.flags & SCHEME_PRIM_IS_STRUCT_PROC))
#define SCHEME_GENERICP(obj) (SCHEME_CLSD_PRIMP(obj) && (((Scheme_Closed_Primitive_Proc *)(obj))->pp.flags & SCHEME_PRIM_IS_GENERIC))
#define SCHEME_CLOSUREP(obj) (SAME_TYPE(SCHEME_TYPE(obj), scheme_closure_type) || SAME_TYPE(SCHEME_TYPE(obj), scheme_case_closure_type))
#define SCHEME_PRIM(obj) (((Scheme_Primitive_Proc *)(obj))->prim_val)
@ -809,7 +811,7 @@ typedef struct {
typedef struct Scheme_Jumpup_Buf {
void *stack_from, *stack_copy;
long stack_size, stack_max_size;
struct Scheme_Jumpup_Buf *cont;
struct Scheme_Cont *cont; /* for sharing continuation tails */
mz_jmp_buf buf;
#ifdef MZ_PRECISE_GC
void *gc_var_stack;

18
src/mzscheme/src/bool.c
View File

@ -35,8 +35,8 @@
/* global_constants */
Scheme_Object scheme_true[1];
Scheme_Object scheme_false[1];
Scheme_Object *scheme_not_prim;
Scheme_Object *scheme_eq_prim;
/* locals */
static Scheme_Object *not_prim (int argc, Scheme_Object *argv[]);
@ -57,20 +57,26 @@ void scheme_init_true_false(void)
void scheme_init_bool (Scheme_Env *env)
{
Scheme_Object *p;
REGISTER_SO(scheme_not_prim);
REGISTER_SO(scheme_eq_prim);
scheme_not_prim = scheme_make_folding_prim(not_prim, "not", 1, 1, 1);
p = scheme_make_folding_prim(not_prim, "not", 1, 1, 1);
scheme_not_prim = p;
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
scheme_add_global_constant("not", p, env);
scheme_add_global_constant("not", scheme_not_prim, env);
scheme_add_global_constant("boolean?",
scheme_make_folding_prim(boolean_p_prim,
"boolean?",
1, 1, 1),
env);
scheme_eq_prim = scheme_make_folding_prim(eq_prim, "eq?", 2, 2, 1);
scheme_add_global_constant("eq?", scheme_eq_prim, env);
p = scheme_make_folding_prim(eq_prim, "eq?", 2, 2, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant("eq?", p, env);
scheme_add_global_constant("eqv?",
scheme_make_folding_prim(eqv_prim,
"eqv?",

10
src/mzscheme/src/char.c
View File

@ -68,6 +68,7 @@ void scheme_init_portable_case(void)
void scheme_init_char (Scheme_Env *env)
{
Scheme_Object *p;
int i;
REGISTER_SO(scheme_char_constants);
@ -84,11 +85,10 @@ void scheme_init_char (Scheme_Env *env)
scheme_char_constants[i] = sc;
}
scheme_add_global_constant("char?",
scheme_make_folding_prim(char_p,
"char?",
1, 1, 1),
env);
p = scheme_make_folding_prim(char_p, "char?", 1, 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
scheme_add_global_constant("char?", p, env);
scheme_add_global_constant("char=?",
scheme_make_folding_prim(char_eq,
"char=?",

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

File diff suppressed because it is too large Load Diff

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

@ -1699,7 +1699,7 @@ static Scheme_Object *jit_letrec(Scheme_Object *o)
lr2->procs = procs2;
for (i = 0; i < count; i++) {
v = scheme_jit_expr(procs[i]);
v = scheme_jit_closure(procs[i], lr2);
procs2[i] = v;
}
@ -1763,7 +1763,7 @@ Scheme_Object *scheme_jit_expr(Scheme_Object *expr)
case scheme_with_cont_mark_type:
return jit_wcm(expr);
case scheme_unclosed_procedure_type:
return scheme_jit_closure(expr);
return scheme_jit_closure(expr, NULL);
case scheme_let_value_type:
return jit_let_value(expr);
case scheme_let_void_type:
@ -1777,7 +1777,7 @@ Scheme_Object *scheme_jit_expr(Scheme_Object *expr)
Scheme_Closure *c = (Scheme_Closure *)expr;
if (ZERO_SIZED_CLOSUREP(c)) {
/* JIT the closure body, producing a native closure: */
return scheme_jit_closure((Scheme_Object *)c->code);
return scheme_jit_closure((Scheme_Object *)c->code, NULL);
} else
return expr;
}

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

@ -80,7 +80,7 @@ int scheme_cont_capture_count;
static Scheme_Object *certify_mode_symbol, *transparent_symbol, *transparent_binding_symbol, *opaque_symbol;
static Scheme_Object *null_val_key;
static Scheme_Object *null_val_key, *cont_key;
/* locals */
static Scheme_Object *procedure_p (int argc, Scheme_Object *argv[]);
@ -90,6 +90,7 @@ static Scheme_Object *for_each (int argc, Scheme_Object *argv[]);
static Scheme_Object *andmap (int argc, Scheme_Object *argv[]);
static Scheme_Object *ormap (int argc, Scheme_Object *argv[]);
static Scheme_Object *call_cc (int argc, Scheme_Object *argv[]);
static Scheme_Object *internal_call_cc (int argc, Scheme_Object *argv[]);
static Scheme_Object *call_with_continuation_barrier (int argc, Scheme_Object *argv[]);
static Scheme_Object *call_with_sema (int argc, Scheme_Object *argv[]);
static Scheme_Object *call_with_sema_enable_break (int argc, Scheme_Object *argv[]);
@ -151,6 +152,8 @@ typedef void (*DW_PrePost_Proc)(void *);
static void register_traversers(void);
#endif
static Scheme_Object *internal_call_cc_prim;
/* See call_cc: */
typedef struct Scheme_Dynamic_Wind_List {
MZTAG_IF_REQUIRED
@ -240,6 +243,12 @@ scheme_init_fun (Scheme_Env *env)
scheme_add_global_constant("call-with-escape-continuation", o, env);
scheme_add_global_constant("call/ec", o, env);
REGISTER_SO(internal_call_cc_prim);
internal_call_cc_prim = scheme_make_prim_w_arity2(internal_call_cc,
"call-with-current-continuation",
1, 1,
0, -1);
o = scheme_make_prim_w_arity2(call_cc,
"call-with-current-continuation",
1, 1,
@ -411,8 +420,10 @@ scheme_init_fun (Scheme_Env *env)
REGISTER_SO(is_method_symbol);
REGISTER_SO(scheme_inferred_name_symbol);
REGISTER_SO(cont_key);
is_method_symbol = scheme_intern_symbol("method-arity-error");
scheme_inferred_name_symbol = scheme_intern_symbol("inferred-name");
cont_key = scheme_make_symbol("k"); /* uninterned */
}
Scheme_Object *
@ -649,17 +660,21 @@ scheme_make_closure(Scheme_Thread *p, Scheme_Object *code, int close)
return (Scheme_Object *)closure;
}
Scheme_Object *scheme_jit_closure(Scheme_Object *code)
Scheme_Object *scheme_jit_closure(Scheme_Object *code, Scheme_Letrec *lr)
/* If lr is supplied as a letrec binding this closure, it may be used
for JIT compilation. */
{
#ifdef MZ_USE_JIT
Scheme_Closure_Data *data = (Scheme_Closure_Data *)code;
#ifdef MZ_USE_JIT
if (!data->native_code) {
Scheme_Native_Closure_Data *ndata;
data = MALLOC_ONE_TAGGED(Scheme_Closure_Data);
memcpy(data, code, sizeof(Scheme_Closure_Data));
data->context = (Scheme_Object *)lr;
ndata = scheme_generate_lambda(data, 1, NULL);
data->native_code = ndata;
@ -1314,6 +1329,30 @@ scheme_force_one_value(Scheme_Object *obj)
return force_values(obj, 0);
}
Scheme_Object *
scheme_force_value_same_mark(Scheme_Object *obj)
{
Scheme_Object *v;
MZ_CONT_MARK_POS -= 2;
v = force_values(obj, 1);
MZ_CONT_MARK_POS += 2;
return v;
}
Scheme_Object *
scheme_force_one_value_same_mark(Scheme_Object *obj)
{
Scheme_Object *v;
MZ_CONT_MARK_POS -= 2;
v = force_values(obj, 0);
MZ_CONT_MARK_POS += 2;
return v;
}
static void *apply_k(void)
{
Scheme_Thread *p = scheme_current_thread;
@ -2711,62 +2750,89 @@ call_with_sema_enable_break(int argc, Scheme_Object *argv[])
static Scheme_Saved_Stack *copy_out_runstack(Scheme_Thread *p,
Scheme_Object **runstack,
Scheme_Object **runstack_start)
Scheme_Object **runstack_start,
Scheme_Cont *share_from)
{
Scheme_Saved_Stack *saved, *isaved, *csaved;
Scheme_Saved_Stack *saved, *isaved, *csaved, *share_saved, *ss;
Scheme_Object **start;
long size;
/* Copy out stack: */
/* Copy out current runstack: */
saved = MALLOC_ONE_RT(Scheme_Saved_Stack);
#ifdef MZTAG_REQUIRED
saved->type = scheme_rt_saved_stack;
#endif
size = p->runstack_size - (runstack XFORM_OK_MINUS runstack_start);
saved->runstack_size = size;
{
Scheme_Object **start;
start = MALLOC_N(Scheme_Object*, size);
saved->runstack_start = start;
if (share_from && (share_from->ss.runstack_start == runstack_start)) {
/* Copy just the difference between share_from's runstack and current runstack */
size = (share_from->ss.runstack XFORM_OK_MINUS runstack);
} else {
size = p->runstack_size - (runstack XFORM_OK_MINUS runstack_start);
}
saved->runstack_size = size;
start = MALLOC_N(Scheme_Object*, size);
saved->runstack_start = start;
memcpy(saved->runstack_start, runstack, size * sizeof(Scheme_Object *));
/* Copy saved runstacks: */
isaved = saved;
share_saved = NULL;
if (share_from) {
/* We can share all saved runstacks */
share_saved = share_from->ss.runstack_saved;
}
for (csaved = p->runstack_saved; csaved; csaved = csaved->prev) {
{
Scheme_Saved_Stack *ss;
ss = MALLOC_ONE_RT(Scheme_Saved_Stack);
#ifdef MZTAG_REQUIRED
ss->type = scheme_rt_saved_stack;
#endif
isaved->prev = ss;
if (share_saved && (csaved->runstack_start == share_saved->runstack_start)) {
/* Share */
isaved->prev = share_saved;
break;
}
isaved = isaved->prev;
ss = MALLOC_ONE_RT(Scheme_Saved_Stack);
#ifdef MZTAG_REQUIRED
ss->type = scheme_rt_saved_stack;
#endif
isaved->prev = ss;
isaved = ss;
size = csaved->runstack_size - (csaved->runstack XFORM_OK_MINUS csaved->runstack_start);
isaved->runstack_size = size;
{
Scheme_Object **start;
start = MALLOC_N(Scheme_Object*, size);
isaved->runstack_start = start;
}
start = MALLOC_N(Scheme_Object*, size);
isaved->runstack_start = start;
memcpy(isaved->runstack_start, csaved->runstack, size * sizeof(Scheme_Object *));
}
isaved->prev = NULL;
return saved;
}
static Scheme_Cont_Mark *copy_out_mark_stack(Scheme_Thread *p,
MZ_MARK_POS_TYPE pos)
MZ_MARK_STACK_TYPE pos,
Scheme_Cont *sub_cont,
long *_offset)
{
long cmcount;
long cmcount, offset = 0;
Scheme_Cont_Mark *cont_mark_stack_copied;
/* Copy cont mark stack: */
cmcount = (long)pos;
offset = 0;
if (sub_cont) {
/* Rely on copy of marks in a tail of this continuation. */
long sub_count = sub_cont->cont_mark_shareable;
cmcount -= sub_count;
offset += sub_count;
}
if (_offset) *_offset = offset;
if (cmcount) {
cont_mark_stack_copied = MALLOC_N(Scheme_Cont_Mark, cmcount);
while (cmcount--) {
Scheme_Cont_Mark *seg = p->cont_mark_stack_segments[cmcount >> SCHEME_LOG_MARK_SEGMENT_SIZE];
long pos = cmcount & SCHEME_MARK_SEGMENT_MASK;
int cms = cmcount + offset;
Scheme_Cont_Mark *seg = p->cont_mark_stack_segments[cms >> SCHEME_LOG_MARK_SEGMENT_SIZE];
long pos = cms & SCHEME_MARK_SEGMENT_MASK;
Scheme_Cont_Mark *cm = seg + pos;
memcpy(cont_mark_stack_copied + cmcount, cm, sizeof(Scheme_Cont_Mark));
@ -2777,13 +2843,15 @@ static Scheme_Cont_Mark *copy_out_mark_stack(Scheme_Thread *p,
return NULL;
}
static void copy_in_runstack(Scheme_Thread *p, Scheme_Saved_Stack *isaved)
static void copy_in_runstack(Scheme_Thread *p, Scheme_Saved_Stack *isaved, int set_runstack)
{
Scheme_Saved_Stack *csaved;
long size;
size = isaved->runstack_size;
MZ_RUNSTACK = MZ_RUNSTACK_START + (p->runstack_size - size);
if (set_runstack) {
MZ_RUNSTACK = MZ_RUNSTACK_START + (p->runstack_size - size);
}
memcpy(MZ_RUNSTACK, isaved->runstack_start, size * sizeof(Scheme_Object *));
for (csaved = p->runstack_saved; csaved; csaved = csaved->prev) {
isaved = isaved->prev;
@ -2794,13 +2862,16 @@ static void copy_in_runstack(Scheme_Thread *p, Scheme_Saved_Stack *isaved)
}
static void copy_in_mark_stack(Scheme_Thread *p, Scheme_Cont_Mark *cont_mark_stack_copied,
MZ_MARK_STACK_TYPE cms, MZ_MARK_STACK_TYPE base_cms)
MZ_MARK_STACK_TYPE cms, MZ_MARK_STACK_TYPE base_cms,
long copied_offset, Scheme_Object **_sub_conts)
/* Copies in the mark stack up to depth cms, but assumes that the
stack up to depth base_cms is already in place (probably in
place for a dynamic-wind context in an continuation
restoration.) */
{
long cmcount, base_cmcount;
long cmcount, base_cmcount, cmoffset;
Scheme_Cont_Mark *cm_src;
Scheme_Cont *sub_cont = NULL;
cmcount = (long)cms;
base_cmcount = (long)base_cms;
@ -2834,27 +2905,130 @@ static void copy_in_mark_stack(Scheme_Thread *p, Scheme_Cont_Mark *cont_mark_sta
p->cont_mark_stack_segments = segs;
}
}
while (cmcount-- > base_cmcount) {
Scheme_Cont_Mark *seg = p->cont_mark_stack_segments[cmcount >> SCHEME_LOG_MARK_SEGMENT_SIZE];
long pos = cmcount & SCHEME_MARK_SEGMENT_MASK;
if (_sub_conts) {
if (*_sub_conts) {
sub_cont = (Scheme_Cont *)SCHEME_CAR(*_sub_conts);
}
}
while (base_cmcount < cmcount) {
Scheme_Cont_Mark *seg = p->cont_mark_stack_segments[base_cmcount >> SCHEME_LOG_MARK_SEGMENT_SIZE];
long pos = base_cmcount & SCHEME_MARK_SEGMENT_MASK;
Scheme_Cont_Mark *cm = seg + pos;
memcpy(cm, cont_mark_stack_copied + cmcount, sizeof(Scheme_Cont_Mark));
cm_src = cont_mark_stack_copied;
cmoffset = base_cmcount - copied_offset;
if (sub_cont) {
while (base_cmcount >= sub_cont->cont_mark_shareable) {
*_sub_conts = SCHEME_CDR(*_sub_conts);
if (*_sub_conts) {
sub_cont = (Scheme_Cont *)SCHEME_CAR(*_sub_conts);
} else {
sub_cont = NULL;
break;
}
}
if (sub_cont) {
cm_src = sub_cont->cont_mark_stack_copied;
cmoffset = base_cmcount - sub_cont->cont_mark_offset;
}
}
memcpy(cm, cm_src + cmoffset, sizeof(Scheme_Cont_Mark));
base_cmcount++;
}
}
static MZ_MARK_STACK_TYPE find_sharable_marks()
{
Scheme_Thread *p = scheme_current_thread;
long cmcount, delta = 0;
cmcount = (long)MZ_CONT_MARK_STACK;
while (cmcount--) {
Scheme_Cont_Mark *seg = p->cont_mark_stack_segments[cmcount >> SCHEME_LOG_MARK_SEGMENT_SIZE];
long pos = cmcount & SCHEME_MARK_SEGMENT_MASK;
if (seg[pos].pos < MZ_CONT_MARK_POS)
break;
if (SAME_OBJ(seg[pos].key, cont_key))
delta = 1;
else
delta = 0;
}
return cmcount + 1 + delta;
}
static Scheme_Cont_Mark **copy_out_segment_array(Scheme_Cont *sub_cont)
{
long cnt;
Scheme_Cont_Mark **orig;
if (!MZ_CONT_MARK_STACK)
cnt = 0;
else
cnt = (((long)MZ_CONT_MARK_STACK - 1) >> SCHEME_LOG_MARK_SEGMENT_SIZE) + 1;
if (sub_cont) {
/* Already saved this set? */
int scnt;
if (!sub_cont->ss.cont_mark_stack)
scnt = 0;
else
scnt = (((long)(sub_cont->ss.cont_mark_stack) - 1) >> SCHEME_LOG_MARK_SEGMENT_SIZE) + 1;
if (scnt == cnt) {
return sub_cont->orig_mark_segments;
}
}
orig = (Scheme_Cont_Mark **)scheme_malloc(cnt * sizeof(Scheme_Cont_Mark*));
memcpy(orig, scheme_current_thread->cont_mark_stack_segments, cnt * sizeof(Scheme_Cont_Mark*));
return orig;
}
static Scheme_Object *
call_cc (int argc, Scheme_Object *argv[])
{
scheme_check_proc_arity("call-with-current-continuation", 1,
0, argc, argv);
/* Trampoline to internal_call_cc. This trampoline ensures that
the runstack is flushed before we try to grab the continuation. */
return _scheme_tail_apply(internal_call_cc_prim, argc, argv);
}
static Scheme_Object *
internal_call_cc (int argc, Scheme_Object *argv[])
{
Scheme_Object *ret;
Scheme_Cont * volatile cont;
Scheme_Cont *sub_cont;
Scheme_Dynamic_Wind *dw;
Scheme_Thread *p = scheme_current_thread;
Scheme_Saved_Stack *saved;
Scheme_Cont_Mark *msaved;
scheme_check_proc_arity("call-with-current-continuation", 1,
0, argc, argv);
sub_cont = (Scheme_Cont *)scheme_extract_one_cc_mark(NULL, cont_key);
if (sub_cont && (sub_cont->save_overflow != p->overflow))
sub_cont = NULL;
if (sub_cont && (sub_cont->ss.cont_mark_pos == MZ_CONT_MARK_POS)) {
/* Old cont is the same as this one, except that it may
have different marks --- not counting cont_key! */
if ((sub_cont->cont_mark_shareable == (long)sub_cont->ss.cont_mark_stack)
&& (find_sharable_marks() == MZ_CONT_MARK_STACK)) {
/* Just use this one. */
Scheme_Object *argv2[1];
argv2[0] = (Scheme_Object *)sub_cont;
return _scheme_tail_apply(argv[0], 1, argv2);
} else {
sub_cont = sub_cont->buf.cont;
}
}
cont = MALLOC_ONE_TAGGED(Scheme_Cont);
cont->so.type = scheme_cont_type;
@ -2896,25 +3070,21 @@ call_cc (int argc, Scheme_Object *argv[])
}
}
/* Hide call/cc's arg off of stack */
p->ku.k.p1 = argv[0];
argv[0] = NULL;
saved = copy_out_runstack(p, MZ_RUNSTACK, MZ_RUNSTACK_START);
saved = copy_out_runstack(p, MZ_RUNSTACK, MZ_RUNSTACK_START, sub_cont);
cont->runstack_copied = saved;
msaved = copy_out_mark_stack(p, MZ_CONT_MARK_STACK);
cont->cont_mark_stack_copied = msaved;
{
long offset;
msaved = copy_out_mark_stack(p, cont->ss.cont_mark_stack, sub_cont, &offset);
cont->cont_mark_stack_copied = msaved;
cont->cont_mark_offset = offset;
offset = find_sharable_marks();
cont->cont_mark_shareable = offset;
}
/* Remember the original mark-stack segments. */
{
long cnt;
Scheme_Cont_Mark **orig;
if (!MZ_CONT_MARK_STACK)
cnt = 0;
else
cnt = (((long)MZ_CONT_MARK_STACK - 1) >> SCHEME_LOG_MARK_SEGMENT_SIZE) + 1;
orig = (Scheme_Cont_Mark **)scheme_malloc(cnt * sizeof(Scheme_Cont_Mark*));
memcpy(orig, p->cont_mark_stack_segments, cnt * sizeof(Scheme_Cont_Mark*));
orig = copy_out_segment_array(sub_cont);
cont->orig_mark_segments = orig;
}
@ -2930,10 +3100,12 @@ call_cc (int argc, Scheme_Object *argv[])
scheme_flatten_config(scheme_current_config());
if (scheme_setjmpup(&cont->buf, cont, p->next ? p->stack_start : p->o_start)) {
scheme_set_cont_mark(cont_key, (Scheme_Object *)cont);
if (scheme_setjmpup_relative(&cont->buf, cont, p->next ? p->stack_start : p->o_start, sub_cont)) {
/* We arrive here when the continuation is applied */
MZ_MARK_STACK_TYPE copied_cms = 0;
Scheme_Object *result, **mv;
Scheme_Object *result, **mv, *sub_conts = NULL;
int mc;
result = cont->value;
@ -2975,16 +3147,34 @@ call_cc (int argc, Scheme_Object *argv[])
Scheme_Thread *op;
op = *p->runstack_owner;
if (op) {
saved = copy_out_runstack(op, op->runstack, op->runstack_start);
saved = copy_out_runstack(op, op->runstack, op->runstack_start, NULL);
op->runstack_swapped = saved;
}
*p->runstack_owner = p;
}
/* Copy stack back in: (p->runstack and p->runstack_saved arrays
/* Copy stack back in: p->runstack and p->runstack_saved arrays
are already restored, so the shape is certainly the same as
when cont->runstack_copied was made) */
copy_in_runstack(p, cont->runstack_copied);
when cont->runstack_copied was made. If we have a derived
continuation, then we're sharing it's base runstack. */
copy_in_runstack(p, cont->runstack_copied, 0);
{
long done = cont->runstack_copied->runstack_size, size;
sub_cont = cont;
while (sub_cont) {
if (sub_cont->buf.cont
&& (sub_cont->ss.runstack_start == sub_cont->buf.cont->ss.runstack_start)) {
/* Copy shared part in: */
sub_cont = sub_cont->buf.cont;
size = sub_cont->runstack_copied->runstack_size;
memcpy(MZ_RUNSTACK XFORM_OK_PLUS done,
sub_cont->runstack_copied->runstack_start,
size * sizeof(Scheme_Object *));
done += size;
} else
break;
}
}
if (p->cont_mark_stack_owner
&& (*p->cont_mark_stack_owner == p))
@ -2996,7 +3186,7 @@ call_cc (int argc, Scheme_Object *argv[])
Scheme_Thread *op;
op = *p->cont_mark_stack_owner;
if (op) {
msaved = copy_out_mark_stack(op, op->cont_mark_stack);
msaved = copy_out_mark_stack(op, op->cont_mark_stack, NULL, NULL);
op->cont_mark_stack_swapped = msaved;
}
*p->cont_mark_stack_owner = p;
@ -3004,6 +3194,12 @@ call_cc (int argc, Scheme_Object *argv[])
MZ_CONT_MARK_STACK = 0;
}
/* For copying cont marks back in, we need a list of sub_conts,
deepest to shallowest: */
for (sub_cont = cont->buf.cont; sub_cont; sub_cont = sub_cont->buf.cont) {
sub_conts = scheme_make_pair((Scheme_Object *)sub_cont, sub_conts);
}
/* For dynamic-winds after the "common" intersection
(see eval.c), execute the pre thunks. Make a list
of these first because they have to be done in the
@ -3032,7 +3228,9 @@ call_cc (int argc, Scheme_Object *argv[])
MZ_CONT_MARK_POS = dwl->dw->envss.cont_mark_pos;
MZ_CONT_MARK_STACK = dwl->dw->envss.cont_mark_stack;
copy_in_mark_stack(p, cont->cont_mark_stack_copied,
MZ_CONT_MARK_STACK, copied_cms);
MZ_CONT_MARK_STACK, copied_cms,
cont->cont_mark_offset, &sub_conts);
copied_cms = MZ_CONT_MARK_STACK;
p->dw = dwl->dw->prev;
pre(dwl->dw->data);
@ -3049,8 +3247,8 @@ call_cc (int argc, Scheme_Object *argv[])
MZ_CONT_MARK_POS = cont->ss.cont_mark_pos;
MZ_CONT_MARK_STACK = cont->ss.cont_mark_stack;
copy_in_mark_stack(p, cont->cont_mark_stack_copied,
MZ_CONT_MARK_STACK, copied_cms);
MZ_CONT_MARK_STACK, copied_cms,
cont->cont_mark_offset, &sub_conts);
/* If any mark-stack segment is different now than before, then
set the cache field of the *original* mark segment. Setting the
@ -3092,11 +3290,6 @@ call_cc (int argc, Scheme_Object *argv[])
} else {
Scheme_Object *argv2[1];
/* Restore call/cc's arg to stack. */
/* (We aren't actually allowed to modify argv! :) */
argv[0] = p->ku.k.p1;
p->ku.k.p1 = NULL;
argv2[0] = (Scheme_Object *)cont;
ret = _scheme_tail_apply(argv[0], 1, argv2);
return ret;
@ -3115,11 +3308,11 @@ void scheme_takeover_stacks(Scheme_Thread *p)
Scheme_Saved_Stack *swapped;
op = *p->runstack_owner;
if (op) {
swapped = copy_out_runstack(op, op->runstack, op->runstack_start);
swapped = copy_out_runstack(op, op->runstack, op->runstack_start, NULL);
op->runstack_swapped = swapped;
}
*(p->runstack_owner) = p;
copy_in_runstack(p, p->runstack_swapped);
copy_in_runstack(p, p->runstack_swapped, 1);
p->runstack_swapped = NULL;
}
@ -3128,11 +3321,11 @@ void scheme_takeover_stacks(Scheme_Thread *p)
Scheme_Cont_Mark *swapped;
op = *p->cont_mark_stack_owner;
if (op) {
swapped = copy_out_mark_stack(op, op->cont_mark_stack);
swapped = copy_out_mark_stack(op, op->cont_mark_stack, NULL, NULL);
op->cont_mark_stack_swapped = swapped;
}
*(p->cont_mark_stack_owner) = p;
copy_in_mark_stack(p, p->cont_mark_stack_swapped, MZ_CONT_MARK_STACK, 0);
copy_in_mark_stack(p, p->cont_mark_stack_swapped, MZ_CONT_MARK_STACK, 0, 0, NULL);
p->cont_mark_stack_swapped = NULL;
}
}

1316
src/mzscheme/src/jit.c
View File

File diff suppressed because it is too large Load Diff

40
src/mzscheme/src/list.c
View File

@ -26,16 +26,10 @@
/* globals */
Scheme_Object scheme_null[1];
Scheme_Object *scheme_null_p_prim;
Scheme_Object *scheme_pair_p_prim;
Scheme_Object *scheme_car_prim;
Scheme_Object *scheme_cdr_prim;
/* locals */
static Scheme_Object *pair_p_prim (int argc, Scheme_Object *argv[]);
static Scheme_Object *cons_prim (int argc, Scheme_Object *argv[]);
static Scheme_Object *car_prim (int argc, Scheme_Object *argv[]);
static Scheme_Object *cdr_prim (int argc, Scheme_Object *argv[]);
static Scheme_Object *set_car_prim (int argc, Scheme_Object *argv[]);
static Scheme_Object *set_cdr_prim (int argc, Scheme_Object *argv[]);
static Scheme_Object *cons_immutable (int argc, Scheme_Object *argv[]);
@ -126,28 +120,29 @@ static Scheme_Object *weak_symbol, *equal_symbol;
void
scheme_init_list (Scheme_Env *env)
{
REGISTER_SO(scheme_null_p_prim);
REGISTER_SO(scheme_pair_p_prim);
REGISTER_SO(scheme_car_prim);
REGISTER_SO(scheme_cdr_prim);
Scheme_Object *p;
scheme_null->type = scheme_null_type;
scheme_add_global_constant ("null", scheme_null, env);
scheme_pair_p_prim = scheme_make_folding_prim(pair_p_prim, "pair?", 1, 1, 1);
scheme_add_global_constant ("pair?", scheme_pair_p_prim, env);
p = scheme_make_folding_prim(pair_p_prim, "pair?", 1, 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
scheme_add_global_constant ("pair?", p, env);
scheme_add_global_constant ("cons",
scheme_make_prim_w_arity(cons_prim,
"cons",
2, 2),
env);
scheme_car_prim = scheme_make_noncm_prim(car_prim, "car", 1, 1);
scheme_add_global_constant ("car", scheme_car_prim, env);
scheme_cdr_prim = scheme_make_noncm_prim(cdr_prim, "cdr", 1, 1);
scheme_add_global_constant ("cdr", scheme_cdr_prim, env);
p = scheme_make_noncm_prim(scheme_checked_car, "car", 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
scheme_add_global_constant ("car", p, env);
p = scheme_make_noncm_prim(scheme_checked_cdr, "cdr", 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
scheme_add_global_constant ("cdr", p, env);
scheme_add_global_constant ("set-car!",
scheme_make_noncm_prim(set_car_prim,
@ -165,8 +160,9 @@ scheme_init_list (Scheme_Env *env)
2, 2),
env);
scheme_null_p_prim = scheme_make_folding_prim(null_p_prim, "null?", 1, 1, 1);
scheme_add_global_constant ("null?", scheme_null_p_prim, env);
p = scheme_make_folding_prim(null_p_prim, "null?", 1, 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
scheme_add_global_constant ("null?", p, env);
scheme_add_global_constant ("list?",
scheme_make_noncm_prim(list_p_prim,
@ -733,16 +729,16 @@ cons_immutable (int argc, Scheme_Object *argv[])
return (cons);
}
static Scheme_Object *
car_prim (int argc, Scheme_Object *argv[])
Scheme_Object *
scheme_checked_car (int argc, Scheme_Object *argv[])
{
if (!SCHEME_PAIRP(argv[0]))
scheme_wrong_type("car", "pair", 0, argc, argv);
return (SCHEME_CAR (argv[0]));
}
static Scheme_Object *
cdr_prim (int argc, Scheme_Object *argv[])
Scheme_Object *
scheme_checked_cdr (int argc, Scheme_Object *argv[])
{
if (!SCHEME_PAIRP(argv[0]))
scheme_wrong_type("cdr", "pair", 0, argc, argv);

2
src/mzscheme/src/mzmark.c
View File

@ -1475,6 +1475,7 @@ int thread_val_MARK(void *p) {
gcMARK(pr->runstack_saved);
gcMARK(pr->runstack_owner);
gcMARK(pr->runstack_swapped);
pr->spare_runstack = NULL; /* just in case */
gcMARK(pr->cont_mark_stack_segments);
gcMARK(pr->cont_mark_stack_owner);
@ -1561,6 +1562,7 @@ int thread_val_FIXUP(void *p) {
gcFIXUP(pr->runstack_saved);
gcFIXUP(pr->runstack_owner);
gcFIXUP(pr->runstack_swapped);
pr->spare_runstack = NULL; /* just in case */
gcFIXUP(pr->cont_mark_stack_segments);
gcFIXUP(pr->cont_mark_stack_owner);

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

@ -570,6 +570,7 @@ thread_val {
gcMARK(pr->runstack_saved);
gcMARK(pr->runstack_owner);
gcMARK(pr->runstack_swapped);
pr->spare_runstack = NULL; /* just in case */
gcMARK(pr->cont_mark_stack_segments);
gcMARK(pr->cont_mark_stack_owner);

30
src/mzscheme/src/numarith.c
View File

@ -26,11 +26,6 @@
#include "nummacs.h"
#include <math.h>
Scheme_Object *scheme_add1_prim;
Scheme_Object *scheme_sub1_prim;
Scheme_Object *scheme_plus_prim;
Scheme_Object *scheme_minus_prim;
static Scheme_Object *plus (int argc, Scheme_Object *argv[]);
static Scheme_Object *minus (int argc, Scheme_Object *argv[]);
static Scheme_Object *mult (int argc, Scheme_Object *argv[]);
@ -43,22 +38,23 @@ static Scheme_Object *quotient_remainder (int argc, Scheme_Object *argv[]);
void scheme_init_numarith(Scheme_Env *env)
{
REGISTER_SO(scheme_add1_prim);
REGISTER_SO(scheme_sub1_prim);
REGISTER_SO(scheme_plus_prim);
REGISTER_SO(scheme_minus_prim);
Scheme_Object *p;
scheme_add1_prim = scheme_make_folding_prim(scheme_add1, "add1", 1, 1, 1);
scheme_add_global_constant("add1", scheme_add1_prim, env);
p = scheme_make_folding_prim(scheme_add1, "add1", 1, 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
scheme_add_global_constant("add1", p, env);
scheme_sub1_prim = scheme_make_folding_prim(scheme_sub1, "sub1", 1, 1, 1);
scheme_add_global_constant("sub1", scheme_sub1_prim, env);
p = scheme_make_folding_prim(scheme_sub1, "sub1", 1, 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
scheme_add_global_constant("sub1", p, env);
scheme_plus_prim = scheme_make_folding_prim(plus, "+", 0, -1, 1);
scheme_add_global_constant("+", scheme_plus_prim, env);
p = scheme_make_folding_prim(plus, "+", 0, -1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant("+", p, env);
scheme_minus_prim = scheme_make_folding_prim(minus, "-", 1, -1, 1);
scheme_add_global_constant("-", scheme_minus_prim, env);
p = scheme_make_folding_prim(minus, "-", 1, -1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant("-", p, env);
scheme_add_global_constant("*",
scheme_make_folding_prim(mult,

74
src/mzscheme/src/numcomp.c
View File

@ -38,46 +38,40 @@ static Scheme_Object *sch_min (int argc, Scheme_Object *argv[]);
void scheme_init_numcomp(Scheme_Env *env)
{
scheme_add_global_constant("=",
scheme_make_folding_prim(eq,
"=",
2, -1, 1),
env);
scheme_add_global_constant("<",
scheme_make_folding_prim(lt,
"<",
2, -1, 1),
env);
scheme_add_global_constant(">",
scheme_make_folding_prim(gt,
">",
2, -1, 1),
env);
scheme_add_global_constant("<=",
scheme_make_folding_prim(lt_eq,
"<=",
2, -1, 1),
env);
scheme_add_global_constant(">=",
scheme_make_folding_prim(gt_eq,
">=",
2, -1, 1),
env);
scheme_add_global_constant("zero?",
scheme_make_folding_prim(scheme_zero_p,
"zero?",
1, 1, 1),
env);
scheme_add_global_constant("positive?",
scheme_make_folding_prim(scheme_positive_p,
"positive?",
1, 1, 1),
env);
scheme_add_global_constant("negative?",
scheme_make_folding_prim(scheme_negative_p,
"negative?",
1, 1, 1),
env);
Scheme_Object *p;
p = scheme_make_folding_prim(eq, "=", 2, -1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant("=", p, env);
p = scheme_make_folding_prim(lt, "<", 2, -1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant("<", p, env);
p = scheme_make_folding_prim(gt, ">", 2, -1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant(">", p, env);
p = scheme_make_folding_prim(lt_eq, "<=", 2, -1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant("<=", p, env);
p = scheme_make_folding_prim(gt_eq, ">=", 2, -1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant(">=", p, env);
p = scheme_make_folding_prim(scheme_zero_p, "zero?", 1, 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
scheme_add_global_constant("zero?", p, env);
p = scheme_make_folding_prim(scheme_positive_p, "positive?", 1, 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
scheme_add_global_constant("positive?", p, env);
p = scheme_make_folding_prim(scheme_negative_p, "negative?", 1, 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
scheme_add_global_constant("negative?", p, env);
scheme_add_global_constant("max",
scheme_make_folding_prim(sch_max,
"max",

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

@ -1653,8 +1653,7 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
-1, pp);
} else {
print_utf8_string(pp, "#<", 0, 2);
print_string_in_angle(pp, ((Scheme_Closed_Primitive_Proc *)obj)->name,
SCHEME_GENERICP(obj) ? "" : "primitive:", -1);
print_string_in_angle(pp, ((Scheme_Closed_Primitive_Proc *)obj)->name, "primitive:", -1);
PRINTADDRESS(pp, obj);
print_utf8_string(pp, ">", 0, 1);
}

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

@ -30,7 +30,7 @@
MZ_EXTERN void scheme_init_jmpup_buf(Scheme_Jumpup_Buf *b);
MZ_EXTERN int scheme_setjmpup_relative(Scheme_Jumpup_Buf *b, void *base,
void * volatile start, Scheme_Jumpup_Buf *cont);
void * volatile start, struct Scheme_Cont *cont);
MZ_EXTERN void scheme_longjmpup(Scheme_Jumpup_Buf *b);
MZ_EXTERN void scheme_reset_jmpup_buf(Scheme_Jumpup_Buf *b);

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

@ -28,7 +28,7 @@ typedef struct {
/*========================================================================*/
void (*scheme_init_jmpup_buf)(Scheme_Jumpup_Buf *b);
int (*scheme_setjmpup_relative)(Scheme_Jumpup_Buf *b, void *base,
void * volatile start, Scheme_Jumpup_Buf *cont);
void * volatile start, struct Scheme_Cont *cont);
void (*scheme_longjmpup)(Scheme_Jumpup_Buf *b);
void (*scheme_reset_jmpup_buf)(Scheme_Jumpup_Buf *b);
#ifdef USE_MZ_SETJMP

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

@ -216,20 +216,11 @@ void scheme_do_add_global_symbol(Scheme_Env *env, Scheme_Object *sym,
extern Scheme_Object *scheme_values_func;
extern Scheme_Object *scheme_void_proc;
extern Scheme_Object *scheme_not_prim;
extern Scheme_Object *scheme_eq_prim;
extern Scheme_Object *scheme_null_p_prim;
extern Scheme_Object *scheme_pair_p_prim;
extern Scheme_Object *scheme_car_prim;
extern Scheme_Object *scheme_cdr_prim;
extern Scheme_Object *scheme_define_values_syntax, *scheme_define_syntaxes_syntax;
extern Scheme_Object *scheme_lambda_syntax;
extern Scheme_Object *scheme_begin_syntax;
extern Scheme_Object *scheme_add1_prim;
extern Scheme_Object *scheme_sub1_prim;
extern Scheme_Object *scheme_plus_prim;
extern Scheme_Object *scheme_minus_prim;
extern Scheme_Object *scheme_not_prim;
extern Scheme_Object *scheme_def_exit_proc;
@ -916,6 +907,7 @@ typedef struct Scheme_Cont {
Scheme_Cont_Mark *cont_mark_stack_copied;
Scheme_Thread **cont_mark_stack_owner;
Scheme_Cont_Mark **orig_mark_segments;
long cont_mark_shareable, cont_mark_offset;
void *stack_start;
void *o_start;
Scheme_Config *init_config;
@ -1415,6 +1407,9 @@ Scheme_Object *_scheme_tail_apply_from_native(Scheme_Object *rator,
int argc,
Scheme_Object **argv);
Scheme_Object *scheme_force_value_same_mark(Scheme_Object *);
Scheme_Object *scheme_force_one_value_same_mark(Scheme_Object *);
void scheme_flush_stack_cache();
/*========================================================================*/
@ -1535,6 +1530,7 @@ typedef struct Scheme_Closure_Data
Scheme_Object *name;
#ifdef MZ_USE_JIT
struct Scheme_Native_Closure_Data *native_code; /* generated by lightning */
Scheme_Object *context; /* e.g., a letrec that binds the closure */
#endif
} Scheme_Closure_Data;
@ -1777,7 +1773,7 @@ Scheme_App_Rec *scheme_malloc_application(int n);
void scheme_finish_application(Scheme_App_Rec *app);
Scheme_Object *scheme_jit_expr(Scheme_Object *);
Scheme_Object *scheme_jit_closure(Scheme_Object *);
Scheme_Object *scheme_jit_closure(Scheme_Object *, Scheme_Letrec *lr);
#define SCHEME_SYNTAX(obj) SCHEME_PTR1_VAL(obj)
#define SCHEME_SYNTAX_EXP(obj) SCHEME_PTR2_VAL(obj)
@ -2361,6 +2357,11 @@ void scheme_count_generic(Scheme_Object *o, long *s, long *e, Scheme_Hash_Table
/* miscellaneous */
/*========================================================================*/
Scheme_Object *scheme_checked_car(int argc, Scheme_Object **argv);
Scheme_Object *scheme_checked_cdr(int argc, Scheme_Object **argv);
Scheme_Object *scheme_checked_vector_ref(int argc, Scheme_Object **argv);
Scheme_Object *scheme_checked_syntax_e(int argc, Scheme_Object **argv);
void scheme_set_root_param(int p, Scheme_Object *v);
Scheme_Object *scheme_intern_exact_parallel_symbol(const char *name, unsigned int len);

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

@ -9,6 +9,6 @@
#define MZSCHEME_VERSION_MAJOR 301
#define MZSCHEME_VERSION_MINOR 4
#define MZSCHEME_VERSION_MINOR 5
#define MZSCHEME_VERSION "301.4" _MZ_SPECIAL_TAG
#define MZSCHEME_VERSION "301.5" _MZ_SPECIAL_TAG

102
src/mzscheme/src/setjmpup.c
View File

@ -339,6 +339,8 @@ void scheme_copy_stack(Scheme_Jumpup_Buf *b, void *base, void *start GC_VAR_STAC
static void uncopy_stack(int ok, Scheme_Jumpup_Buf *b, long *prev)
{
Scheme_Jumpup_Buf *c;
long top_delta = 0, bottom_delta = 0, size;
void *cfrom, *cto;
if (!ok) {
unsigned long z;
@ -361,10 +363,26 @@ static void uncopy_stack(int ok, Scheme_Jumpup_Buf *b, long *prev)
START_XFORM_SKIP;
c = b;
while (c) {
memcpy(c->stack_from,
get_copy(c->stack_copy),
c->stack_size);
c = c->cont;
size = c->stack_size - top_delta;
cto = (char *)c->stack_from + bottom_delta;
cfrom = (char *)get_copy(c->stack_copy) + bottom_delta;
memcpy(cto, cfrom, size);
if (c->cont) {
if (scheme_stack_grows_up) {
top_delta = ((unsigned long)c->stack_from
- ((unsigned long)c->cont->buf.stack_from
+ c->cont->buf.stack_size));
} else {
bottom_delta = ((unsigned long)c->stack_from
+ c->stack_size
- (unsigned long)c->cont->buf.stack_from);
top_delta = bottom_delta;
}
c = &c->cont->buf;
} else
c = NULL;
}
END_XFORM_SKIP;
@ -377,8 +395,58 @@ static void uncopy_stack(int ok, Scheme_Jumpup_Buf *b, long *prev)
scheme_longjmp(b->buf, 1);
}
#ifdef MZ_PRECISE_GC
START_XFORM_SKIP;
#endif
static long find_same(char *p, char *low, long max_size)
{
long cnt = 0;
/* We assume a max possible amount of the current stack that should
not be shared with the saved stack. This is ok (or not) in the same
sense as assuming that STACK_SAFETY_MARGIN is enough wiggle room to
prevent stack overflow. */
# define MAX_STACK_DIFF 4096
if (max_size > MAX_STACK_DIFF) {
cnt = max_size - MAX_STACK_DIFF;
max_size = MAX_STACK_DIFF;
}
if (scheme_stack_grows_up) {
while (max_size--) {
if (p[cnt] != low[cnt])
break;
cnt++;
}
} else {
while (max_size--) {
if (p[max_size] != low[max_size])
break;
cnt++;
}
}
return cnt;
}
#ifdef MZ_PRECISE_GC
static void *align_var_stack(void **vs, void *s)
{
while (STK_COMP((unsigned long)vs, (unsigned long)s)) {
vs = (void **)(*vs);
}
return (void *)vs;
}
#define ALIGN_VAR_STACK(vs, s) s = align_var_stack(vs, s)
END_XFORM_SKIP;
#else
# define ALIGN_VAR_STACK(vs, s) /* empty */
#endif
int scheme_setjmpup_relative(Scheme_Jumpup_Buf *b, void *base,
void * volatile start, Scheme_Jumpup_Buf *c)
void * volatile start, struct Scheme_Cont *c)
{
int local;
long disguised_b;
@ -394,12 +462,32 @@ int scheme_setjmpup_relative(Scheme_Jumpup_Buf *b, void *base,
if (!(local = scheme_setjmp(b->buf))) {
if (c) {
/* We'd like to re-use the stack copied for a continuation
that encloses the current one --- but we dont' know exactly
how much the stack is supposed to be shared, since call/cc
is implemented with a trampoline; certainly, the shallowest
bit of the old continuation is not right for this one. So,
we just start from the deepest part of the stack and find
how many bytes match (using find_same)
For chains of continuations C1 < C2 < C3, we assume that the
discovered-safe part of C1 to be used for C2 is also valid
for C3, so checking for C3 starts with the fresh part in C2,
and that's where asymptotic benefits start to kick in.
Unfortunately, I can't quite convince myself that this
assumption is definitely correct. I think it's likely correct,
but watch out. */
long same_size;
START_XFORM_SKIP;
same_size = find_same(get_copy(c->buf.stack_copy), c->buf.stack_from, c->buf.stack_size);
b->cont = c;
if (scheme_stack_grows_up) {
start = (void *)((char *)c->stack_from + c->stack_size);
start = (void *)((char *)c->buf.stack_from + same_size);
} else {
start = c->stack_from;
start = (void *)((char *)c->buf.stack_from + (c->buf.stack_size - same_size));
}
/* In 3m-mode, we need to copy on a var-stack boundary: */
ALIGN_VAR_STACK(__gc_var_stack__, start);
END_XFORM_SKIP;
} else
b->cont = NULL;

26
src/mzscheme/src/stxobj.c
View File

@ -33,7 +33,6 @@ static Scheme_Object *graph_syntax_p(int argc, Scheme_Object **argv);
static Scheme_Object *syntax_to_datum(int argc, Scheme_Object **argv);
static Scheme_Object *datum_to_syntax(int argc, Scheme_Object **argv);
static Scheme_Object *syntax_e(int argc, Scheme_Object **argv);
static Scheme_Object *syntax_line(int argc, Scheme_Object **argv);
static Scheme_Object *syntax_col(int argc, Scheme_Object **argv);
static Scheme_Object *syntax_pos(int argc, Scheme_Object **argv);
@ -317,15 +316,16 @@ static void DO_WRAP_POS_REVINIT(Wrap_Pos *w, Scheme_Object *k)
void scheme_init_stx(Scheme_Env *env)
{
Scheme_Object *p;
#ifdef MZ_PRECISE_GC
register_traversers();
#endif
scheme_add_global_constant("syntax?",
scheme_make_folding_prim(syntax_p,
"syntax?",
1, 1, 1),
env);
p = scheme_make_folding_prim(syntax_p, "syntax?", 1, 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
scheme_add_global_constant("syntax?", p, env);
scheme_add_global_constant("syntax-graph?",
scheme_make_folding_prim(graph_syntax_p,
"syntax-graph?",
@ -346,11 +346,11 @@ void scheme_init_stx(Scheme_Env *env)
scheme_datum_to_syntax_proc,
env);
scheme_add_global_constant("syntax-e",
scheme_make_folding_prim(syntax_e,
"syntax-e",
1, 1, 1),
env);
p = scheme_make_folding_prim(scheme_checked_syntax_e, "syntax-e", 1, 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
scheme_add_global_constant("syntax-e", p, env);
scheme_add_global_constant("syntax-line",
scheme_make_folding_prim(syntax_line,
"syntax-line",
@ -1957,6 +1957,8 @@ Scheme_Object *scheme_stx_content(Scheme_Object *o)
{
Scheme_Stx *stx = (Scheme_Stx *)o;
/* The fast-past tests are duplicated in jit.c. */
if ((STX_KEY(stx) & STX_SUBSTX_FLAG) && stx->u.lazy_prefix) {
Scheme_Object *v = stx->val, *result;
Scheme_Object *here_wraps;
@ -4947,7 +4949,7 @@ static Scheme_Object *datum_to_syntax(int argc, Scheme_Object **argv)
}
static Scheme_Object *syntax_e(int argc, Scheme_Object **argv)
Scheme_Object *scheme_checked_syntax_e(int argc, Scheme_Object **argv)
{
if (!SCHEME_STXP(argv[0]))
scheme_wrong_type("syntax-e", "syntax", 0, argc, argv);

11
src/mzscheme/src/symbol.c
View File

@ -280,11 +280,12 @@ scheme_init_symbol_type (Scheme_Env *env)
void
scheme_init_symbol (Scheme_Env *env)
{
scheme_add_global_constant("symbol?",
scheme_make_folding_prim(symbol_p_prim,
"symbol?",
1, 1, 1),
env);
Scheme_Object *p;
p = scheme_make_folding_prim(symbol_p_prim, "symbol?", 1, 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
scheme_add_global_constant("symbol?", p, env);
scheme_add_global_constant("string->symbol",
scheme_make_noncm_prim(string_to_symbol_prim,
"string->symbol",

17
src/mzscheme/src/vector.c
View File

@ -30,7 +30,6 @@ static Scheme_Object *make_vector (int argc, Scheme_Object *argv[]);
static Scheme_Object *vector (int argc, Scheme_Object *argv[]);
static Scheme_Object *vector_immutable (int argc, Scheme_Object *argv[]);
static Scheme_Object *vector_length (int argc, Scheme_Object *argv[]);
static Scheme_Object *vector_ref (int argc, Scheme_Object *argv[]);
static Scheme_Object *vector_set (int argc, Scheme_Object *argv[]);
static Scheme_Object *vector_to_list (int argc, Scheme_Object *argv[]);
static Scheme_Object *list_to_vector (int argc, Scheme_Object *argv[]);
@ -42,6 +41,8 @@ static Scheme_Object *zero_length_vector;
void
scheme_init_vector (Scheme_Env *env)
{
Scheme_Object *p;
REGISTER_SO(zero_length_vector);
zero_length_vector = (Scheme_Object *)scheme_malloc_tagged(sizeof(Scheme_Vector)
- sizeof(Scheme_Object *));
@ -73,11 +74,15 @@ scheme_init_vector (Scheme_Env *env)
"vector-length",
1, 1, 1),
env);
p = scheme_make_noncm_prim(scheme_checked_vector_ref,
"vector-ref",
2, 2);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant("vector-ref",
scheme_make_noncm_prim(vector_ref,
"vector-ref",
2, 2),
p,
env);
scheme_add_global_constant("vector-set!",
scheme_make_noncm_prim(vector_set,
"vector-set!",
@ -229,8 +234,8 @@ bad_index(char *name, Scheme_Object *i, Scheme_Object *vec)
return NULL;
}
static Scheme_Object *
vector_ref (int argc, Scheme_Object *argv[])
Scheme_Object *
scheme_checked_vector_ref (int argc, Scheme_Object *argv[])
{
long i, len;

30
src/wxcommon/PSDC.cxx
View File

@ -2016,6 +2016,11 @@ double wxPostScriptDC::DeviceToLogicalXRel(int x)
return x / user_scale_x;
}
double wxPostScriptDC::UnscrolledDeviceToLogicalX(int x)
{
return DeviceToLogicalX(x);
}
double wxPostScriptDC::DeviceToLogicalY(int y)
{
double y2 = -(y - paper_h);
@ -2027,6 +2032,11 @@ double wxPostScriptDC::DeviceToLogicalYRel(int y)
return y / user_scale_y;
}
double wxPostScriptDC::UnscrolledDeviceToLogicalY(int y)
{
return DeviceToLogicalY(y);
}
int wxPostScriptDC::LogicalToDeviceX(double x)
{
return (int)floor(XSCALE(x));
@ -2037,6 +2047,11 @@ int wxPostScriptDC::LogicalToDeviceXRel(double x)
return (int)floor(XSCALEREL(x));
}
int wxPostScriptDC::LogicalToUnscrolledDeviceX(double x)
{
return LogicalToDeviceX(x);
}
int wxPostScriptDC::LogicalToDeviceY(double y)
{
return (int)floor(YSCALE(y));
@ -2047,6 +2062,11 @@ int wxPostScriptDC::LogicalToDeviceYRel(double y)
return (int)floor(YSCALEREL(y));
}
int wxPostScriptDC::LogicalToUnscrolledDeviceY(double y)
{
return LogicalToDeviceY(y);
}
double wxPostScriptDC::FLogicalToDeviceX(double x)
{
return XSCALE(x);
@ -2057,6 +2077,11 @@ double wxPostScriptDC::FLogicalToDeviceXRel(double x)
return XSCALEREL(x);
}
double wxPostScriptDC::FLogicalToUnscrolledDeviceX(double x)
{
return FLogicalToDeviceX(x);
}
double wxPostScriptDC::FLogicalToDeviceY(double y)
{
return YSCALE(y);
@ -2067,6 +2092,11 @@ double wxPostScriptDC::FLogicalToDeviceYRel(double y)
return YSCALEREL(y);
}
double wxPostScriptDC::FLogicalToUnscrolledDeviceY(double y)
{
return FLogicalToDeviceY(y);
}
double wxPostScriptDC::FsLogicalToDeviceX(double x, double device_origin_x, double user_scale_x)
{
/* Intentional capture of arguments by macro! */

6
src/wxcommon/PSDC.h
View File

@ -136,14 +136,20 @@ class wxPostScriptDC: public wxDC
double DeviceToLogicalY(int y);
double DeviceToLogicalXRel(int x);
double DeviceToLogicalYRel(int y);
double UnscrolledDeviceToLogicalX(int x);
double UnscrolledDeviceToLogicalY(int y);
int LogicalToDeviceX(double x);
int LogicalToDeviceY(double y);
int LogicalToDeviceXRel(double x);
int LogicalToDeviceYRel(double y);
int LogicalToUnscrolledDeviceX(double x);
int LogicalToUnscrolledDeviceY(double y);
double FLogicalToDeviceX(double x);
double FLogicalToDeviceY(double y);
double FLogicalToDeviceXRel(double x);
double FLogicalToDeviceYRel(double y);
double FLogicalToUnscrolledDeviceX(double x);
double FLogicalToUnscrolledDeviceY(double y);
double FsLogicalToDeviceX(double x, double o, double s);
double FsLogicalToDeviceY(double y, double o, double s);

40
src/wxcommon/Region.cxx
View File

@ -101,11 +101,11 @@ void wxRegion::SetRectangle(double x, double y, double width, double height)
xw = x + width;
yh = y + height;
x = dc->FLogicalToDeviceX(x);
y = dc->FLogicalToDeviceY(y);
xw = dc->FLogicalToDeviceX(xw);
x = dc->FLogicalToUnscrolledDeviceX(x);
y = dc->FLogicalToUnscrolledDeviceY(y);
xw = dc->FLogicalToUnscrolledDeviceX(xw);
width = xw - x;
yh = dc->FLogicalToDeviceY(yh);
yh = dc->FLogicalToUnscrolledDeviceY(yh);
height = yh - y;
if (is_ps) {
@ -198,10 +198,10 @@ void wxRegion::SetRoundedRectangle(double x, double y, double width, double heig
/* Windows and Mac */
xw = x + width;
yh = y + height;
x = dc->FLogicalToDeviceX(x);
y = dc->FLogicalToDeviceY(y);
width = dc->FLogicalToDeviceX(xw) - x;
height = dc->FLogicalToDeviceY(yh) - y;
x = dc->FLogicalToUnscrolledDeviceX(x);
y = dc->FLogicalToUnscrolledDeviceY(y);
width = dc->FLogicalToUnscrolledDeviceX(xw) - x;
height = dc->FLogicalToUnscrolledDeviceY(yh) - y;
xradius = (int)(dc->FLogicalToDeviceXRel(radius));
yradius = (int)(dc->FLogicalToDeviceYRel(radius));
@ -271,10 +271,10 @@ void wxRegion::SetEllipse(double x, double y, double width, double height)
xw = x + width;
yh = y + height;
x = dc->FLogicalToDeviceX(x);
y = dc->FLogicalToDeviceY(y);
width = dc->FLogicalToDeviceX(xw) - x;
height = dc->FLogicalToDeviceY(yh) - y;
x = dc->FLogicalToUnscrolledDeviceX(x);
y = dc->FLogicalToUnscrolledDeviceY(y);
width = dc->FLogicalToUnscrolledDeviceX(xw) - x;
height = dc->FLogicalToUnscrolledDeviceY(yh) - y;
if (is_ps) {
/* So bitmap-based region is right */
@ -355,14 +355,14 @@ void wxRegion::SetPolygon(int n, wxPoint points[], double xoffset, double yoffse
cpoints = new POINT[n];
fpoints = (is_ps ? new FPoint[n] : (FPoint *)NULL);
for (i = 0; i < n; i++) {
v = dc->LogicalToDeviceX(points[i+delta].x + xoffset);
v = dc->LogicalToUnscrolledDeviceX(points[i+delta].x + xoffset);
cpoints[i].x = v;
v = dc->LogicalToDeviceY(points[i+delta].y + yoffset);
v = dc->LogicalToUnscrolledDeviceY(points[i+delta].y + yoffset);
cpoints[i].y = v;
if (fpoints) {
vf = dc->FLogicalToDeviceX(points[i+delta].x + xoffset);
vf = dc->FLogicalToUnscrolledDeviceX(points[i+delta].x + xoffset);
fpoints[i].x = vf;
vf = dc->FLogicalToDeviceY(points[i+delta].y + yoffset);
vf = dc->FLogicalToUnscrolledDeviceY(points[i+delta].y + yoffset);
fpoints[i].y = vf;
}
}
@ -811,9 +811,9 @@ void wxRegion::BoundingBox(double *x, double *y, double *w, double *h)
*y = -(*y);
}
v = dc->DeviceToLogicalX((int)*x);
v = dc->UnscrolledDeviceToLogicalX((int)*x);
*x = v;
v = dc->DeviceToLogicalY((int)*y);
v = dc->UnscrolledDeviceToLogicalY((int)*y);
*y = v;
v = dc->DeviceToLogicalXRel((int)*w);
*w = v;
@ -851,8 +851,8 @@ Bool wxRegion::IsInRegion(double x, double y)
if (!rgn) return FALSE;
x = dc->FLogicalToDeviceX(x);
y = dc->FLogicalToDeviceY(y);
x = dc->FLogicalToUnscrolledDeviceX(x);
y = dc->FLogicalToUnscrolledDeviceY(y);
ix = (int)floor(x);

6
src/wxmac/include/base/wb_dc.h
View File

@ -180,14 +180,20 @@ class wxbDC: public wxObject
virtual double DeviceToLogicalY(int y) = 0;
virtual double DeviceToLogicalXRel(int x) = 0;
virtual double DeviceToLogicalYRel(int y) = 0;
virtual double UnscrolledDeviceToLogicalX(int x) = 0;
virtual double UnscrolledDeviceToLogicalY(int y) = 0;
virtual int LogicalToDeviceX(double x) = 0;
virtual int LogicalToDeviceY(double y) = 0;
virtual int LogicalToDeviceXRel(double x) = 0;
virtual int LogicalToDeviceYRel(double y) = 0;
virtual int LogicalToUnscrolledDeviceX(double x) = 0;
virtual int LogicalToUnscrolledDeviceY(double y) = 0;
virtual double FLogicalToDeviceX(double x) = 0;
virtual double FLogicalToDeviceY(double y) = 0;
virtual double FLogicalToDeviceXRel(double x) = 0;
virtual double FLogicalToDeviceYRel(double y) = 0;
virtual double FLogicalToUnscrolledDeviceX(double x) = 0;
virtual double FLogicalToUnscrolledDeviceY(double y) = 0;
// Only works for PostScript *after* you've printed an image.
// Gives width and height of image.
virtual void GetSize(double *width, double *height);

23
src/wxmac/include/mac/wx_dc.h
View File

@ -56,12 +56,18 @@ extern "C" {
// Logical to device
// Absolute
#define XLOG2DEV(x) (int)floor(((x) - logical_origin_x)*logical_scale_x*user_scale_x + device_origin_x)
#define YLOG2DEV(y) (int)floor(((y) - logical_origin_y)*logical_scale_y*user_scale_y + device_origin_y)
#define _XLOG2DEV(x,dox) (int)floor(((x) - logical_origin_x)*logical_scale_x*user_scale_x + dox)
#define _YLOG2DEV(y,doy) (int)floor(((y) - logical_origin_y)*logical_scale_y*user_scale_y + doy)
#define XLOG2DEV(x) _XLOG2DEV(x, device_origin_x)
#define YLOG2DEV(y) _YLOG2DEV(y, device_origin_y)
#define XLOG2UDEV(x) _XLOG2DEV(x, (device_origin_x - auto_device_origin_x))
#define YLOG2UDEV(y) _YLOG2DEV(y, (device_origin_y - auto_device_origin_y))
// Logical to device without the device translation
#define XLOG2DEV_2(x) (int)floor(((x) - logical_origin_x)*logical_scale_x*user_scale_x)
#define YLOG2DEV_2(y) (int)floor(((y) - logical_origin_y)*logical_scale_y*user_scale_y)
#define XLOG2DEV_2(x) _XLOG2DEV(x, 0)
#define YLOG2DEV_2(y) _YLOG2DEV(y, 0)
// Relative
#define XLOG2DEVREL(x) (int)floor((x)*logical_scale_x*user_scale_x)
@ -69,9 +75,14 @@ extern "C" {
// Device to logical
// Absolute
#define XDEV2LOG(x) (((x) - device_origin_x)/(logical_scale_x*user_scale_x) + logical_origin_x)
#define _XDEV2LOG(x, dox) (((x) - dox)/(logical_scale_x*user_scale_x) + logical_origin_x)
#define _YDEV2LOG(y, doy) (((y) - doy)/(logical_scale_y*user_scale_y) + logical_origin_y)
#define YDEV2LOG(y) (((y) - device_origin_y)/(logical_scale_y*user_scale_y) + logical_origin_y)
#define XDEV2LOG(x) _XDEV2LOG(x, device_origin_x)
#define YDEV2LOG(y) _YDEV2LOG(y, device_origin_y)
#define XUDEV2LOG(x) _XDEV2LOG(x, (device_origin_x - auto_device_origin_x))
#define YUDEV2LOG(y) _YDEV2LOG(y, (device_origin_y - auto_device_origin_y))
// Relative
#define XDEV2LOGREL(x) ((x)/(logical_scale_x*user_scale_x))

6
src/wxmac/include/mac/wx_dccan.h
View File

@ -134,14 +134,20 @@ class wxCanvasDC: public wxbCanvasDC
double DeviceToLogicalY(int y);
double DeviceToLogicalXRel(int x);
double DeviceToLogicalYRel(int y);
double UnscrolledDeviceToLogicalX(int x);
double UnscrolledDeviceToLogicalY(int y);
int LogicalToDeviceX(double x);
int LogicalToDeviceY(double y);
int LogicalToDeviceXRel(double x);
int LogicalToDeviceYRel(double y);
int LogicalToUnscrolledDeviceX(double x);
int LogicalToUnscrolledDeviceY(double y);
double FLogicalToDeviceX(double x);
double FLogicalToDeviceY(double y);
double FLogicalToDeviceXRel(double x);
double FLogicalToDeviceYRel(double y);
double FLogicalToUnscrolledDeviceX(double x);
double FLogicalToUnscrolledDeviceY(double y);
Bool Blit(double xdest, double ydest, double width, double height,
wxBitmap* source, double xsrc, double ysrc, int rop = wxSOLID, wxColour *c = NULL,

31
src/wxmac/src/mac/wx_dccan1.cc
View File

@ -291,10 +291,12 @@ void wxCanvasDC::SetCanvasClipping(void)
current_reg = ::NewRgn();
CheckMemOK(current_reg);
}
} else if (onpaint_reg && clipping) {
::SectRgn(clipping->rgn, onpaint_reg, current_reg) ;
} else if (clipping) {
::CopyRgn(clipping->rgn, current_reg) ;
::CopyRgn(clipping->rgn, current_reg);
::OffsetRgn(current_reg, auto_device_origin_x, auto_device_origin_y);
if (onpaint_reg) {
::SectRgn(current_reg, onpaint_reg, current_reg) ;
}
} else if (onpaint_reg) {
::CopyRgn(onpaint_reg, current_reg);
}
@ -564,36 +566,54 @@ double wxCanvasDC::DeviceToLogicalX(int x) { return XDEV2LOG(x); }
//-----------------------------------------------------------------------------
double wxCanvasDC::DeviceToLogicalXRel(int x) { return XDEV2LOGREL(x); }
//-----------------------------------------------------------------------------
double wxCanvasDC::UnscrolledDeviceToLogicalX(int x) { return XUDEV2LOG(x); }
//-----------------------------------------------------------------------------
double wxCanvasDC::DeviceToLogicalY(int y) { return YDEV2LOG(y); }
//-----------------------------------------------------------------------------
double wxCanvasDC::DeviceToLogicalYRel(int y) { return YDEV2LOGREL(y); }
//-----------------------------------------------------------------------------
double wxCanvasDC::UnscrolledDeviceToLogicalY(int y) { return YUDEV2LOG(y); }
//-----------------------------------------------------------------------------
int wxCanvasDC::LogicalToDeviceX(double x) { return XLOG2DEV(x); }
//-----------------------------------------------------------------------------
int wxCanvasDC::LogicalToDeviceXRel(double x) { return XLOG2DEVREL(x); }
//-----------------------------------------------------------------------------
int wxCanvasDC::LogicalToUnscrolledDeviceX(double x) { return XLOG2UDEV(x); }
//-----------------------------------------------------------------------------
int wxCanvasDC::LogicalToDeviceY(double y) { return YLOG2DEV(y); }
//-----------------------------------------------------------------------------
int wxCanvasDC::LogicalToDeviceYRel(double y) { return YLOG2DEVREL(y); }
//-----------------------------------------------------------------------------
int wxCanvasDC::LogicalToUnscrolledDeviceY(double y) { return YLOG2UDEV(y); }
//-----------------------------------------------------------------------------
double wxCanvasDC::FLogicalToDeviceX(double x) { return XLOG2DEV(x); }
//-----------------------------------------------------------------------------
double wxCanvasDC::FLogicalToDeviceXRel(double x) { return XLOG2DEVREL(x); }
//-----------------------------------------------------------------------------
double wxCanvasDC::FLogicalToUnscrolledDeviceX(double x) { return XLOG2UDEV(x); }
//-----------------------------------------------------------------------------
double wxCanvasDC::FLogicalToDeviceY(double y) { return YLOG2DEV(y); }
//-----------------------------------------------------------------------------
double wxCanvasDC::FLogicalToDeviceYRel(double y) { return YLOG2DEVREL(y); }
//-----------------------------------------------------------------------------
double wxCanvasDC::FLogicalToUnscrolledDeviceY(double y) { return YLOG2UDEV(y); }
//-----------------------------------------------------------------------------
void wxCanvasDC::wxMacSetClip(void)
{
@ -959,8 +979,11 @@ CGContextRef wxCanvasDC::GetCG()
CGContextTranslateCTM(cg, gdx, (float)(portRect.bottom - portRect.top - gdy));
CGContextScaleCTM(cg, 1.0, -1.0 );
if (clipping)
if (clipping) {
CGContextTranslateCTM(cg, auto_device_origin_x, auto_device_origin_y);
clipping->Install((long)cg, AlignSmoothing());
CGContextTranslateCTM(cg, -auto_device_origin_x, -auto_device_origin_y);
}
if (!AlignSmoothing()) {
CGContextTranslateCTM(cg, device_origin_x, device_origin_y);

6
src/wxwindow/include/base/wb_dc.h
View File

@ -174,14 +174,20 @@ class wxbDC: public wxObject
virtual double DeviceToLogicalY(int y) = 0;
virtual double DeviceToLogicalXRel(int x) = 0;
virtual double DeviceToLogicalYRel(int y) = 0;
virtual double UnscrolledDeviceToLogicalX(int x) = 0;
virtual double UnscrolledDeviceToLogicalY(int y) = 0;
virtual int LogicalToDeviceX(double x) = 0;
virtual int LogicalToDeviceY(double y) = 0;
virtual int LogicalToDeviceXRel(double x) = 0;
virtual int LogicalToDeviceYRel(double y) = 0;
virtual int LogicalToUnscrolledDeviceX(double x) = 0;
virtual int LogicalToUnscrolledDeviceY(double y) = 0;
virtual double FLogicalToDeviceX(double x) = 0;
virtual double FLogicalToDeviceY(double y) = 0;
virtual double FLogicalToDeviceXRel(double x) = 0;
virtual double FLogicalToDeviceYRel(double y) = 0;
virtual double FLogicalToUnscrolledDeviceX(double x) = 0;
virtual double FLogicalToUnscrolledDeviceY(double y) = 0;
// Only works for PostScript *after* you've printed an image.
// Gives width and height of image.
virtual void GetSize(double *width, double *height);

26
src/wxwindow/include/msw/wx_dc.h
View File

@ -138,14 +138,20 @@ class wxDC: public wxbDC
double DeviceToLogicalY(int y);
double DeviceToLogicalXRel(int x);
double DeviceToLogicalYRel(int y);
double UnscrolledDeviceToLogicalX(int x);
double UnscrolledDeviceToLogicalY(int y);
int LogicalToDeviceX(double x);
int LogicalToDeviceY(double y);
int LogicalToDeviceXRel(double x);
int LogicalToDeviceYRel(double y);
int LogicalToUnscrolledDeviceX(double x);
int LogicalToUnscrolledDeviceY(double y);
double FLogicalToDeviceX(double x);
double FLogicalToDeviceY(double y);
double FLogicalToDeviceXRel(double x);
double FLogicalToDeviceYRel(double y);
double FLogicalToUnscrolledDeviceX(double x);
double FLogicalToUnscrolledDeviceY(double y);
Bool GlyphAvailable(int c, wxFont *f = NULL);
@ -214,8 +220,14 @@ HDC wxGetPrinterDC(void);
// Logical to device
// Absolute
#define MS_XLOG2DEV(x) ((int)floor((x)*logical_scale_x*user_scale_x + (device_origin_x+canvas_scroll_dx)*logical_scale_x))
#define MS_YLOG2DEV(y) ((int)floor((y)*logical_scale_y*user_scale_y + (device_origin_y+canvas_scroll_dy)*logical_scale_y))
#define _MS_XLOG2DEV(x, cdx) ((int)floor((x)*logical_scale_x*user_scale_x + (device_origin_x+cdx)*logical_scale_x))
#define _MS_YLOG2DEV(y, cdy) ((int)floor((y)*logical_scale_y*user_scale_y + (device_origin_y+cdy)*logical_scale_y))
#define MS_XLOG2DEV(x) _MS_XLOG2DEV(x, canvas_scroll_dx)
#define MS_YLOG2DEV(y) _MS_YLOG2DEV(y, canvas_scroll_dy)
#define MS_XLOG2UDEV(x) _MS_XLOG2DEV(x, 0)
#define MS_YLOG2UDEV(y) _MS_YLOG2DEV(y, 0)
// Logical to device
#define XLOG2DEV(x) MS_XLOG2DEV(x)
@ -227,8 +239,14 @@ HDC wxGetPrinterDC(void);
// Device to logical
// Absolute
#define MS_XDEV2LOG(x) (((x)/(logical_scale_x*user_scale_x)) - (device_origin_x + canvas_scroll_dx)/logical_scale_x)
#define MS_YDEV2LOG(y) (((y)/(logical_scale_y*user_scale_y)) - (device_origin_y + canvas_scroll_dy)/logical_scale_y)
#define _MS_XDEV2LOG(x, cdx) ((((x) - (device_origin_x + cdx)/logical_scale_x)/(logical_scale_x*user_scale_x)))
#define _MS_YDEV2LOG(y, cdy) ((((y) - (device_origin_y + cdy)/logical_scale_y)/(logical_scale_y*user_scale_y)))
#define MS_XDEV2LOG(x) _MS_XDEV2LOG(x, canvas_scroll_dx)
#define MS_YDEV2LOG(y) _MS_YDEV2LOG(y, canvas_scroll_dy)
#define MS_XUDEV2LOG(x) _MS_XDEV2LOG(x, 0)
#define MS_YUDEV2LOG(y) _MS_YDEV2LOG(y, 0)
// Relative
#define MS_XDEV2LOGREL(x) ((x)/(logical_scale_x*user_scale_x))

43
src/wxwindow/src/msw/wx_dc.cxx
View File

@ -434,9 +434,10 @@ static HRGN empty_rgn;
void wxDC::DoClipping(HDC dc)
{
if (clipping) {
if (clipping->rgn)
if (clipping->rgn) {
SelectClipRgn(dc, clipping->rgn);
else {
OffsetClipRgn(dc, canvas_scroll_dx, canvas_scroll_dy);
} else {
if (!empty_rgn)
empty_rgn = CreateRectRgn(0, 0, 0, 0);
SelectClipRgn(dc, empty_rgn);
@ -800,8 +801,8 @@ static void FillWithStipple(wxDC *dc, wxRegion *r, wxBrush *brush)
bw = bm->GetWidth();
bh = bm->GetHeight();
x = dc->LogicalToDeviceX(x);
y = dc->LogicalToDeviceY(y);
x = dc->LogicalToUnscrolledDeviceX(x);
y = dc->LogicalToUnscrolledDeviceY(y);
w = dc->LogicalToDeviceXRel(w);
h = dc->LogicalToDeviceYRel(h);
@ -815,8 +816,8 @@ static void FillWithStipple(wxDC *dc, wxRegion *r, wxBrush *brush)
for (i = xstart; i < xend; i++) {
for (j = ystart; j < yend; j++) {
dc->Blit(dc->DeviceToLogicalX(i * bw),
dc->DeviceToLogicalY(j * bh),
dc->Blit(dc->UnscrolledDeviceToLogicalX(i * bw),
dc->UnscrolledDeviceToLogicalY(j * bh),
dc->DeviceToLogicalXRel(bw),
dc->DeviceToLogicalYRel(bh),
bm, 0, 0, style, c);
@ -2350,6 +2351,11 @@ double wxDC::DeviceToLogicalXRel(int x)
return (double)MS_XDEV2LOGREL(x);
}
double wxDC::UnscrolledDeviceToLogicalX(int x)
{
return (double)MS_XUDEV2LOG(x);
}
double wxDC::DeviceToLogicalY(int y)
{
return (double)MS_YDEV2LOG(y);
@ -2360,6 +2366,11 @@ double wxDC::DeviceToLogicalYRel(int y)
return (double)MS_YDEV2LOGREL(y);
}
double wxDC::UnscrolledDeviceToLogicalY(int y)
{
return (double)MS_YUDEV2LOG(y);
}
int wxDC::LogicalToDeviceX(double x)
{
return MS_XLOG2DEV(x);
@ -2370,6 +2381,11 @@ int wxDC::LogicalToDeviceXRel(double x)
return MS_XLOG2DEVREL(x);
}
int wxDC::LogicalToUnscrolledDeviceX(double x)
{
return MS_XLOG2UDEV(x);
}
int wxDC::LogicalToDeviceY(double y)
{
return MS_YLOG2DEV(y);
@ -2380,6 +2396,11 @@ int wxDC::LogicalToDeviceYRel(double y)
return MS_YLOG2DEVREL(y);
}
int wxDC::LogicalToUnscrolledDeviceY(double y)
{
return MS_YLOG2UDEV(y);
}
double wxDC::FLogicalToDeviceX(double x)
{
return MS_XLOG2DEV(x);
@ -2390,6 +2411,11 @@ double wxDC::FLogicalToDeviceXRel(double x)
return MS_XLOG2DEVREL(x);
}
double wxDC::FLogicalToUnscrolledDeviceX(double x)
{
return MS_XLOG2UDEV(x);
}
double wxDC::FLogicalToDeviceY(double y)
{
return MS_YLOG2DEV(y);
@ -2400,6 +2426,11 @@ double wxDC::FLogicalToDeviceYRel(double y)
return MS_YLOG2DEVREL(y);
}
double wxDC::FLogicalToUnscrolledDeviceY(double y)
{
return MS_YLOG2UDEV(y);
}
#define wxKEEPDEST (DWORD)0x00AA0029
typedef BOOL (WINAPI *wxALPHA_BLEND)(HDC,int,int,int,int,HDC,int,int,int,int,BLENDFUNCTION);

12
src/wxxt/src/DeviceContexts/DC.h
View File

@ -135,10 +135,14 @@ public:
{ return XDEV2LOG(x); }
virtual double DeviceToLogicalXRel(int x)
{ return XDEV2LOGREL(x); }
virtual double UnscrolledDeviceToLogicalX(int x)
{ return XDEV2LOG(x); }
virtual double DeviceToLogicalY(int y)
{ return YDEV2LOG(y); }
virtual double DeviceToLogicalYRel(int y)
{ return YDEV2LOGREL(y); }
virtual double UnscrolledDeviceToLogicalY(int y)
{ return YDEV2LOG(y); }
void DrawSpline(int n, wxPoint pts[]);
void DrawSpline(wxList *pts);
virtual void DrawSpline(double x1,double y1, double x2,double y2, double x3,double y3);
@ -172,18 +176,26 @@ public:
{ return XLOG2DEV(x); }
virtual int LogicalToDeviceXRel(double x)
{ return XLOG2DEVREL(x); }
virtual int LogicalToUnscrolledDeviceX(double x)
{ return XLOG2DEV(x); }
virtual int LogicalToDeviceY(double y)
{ return YLOG2DEV(y); }
virtual int LogicalToDeviceYRel(double y)
{ return YLOG2DEVREL(y); }
virtual int LogicalToUnscrolledDeviceY(double y)
{ return YLOG2DEV(y); }
virtual double FLogicalToDeviceX(double x)
{ return XLOG2DEV(x); }
virtual double FLogicalToDeviceXRel(double x)
{ return XLOG2DEVREL(x); }
virtual double FLogicalToUnscrolledDeviceX(double x)
{ return XLOG2DEV(x); }
virtual double FLogicalToDeviceY(double y)
{ return YLOG2DEV(y); }
virtual double FLogicalToDeviceYRel(double y)
{ return YLOG2DEVREL(y); }
virtual double FLogicalToUnscrolledDeviceY(double y)
{ return YLOG2DEV(y); }
virtual Bool Ok(void)
{ return ok; }
void SetBackgroundMode(int mode)