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

3937 lines
86 KiB
C++
Raw Blame History

/*
* File: mred.cc
* Purpose: MrEd main file, including a hodge-podge of global stuff
* Author: Matthew Flatt
* Created: 1995
* Copyright: (c) 2004-2007 PLT Scheme Inc.
* Copyright: (c) 1995-2000, Matthew Flatt
*/
/* wx_xt: */
#define Uses_XtIntrinsic
#define Uses_XtIntrinsicP
#define Uses_XLib
#if defined(_MSC_VER) && defined(MZ_PRECISE_GC)
# include "wx.h"
#endif
/* wx_motif, for wxTimer: */
#ifdef __GNUG__
# pragma implementation "wx_timer.h"
#endif
#include "common.h"
#include "wx_frame.h"
#include "wx_utils.h"
#include "wx_main.h"
#include "wx_buttn.h"
#include "wx_messg.h"
#include "wx_timer.h"
#include "wx_media.h"
#include "wx_dialg.h"
#include "wx_cmdlg.h"
#include "wx_menu.h"
#include "wx_dcps.h"
#include "wx_clipb.h"
#include "wx_types.h"
#ifdef wx_mac
# include "simpledrop.h"
#endif
#ifdef wx_msw
# include "wx_wmgr.h"
#endif
#include <ctype.h>
#include <stdio.h>
#include <stdarg.h>
/* Solaris: getdtablesize sometimes not available */
#if !defined(USE_ULIMIT) && defined(sun) && defined(__svr4__)
# define USE_ULIMIT
#endif
#if defined(wx_xt)
# include <X11/Xlib.h>
# include <X11/keysymdef.h>
#endif
#ifdef wx_x
# include <sys/types.h>
# include <sys/time.h>
# include <unistd.h>
# if defined(_IBMR2)
# include <sys/select.h>
# endif
# include <signal.h>
#endif
#ifdef wx_msw
# ifdef _MSC_VER
# include <direct.h>
# else
# include <dir.h>
# endif
#endif
#ifdef wx_mac
# ifndef WX_CARBON
# include <Events.h>
# endif
# ifdef OS_X
int wx_in_terminal;
# else
# define wx_in_terminal 0
# endif
#else
# ifdef wx_msw
static int wx_in_terminal = 0;
# else
# define wx_in_terminal 0
# endif
#endif
#ifdef OS_X
extern "C" void _signal_nobind(...);
#endif
#if defined(wx_x) || defined(wx_msw)
# define ADD_OBJ_DUMP 0
#else
# define ADD_OBJ_DUMP 0
#endif
#define INTERRUPT_CHECK_ON 0
# include "wxs/wxscheme.h"
# include "wxs/wxsmred.h"
# include "wxs/wxs_fram.h"
# include "wxs/wxs_obj.h"
wxFrame *mred_real_main_frame;
#if defined(wx_xt) || defined(OS_X)
# define mred_BREAK_HANDLER
#endif
static Scheme_Thread *user_main_thread;
extern void wxMediaIOCheckLSB(void);
extern void wxMouseEventHandled(void);
#ifdef wx_xt
extern int wx_single_instance;
#endif
#include "mred.h"
#ifdef MPW_CPLUS
extern "C" {
typedef void (*GC_F_PTR)(void *, void *);
typedef void (*ON_KILL_PTR)(struct Scheme_Thread *p);
typedef Scheme_Object *(*MK_PTR)(void);
# if !defined(USE_SENORA_GC) && !defined(MZ_PRECISE_GC)
typedef void (*IGNORE_PTR)(char *, GC_word);
# endif
typedef void (*CONSOLE_PRINTF_PTR)(char *str, ...);
typedef void (*CONSOLE_OUTPUT_PTR)(char *str, long len);
typedef void (*EXIT_PTR)(int);
typedef void (*DW_PRE_PTR)(void *);
typedef Scheme_Object *(*DW_RUN_PTR)(void *);
typedef void (*DW_POST_PTR)(void *);
typedef void (*ON_SUSPEND_PTR)(void);
}
# define CAST_SCP (Scheme_Closed_Prim *)
# define CAST_GCP (GC_F_PTR)
# define CAST_SCCC (Scheme_Close_Custodian_Client *)
# define CAST_BLKCHK (Scheme_Ready_Fun)
# define CAST_WU (Scheme_Needs_Wakeup_Fun)
# define CAST_TOK (ON_KILL_PTR)
# define CAST_GS (Scheme_Get_String_Fun)
# define CAST_IREADY (Scheme_In_Ready_Fun)
# define CAST_ICLOSE (Scheme_Close_Input_Fun)
# define CAST_WS (Scheme_Write_String_Fun)
# define CAST_MK (MK_PTR)
# define CAST_SLEEP (SLEEP_PROC_PTR)
# define CAST_IGNORE (IGNORE_PTR)
# define CAST_PRINTF (CONSOLE_PRINTF_PTR)
# define CAST_OUTPUT (CONSOLE_OUTPUT_PTR)
# define CAST_EXIT (EXIT_PTR)
# define CAST_DW_PRE (DW_PRE_PTR)
# define CAST_DW_RUN (DW_RUN_PTR)
# define CAST_DW_POST (DW_POST_PTR)
# define CAST_SUSPEND (ON_SUSPEND_PTR)
# define CAST_EXT (Scheme_Custodian_Extractor)
#else
# define CAST_SCP /* empty */
# define CAST_GCP /* empty */
# define CAST_SCCC /* empty */
# define CAST_BLKCHK /* empty */
# define CAST_WU /* empty */
# define CAST_TOK /* empty */
# define CAST_GS /* empty */
# define CAST_IREADY /* empty */
# define CAST_ICLOSE /* empty */
# define CAST_WS /* empty */
# define CAST_MK /* empty */
# define CAST_SLEEP /* empty */
# define CAST_IGNORE /* empty */
# define CAST_PRINTF /* empty */
# define CAST_OUTPUT /* empty */
# define CAST_EXIT /* empty */
# define CAST_DW_PRE /* empty */
# define CAST_DW_RUN /* empty */
# define CAST_DW_POST /* empty */
# define CAST_SUSPEND /* empty */
# define CAST_EXT /* empty */
#endif
/* Set by mrmain.cxx: */
/* (The indirection is needed to avoid mutual .dll dependencies.) */
MrEd_Finish_Cmd_Line_Run_Proc mred_finish_cmd_line_run;
void mred_set_finish_cmd_line_run(MrEd_Finish_Cmd_Line_Run_Proc p) { mred_finish_cmd_line_run = p; }
MrEd_Run_From_Cmd_Line_Proc mred_run_from_cmd_line;
void mred_set_run_from_cmd_line(MrEd_Run_From_Cmd_Line_Proc p) { mred_run_from_cmd_line = p; }
#if 0
/* Force initialization of the garbage collector (currently needed
only when supporting Irix sprocs) */
class GCInit {
public:
GCInit() {
GC_INIT();
}
};
static GCInit _gcinit;
#endif
static Scheme_Env *global_env;
class MrEdApp: public wxApp
{
public:
Bool initialized;
int xargc;
char **xargv;
MrEdApp();
wxFrame *OnInit(void);
void RealInit(void);
#ifdef wx_mac
char *GetDefaultAboutItemName();
void DoDefaultAboutItem();
#endif
int OnExit(void);
};
MrEdApp *TheMrEdApp;
static int exit_val = 0;
#ifdef LIBGPP_REGEX_HACK
/* Fixes weirdness with libg++ and the compiler: it tries to
destroy global regexp objects that were never created. Calling
the constructor forces the other global values to be initialized. */
# include <Regex.h>
#endif
/****************************************************************************/
/* Contexts */
/****************************************************************************/
MrEdContext *mred_contexts;
static MrEdContext *mred_main_context;
static MrEdContext *mred_only_context;
static int only_context_just_once = 0;
static MrEdContext *user_main_context;
static MrEdContextFramesRef mred_frames; /* list of all frames (weak link to invisible ones) */
static Scheme_Hash_Table *timer_contexts;
int mred_eventspace_param;
int mred_event_dispatch_param;
Scheme_Type mred_eventspace_type;
Scheme_Type mred_nested_wait_type;
static Scheme_Type mred_eventspace_hop_type;
static Scheme_Object *def_dispatch;
int mred_ps_setup_param;
#ifdef NEED_HET_PARAM
Scheme_Object *mred_het_key;
#endif
typedef struct Nested_Wait {
Scheme_Object so;
Scheme_Object *wait_on;
} Nested_Wait;
typedef struct Context_Custodian_Hop {
Scheme_Object so;
MrEdContext *context;
} Context_Custodian_Hop;
#ifdef MZ_PRECISE_GC
# define WEAKIFY(x) ((MrEdContext *)GC_malloc_weak_box(x, NULL, 0))
# define WEAKIFIED(x) ((MrEdContext *)GC_weak_box_val(x))
#else
# define WEAKIFY(x) x
# define WEAKIFIED(x) x
# define HIDE_FROM_XFORM(x) x
#endif
static MrEdContext *check_q_callbacks(int hi, int (*test)(MrEdContext *, MrEdContext *),
MrEdContext *tdata, int check_only);
static void remove_q_callbacks(MrEdContext *c);
#ifdef MZ_PRECISE_GC
START_XFORM_SKIP;
static int size_eventspace_val(void *)
{
return gcBYTES_TO_WORDS(sizeof(MrEdContext));
}
static int mark_eventspace_val(void *p)
{
MrEdContext *c = (MrEdContext *)p;
gcMARK_TYPED(Scheme_Thread *, c->handler_running);
gcMARK_TYPED(MrEdFinalizedContext *, c->finalized);
gcMARK_TYPED(wxChildList *, c->topLevelWindowList);
gcMARK_TYPED(wxStandardSnipClassList *, c->snipClassList);
gcMARK_TYPED(wxBufferDataClassList *, c->bufferDataClassList);
gcMARK_TYPED(wxWindow *, c->modal_window);
gcMARK_TYPED(MrEd_Saved_Modal *, c->modal_stack);
gcMARK_TYPED(Scheme_Config *, c->main_config);
gcMARK_TYPED(Scheme_Thread_Cell_Table *, c->main_cells);
gcMARK_TYPED(Scheme_Thread_Cell_Table *, c->main_break_cell);
gcMARK_TYPED(wxTimer *, c->timer);
gcMARK_TYPED(wxTimer **, c->timers);
gcMARK_TYPED(void *, c->alt_data);
gcMARK_TYPED(MrEdContext *, c->next);
#ifdef wx_msw
gcMARK_TYPED(LeaveEvent *, c->queued_leaves);
#endif
gcMARK_TYPED(Context_Custodian_Hop *, c->mr_hop);
gcMARK_TYPED(Scheme_Custodian_Reference *, c->mref);
return gcBYTES_TO_WORDS(sizeof(MrEdContext));
}
static int fixup_eventspace_val(void *p)
{
MrEdContext *c = (MrEdContext *)p;
gcFIXUP_TYPED(Scheme_Thread *, c->handler_running);
gcFIXUP_TYPED(MrEdFinalizedContext *, c->finalized);
gcFIXUP_TYPED(wxChildList *, c->topLevelWindowList);
gcFIXUP_TYPED(wxStandardSnipClassList *, c->snipClassList);
gcFIXUP_TYPED(wxBufferDataClassList *, c->bufferDataClassList);
gcFIXUP_TYPED(wxWindow *, c->modal_window);
gcFIXUP_TYPED(MrEd_Saved_Modal *, c->modal_stack);
gcFIXUP_TYPED(Scheme_Config *, c->main_config);
gcFIXUP_TYPED(Scheme_Thread_Cell_Table *, c->main_cells);
gcFIXUP_TYPED(Scheme_Thread_Cell_Table *, c->main_break_cell);
gcFIXUP_TYPED(wxTimer *, c->timer);
gcFIXUP_TYPED(wxTimer **, c->timers);
gcFIXUP_TYPED(void *, c->alt_data);
gcFIXUP_TYPED(MrEdContext *, c->next);
#ifdef wx_msw
gcFIXUP_TYPED(LeaveEvent *, c->queued_leaves);
#endif
gcFIXUP_TYPED(Context_Custodian_Hop *, c->mr_hop);
gcFIXUP_TYPED(Scheme_Custodian_Reference *, c->mref);
return gcBYTES_TO_WORDS(sizeof(MrEdContext));
}
static int size_nested_wait_val(void *)
{
return gcBYTES_TO_WORDS(sizeof(Nested_Wait));
}
static int mark_nested_wait_val(void *p)
{
Nested_Wait *c = (Nested_Wait *)p;
gcMARK_TYPED(MrEdContext *, c->wait_on);
return gcBYTES_TO_WORDS(sizeof(Nested_Wait));
}
static int fixup_nested_wait_val(void *p)
{
Nested_Wait *c = (Nested_Wait *)p;
gcFIXUP_TYPED(MrEdContext *, c->wait_on);
return gcBYTES_TO_WORDS(sizeof(Nested_Wait));
}
static int size_eventspace_hop_val(void *)
{
return gcBYTES_TO_WORDS(sizeof(Context_Custodian_Hop));
}
static int mark_eventspace_hop_val(void *p)
{
Context_Custodian_Hop *c = (Context_Custodian_Hop *)p;
gcMARK_TYPED(MrEdContext *, c->context);
return gcBYTES_TO_WORDS(sizeof(Context_Custodian_Hop));
}
static int fixup_eventspace_hop_val(void *p)
{
Context_Custodian_Hop *c = (Context_Custodian_Hop *)p;
gcFIXUP_TYPED(MrEdContext *, c->context);
return gcBYTES_TO_WORDS(sizeof(Context_Custodian_Hop));
}
END_XFORM_SKIP;
#endif
MrEdContext *MrEdGetContext(wxObject *w)
{
if (w) {
#if !defined(wx_xt) && !defined(wx_mac)
if (wxSubType(w->__type, wxTYPE_FRAME)) {
#endif
MrEdContext *c;
c = (MrEdContext *)((wxFrame *)w)->context;
if (c)
return c;
#if !defined(wx_xt) && !defined(wx_mac)
} else {
MrEdContext *c;
c = (MrEdContext *)((wxDialogBox *)w)->context;
if (c)
return c;
}
#endif
}
if (mred_only_context) {
if (only_context_just_once) {
MrEdContext *c = mred_only_context;
mred_only_context = NULL;
only_context_just_once = 0;
return c;
} else
return mred_only_context;
} else
return (MrEdContext *)scheme_get_param(scheme_current_config(), mred_eventspace_param);
}
void *MrEdGetWindowContext(wxWindow *w)
{
while (1) {
if (wxSubType(w->__type, wxTYPE_FRAME))
return MrEdGetContext(w);
#if !defined(wx_xt) && !defined(wx_mac)
if (wxSubType(w->__type, wxTYPE_DIALOG_BOX))
return MrEdGetContext(w);
#endif
w = w->GetParent();
}
}
void *wxGetContextForFrame()
{
if (!TheMrEdApp)
return NULL;
else
return (void *)MrEdGetContext();
}
wxChildList *wxGetTopLevelWindowsList(wxObject *w)
{
MrEdContext *c;
c = MrEdGetContext(w);
return c->topLevelWindowList;
}
wxWindow *wxGetModalWindow(wxObject *w)
{
MrEdContext *c;
c = MrEdGetContext(w);
return c->modal_window;
}
class MrEd_Saved_Modal {
public:
wxWindow *win;
MrEd_Saved_Modal *next;
};
void wxPushModalWindow(wxObject *w, wxWindow *win)
{
MrEdContext *c;
c = MrEdGetContext(w);
if (c->modal_window) {
MrEd_Saved_Modal *save;
save = new WXGC_PTRS MrEd_Saved_Modal;
save->next = c->modal_stack;
save->win = c->modal_window;
c->modal_stack = save;
}
c->modal_window = win;
}
void wxPopModalWindow(wxObject *w, wxWindow *win)
{
MrEdContext *c;
MrEd_Saved_Modal *save, *prev;
c = MrEdGetContext(w);
if (c->modal_window == win)
c->modal_window = NULL;
prev = NULL;
for (save = c->modal_stack; save; save = save->next) {
if ((save->win == win) || !c->modal_window) {
if (prev)
prev->next = save->next;
else
c->modal_stack = save->next;
if (save->win != win)
c->modal_window = save->win;
} else
prev = save;
}
}
wxStandardSnipClassList *wxGetTheSnipClassList()
{
MrEdContext *c;
c = MrEdGetContext();
return c->snipClassList;
}
wxBufferDataClassList *wxGetTheBufferDataClassList()
{
MrEdContext *c;
c = MrEdGetContext();
return c->bufferDataClassList;
}
int wxGetBusyState(void)
{
MrEdContext *c;
c = MrEdGetContext();
return c->busyState;
}
void wxSetBusyState(int state)
{
MrEdContext *c;
c = MrEdGetContext();
c->busyState = state;
}
extern int MrEdGetDoubleTime(void);
static int doubleClickThreshold = -1;
int wxMrEdGetDoubleTime(void)
{
if (doubleClickThreshold < 0) {
if (!wxGetPreference("doubleClickTime", &doubleClickThreshold)) {
doubleClickThreshold = MrEdGetDoubleTime();
}
}
return doubleClickThreshold;
}
#ifdef wx_xt
/* For widgets: */
extern "C" {
int wxGetMultiClickTime(Display *d)
{
return wxMrEdGetDoubleTime();
}
}
#endif
Bool wxIsPrimEventspace()
{
return MrEdGetContext() == mred_main_context;
}
int wxIsUserMainEventspace(Scheme_Object *o)
{
return o == (Scheme_Object *)user_main_context;
}
int wxsIsContextShutdown(void *cx)
{
MrEdContext *c;
c = (MrEdContext *)cx;
return c->killed;
}
void *wxsCheckEventspace(char *who)
{
MrEdContext *c;
c = (MrEdContext *)wxGetContextForFrame();
if (c->killed)
scheme_signal_error("%s: the current eventspace has been shutdown", who);
return (void *)c;
}
static int ps_ready = 0;
static wxPrintSetupData *orig_ps_setup;
wxPrintSetupData *wxGetThePrintSetupData()
{
if (ps_ready) {
Scheme_Object *o;
o = scheme_get_param(scheme_current_config(), mred_ps_setup_param);
if (o && SCHEME_TRUEP(o))
return wxsUnbundlePSSetup(o);
}
return orig_ps_setup;
}
void wxSetThePrintSetupData(wxPrintSetupData *d)
{
if (ps_ready) {
Scheme_Object *o;
o = wxsBundlePSSetup(d);
scheme_set_param(scheme_current_config(), mred_ps_setup_param, o);
}
orig_ps_setup = d;
}
/* Forward decl: */
static int MrEdSameContext(MrEdContext *c, MrEdContext *testc);
static void destroy_wxObject(wxWindow *w, void *)
{
if (w->__gc_external) {
objscheme_destroy(w, (Scheme_Object *)w->__gc_external);
((Scheme_Class_Object *)w->__gc_external)->primflag = -2; /* -2 => shutdown */
w->__gc_external = NULL;
}
}
static void kill_eventspace(Scheme_Object *ec, void *)
{
MrEdContext *c;
c = WEAKIFIED(((Context_Custodian_Hop *)ec)->context);
if (!c)
return; /* must not have had any frames, timers, etc. */
{
wxClipboardClient *clipOwner;
clipOwner = wxTheClipboard->GetClipboardClient();
if (clipOwner && (clipOwner->context == c))
wxTheClipboard->SetClipboardString("", 0);
}
c->killed = 1;
{
wxChildNode *node, *next;
for (node = c->topLevelWindowList->First(); node; node = next) {
wxWindow *w;
w = (wxWindow *)node->Data();
next = node->Next();
if (w) {
w->ForEach(destroy_wxObject, NULL);
if (node->IsShown())
w->Show(FALSE);
}
}
}
{
wxTimer *t;
while (c->timers) {
t = c->timers;
t->Stop();
}
}
remove_q_callbacks(c);
}
static Scheme_Object *extract_eventspace_from_hop(Scheme_Object *ec)
{
return (Scheme_Object *)WEAKIFIED(((Context_Custodian_Hop *)ec)->context);
}
static void CollectingContext(void *cfx, void *)
{
wxChildNode *cnode, *next;
MrEdFinalizedContext *cf;
cf = (MrEdFinalizedContext *)gcPTR_TO_OBJ(cfx);
if (cf->frames->next)
FRAMES_REF(cf->frames->next)->prev = cf->frames->prev;
if (cf->frames->prev)
FRAMES_REF(cf->frames->prev)->next = cf->frames->next;
else
mred_frames = cf->frames->next;
cf->frames->next = NULL;
cf->frames->prev = NULL;
/* Must explicitly delete frames now because their context
is going away. (The frame would certainly have been finalized
later during this set of finalizations, but that would be
too late.) */
for (cnode = cf->frames->list->First(); cnode; cnode = next) {
wxFrame *fr;
next = cnode->Next();
fr = (wxFrame *)cnode->Data();
if (fr) {
DELETE_OBJ fr;
}
}
MrEdDestroyContext(cf);
DELETE_OBJ cf->frames->list;
cf->frames = NULL;
}
static MrEdContext *MakeContext(MrEdContext *c)
{
MrEdContextFrames *frames;
Context_Custodian_Hop *mr_hop;
Scheme_Object *break_cell;
Scheme_Config *config;
Scheme_Thread_Cell_Table *cells;
scheme_custodian_check_available(NULL, "make-eventspace", "eventspace");
if (!c) {
wxChildList *tlwl;
wxStandardSnipClassList *scl;
wxBufferDataClassList *bdcl;
MrEdFinalizedContext *fc;
c = (MrEdContext *)scheme_malloc_tagged(sizeof(MrEdContext));
c->so.type = mred_eventspace_type;
tlwl = new WXGC_PTRS wxChildList();
c->topLevelWindowList = tlwl;
scl = wxMakeTheSnipClassList();
c->snipClassList = scl;
bdcl = wxMakeTheBufferDataClassList();
c->bufferDataClassList = bdcl;
fc = new WXGC_PTRS MrEdFinalizedContext;
c->finalized = fc;
}
c->ready = 1;
c->handler_running = NULL;
c->busyState = 0;
c->killed = 0;
frames = new WXGC_PTRS MrEdContextFrames;
c->finalized->frames = frames;
frames->next = mred_frames;
frames->prev = NULL;
frames->list = c->topLevelWindowList;
{
MrEdContextFramesRef r;
r = MAKE_FRAMES_REF(frames);
if (mred_frames)
FRAMES_REF(mred_frames)->prev = r;
mred_frames = r;
}
c->modal_window = NULL;
config = scheme_extend_config(scheme_current_config(),
mred_eventspace_param,
(Scheme_Object *)c);
c->main_config = config;
cells = scheme_inherit_cells(NULL);
c->main_cells = cells;
break_cell = scheme_current_break_cell();
c->main_break_cell = break_cell;
#ifdef MZ_PRECISE_GC
/* Override destructor-based finalizer: */
GC_set_finalizer(gcOBJ_TO_PTR(c->finalized),
0, 3,
CollectingContext, NULL,
NULL, NULL);
#else
scheme_register_finalizer(gcOBJ_TO_PTR(c->finalized),
CAST_GCP CollectingContext, NULL,
NULL, NULL);
#endif
WXGC_IGNORE(c, c->finalized);
#ifdef MZ_PRECISE_GC
mr_hop = (Context_Custodian_Hop *)GC_malloc_one_tagged(sizeof(Context_Custodian_Hop));
#else
mr_hop = (Context_Custodian_Hop *)scheme_malloc_atomic(sizeof(Context_Custodian_Hop));
#endif
mr_hop->so.type = mred_eventspace_hop_type;
{
MrEdContext *ctx;
ctx = WEAKIFY(c);
mr_hop->context = ctx;
}
c->mr_hop = mr_hop;
#ifndef MZ_PRECISE_GC
scheme_weak_reference((void **)(void *)&mr_hop->context);
#endif
{
Scheme_Custodian_Reference *mr;
mr = scheme_add_managed(NULL, (Scheme_Object *)mr_hop,
CAST_SCCC kill_eventspace,
NULL, 0);
c->mref = mr;
}
return c;
}
static void ChainContextsList()
{
MrEdContextFrames *f;
MrEdContextFramesRef fr = mred_frames;
wxChildNode *first;
mred_contexts = NULL;
while (fr) {
f = FRAMES_REF(fr);
first = f->list->First();
#if 0
while (first && !first->IsShown())
first = first->Next();
#endif
if (first) {
wxObject *o;
MrEdContext *c;
o = first->Data();
c = MrEdGetContext(o);
c->next = mred_contexts;
mred_contexts = c;
}
fr = f->next;
}
}
static void UnchainContextsList()
{
while (mred_contexts) {
MrEdContext *next = mred_contexts->next;
mred_contexts->next = NULL;
mred_contexts = next;
}
}
static wxTimer *GlobalFirstTimer()
{
wxTimer *timer = NULL;
int i;
for (i = timer_contexts->size; i--; ) {
if (timer_contexts->vals[i]) {
MrEdContext *c = (MrEdContext *)timer_contexts->keys[i];
if (c->ready && c->timers) {
if (!timer)
timer = c->timers;
else if (c->timers->expiration < timer->expiration)
timer = c->timers;
}
}
}
return timer;
}
#ifdef wx_xt
void wxUnhideAllCursors()
{
MrEdContextFrames *f;
MrEdContextFramesRef fr = mred_frames;
wxChildNode *first;
int v;
if (wxCheckHiddenCursors()) {
while (fr) {
f = FRAMES_REF(fr);
first = f->list->First();
if (first) {
wxObject *o;
MrEdContext *c;
o = first->Data();
c = MrEdGetContext(o);
v = wxUnhideCursorInFrame(o, c->busyState);
c->busyState = v;
}
fr = f->next;
}
}
}
#endif
Scheme_Object *MrEdMakeEventspace()
{
MrEdContext *c;
c = MakeContext(NULL);
MrEdInitNewContext(c);
return (Scheme_Object *)c;
}
Scheme_Object *MrEdEventspaceThread(Scheme_Object *e)
{
return (Scheme_Object *)((MrEdContext *)e)->handler_running;
}
Scheme_Object *MrEdGetFrameList(void)
{
MrEdContext *c;
Scheme_Object *l = scheme_null;
c = MrEdGetContext();
if (c) {
wxChildNode *node;
for (node = c->topLevelWindowList->First(); node; node = node->Next()) {
wxObject *o;
o = node->Data();
if (node->IsShown()) {
#ifdef wx_mac
/* Mac: some frames really represent dialogs. Any modal frame is
a dialog, so extract its only child. */
if (((wxFrame *)o)->IsModal()) {
wxChildNode *node2;
wxChildList *cl;
cl = ((wxFrame *)o)->GetChildren();
node2 = cl->First();
if (node2)
o = node2->Data();
}
#endif
l = scheme_make_pair(objscheme_bundle_wxObject(o), l);
}
}
}
return l;
}
void *MrEdForEachFrame(ForEachFrameProc fp, void *data)
{
MrEdContextFrames *f;
MrEdContextFramesRef fr = mred_frames;
wxChildNode *node;
while (fr) {
f = FRAMES_REF(fr);
node = f->list->First();
while (node) {
if (node->IsShown()) {
wxObject *o;
o = node->Data();
#ifdef wx_mac
/* Mac: some frames really represent dialogs. Any modal frame is
a dialog, so extract its only child. */
if (((wxFrame *)o)->IsModal()) {
wxChildNode *node2;
wxChildList *cl;
cl = ((wxFrame *)o)->GetChildren();
node2 = cl->First();
if (node2)
o = node2->Data();
}
#endif
data = fp(o, data);
}
node = node->Next();
}
fr = f->next;
}
return data;
}
static int check_eventspace_inactive(void *_c)
{
MrEdContext *c = (MrEdContext *)_c;
if (c->nested_avail)
return 0;
/* Any callbacks prepared for this eventspace? */
if (check_q_callbacks(0, MrEdSameContext, c, 1)
|| check_q_callbacks(1, MrEdSameContext, c, 1)
|| check_q_callbacks(2, MrEdSameContext, c, 1))
return 0;
/* Any running timers for the eventspace? */
if (c->timers)
return 0;
/* Any top-level windows visible in this eventspace */
{
MrEdContextFrames *f = c->finalized->frames;
wxChildNode *node;
node = f->list->First();
while (node) {
if (node->IsShown()) {
return 0;
}
node = node->Next();
}
}
return 1;
}
void mred_wait_eventspace(void)
{
MrEdContext *c;
c = MrEdGetContext();
if (c && (c->handler_running == scheme_current_thread)) {
wxDispatchEventsUntilWaitable(check_eventspace_inactive, c, NULL);
}
}
int mred_current_thread_is_handler(void *ctx)
{
if (!ctx)
ctx = MrEdGetContext();
return (((MrEdContext *)ctx)->handler_running == scheme_current_thread);
}
int mred_in_restricted_context()
{
#ifdef NEED_HET_PARAM
/* see wxHiEventTrampoline for info on mred_het_key: */
Scheme_Object *v;
if (!scheme_current_thread)
return 1;
if (mred_het_key)
v = scheme_extract_one_cc_mark(NULL, mred_het_key);
else
v = NULL;
if (v && SCHEME_BOX_VAL(v))
return 1;
#endif
return 0;
}
/****************************************************************************/
/* Events */
/****************************************************************************/
static wxTimer *TimerReady(MrEdContext *c)
{
wxTimer *timer;
if (c) {
timer = c->timers;
} else {
timer = GlobalFirstTimer();
}
if (timer) {
double now;
double goal = timer->expiration;
now = scheme_get_inexact_milliseconds();
return ((now >= goal)
? timer
: (wxTimer *)NULL);
} else
return NULL;
}
static void DoTimer(wxTimer *timer)
{
int once;
mz_jmp_buf *save, newbuf;
if (timer->interval == -1)
return;
once = timer->one_shot;
timer->one_shot = -1;
save = scheme_current_thread->error_buf;
scheme_current_thread->error_buf = &newbuf;
if (!scheme_setjmp(newbuf))
timer->Notify();
scheme_clear_escape();
scheme_current_thread->error_buf = save;
if (!once && (timer->one_shot == -1) && (timer->interval != -1)
&& !((MrEdContext *)timer->context)->killed)
timer->Start(timer->interval, FALSE);
}
static int do_check_for_nested_event(Scheme_Object *cx)
{
MrEdContext *c = (MrEdContext *)cx;
if (!c->waiting_for_nested)
return 1;
if (c->alternate) {
if (c->alternate(c->alt_data))
return 1;
return 0;
} else
return 0;
}
static int check_for_nested_event(Scheme_Object *cx)
{
return do_check_for_nested_event(((Nested_Wait *)cx)->wait_on);
}
static int MrEdSameContext(MrEdContext *c, MrEdContext *testc)
{
return (c == testc);
}
static void GoAhead(MrEdContext *c)
{
c->ready_to_go = 0;
if (c->q_callback) {
int hi = (c->q_callback - 1);
c->q_callback = 0;
(void)check_q_callbacks(hi, MrEdSameContext, c, 0);
} else if (c->timer) {
wxTimer *timer;
timer = c->timer;
c->timer = NULL;
DoTimer(timer);
} else {
GC_CAN_IGNORE MrEdEvent e;
mz_jmp_buf *save, newbuf;
memcpy(&e, &c->event, sizeof(MrEdEvent));
save = scheme_current_thread->error_buf;
scheme_current_thread->error_buf = &newbuf;
if (!scheme_setjmp(newbuf))
MrEdDispatchEvent(&e);
scheme_clear_escape();
scheme_current_thread->error_buf = save;
}
}
static Scheme_Object *def_event_dispatch_handler(int argc, Scheme_Object *argv[])
{
MrEdContext *c;
c = (MrEdContext *)argv[0];
if (!SAME_TYPE(SCHEME_TYPE(argv[0]), mred_eventspace_type)
|| !c->ready_to_go) {
scheme_wrong_type("default-event-dispatch-handler",
"eventspace (with ready event)",
0, argc, argv);
return NULL;
}
GoAhead(c);
return scheme_void;
}
static void DoTheEvent(MrEdContext *c)
{
Scheme_Object *p;
c->ready_to_go = 1;
p = scheme_get_param(scheme_current_config(), mred_event_dispatch_param);
if (p != def_dispatch) {
Scheme_Object *a[1];
mz_jmp_buf *save, newbuf;
a[0] = (Scheme_Object *)c;
save = scheme_current_thread->error_buf;
scheme_current_thread->error_buf = &newbuf;
if (!scheme_setjmp(newbuf))
scheme_apply_multi(p, 1, a);
scheme_clear_escape();
scheme_current_thread->error_buf = save;
#if 0
if (c->ready_to_go)
printf("Bad dispatcher\n");
#endif
}
if (c->ready_to_go)
GoAhead(c);
}
static void reset_nested_wait(MrEdContext *c)
{
c->ready = 0;
c->waiting_for_nested = 0;
c->alternate = NULL;
c->alt_data = NULL;
}
static Scheme_Object *MrEdDoNextEvent(MrEdContext *c, wxDispatch_Check_Fun alt, void *altdata, Scheme_Object *alt_wait)
{
wxTimer *timer;
GC_CAN_IGNORE MrEdEvent evt;
int restricted = 0;
#ifdef NEED_HET_PARAM
/* see wxHiEventTrampoline for info on mred_het_key: */
if (mred_in_restricted_context())
restricted = 1;
#endif
if (alt) {
if (alt(altdata)) {
/* Do nothing, since alt fired. */
return scheme_void;
}
}
if (alt_wait) {
Scheme_Object *a[2], *r;
a[0] = scheme_make_integer(0);
a[1] = alt_wait;
r = scheme_sync_timeout(2, a);
if (r) {
/* Do nothing, since alt fired. */
return r;
}
}
if (c->nested_avail) {
c->nested_avail = 0;
DoTheEvent(c);
} else if (check_q_callbacks(2, MrEdSameContext, c, 1)) {
c->q_callback = 3;
DoTheEvent(c);
} else if ((timer = TimerReady(c))) {
timer->Dequeue();
c->timer = timer;
DoTheEvent(c);
} else if (check_q_callbacks(1, MrEdSameContext, c, 1)) {
c->q_callback = 2;
DoTheEvent(c);
} else if (!restricted && MrEdGetNextEvent(0, 1, &evt, NULL)) {
memcpy(&c->event, &evt, sizeof(MrEdEvent));
DoTheEvent(c);
#ifdef wx_mac
/* MrEdGetNextEvent might enqueue */
} else if (check_q_callbacks(1, MrEdSameContext, c, 1)) {
c->q_callback = 2;
DoTheEvent(c);
#endif
} else if (!restricted && check_q_callbacks(0, MrEdSameContext, c, 1)) {
c->q_callback = 1;
DoTheEvent(c);
} else if (c != mred_main_context) {
Scheme_Object *result = NULL;
c->ready = 1;
c->waiting_for_nested = 1;
c->alternate = alt;
c->alt_data = altdata;
if (alt_wait) {
Nested_Wait *nw;
Scheme_Object *a[2], *v = NULL;
nw = (Nested_Wait *)scheme_malloc_tagged(sizeof(Nested_Wait));
nw->so.type = mred_nested_wait_type;
nw->wait_on = (Scheme_Object *)c;
a[0] = alt_wait;
a[1] = (Scheme_Object *)nw;
/* Running arbitrary Scheme code here. */
BEGIN_ESCAPEABLE(reset_nested_wait, c);
v = scheme_sync(2, a);
END_ESCAPEABLE();
if (!SAME_OBJ(v, a[1]))
result = v;
} else {
scheme_block_until((Scheme_Ready_Fun)do_check_for_nested_event, NULL,
(Scheme_Object *)c, 0.0);
}
c->alternate = NULL;
c->alt_data = NULL;
if (c->waiting_for_nested) {
/* Alternate condition fired. Clear waiting flag. */
c->ready = 0;
c->waiting_for_nested = 0;
if (!result)
result = scheme_void;
}
return result;
}
return NULL;
}
void wxDoNextEvent()
{
MrEdContext *c;
c = MrEdGetContext();
if (!c->ready_to_go)
if (c->handler_running == scheme_current_thread)
MrEdDoNextEvent(c, NULL, NULL, NULL);
}
int MrEdEventReady(MrEdContext *c)
{
int restricted = 0;
#ifdef NEED_HET_PARAM
/* see wxHiEventTrampoline for info on mred_het_key: */
if (mred_in_restricted_context())
restricted = 1;
#endif
return (c->nested_avail
|| TimerReady(c)
|| (!restricted && MrEdGetNextEvent(1, 1, NULL, NULL))
|| (!restricted && check_q_callbacks(2, MrEdSameContext, c, 1))
|| check_q_callbacks(1, MrEdSameContext, c, 1)
|| check_q_callbacks(0, MrEdSameContext, c, 1));
}
int wxEventReady()
{
MrEdContext *c;
c = MrEdGetContext();
return (!c->ready_to_go
&& (c->handler_running == scheme_current_thread)
&& MrEdEventReady(c));
}
static void WaitForAnEvent_OrDie(MrEdContext *c)
{
c->ready = 1;
c->waiting_for_nested = 1;
c->alternate = NULL;
c->alt_data = NULL;
/* Suspend the thread. If another event is found for the eventspace, the
thread will be resumed. */
c->suspended = 1;
while (1) {
scheme_weak_suspend_thread(c->handler_running); /* suspend self */
if (c->waiting_for_nested) {
/* we were resumed for a break signal, or some such: */
c->suspended = 0;
c->ready = 0;
c->waiting_for_nested = 0;
scheme_thread_block(0);
scheme_current_thread->ran_some = 1;
/* Go back to sleep: */
c->ready = 1;
c->waiting_for_nested = 1;
c->suspended = 1;
} else
break;
}
/* An event has been found. Do it. */
c->nested_avail = 0;
DoTheEvent(c);
/* Return to loop and look for more events... */
}
static void on_handler_killed(Scheme_Thread *p)
{
MrEdContext *c = (MrEdContext *)p->kill_data;
p->on_kill = NULL;
p->kill_data = NULL;
/* The thread is forever not ready: */
c->handler_running = NULL;
c->ready = 0;
c->waiting_for_nested = 0;
c->nested_avail = 0;
c->q_callback = 0;
c->timer = NULL;
c->alternate = NULL;
c->alt_data = NULL;
c->ready_to_go = 0;
}
static Scheme_Object *handle_events(void *cx, int, Scheme_Object **)
{
MrEdContext *c = (MrEdContext *)cx;
Scheme_Thread *this_thread;
mz_jmp_buf newbuf;
#if SGC_STD_DEBUGGING
fprintf(stderr, "new thread\n");
#endif
this_thread = scheme_current_thread;
if (!this_thread->name) {
Scheme_Object *tn;
tn = scheme_intern_symbol("handler");
this_thread->name = tn;
}
c->handler_running = this_thread;
this_thread->on_kill = CAST_TOK on_handler_killed;
this_thread->kill_data = c;
c->suspended = 0;
c->ready = 0;
scheme_current_thread->error_buf = &newbuf;
if (!scheme_setjmp(newbuf)) {
if (!TheMrEdApp->initialized)
TheMrEdApp->RealInit();
else {
DoTheEvent(c);
while(1) {
while (MrEdEventReady(c)) {
MrEdDoNextEvent(c, NULL, NULL, NULL);
}
WaitForAnEvent_OrDie(c);
}
}
}
/* We should never get here. */
#if 0
c->ready = 1;
c->handler_running = NULL;
this_thread->on_kill = NULL;
this_thread->kill_data = NULL;
#endif
return scheme_void;
}
static int MrEdContextReady(MrEdContext *, MrEdContext *c)
{
return ((MrEdContext *)c)->ready;
}
static void event_found(MrEdContext *c)
{
if (c->killed)
return;
c->ready = 0;
if (c->waiting_for_nested) {
c->waiting_for_nested = 0;
c->nested_avail = 1;
if (c->suspended) {
c->suspended = 0;
scheme_weak_resume_thread(c->handler_running);
}
} else {
Scheme_Object *cp, *cust;
cp = scheme_make_closed_prim(CAST_SCP handle_events, c);
cust = scheme_get_thread_param(c->main_config, c->main_cells, MZCONFIG_CUSTODIAN);
scheme_thread_w_details(cp, c->main_config, c->main_cells, c->main_break_cell, (Scheme_Custodian *)cust, 0);
}
}
static int try_q_callback(Scheme_Object *do_it, int hi)
{
MrEdContext *c;
if ((c = check_q_callbacks(hi, MrEdContextReady, NULL, 1))) {
if (!do_it)
return 1;
if (SCHEME_FALSEP(do_it))
scheme_current_thread->ran_some = 1;
if (c == mred_main_context)
check_q_callbacks(hi, MrEdSameContext, c, 0);
else {
c->q_callback = 1 + hi;
event_found(c);
}
return 1;
}
return 0;
}
static int try_dispatch(Scheme_Object *do_it)
{
MrEdContext *c;
GC_CAN_IGNORE MrEdEvent e;
wxTimer *timer;
int got_one;
if (try_q_callback(do_it, 2))
return 1;
timer = TimerReady(NULL);
if (timer) {
if (!do_it)
return 1;
if (SCHEME_FALSEP(do_it))
scheme_current_thread->ran_some = 1;
c = (MrEdContext *)timer->context;
timer->Dequeue();
if (c == mred_main_context)
timer->Notify();
else {
c->timer = timer;
event_found(c);
}
return 1;
}
if (try_q_callback(do_it, 1))
return 1;
ChainContextsList();
got_one = MrEdGetNextEvent(!do_it, 0, &e, &c);
UnchainContextsList();
#ifdef wx_mac
/* MrEdGetNextEvent might enqueue */
if (try_q_callback(do_it, 1))
return 1;
#endif
if (got_one) {
if (!do_it)
return 1;
if (SCHEME_FALSEP(do_it))
scheme_current_thread->ran_some = 1;
if (c) {
memcpy(&c->event, &e, sizeof(MrEdEvent));
event_found(c);
} else {
/* Event with unknown context: */
MrEdDispatchEvent(&e);
}
return 1;
}
if (try_q_callback(do_it, 0))
return 1;
return 0;
}
static void wakeup_on_dispatch(Scheme_Object *, void *fds)
{
#ifdef wx_x
Display *d = XtDisplay(mred_main_context->finalized->toplevel);
int fd;
fd = ConnectionNumber(d);
MZ_FD_SET(fd, (fd_set *)fds);
#endif
}
static int check_initialized(Scheme_Object *)
{
return TheMrEdApp->initialized;
}
# define KEEP_GOING wxTheApp->keep_going
#if WINDOW_STDIO
static Scheme_Custodian *main_custodian;
#endif
void wxDoEvents()
{
/* When we get here, we are in the main dispatcher thread */
if (!TheMrEdApp->initialized) {
MrEdContext *c;
#if WINDOW_STDIO
Scheme_Custodian *m, *oldm = NULL;
Scheme_Config *config = NULL;
if (!wx_in_terminal) {
config = scheme_current_config();
oldm = (Scheme_Custodian *)scheme_get_param(config, MZCONFIG_CUSTODIAN);
m = scheme_make_custodian(oldm);
scheme_set_param(config, MZCONFIG_CUSTODIAN, (Scheme_Object *)m);
wxREGGLOB(main_custodian);
main_custodian = m;
}
#endif
/* Create the user's main thread: */
c = (MrEdContext *)MrEdMakeEventspace();
wxREGGLOB(user_main_context);
user_main_context = c;
{
Scheme_Object *cp;
cp = scheme_make_closed_prim(CAST_SCP handle_events, c);
wxREGGLOB(user_main_thread);
user_main_thread = (Scheme_Thread *)scheme_thread_w_details(cp,
c->main_config,
c->main_cells,
c->main_break_cell,
NULL, 0);
cp = scheme_intern_symbol("mred");
user_main_thread->name = cp;
}
#if WINDOW_STDIO
if (!wx_in_terminal)
scheme_set_param(config, MZCONFIG_CUSTODIAN, (Scheme_Object *)oldm);
#endif
/* Block until the user's main thread is initialized: */
scheme_block_until(CAST_BLKCHK check_initialized, NULL, NULL, 0.0);
}
if (!try_dispatch(scheme_true)) {
do {
scheme_current_thread->block_descriptor = -1;
scheme_current_thread->blocker = NULL;
scheme_current_thread->block_check = CAST_BLKCHK try_dispatch;
scheme_current_thread->block_needs_wakeup = CAST_WU wakeup_on_dispatch;
scheme_thread_block(0);
scheme_current_thread->block_descriptor = 0;
/* Sets ran_some if it succeeds: */
if (try_dispatch(scheme_false))
break;
} while (KEEP_GOING);
}
}
Scheme_Object *wxDispatchEventsUntilWaitable(wxDispatch_Check_Fun f, void *data, Scheme_Object *w)
{
MrEdContext *c;
Scheme_Object *result = scheme_void;
c = MrEdGetContext();
#ifdef wx_mac
wxMouseEventHandled();
#endif
if (c->ready_to_go
|| (c->handler_running != scheme_current_thread)) {
/* This is not the handler thread or an event still hasn't been
dispatched. Wait. */
if (w) {
Scheme_Object *a[1];
a[0] = w;
result = scheme_sync(1, a);
} else {
scheme_block_until((Scheme_Ready_Fun)f, NULL, (Scheme_Object *)data, 0.0);
}
} else {
/* This is the main thread. Handle events */
do {
result = MrEdDoNextEvent(c, f, data, w);
if (result)
break;
} while (1);
}
return result;
}
void wxDispatchEventsUntil(wxDispatch_Check_Fun f, void *data)
{
wxDispatchEventsUntilWaitable(f, data, NULL);
}
void wxBlockUntil(wxDispatch_Check_Fun f, void *data)
{
scheme_block_until((Scheme_Ready_Fun)f, NULL, (Scheme_Object *)data, 0.0);
}
void wxBlockUntilTimeout(wxDispatch_Check_Fun f, void *data, float timeout)
{
scheme_block_until((Scheme_Ready_Fun)f, NULL, (Scheme_Object *)data, timeout);
}
static SLEEP_PROC_PTR mzsleep;
static void MrEdSleep(float secs, void *fds)
{
double now;
#ifdef NEVER_EVER_SLEEP
return;
#endif
if (!(KEEP_GOING))
return;
now = scheme_get_inexact_milliseconds();
{
wxTimer *timer;
timer = GlobalFirstTimer();
if (timer) {
double done = timer->expiration;
double diff = done - now;
diff /= 1000;
if (diff <= 0)
secs = (float)0.00001;
else if (!secs || (secs > diff))
secs = (float)diff;
}
}
#ifdef wx_msw
MrEdMSWSleep(secs, fds);
#else
# ifdef wx_mac
MrEdMacSleep(secs, fds, mzsleep);
# else
mzsleep(secs, fds);
# endif
#endif
}
#ifdef mred_BREAK_HANDLER
static void user_break_hit(int ignore)
{
scheme_break_thread(user_main_thread);
scheme_signal_received();
# ifdef SIGSET_NEEDS_REINSTALL
MZ_SIGSET(SIGINT, user_break_hit);
# endif
# ifdef MZ_PRECISE_GC
# ifndef GC_STACK_CALLEE_RESTORE
/* Restore variable stack. */
GC_variable_stack = (void **)__gc_var_stack__[0];
# endif
# endif
}
#endif
/****************************************************************************/
/* wxTimer */
/****************************************************************************/
wxTimer::wxTimer(void *ctx)
#ifdef wx_xt
: wxObject(WXGC_NO_CLEANUP)
#endif
{
__type = wxTYPE_TIMER;
next = prev = NULL;
if (!ctx)
ctx = (void *)MrEdGetContext();
context = ctx;
}
wxTimer::~wxTimer(void)
{
}
void wxTimer::SetContext(void *ctx)
{
context = ctx;
}
Bool wxTimer::Start(int millisec, Bool _one_shot)
{
double now;
if (prev || next || (((MrEdContext *)context)->timers == this))
return FALSE;
if (((MrEdContext *)context)->killed)
scheme_signal_error("start in timer%%: the current eventspace has been shutdown");
interval = millisec;
if (interval <= 0)
interval = 1;
one_shot = !!_one_shot;
now = scheme_get_inexact_milliseconds();
expiration = now + interval;
if (((MrEdContext *)context)->timers) {
wxTimer *t = ((MrEdContext *)context)->timers;
while (1) {
int later;
later = (expiration >= t->expiration);
if (!later) {
prev = t->prev;
t->prev = this;
next = t;
if (prev)
prev->next = this;
else
((MrEdContext *)context)->timers = this;
return TRUE;
}
if (!t->next) {
t->next = this;
prev = t;
return TRUE;
}
t = t->next;
}
} else {
((MrEdContext *)context)->timers = this;
scheme_hash_set(timer_contexts, (Scheme_Object *)context, scheme_true);
}
return TRUE;
}
void wxTimer::Dequeue(void)
{
if (!prev) {
if (((MrEdContext *)context)->timers == this) {
((MrEdContext *)context)->timers = next;
if (!next)
scheme_hash_set(timer_contexts, (Scheme_Object *)context, NULL);
}
}
if (prev)
prev->next = next;
if (next)
next->prev = prev;
next = prev = NULL;
}
void wxTimer::Stop(void)
{
Dequeue();
interval = -1;
}
/****************************************************************************/
/* Callbacks */
/****************************************************************************/
typedef struct Q_Callback {
/* MZ_PRECISE_GC: allocation relies on this struct as the same as
array of pointers: */
MrEdContext *context;
Scheme_Object *callback;
struct Q_Callback *prev;
struct Q_Callback *next;
} Q_Callback;
typedef struct {
/* Collection relies on this struct as the same as array of
pointers: */
Q_Callback *first;
Q_Callback *last;
} Q_Callback_Set;
static Q_Callback_Set q_callbacks[3];
static void insert_q_callback(Q_Callback_Set *cs, Q_Callback *cb)
{
/* This can happen under Windows, for example,
due to an on-paint queue attempt: */
if (cb->context->killed)
return;
cb->next = NULL;
cb->prev = cs->last;
cs->last = cb;
if (cb->prev)
cb->prev->next = cb;
else
cs->first = cb;
}
static void remove_q_callback(Q_Callback_Set *cs, Q_Callback *cb)
{
if (cb->prev)
cb->prev->next = cb->next;
else
cs->first = cb->next;
if (cb->next)
cb->next->prev = cb->prev;
else
cs->last = cb->prev;
cb->next = NULL;
cb->prev = NULL;
}
static void call_one_callback(Q_Callback * volatile cb)
{
mz_jmp_buf *save, newbuf;
save = scheme_current_thread->error_buf;
scheme_current_thread->error_buf = &newbuf;
if (!scheme_setjmp(newbuf))
scheme_apply_multi(cb->callback, 0, NULL);
scheme_clear_escape();
scheme_current_thread->error_buf = save;
}
static MrEdContext *check_q_callbacks(int hi, int (*test)(MrEdContext *, MrEdContext *),
MrEdContext *tdata, int check_only)
{
Q_Callback_Set *cs = q_callbacks + hi;
Q_Callback *cb;
cb = cs->first;
while (cb) {
if (test(tdata, cb->context)) {
if (check_only)
return cb->context;
remove_q_callback(cs, cb);
call_one_callback(cb);
return cb->context;
}
cb = cb->next;
}
return NULL;
}
static void remove_q_callbacks(MrEdContext *c)
{
Q_Callback_Set *cs;
Q_Callback *cb, *next;
int i;
for (i = 0; i < 3; i++) {
cs = q_callbacks + i;
for (cb = cs->first; cb; cb = next) {
next = cb->next;
if (cb->context == c)
remove_q_callback(cs, cb);
}
}
}
Scheme_Object *MrEd_mid_queue_key;
void MrEd_add_q_callback(char *who, int argc, Scheme_Object **argv)
{
MrEdContext *c;
Q_Callback_Set *cs;
Q_Callback *cb;
int hi;
scheme_check_proc_arity(who, 0, 0, argc, argv);
c = (MrEdContext *)wxsCheckEventspace("queue-callback");
if (argc > 1) {
if (argv[1] == MrEd_mid_queue_key)
hi = 1;
else
hi = (SCHEME_TRUEP(argv[1]) ? 2 : 0);
} else
hi = 2;
cs = q_callbacks + hi;
cb = (Q_Callback*)scheme_malloc(sizeof(Q_Callback));
cb->context = c;
cb->callback = argv[0];
insert_q_callback(cs, cb);
}
#if defined(wx_msw) || defined(wx_mac)
static void MrEdQueueWindowCallback(wxWindow *wx_window, Scheme_Closed_Prim *scp, void *data)
{
MrEdContext *c;
Q_Callback *cb;
Scheme_Object *p;
if (!scheme_current_thread) {
/* Scheme hasn't started yet, so call directly.
We might get here for an update to the stdio
window, for example. */
scp(data, 0, NULL);
return;
}
#ifdef wx_mac
c = MrEdGetContext(wx_window->GetRootFrame());
#else
c = MrEdGetContext();
#endif
/* Search for existing queued on-paint: */
cb = q_callbacks[1].last;
while (cb) {
if (cb->context == c) {
if (SCHEME_CLSD_PRIMP(cb->callback)) {
Scheme_Closed_Primitive_Proc *prim;
prim = (Scheme_Closed_Primitive_Proc *)cb->callback;
if ((prim->data == wx_window)
&& (prim->prim_val == scp)) {
/* on-paint already queued */
return;
}
}
}
cb = cb->prev;
}
p = scheme_make_closed_prim(scp, data);
cb = (Q_Callback*)scheme_malloc(sizeof(Q_Callback));
cb->context = c;
cb->callback = p;
insert_q_callback(q_callbacks + 1, cb);
#ifdef wx_mac
WakeUpMrEd();
#endif
}
static Scheme_Object *call_on_paint(void *d, int, Scheme_Object **argv)
{
wxWindow *w = (wxWindow *)d;
#ifdef wx_msw
w->OnPaint();
#else
((wxCanvas *)w)->DoPaint();
#endif
return scheme_void;
}
void MrEdQueuePaint(wxWindow *wx_window)
{
MrEdQueueWindowCallback(wx_window, CAST_SCP call_on_paint, wx_window);
}
static Scheme_Object *call_close(void *d, int, Scheme_Object **argv)
{
wxFrame *w = (wxFrame *)d;
if (w->OnClose())
w->Show(FALSE);
return scheme_void;
}
void MrEdQueueClose(wxWindow *wx_window)
{
MrEdQueueWindowCallback(wx_window, CAST_SCP call_close, wx_window);
}
static Scheme_Object *call_zoom(void *d, int, Scheme_Object **argv)
{
wxFrame *w = (wxFrame *)d;
w->Maximize(2);
return scheme_void;
}
void MrEdQueueZoom(wxWindow *wx_window)
{
MrEdQueueWindowCallback(wx_window, CAST_SCP call_zoom, wx_window);
}
static Scheme_Object *call_toolbar(void *d, int, Scheme_Object **argv)
{
wxFrame *w = (wxFrame *)d;
w->OnToolbarButton();
return scheme_void;
}
void MrEdQueueToolbar(wxWindow *wx_window)
{
MrEdQueueWindowCallback(wx_window, CAST_SCP call_toolbar, wx_window);
}
static Scheme_Object *call_on_size(void *d, int, Scheme_Object **argv)
{
wxWindow *w = (wxWindow *)d;
w->OnSize(-1, -1);
return scheme_void;
}
void MrEdQueueOnSize(wxWindow *wx_window)
{
MrEdQueueWindowCallback(wx_window, CAST_SCP call_on_size, wx_window);
}
# ifdef wx_mac
static Scheme_Object *call_unfocus(void *d, int, Scheme_Object **argv)
{
wxFrame *w = (wxFrame *)d;
w->Unfocus();
return scheme_void;
}
void MrEdQueueUnfocus(wxWindow *wx_window)
{
MrEdQueueWindowCallback(wx_window, CAST_SCP call_unfocus, wx_window);
}
static Scheme_Object *call_drop(void *d, int, Scheme_Object **argv)
{
wxWindow *w = (wxWindow *)SCHEME_CAR((Scheme_Object *)d);
char *s = (char *)SCHEME_CDR((Scheme_Object *)d);
w->OnDropFile(s);
return scheme_void;
}
void MrEdQueueDrop(wxWindow *wx_window, char *s)
{
MrEdQueueWindowCallback(wx_window, CAST_SCP call_drop,
scheme_make_pair((Scheme_Object *)wx_window, (Scheme_Object *)s));
}
# endif
#endif
static Scheme_Object *call_being_replaced(void *d, int, Scheme_Object **argv)
{
wxClipboardClient *clipOwner = (wxClipboardClient *)d;
clipOwner->BeingReplaced();
return scheme_void;
}
void MrEdQueueBeingReplaced(wxClipboardClient *clipOwner)
{
Scheme_Object *p;
MrEdContext *c = (MrEdContext *)clipOwner->context;
Q_Callback *cb;
if (c) {
clipOwner->context = NULL;
p = scheme_make_closed_prim(CAST_SCP call_being_replaced, clipOwner);
cb = (Q_Callback*)scheme_malloc(sizeof(Q_Callback));
cb->context = c;
cb->callback = p;
insert_q_callback(q_callbacks + 1, cb);
}
}
void MrEdQueueInEventspace(void *context, Scheme_Object *thunk)
{
Q_Callback *cb;
cb = (Q_Callback*)scheme_malloc(sizeof(Q_Callback));
cb->context = (MrEdContext *)context;
cb->callback = thunk;
insert_q_callback(q_callbacks + 1, cb);
}
/****************************************************************************/
/* Redirected Standard I/O */
/****************************************************************************/
#if REDIRECT_STDIO || WINDOW_STDIO || WCONSOLE_STDIO
static void MrEdSchemeMessages(char *, ...);
static Scheme_Object *stdin_pipe;
#endif
#if WINDOW_STDIO
static int have_stdio = 0;
static int stdio_kills_prog = 0;
static Bool RecordInput(void *media, wxEvent *event, void *data);
static Bool SendBreak(void *media, wxEvent *event, void *data);
static void break_console_reading_threads();
static char utf8_leftover[8];
static int utf8_leftover_count;
class IOMediaEdit : public wxMediaEdit
{
public:
Bool CanInsert(long start, long);
Bool CanDelete(long start, long);
};
class IOFrame : public wxFrame
{
public:
wxMediaCanvas *display;
wxMediaEdit *media;
wxMenu *fileMenu;
Bool hidden, beginEditSeq;
int endpos;
IOFrame();
void OnSize(int x, int y);
Bool OnClose(void);
void OnMenuCommand(long id);
Bool PreOnChar(wxWindow *, wxKeyEvent *e);
Bool PreOnEvent(wxWindow *, wxMouseEvent *e);
void CloseIsQuit(void);
};
IOFrame::IOFrame()
: wxFrame(NULL, "Standard Output", -1, -1, 600, 400, 0, "stdout")
{
wxKeymap *km;
wxStyle *style;
wxStyleList *sl;
wxStyleDelta *sd;
wxMenuBar *mb;
wxMenu *m;
display = new WXGC_PTRS wxMediaCanvas(this);
media = new WXGC_PTRS IOMediaEdit();
display->SetMedia(media);
endpos = 0;
hidden = FALSE;
/* Map copy keys: */
km = media->GetKeymap();
media->AddBufferFunctions(km);
media->AddEditorFunctions(km);
km->AddFunction("send-break", SendBreak, NULL);
# ifdef wx_msw
km->MapFunction("c:c", "copy-clipboard");
km->MapFunction("c:x", "copy-clipboard");
km->MapFunction("c:v", "paste-clipboard");
# else
km->MapFunction("d:c", "copy-clipboard");
km->MapFunction("d:x", "copy-clipboard");
km->MapFunction("d:v", "paste-clipboard");
km->MapFunction("d:.", "send-break");
# endif
km->MapFunction("return", "record-input");
km->AddFunction("record-input", RecordInput, NULL);
/* Fixed-width font: */
sl = media->GetStyleList();
style = sl->FindNamedStyle("Standard");
sd = new WXGC_PTRS wxStyleDelta(wxCHANGE_FAMILY, wxMODERN);
style->SetDelta(sd);
#ifdef wx_mac
OnSize(600, 400);
#endif
#ifdef wx_mac
# define CLOSE_MENU_ITEM "Close\tCmd+W"
#else
# define CLOSE_MENU_ITEM "Close"
#endif
mb = new WXGC_PTRS wxMenuBar();
SetMenuBar(mb);
fileMenu = new WXGC_PTRS wxMenu();
fileMenu->Append(77, CLOSE_MENU_ITEM);
m = new WXGC_PTRS wxMenu();
m->Append(79, "&Copy\tCmd+C");
m->Append(81, "&Paste\tCmd+V");
m->AppendSeparator();
m->Append(83, "&Break\tCmd+.");
mb->Append(fileMenu, "File");
mb->Append(m, "Edit");
have_stdio = 1;
Show(TRUE);
beginEditSeq = 0;
}
void IOFrame::OnSize(int x, int y)
{
GetClientSize(&x, &y);
if (display)
display->SetSize(0, 0, x, y);
if (media && (x > 30))
media->SetMaxWidth((float)(x - 30));
}
Bool IOFrame::OnClose(void)
{
hidden = TRUE;
if (stdio_kills_prog) {
if (scheme_exit)
scheme_exit(exit_val);
#ifdef wx_msw
mred_clean_up_gdi_objects();
#endif
scheme_immediate_exit(exit_val);
} else {
break_console_reading_threads();
have_stdio = 0;
}
return TRUE;
}
void IOFrame::OnMenuCommand(long id)
{
if (id == 79)
media->Copy();
else if (id == 81)
media->Paste();
else if (id == 83)
scheme_break_thread(user_main_thread);
else if (id == 77)
if (OnClose())
Show(FALSE);
}
Bool IOFrame::PreOnChar(wxWindow *, wxKeyEvent *e)
{
PreOnEvent(NULL, NULL);
#if defined(wx_mac) && WINDOW_STDIO
if (e->metaDown && e->KeyCode() == (stdio_kills_prog ? 'q' : 'w')) {
OnMenuCommand(77);
return TRUE;
}
#endif
return FALSE;
}
Bool IOFrame::PreOnEvent(wxWindow *, wxMouseEvent *e)
{
if (beginEditSeq) {
beginEditSeq = 0;
media->EndEditSequence();
}
return FALSE;
}
void IOFrame::CloseIsQuit(void)
{
#ifdef wx_mac
# define QUIT_MENU_ITEM "Quit\tCmd+Q"
#else
# define QUIT_MENU_ITEM "E&xit"
#endif
fileMenu->Delete(77);
fileMenu->Append(77, QUIT_MENU_ITEM);
media->Insert("\n[Exited]", media->LastPosition());
if (beginEditSeq) {
beginEditSeq = 0;
media->EndEditSequence();
}
media->Lock(1);
}
static IOFrame *ioFrame = NULL;
Bool IOMediaEdit::CanInsert(long start, long)
{
return (start >= ioFrame->endpos);
}
Bool IOMediaEdit::CanDelete(long start, long)
{
return (start >= ioFrame->endpos);
}
static Bool RecordInput(void *m, wxEvent *event, void *data)
{
char *s;
long len, start;
wxMediaEdit *media = ioFrame->media;
media->Insert("\n");
start = media->GetStartPosition();
len = start - ioFrame->endpos;
s = media->GetTextUTF8(ioFrame->endpos, start);
ioFrame->endpos = start;
scheme_write_byte_string(s, len, stdin_pipe);
return TRUE;
}
static Bool SendBreak(void *m, wxEvent *event, void *data)
{
scheme_break_thread(user_main_thread);
return TRUE;
}
#else /* !WINDOW_STDIO */
#if WCONSOLE_STDIO
static HANDLE console_out;
#else /* !WCONSOLE_STDIO */
#if REDIRECT_STDIO
static FILE *mrerr = NULL;
#else
#define mrerr stderr
#endif
#endif /* WCONSOLE_STDIO */
#endif /* WINDOW_STDIO */
#if REDIRECT_STDIO || WINDOW_STDIO || WCONSOLE_STDIO
static void MrEdSchemeMessages(char *msg, ...)
{
GC_CAN_IGNORE va_list args;
scheme_start_atomic();
#if WINDOW_STDIO
if (!wx_in_terminal) {
static int opening = 0;
if (opening)
return;
opening = 1;
if (!ioFrame) {
wxREGGLOB(ioFrame);
if (mred_only_context)
ioFrame = new WXGC_PTRS IOFrame;
else {
/* Set eventspace ... */
mred_only_context = mred_main_context;
only_context_just_once = 1;
ioFrame = new WXGC_PTRS IOFrame;
mred_only_context = NULL;
}
}
opening = 0;
if (ioFrame->hidden) {
ioFrame->hidden = FALSE;
have_stdio = 1;
ioFrame->Show(TRUE);
}
}
#endif
#if WCONSOLE_STDIO
if (!console_out) {
AllocConsole();
console_out = GetStdHandle(STD_OUTPUT_HANDLE);
}
#endif
#if REDIRECT_STDIO
if (!mrerr)
mrerr = fopen("mrstderr.txt", "w");
if (!mrerr) {
scheme_end_atomic_no_swap();
return;
}
#endif
HIDE_FROM_XFORM(va_start(args, msg));
#if WINDOW_STDIO
if (wx_in_terminal) {
vfprintf(stderr, msg, args);
} else if (!msg) {
char *s;
wxchar *us;
long d, l, ulen, ipos;
s = HIDE_FROM_XFORM(va_arg(args, char*));
d = HIDE_FROM_XFORM(va_arg(args, long));
l = HIDE_FROM_XFORM(va_arg(args, long));
if (!ioFrame->beginEditSeq) {
ioFrame->media->BeginEditSequence();
ioFrame->beginEditSeq = 1;
}
if (utf8_leftover_count) {
char *naya;
naya = new WXGC_ATOMIC char[l + utf8_leftover_count];
memcpy(naya, utf8_leftover, utf8_leftover_count);
memcpy(naya + utf8_leftover_count, s + d, l);
s = naya;
d = 0;
l += utf8_leftover_count;
}
ulen = scheme_utf8_decode_as_prefix((unsigned char *)s, d, l,
NULL, 0, -1,
&ipos, 0, '?');
utf8_leftover_count = (l - (ipos - d));
memcpy(utf8_leftover, s + ipos, utf8_leftover_count);
us = (wxchar *)scheme_malloc_atomic(sizeof(wxchar) * ulen);
scheme_utf8_decode_as_prefix((unsigned char *)s, d, l,
us, 0, -1,
&ipos, 0, '?');
ioFrame->media->Insert(ulen, us, ioFrame->endpos);
ioFrame->endpos += ulen;
if (ulen != 1 || s[0] == '\n') {
ioFrame->media->EndEditSequence();
ioFrame->beginEditSeq = 0;
}
} else {
# define VSP_BUFFER_SIZE 4096
# ifdef MPW_CPLUS
/* FIXME: No vsnprintf in MPW. */
# define vsnprintf(x, y, z, w) vsprintf(x, z, w)
# endif
char buffer[VSP_BUFFER_SIZE];
MSC_IZE(vsnprintf)(buffer, VSP_BUFFER_SIZE, msg, args);
ioFrame->media->Insert((char *)buffer, ioFrame->endpos);
ioFrame->endpos += strlen(buffer);
if (ioFrame->beginEditSeq) {
ioFrame->media->EndEditSequence();
ioFrame->beginEditSeq = 0;
}
}
#endif
#if WCONSOLE_STDIO
if (!msg) {
char *s;
long l;
DWORD wrote;
s = va_arg(args, char*);
l = va_arg(args, long);
WriteConsole(console_out, s, l, &wrote, NULL);
} else {
char buffer[2048];
DWORD wrote;
vsprintf(buffer, msg, args);
WriteConsole(console_out, buffer, strlen(buffer), &wrote, NULL);
}
#endif
#if !WINDOW_STDIO && !WCONSOLE_STDIO
vfprintf(mrerr, msg, args);
#endif
scheme_end_atomic_no_swap();
HIDE_FROM_XFORM(va_end(args));
}
static void MrEdSchemeMessagesOutput(char *s, long l)
{
if (l)
MrEdSchemeMessages(NULL, s, 0, l);
}
#endif
#if REDIRECT_STDIO || WINDOW_STDIO || WCONSOLE_STDIO
static Scheme_Object *console_reading;
static void add_console_reading()
{
if (!console_reading) {
wxREGGLOB(console_reading);
console_reading = scheme_null;
}
console_reading = scheme_make_pair((Scheme_Object *)scheme_current_thread,
console_reading);
}
static void remove_console_reading()
{
Scheme_Object *p, *prev = NULL;
if (!console_reading)
return;
p = console_reading;
while (SCHEME_PAIRP(p)) {
if (SAME_OBJ(SCHEME_CAR(p), (Scheme_Object *)scheme_current_thread)) {
if (prev)
SCHEME_CDR(prev) = SCHEME_CDR(p);
else
console_reading = SCHEME_CDR(p);
return;
}
prev = p;
p = SCHEME_CDR(p);
}
}
static void break_console_reading_threads()
{
Scheme_Object *p;
if (!console_reading)
return;
for (p = console_reading; SCHEME_PAIRP(p); p = SCHEME_CDR(p)) {
scheme_break_thread((Scheme_Thread *)SCHEME_CAR(p));
}
}
static long mrconsole_get_string(Scheme_Input_Port *ip,
char *buffer, long offset, long size,
int nonblock, Scheme_Object *unless)
{
long result;
Scheme_Object *pipe = (Scheme_Object *)ip->port_data;
MrEdSchemeMessages("");
add_console_reading();
result = scheme_get_byte_string("console get-string", pipe, buffer, offset, size, nonblock ? 2 : 0, 0, 0);
remove_console_reading();
return result;
}
static int mrconsole_char_ready(Scheme_Input_Port *ip)
{
Scheme_Object *pipe = (Scheme_Object *)ip->port_data;
MrEdSchemeMessages("");
return scheme_char_ready(pipe);
}
static void mrconsole_close(Scheme_Input_Port *ip)
{
Scheme_Object *pipe = (Scheme_Object *)ip->port_data;
scheme_close_input_port(pipe);
}
static Scheme_Object *MrEdMakeStdIn(void)
{
Scheme_Object *readp;
Scheme_Input_Port *ip;
wxREGGLOB(stdin_pipe);
scheme_pipe(&readp, &stdin_pipe);
ip = scheme_make_input_port(scheme_make_port_type("mred-console-input-port"),
readp,
scheme_intern_symbol("mred-console"),
CAST_GS mrconsole_get_string,
NULL,
scheme_progress_evt_via_get,
scheme_peeked_read_via_get,
CAST_IREADY mrconsole_char_ready,
CAST_ICLOSE mrconsole_close,
NULL,
0);
return (Scheme_Object *)ip;
}
static long stdout_write(Scheme_Output_Port*, const char *s, long d, long l,
int rarely_block, int enable_break)
{
#if WINDOW_STDIO || WCONSOLE_STDIO
if (l)
MrEdSchemeMessages(NULL, s, d, l);
#else
static FILE *out = NULL;
if (!out)
out = fopen("mrstdout.txt", "w");
if (out)
fwrite(s + d, l, 1, out);
#endif
return l;
}
static Scheme_Object *MrEdMakeStdOut(void)
{
Scheme_Object *outtype;
outtype = scheme_make_port_type("stdout");
return (Scheme_Object *)scheme_make_output_port(outtype, NULL,
scheme_intern_symbol("mred-console"),
scheme_write_evt_via_write,
CAST_WS stdout_write,
NULL, NULL, NULL, NULL, NULL, 0);
}
static long stderr_write(Scheme_Output_Port*, const char *s, long d, long l,
int rarely_block, int enable_break)
{
#if WINDOW_STDIO || WCONSOLE_STDIO
if (l)
MrEdSchemeMessages(NULL, s, d, l);
#else
if (!mrerr)
mrerr = fopen("mrstderr.txt", "w");
if (mrerr)
fwrite(s + d, l, 1, mrerr);
#endif
return l;
}
static Scheme_Object *MrEdMakeStdErr(void)
{
Scheme_Object *errtype;
errtype = scheme_make_port_type("stderr");
return (Scheme_Object *)scheme_make_output_port(errtype, NULL,
scheme_intern_symbol("mred-console"),
scheme_write_evt_via_write,
CAST_WS stderr_write,
NULL, NULL, NULL, NULL, NULL, 0);
}
#endif
void wxmeError(const char *e)
{
scheme_signal_error("%s", e);
}
/****************************************************************************/
/* Debugging */
/****************************************************************************/
#if ADD_OBJ_DUMP
extern int wx_object_count;
# ifndef USE_SENORA_GC
extern "C" GC_PTR GC_changing_list_start, GC_changing_list_current;
# else
# define GC_word int
# endif
extern "C" GC_word GC_dl_entries;
extern "C" GC_word GC_fo_entries;
Scheme_Object *OBJDump(int, Scheme_Object *[])
{
# if REDIRECT_STDIO || WINDOW_STDIO || WCONSOLE
# define PRINT_IT MrEdSchemeMessages
# else
# define PRINT_IT scheme_console_printf
# endif
int c;
PRINT_IT("Objects: %d\n", wx_object_count);
# ifndef USE_SENORA_GC
PRINT_IT("Memory: %d\n", GC_get_heap_size());
# endif
PRINT_IT("FO: %d\n", GC_fo_entries);
PRINT_IT("DL: %d\n", GC_dl_entries);
# ifndef USE_SENORA_GC
PRINT_IT("Changing: %d\n",
(long)GC_changing_list_current - (long)GC_changing_list_start);
# endif
Scheme_Thread *p;
for (c = 0, p = scheme_first_thread; p; p = p->next)
c++;
PRINT_IT("Threads: %d\n", c);
return scheme_make_integer(wx_object_count);
}
#endif
#ifdef SGC_STD_DEBUGGING
extern "C" {
extern void (*scheme_external_dump_info)(void);
extern void (*scheme_external_dump_arg)(Scheme_Object *);
extern char *(*scheme_external_dump_type)(void *);
};
extern void GC_cpp_for_each(void (*f)(void *, int, void *), void *data);
extern int GC_is_wx_object(void *v);
#define NUM_OBJ_KIND (wxTYPE_SNIP_CLASS_LIST + 1)
static int cpp_count[NUM_OBJ_KIND], cpp_sch_count[NUM_OBJ_KIND], cpp_size[NUM_OBJ_KIND];
static int cpp_actual_count[NUM_OBJ_KIND], cpp_actual_size[NUM_OBJ_KIND];
static unsigned long cpp_lo[NUM_OBJ_KIND], cpp_hi[NUM_OBJ_KIND];
static int trace_path_type;
#if SGC_STD_DEBUGGING
# define USE_WXOBJECT_TRACE_COUNTER
#endif
#ifdef USE_WXOBJECT_TRACE_COUNTER
void wxTraceCount(void *o, int size)
{
wxObject *obj = (wxObject *)o;
int type = obj->__type;
if ((type >= 0) && (type < NUM_OBJ_KIND)) {
cpp_actual_count[type]++;
cpp_actual_size[type] += size;
unsigned long s = (unsigned long)o;
if (!cpp_lo[type] || (s < cpp_lo[type]))
cpp_lo[type] = s;
if (!cpp_hi[type] || (s > cpp_hi[type]))
cpp_hi[type] = s;
}
}
void wxTracePath(void *o, unsigned long src, void *pd)
{
if (trace_path_type > 0) {
wxObject *obj = (wxObject *)o;
int type = obj->__type;
if (type == trace_path_type)
GC_store_path(o, src, pd);
}
}
void wxTraceInit(void)
{
int i;
for (i = 0; i < NUM_OBJ_KIND; i++) {
cpp_actual_count[i] = cpp_actual_size[i] = 0;
cpp_lo[i] = cpp_hi[i] = 0;
}
}
void wxTraceDone(void)
{
/* nothing */
}
void wxObjectFinalize(void *o)
{
#if 0
/* Not every gc instance is a wxObject instance, now: */
if (((wxObject *)o)->__type != -1) {
# if 0
/* New non-cleanup flag makes this incorrect: */
fprintf(stderr, "ERROR: free wxObject had non-deleted type value!");
# else
((wxObject *)o)->__type = -1;
# endif
}
#endif
}
static void set_trace_arg(Scheme_Object *a)
{
trace_path_type = -1;
if (a && SCHEME_SYMBOLP(a)) {
char *s = SCHEME_SYM_VAL(a);
int i;
for (i = 0; i < NUM_OBJ_KIND; i++) {
char *tn = wxGetTypeName(i);
if (tn && !strcmp(tn, s)) {
trace_path_type = i;
return;
}
}
}
}
static char *object_type_name(void *v)
{
if (GC_is_wx_object(v)) {
int t = ((wxObject *)v)->__type;
if ((t >= 0) && (t < NUM_OBJ_KIND)) {
char *c;
c = wxGetTypeName(t);
if (c) {
if (wxSubType(t, wxTYPE_WINDOW)) {
char *lbl;
lbl = ((wxWindow *)v)->GetLabel();
if (!lbl)
lbl = ((wxWindow *)v)->GetTitle();
if (!lbl)
lbl = ((wxWindow *)v)->GetName();
if (lbl) {
int l1, l2;
char *r;
l1 = strlen(c);
l2 = strlen(lbl);
r = new WXGC_ATOMIC char[l1+l2+2];
memcpy(r, c, l1);
r[l1] = '=';
memcpy(r + l1 + 1, lbl, l2 + 1);
return r;
}
}
return c;
} else
return "wxUNKNOWN";
} else
return "wxBAD";
} else
return "";
}
#endif
static void count_obj(void *o, int s, void *)
{
wxObject *obj = (wxObject *)o;
int type = obj->__type;
if ((type >= 0) && (type < NUM_OBJ_KIND)) {
cpp_count[type]++;
if (obj->__gc_external)
cpp_sch_count[type]++;
#ifdef MEMORY_USE_METHOD
cpp_size[type] += s + (obj->MemoryUse());
#endif
}
}
static void dump_cpp_info()
{
int i, total_count = 0, total_size = 0, total_actual_size = 0;
for (i = 0; i < NUM_OBJ_KIND; i++)
cpp_count[i] = cpp_sch_count[i] = cpp_size[i] = 0;
GC_cpp_for_each(count_obj, NULL);
scheme_console_printf("\nBegin wxWindows\n");
for (i = 0; i < NUM_OBJ_KIND; i++) {
if (cpp_count[i] || cpp_actual_count[i]) {
char buffer[50];
char *name = wxGetTypeName(i);
if (!name) {
sprintf(buffer, "#%d", i);
name = buffer;
}
scheme_console_printf("%30.30s %4ld %5ld %10ld %10ld %8lx - %8lx\n",
name,
cpp_sch_count[i],
cpp_count[i],
cpp_size[i],
cpp_actual_size[i],
cpp_lo[i],
cpp_hi[i]);
#ifdef USE_WXOBJECT_TRACE_COUNTER
if (cpp_count[i] != cpp_actual_count[i])
scheme_console_printf("%30.30s actual count: %10ld\n",
"", cpp_actual_count[i]);
#endif
total_count += cpp_count[i];
total_size += cpp_size[i];
total_actual_size += cpp_actual_size[i];
}
}
scheme_console_printf("%30.30s %10ld %10ld %10ld\n",
"total", total_count, total_size, total_actual_size);
scheme_console_printf("End wxWindows\n");
#if ADD_OBJ_DUMP
scheme_console_printf("\n");
OBJDump(0, NULL);
#endif
}
#endif
/****************************************************************************/
/* AIX DANGER signal */
/****************************************************************************/
#if defined(_IBMR2)
#define DANGER_ALARM
#endif
#ifdef DANGER_ALARM
static int danger_signal_received = 0;
static wxDialogBox *dangerFrame = NULL;
class DangerThreadTimer : public wxTimer
{
public:
void Notify(void);
};
void DismissDanger(wxObject &o, wxEvent &e)
{
dangerFrame->Show(FALSE);
dangerFrame = NULL;
danger_signal_received = 0;
}
void DangerThreadTimer::Notify(void)
{
if (danger_signal_received) {
if (!dangerFrame) {
wxREGGLOB(dangerFrame);
dangerFrame = new WXGC_PTRS wxDialogBox((wxWindow *)NULL, "Danger", FALSE, 0, 0, 300, 200);
(void) new WXGC_PTRS wxMessage(dangerFrame, "Warning: Paging space is low.");
dangerFrame->NewLine();
wxButton *b = new WXGC_PTRS wxButton(dangerFrame, (wxFunction)DismissDanger, "Ok");
dangerFrame->Fit();
b->Centre(wxHORIZONTAL);
dangerFrame->Centre(wxBOTH);
dangerFrame->Show(TRUE);
}
}
}
#endif
/****************************************************************************/
/* Application */
/****************************************************************************/
MrEdApp::MrEdApp()
{
#ifndef wx_xt
if (!wx_class)
wx_class = "mred";
#endif
}
extern "C" {
MZ_EXTERN void (*GC_out_of_memory)(void);
};
static void MrEdOutOfMemory(void)
{
#ifdef wx_mac
Alert(101, NULL);
ExitToShell();
#else
#ifdef wx_x
printf("mred: out of memory\n");
#endif
_exit(-1);
#endif
}
void *wxOutOfMemory()
{
MrEdOutOfMemory();
return NULL;
}
extern "C" {
typedef void (*OOM_ptr)(void);
}
static OOM_ptr mr_save_oom;
static mz_jmp_buf oom_buf;
static void not_so_much_memory(void)
{
scheme_longjmp(oom_buf, 1);
}
void *wxMallocAtomicIfPossible(size_t s)
{
void *v;
if (s < 5000)
return scheme_malloc_atomic(s);
mr_save_oom = GC_out_of_memory;
if (!scheme_setjmp(oom_buf)) {
GC_out_of_memory = (OOM_ptr)not_so_much_memory;
v = scheme_malloc_atomic(s);
} else {
v = NULL;
}
GC_out_of_memory = mr_save_oom;
return v;
}
static const char *CallSchemeExpand(const char *filename, const char *who, int to_write)
{
char *s;
s = scheme_expand_filename((char *)filename, strlen(filename),
who, 0,
(to_write
? SCHEME_GUARD_FILE_WRITE
: SCHEME_GUARD_FILE_READ));
return s ? s : filename;
}
#if !defined(USE_SENORA_GC) && !defined(MZ_PRECISE_GC)
static void MrEdIgnoreWarnings(char *, GC_word)
{
}
#endif
void wxDoMainLoop()
{
TheMrEdApp->MainLoop();
}
static Scheme_Env *setup_basic_env()
{
wxREGGLOB(global_env);
global_env = scheme_basic_env();
scheme_no_dumps("the graphics library is running");
scheme_set_banner(BANNER);
wxmeExpandFilename = CallSchemeExpand;
#ifdef DANGER_ALARM
{
DangerThreadTimer *t = new WXGC_PTRS DangerThreadTimer();
t->Start(10000);
}
#endif
scheme_add_evt(mred_eventspace_type,
(Scheme_Ready_Fun)check_eventspace_inactive,
NULL,
NULL, 0);
scheme_add_evt(mred_nested_wait_type,
CAST_BLKCHK check_for_nested_event,
NULL,
NULL, 0);
scheme_add_custodian_extractor(mred_eventspace_hop_type,
CAST_EXT extract_eventspace_from_hop);
wxsScheme_setup(global_env);
scheme_set_param(scheme_current_config(), mred_eventspace_param, (Scheme_Object *)mred_main_context);
wxREGGLOB(def_dispatch);
def_dispatch = scheme_make_prim_w_arity(CAST_SP def_event_dispatch_handler,
"default-event-dispatch-handler",
1, 1);
scheme_set_param(scheme_current_config(), mred_event_dispatch_param, def_dispatch);
/* Make sure ps-setup is installed in the parameterization */
ps_ready = 1;
/* wxSetThePrintSetupData(wxGetThePrintSetupData()); */
MakeContext(mred_main_context);
mred_only_context = NULL;
/* This handler_running pointer gets reset later. Do
we really need to set it now? */
mred_main_context->handler_running = scheme_current_thread;
mzsleep = scheme_sleep;
scheme_sleep = CAST_SLEEP MrEdSleep;
#if ADD_OBJ_DUMP
scheme_add_global("dump-object-stats",
scheme_make_prim(OBJDump), global_env);
#endif
return global_env;
}
wxFrame *MrEdApp::OnInit(void)
{
MrEdContext *mmc;
initialized = 0;
#ifdef wx_mac
{
TSMDocumentID doc;
OSType itfs[1];
itfs[0] = kUnicodeDocumentInterfaceType;
NewTSMDocument(1, itfs, &doc, 0);
UseInputWindow(NULL, TRUE);
ActivateTSMDocument(doc);
}
#endif
wxREGGLOB(mred_frames);
wxREGGLOB(timer_contexts);
timer_contexts = scheme_make_hash_table(SCHEME_hash_ptr);
#ifdef LIBGPP_REGEX_HACK
new WXGC_PTRS Regex("a", 0);
#endif
#if REDIRECT_STDIO || WINDOW_STDIO || WCONSOLE_STDIO
if (!wx_in_terminal) {
scheme_make_stdin = CAST_MK MrEdMakeStdIn;
scheme_make_stdout = CAST_MK MrEdMakeStdOut;
scheme_make_stderr = CAST_MK MrEdMakeStdErr;
}
#endif
#if !defined(USE_SENORA_GC) && !defined(MZ_PRECISE_GC)
GC_set_warn_proc(CAST_IGNORE MrEdIgnoreWarnings);
#endif
#if 0
/* Used to be set for the sake of Mac OS Classic. Now,
setting GC_out_of_memory for 3m means that it's ok
to fail when a limit is reached. We don't want that. */
GC_out_of_memory = (OOM_ptr)MrEdOutOfMemory;
#endif
#ifdef SGC_STD_DEBUGGING
scheme_external_dump_info = dump_cpp_info;
# ifdef USE_WXOBJECT_TRACE_COUNTER
scheme_external_dump_type = object_type_name;
scheme_external_dump_arg = set_trace_arg;
# endif
#endif
#if REDIRECT_STDIO || WINDOW_STDIO || WCONSOLE_STDIO
scheme_console_printf = CAST_PRINTF MrEdSchemeMessages;
if (!wx_in_terminal) {
scheme_console_output = CAST_OUTPUT MrEdSchemeMessagesOutput;
}
#endif
mred_eventspace_param = scheme_new_param();
mred_event_dispatch_param = scheme_new_param();
mred_ps_setup_param = scheme_new_param();
wxInitSnips(); /* and snip classes */
mred_eventspace_type = scheme_make_type("<eventspace>");
mred_nested_wait_type = scheme_make_type("<eventspace-nested-wait>");
mred_eventspace_hop_type = scheme_make_type("<internal:eventspace-hop>");
#ifdef MZ_PRECISE_GC
GC_register_traversers(mred_eventspace_type,
size_eventspace_val,
mark_eventspace_val,
fixup_eventspace_val,
1, 0);
GC_register_traversers(mred_nested_wait_type,
size_nested_wait_val,
mark_nested_wait_val,
fixup_nested_wait_val,
1, 0);
GC_register_traversers(mred_eventspace_hop_type,
size_eventspace_hop_val,
mark_eventspace_hop_val,
fixup_eventspace_hop_val,
1, 0);
#endif
#ifdef NEED_HET_PARAM
wxREGGLOB(mred_het_key);
mred_het_key = scheme_make_symbol("het"); /* uninterned */
#endif
#ifdef MZ_PRECISE_GC
mmc = (MrEdContext *)GC_malloc_one_tagged(sizeof(MrEdContext));
#else
mmc = new WXGC_PTRS MrEdContext;
#endif
mmc->so.type = mred_eventspace_type;
wxREGGLOB(mred_main_context);
mred_main_context = mmc;
{
wxChildList *cl;
cl = new WXGC_PTRS wxChildList();
mmc->topLevelWindowList = cl;
}
{
wxStandardSnipClassList *scl;
scl = wxMakeTheSnipClassList();
mmc->snipClassList = scl;
}
{
wxBufferDataClassList *dcl;
dcl = wxMakeTheBufferDataClassList();
mmc->bufferDataClassList = dcl;
}
{
MrEdFinalizedContext *fc;
fc = new WXGC_PTRS MrEdFinalizedContext;
mmc->finalized = fc;
}
wxREGGLOB(mred_only_context);
mred_only_context = mred_main_context;
MrEdInitFirstContext(mred_main_context);
/* Just in case wxWindows needs an initial frame: */
/* (Windows needs it for the clipboard.) */
wxREGGLOB(mred_real_main_frame);
mred_real_main_frame = new WXGC_PTRS wxFrame(NULL, "MrEd");
#ifdef wx_msw
TheMrEdApp->wx_frame = mred_real_main_frame;
#endif
wxInitMedia();
wxscheme_early_gl_init();
#ifdef mred_BREAK_HANDLER
# ifdef OS_X
_signal_nobind(SIGINT, user_break_hit);
# else
MZ_SIGSET(SIGINT, user_break_hit);
# endif
#endif
mred_run_from_cmd_line(argc, argv, setup_basic_env);
#if WINDOW_STDIO
if (!wx_in_terminal) {
/* The only reason we get here is that a command-line error or
-h occured. In either case, stick around for the sake of the
console. */
setup_basic_env();
TheMrEdApp->initialized = 1;
stdio_kills_prog = 1;
if (ioFrame)
ioFrame->CloseIsQuit();
wxTheApp->MainLoop();
}
#endif
return NULL;
}
#if WINDOW_STDIO
static void MrEdExit(int v)
{
if (have_stdio) {
stdio_kills_prog = 1;
if (ioFrame)
ioFrame->CloseIsQuit();
scheme_close_managed(main_custodian);
return;
}
#ifdef wx_msw
mred_clean_up_gdi_objects();
#endif
scheme_immediate_exit(v);
}
#endif
static void on_main_killed(Scheme_Thread *p)
{
on_handler_killed(p);
if (scheme_exit)
scheme_exit(exit_val);
else {
#ifdef wx_msw
mred_clean_up_gdi_objects();
#endif
scheme_immediate_exit(exit_val);
}
}
void MrEdApp::RealInit(void)
{
initialized = 1;
wxMediaIOCheckLSB(/* scheme_console_printf */);
scheme_current_thread->on_kill = CAST_TOK on_main_killed;
#if WINDOW_STDIO
if (!wx_in_terminal)
scheme_exit = CAST_EXIT MrEdExit;
#endif
#ifdef wx_xt
if (wx_single_instance) {
exit_val = wxCheckSingleInstance(global_env);
}
#endif
if (!exit_val)
exit_val = mred_finish_cmd_line_run();
scheme_kill_thread(scheme_current_thread);
}
#ifdef wx_mac
char *wx_original_argv_zero;
static char *about_label;
extern "C" char *scheme_get_exec_path();
char *MrEdApp::GetDefaultAboutItemName()
{
# ifdef OS_X
if (!about_label) {
char *p;
int i, len;
p = wx_original_argv_zero;
len = strlen(p);
for (i = len - 1; i; i--) {
if (p[i] == '/') {
i++;
break;
}
}
wxREGGLOB(about_label);
about_label = new WXGC_ATOMIC char[len - i + 20];
sprintf(about_label, "About %s...", p + i);
}
return about_label;
# else
return "About...";
# endif
}
void MrEdApp::DoDefaultAboutItem()
{
DialogPtr dial;
short hit;
CGrafPtr port;
GDHandle device;
dial = GetNewDialog(129, NULL, (WindowRef)-1);
GetGWorld(&port,&device);
SetGWorld(GetDialogPort(dial),GetGDevice());
TextFont(kFontIDGeneva);
TextSize(10);
SetGWorld(port,device);
ModalDialog(NULL, &hit);
DisposeDialog(dial);
}
#ifdef OS_X
extern int scheme_mac_path_to_spec(const char *filename, FSSpec *spec);
#endif
int wxGetOriginalAppFSSpec(FSSpec *spec)
{
char *s = wx_original_argv_zero;
#ifdef OS_X
/* Need the folder of the exe, three levels up: */
{
char *p;
int i, len, c = 0;
p = s;
len = strlen(s);
for (i = len - 1; i; i--) {
if (p[i] == '/') {
c++;
if (c == 3) {
i++;
break;
}
}
}
if (i) {
char *s2;
s2 = new WXGC_ATOMIC char[i + 1];
memcpy(s2, s, i);
s2[i] = 0;
s = s2;
}
}
#endif
return scheme_mac_path_to_spec(s, spec);
}
#endif
int MrEdApp::OnExit(void)
{
return 0;
}
void wxCreateApp(void)
{
if (!TheMrEdApp) {
#ifdef wx_mac
wxmac_reg_globs();
#endif
#ifdef wx_msw
{
HANDLE h;
h = GetStdHandle(STD_OUTPUT_HANDLE);
if (h && (h != INVALID_HANDLE_VALUE)
&& (GetFileType(h) != FILE_TYPE_UNKNOWN)) {
wx_in_terminal = 1;
}
}
#endif
wxREGGLOB(orig_ps_setup);
wxREGGLOB(q_callbacks);
wxREGGLOB(TheMrEdApp);
TheMrEdApp = new WXGC_PTRS MrEdApp;
}
}
/****************************************************************************/
/* wxFlushDisplay */
/****************************************************************************/
void wxFlushDisplay(void)
{
#ifdef wx_x
Display *d;
d = XtDisplay(wxAPP_TOPLEVEL);
XFlush(d);
XSync(d, FALSE);
XFlush(d);
XSync(d, FALSE);
#endif
#ifdef wx_mac
wxFlushMacDisplay();
#endif
}
#ifdef DEFINE_DUMMY_PURE_VIRTUAL
/* Weird hack to avoid linking to libg++ */
extern "C" {
void __pure_virtual(void) { }
}
#endif
/****************************************************************************/
/* wxHiEventTrampoline */
/****************************************************************************/
#ifdef NEED_HET_PARAM
/* In certain Windows and Mac OS modes (e.g., to implement scrolling),
we run Scheme code atomically to avoid copying part of the stack
that belongs to the system. We run arbitrary code, however, the
code does not run to completion. Instead, we suspend the
continuation after a while, and then try to continue on the next OS
stop point (e.g., an WM_XSCROLL message). Hopefully, a timer
ensures that a suspended continuation gets to continue soon when
nothing else is going on. During this special mode, other messages
that can call into Scheme are ignored (e.g., WM_ACTIVATE). After
the OS mode ends (e.g., the scroller returns), any pending
continuation is finished, but in non-atomic mode, and things are
generally back to normal.
The call process is
wxHiEventTrampoline(f, data)
-> f(data) in ht mode
-> ... mred_het_run_some(g, data2) \
-> Scheme code, may finish or may not | maybe loop
het->in_progress inicates whether done /
-> continue scheme if not finished
In this process, it's the call stack between f(data)
and the call to mred_het_run_some() that won't be copied
in or out until f(data) returns.
Nesting wxHiEventTrampoline() calls should be safe, but it won't
achieve the goal, which is to limit the amount of work done before
returning (because the inner wxHiEventTrampoline will have to run
to completion). */
static unsigned long get_deeper_base();
int wxHiEventTrampoline(int (*_wha_f)(void *), void *wha_data)
{
HiEventTramp *het;
HiEventTrampProc wha_f = (HiEventTrampProc)_wha_f;
Scheme_Cont_Frame_Data cframe;
Scheme_Object *bx;
het = new WXGC_PTRS HiEventTramp;
bx = scheme_make_raw_pair((Scheme_Object *)het, NULL);
scheme_push_continuation_frame(&cframe);
scheme_set_cont_mark(mred_het_key, bx);
het->progress_cont = scheme_new_jmpupbuf_holder();
scheme_init_jmpup_buf(&het->progress_cont->buf);
scheme_start_atomic();
het->val = wha_f(wha_data);
if (het->timer_on) {
het->timer_on = 0;
# ifdef wx_msw
KillTimer(NULL, het->timer_id);
# endif
}
if (het->in_progress) {
/* We have leftover work; jump and finish it (non-atomically).
But don't swap until we've jumped back in, because the jump-in
point might be trying to suspend the thread (and that should
complete before any swap). */
scheme_end_atomic_no_swap();
SCHEME_CAR(bx) = NULL;
het->in_progress = 0;
het->progress_is_resumed = 1;
if (!scheme_setjmp(het->progress_base)) {
#ifdef MZ_PRECISE_GC
het->fixup_var_stack_chain = &__gc_var_stack__;
#endif
scheme_longjmpup(&het->progress_cont->buf);
}
} else {
scheme_end_atomic();
}
scheme_pop_continuation_frame(&cframe);
het->old_param = NULL;
het->progress_cont = NULL;
het->do_data = NULL;
return het->val;
}
static void suspend_het_progress(void)
{
HiEventTramp * volatile het;
double msecs;
{
Scheme_Object *v;
v = scheme_extract_one_cc_mark(NULL, mred_het_key);
het = (HiEventTramp *)SCHEME_CAR(v);
}
msecs = scheme_get_inexact_milliseconds();
if (msecs < het->continue_until)
return;
scheme_on_atomic_timeout = NULL;
het->yielding = 0;
het->in_progress = 1;
if (scheme_setjmpup(&het->progress_cont->buf, (void*)het->progress_cont, het->progress_base_addr)) {
/* we're back */
scheme_reset_jmpup_buf(&het->progress_cont->buf);
het->yielding = 0;
#ifdef MZ_PRECISE_GC
/* Base addr points to the last valid gc_var_stack address.
Fixup that link to skip over the part of the stack we're
not using right now. */
((void **)het->progress_base_addr)[0] = het->fixup_var_stack_chain;
((void **)het->progress_base_addr)[1] = NULL;
#endif
} else {
/* we're leaving */
scheme_longjmp(het->progress_base, 1);
}
}
#define HET_RUN_MSECS 200
static void het_run_new(HiEventTramp * volatile het)
{
double msecs;
/* We're willing to start new work that is specific to this thread */
het->progress_is_resumed = 0;
msecs = scheme_get_inexact_milliseconds();
het->continue_until = msecs + HET_RUN_MSECS;
if (!scheme_setjmp(het->progress_base)) {
scheme_start_atomic();
scheme_on_atomic_timeout = CAST_SUSPEND suspend_het_progress;
/* Due to het param, yield work will be restricted: */
het->yielding = 1;
if (het->do_f) {
HiEventTrampProc do_f = het->do_f;
do_f(het->do_data);
} else
wxYield();
het->yielding = 0;
}
if (het->progress_is_resumed) {
/* we've already returned once; jump out to new progress base */
scheme_longjmp(het->progress_base, 1);
} else {
scheme_on_atomic_timeout = NULL;
scheme_end_atomic_no_swap();
}
}
static void het_do_run_new(HiEventTramp * volatile het, int *iteration)
{
/* This function just makes room on the stack, eventually calling
het_run_new(). */
int new_iter[32];
if (iteration[0] == 3) {
#ifdef MZ_PRECISE_GC
het->progress_base_addr = (void *)&__gc_var_stack__;
#else
het->progress_base_addr = (void *)new_iter;
#endif
het_run_new(het);
} else {
new_iter[0] = iteration[0] + 1;
het_do_run_new(het, new_iter);
}
}
int mred_het_run_some(HiEventTrampProc do_f, void *do_data)
{
HiEventTramp * volatile het;
int more = 0;
{
Scheme_Object *v;
v = scheme_extract_one_cc_mark(NULL, mred_het_key);
if (v)
het = (HiEventTramp *)SCHEME_CAR(v);
else
het = NULL;
}
if (het) {
if (het->in_progress) {
/* We have work in progress. */
if ((unsigned long)het->progress_base_addr < get_deeper_base()) {
/* We have stack space to resume the old work: */
double msecs;
het->in_progress = 0;
het->progress_is_resumed = 1;
msecs = scheme_get_inexact_milliseconds();
het->continue_until = msecs + HET_RUN_MSECS;
scheme_start_atomic();
scheme_on_atomic_timeout = CAST_SUSPEND suspend_het_progress;
if (!scheme_setjmp(het->progress_base)) {
#ifdef MZ_PRECISE_GC
het->fixup_var_stack_chain = &__gc_var_stack__;
#endif
scheme_longjmpup(&het->progress_cont->buf);
} else {
scheme_on_atomic_timeout = NULL;
scheme_end_atomic_no_swap();
}
}
} else {
int iter[1];
iter[0] = 0;
het->do_f = do_f;
het->do_data = do_data;
het_do_run_new(het, iter);
}
more = het->in_progress;
}
return more;
}
// Disable warning for returning address of local variable.
#ifdef _MSC_VER
#pragma warning (disable:4172)
#endif
static unsigned long get_deeper_base()
{
long here;
return (unsigned long)&here;
}
// re-enable warning
#ifdef _MSC_VER
#pragma warning (default:4172)
#endif
#endif
/****************************************************************************/
/* AE-like support */
/****************************************************************************/
static void wxDo(Scheme_Object *proc, int argc, Scheme_Object **argv)
{
mz_jmp_buf * volatile save, newbuf;
volatile int block_descriptor;
if (!proc) {
/* Oops --- too early. */
return;
}
/* wxDo might be called when MrEd is sleeping (i.e.,
blocked on WNE in OS X). Since we're hijacking the
thread, save an restore block information. */
block_descriptor = scheme_current_thread->block_descriptor;
scheme_current_thread->block_descriptor = 0;
scheme_start_atomic();
save = scheme_current_thread->error_buf;
scheme_current_thread->error_buf = &newbuf;
if (scheme_setjmp(newbuf)) {
scheme_clear_escape();
} else {
scheme_apply(proc, argc, argv);
}
scheme_current_thread->error_buf = save;
scheme_current_thread->block_descriptor = block_descriptor;
scheme_end_atomic_no_swap();
}
void wxDrop_Runtime(char **argv, int argc)
{
int i;
for (i = 0; i < argc; i++) {
Scheme_Object *p[1];
#ifdef wx_xt
p[0] = scheme_char_string_to_path(scheme_make_utf8_string(argv[i]));
#else
p[0] = scheme_make_path(argv[i]);
#endif
wxDo(wxs_app_file_proc, 1, p);
}
}
#if defined(wx_mac) || defined(wx_msw)
void wxDrop_Quit()
{
#if WINDOW_STDIO
if (ioFrame) {
if (ioFrame->OnClose())
ioFrame->Show(FALSE);
}
#endif
wxDo(wxs_app_quit_proc, 0, NULL);
}
#endif
#ifdef wx_mac
void wxDo_About()
{
wxDo(wxs_app_about_proc, 0, NULL);
}
void wxDo_Pref()
{
if (!SCHEME_FALSEP(wxs_app_pref_proc))
wxDo(wxs_app_pref_proc, 0, NULL);
}
int wxCan_Do_Pref()
{
return SCHEME_TRUEP(wxs_app_pref_proc);
}
#endif
Reference in New Issue View Git Blame Copy Permalink