Back to index

plt-scheme  4.2.1
wxscheme.cxx
Go to the documentation of this file.
00001 
00002 #if defined(_MSC_VER)
00003 # include "wx.h"
00004 #endif
00005 #if defined(wx_mac)
00006 # include "common.h"
00007 #endif
00008 
00009 #define Uses_XLib // Xt
00010 #include "common.h" // wxWindows
00011 #include "wx_win.h"
00012 #include "wxscheme.h"
00013 #include "wx_main.h"
00014 #include "wx_dcps.h"
00015 #include "wx_canvs.h"
00016 #include "wx_clipb.h"
00017 #include "wx_print.h"
00018 #include "wx_dcmem.h"
00019 #include "mrdispatch.h"
00020 #include "wxsmred.h"
00021 
00022 #include "wxs_obj.h"
00023 #define WXS_SETUP_ONLY 1
00024 #include "wxs_win.h"
00025 #include "wxs_fram.h"
00026 #include "wxs_item.h"
00027 #include "wxs_butn.h"
00028 #include "wxs_ckbx.h"
00029 #include "wxs_chce.h"
00030 #include "wxs_evnt.h"
00031 #include "wxs_panl.h"
00032 #include "wxs_menu.h"
00033 #include "wxs_bmap.h"
00034 #include "wxs_misc.h"
00035 #include "wxs_rado.h"
00036 #include "wxs_slid.h"
00037 #include "wxs_gage.h"
00038 #include "wxs_lbox.h"
00039 #include "wxs_tabc.h"
00040 
00041 #include "wxs_glob.h"
00042 
00043 #undef WXS_SETUP_ONLY
00044 #include "wxs_gdi.h"
00045 #include "wxs_dc.h"
00046 #include "wxs_cnvs.h"
00047 #include "wxs_misc.h"
00048 
00049 #ifdef wx_msw
00050 # include "wx_pdf.h"
00051 extern void wx_release_lazy_regions();
00052 #endif
00053 
00054 #include <stdlib.h>
00055 #include <ctype.h>
00056 
00057 #ifdef WX_USE_XFT
00058 #include <X11/Xft/Xft.h>
00059 extern char **wxGetCompleteFaceList(int *_len, int mono_only);
00060 #endif
00061 
00062 #ifdef wx_mac
00063 # ifdef WX_CARBON
00064 #  ifdef OS_X
00065 #   include <QuickTime/Movies.h>
00066 #  else
00067 #   include <Movies.h>
00068 #  endif
00069 # else
00070   #include <Gestalt.h>
00071   #include <Movies.h>
00072   #include <ColorPicker.h>
00073   #include <Folders.h>
00074  #endif
00075 #endif
00076 
00077 #ifdef wx_msw
00078 # define fopen_to_read(fn) _wfopen(wxWIDE_STRING(fn), L"rb")
00079 #else
00080 # define fopen_to_read(fn) fopen(fn, "rb")
00081 #endif
00082 
00083 class GCBitmap {
00084 public:
00085 #ifdef MZ_PRECISE_GC
00086   Scheme_Object *canvasptr;
00087 #else
00088   wxCanvas **canvasptr; /* weak reference */
00089 #endif
00090   double x, y, w, h;
00091   double onx, ony, offx, offy;
00092   wxBitmap *on, *off;
00093   GCBitmap *next;
00094 };
00095 
00096 #ifdef MZ_PRECISE_GC
00097 # define GET_CANVAS(gcbm) ((wxCanvas *)gcPTR_TO_OBJ(SCHEME_BOX_VAL(gcbm->canvasptr)))
00098 #else
00099 # define GET_CANVAS(gcbm) (*gcbm->canvasptr)
00100 #endif
00101 
00102 
00103 static GCBitmap *gc_bitmaps = NULL;
00104 extern "C" {
00105   typedef void (*GC_START_END_PTR)(void);
00106   MZ_EXTERN GC_START_END_PTR GC_collect_start_callback;
00107   MZ_EXTERN GC_START_END_PTR GC_collect_end_callback;
00108 };
00109 static GC_START_END_PTR orig_collect_start_callback;
00110 static GC_START_END_PTR orig_collect_end_callback;
00111 static void collect_start_callback(void);
00112 static void collect_end_callback(void);
00113 
00114 static void wxScheme_Install(Scheme_Env *global_env);
00115 
00116 static Scheme_Object *setup_file_symbol, *init_file_symbol, *x_display_symbol;
00117 
00118 static Scheme_Object *get_file, *put_file, *get_ps_setup_from_user, *message_box;
00119 
00120 static Scheme_Object *executer;
00121 
00122 static Scheme_Object *wait_symbol;
00123 
00124 static Scheme_Object *mono_symbol, *all_symbol;
00125 
00126 #define CONS scheme_make_pair
00127 
00128 void wxsScheme_setup(Scheme_Env *env)
00129 {
00130   wxREGGLOB(get_file);
00131   wxREGGLOB(put_file);
00132   wxREGGLOB(get_ps_setup_from_user);
00133   wxREGGLOB(message_box);
00134 
00135   env = scheme_primitive_module(scheme_intern_symbol("#%mred-kernel"), env);
00136 
00137   wxREGGLOB(gc_bitmaps);
00138 
00139   objscheme_init(env);
00140 
00141   wxREGGLOB(setup_file_symbol);
00142   wxREGGLOB(init_file_symbol);
00143   wxREGGLOB(x_display_symbol);
00144   setup_file_symbol = scheme_intern_symbol("setup-file");
00145   init_file_symbol = scheme_intern_symbol("init-file");
00146   x_display_symbol = scheme_intern_symbol("x-display");
00147 
00148   wxScheme_Install(env);
00149 
00150   scheme_finish_primitive_module(env);
00151   scheme_protect_primitive_provide(env, NULL);
00152   
00153   get_file = scheme_false;
00154   put_file = scheme_false;
00155   get_ps_setup_from_user = scheme_false;
00156   message_box = scheme_false;
00157 
00158   orig_collect_start_callback = GC_set_collect_start_callback(collect_start_callback);
00159   orig_collect_end_callback = GC_set_collect_end_callback(collect_end_callback);
00160 }
00161 
00162 extern "C" {
00163 
00164   void scheme_install_xc_global(char *name, Scheme_Object *val, Scheme_Env *env)
00165     {
00166       scheme_add_global(name, val, env);
00167     }
00168   
00169   Scheme_Object * scheme_lookup_xc_global(char *name, Scheme_Env *env)
00170     {
00171       return scheme_lookup_global(scheme_intern_symbol(name), env);
00172     }
00173 
00174 };
00175 
00176 /***********************************************************************/
00177 /*                             gc bitmap                               */
00178 /***********************************************************************/
00179 
00180 #ifdef wx_x
00181 extern Display *MrEdGetXDisplay(void);
00182 #endif
00183 
00184 #ifdef MZ_PRECISE_GC
00185 START_XFORM_SKIP;
00186 #endif
00187 
00188 static void draw_gc_bm(int on)
00189 {
00190   GCBitmap *gcbm = gc_bitmaps;
00191 
00192 #ifdef MZ_PRECISE_GC
00193   /* Too hard to make GCBlit et al. unconverted.
00194      We just save and restore the variable stack instead. */
00195   void **save_var_stack;
00196   save_var_stack = GC_variable_stack;
00197 #endif
00198 
00199   while (gcbm) {
00200     wxCanvas *cnvs = GET_CANVAS(gcbm);
00201 #ifdef MZ_PRECISE_GC
00202     if (!gcOBJ_TO_PTR(cnvs))
00203       cnvs = NULL;
00204 #endif
00205     if (cnvs) {
00206       /* Due to custodian shutdowns and ordered finalization, it's
00207         possible that a canvas will be deleted without yet being
00208         collected: */
00209       if (cnvs->__type != -1) {
00210        wxCanvasDC *dc;
00211        dc = (wxCanvasDC *)cnvs->GetDC();
00212        dc->GCBlit(gcbm->x, gcbm->y,
00213                  gcbm->w, gcbm->h,
00214                  on ? gcbm->on : gcbm->off,
00215                  0, 0);
00216       }
00217     }
00218     gcbm = gcbm->next;
00219   }
00220 
00221 #ifdef MZ_PRECISE_GC
00222   GC_variable_stack = save_var_stack;
00223 #endif
00224 
00225 #ifdef wx_x
00226   XFlush(MrEdGetXDisplay());
00227 #endif
00228 }
00229 
00230 #ifdef MZ_PRECISE_GC
00231 END_XFORM_SKIP;
00232 #endif
00233 
00234 void wxsKeymapError(char *s)
00235 {
00236   scheme_signal_error("%s", s);
00237 }
00238 
00239 #ifdef MZ_PRECISE_GC
00240 START_XFORM_SKIP;
00241 #endif
00242 
00243 static void collect_start_callback(void)
00244 {
00245 #ifdef wx_msw
00246   wx_release_lazy_regions();
00247 #endif
00248   draw_gc_bm(1);
00249   orig_collect_start_callback();
00250 }
00251 
00252 static void collect_end_callback(void)
00253 {
00254   orig_collect_end_callback();
00255   draw_gc_bm(0);
00256 }
00257 
00258 #ifdef MZ_PRECISE_GC
00259 END_XFORM_SKIP;
00260 #endif
00261 
00262 static Scheme_Object *wxSchemeUnregisterCollectingBitmap(int, Scheme_Object **a)
00263 {
00264   GCBitmap *gcbm, *prev = NULL;
00265   wxCanvas *c;
00266 
00267   if (a)
00268     c = objscheme_unbundle_wxCanvas(a[0], "unregister-collecting-blit", 0);
00269   else
00270     c = NULL;
00271   
00272   gcbm = gc_bitmaps;
00273   while (gcbm) {
00274     if (!gcbm->canvasptr || (GET_CANVAS(gcbm) == c)) {
00275       if (prev)
00276        prev->next = gcbm->next;
00277       else
00278        gc_bitmaps = gcbm->next;
00279       gcbm->on = gcbm->off = NULL;
00280       gcbm->canvasptr = NULL;
00281     } else
00282       prev = gcbm;
00283     gcbm = gcbm->next;
00284   }
00285 
00286   return scheme_void;
00287 }
00288 
00289 static Scheme_Object *wxSchemeRegisterCollectingBitmap(int n, Scheme_Object **a)
00290 {
00291   GCBitmap *gcbm;
00292   wxCanvas *cvs;
00293 
00294   gcbm = new WXGC_PTRS GCBitmap;
00295 
00296   cvs = objscheme_unbundle_wxCanvas(a[0], "register-collecting-blit", 0);
00297 
00298 #ifdef MZ_PRECISE_GC
00299   {
00300     void *cp;
00301     cp = GC_malloc_weak_box(gcOBJ_TO_PTR(cvs), NULL, 0);
00302     gcbm->canvasptr = (Scheme_Object *)cp;
00303   }
00304 #else
00305   gcbm->canvasptr = (wxCanvas **)scheme_malloc_atomic(sizeof(wxCanvas*));
00306   *gcbm->canvasptr = cvs;
00307 #endif
00308 
00309   gcbm->x = objscheme_unbundle_double(a[1], "register-collecting-blit");
00310   gcbm->y = objscheme_unbundle_double(a[2], "register-collecting-blit");
00311   gcbm->w = objscheme_unbundle_nonnegative_double(a[3], "register-collecting-blit");
00312   gcbm->h = objscheme_unbundle_nonnegative_double(a[4], "register-collecting-blit");
00313   gcbm->on = objscheme_unbundle_wxBitmap(a[5], "register-collecting-blit", 0);
00314   gcbm->off = objscheme_unbundle_wxBitmap(a[6], "register-collecting-blit", 0);
00315   gcbm->onx = gcbm->ony = gcbm->offx = gcbm-> offy = 0;
00316   if (n > 7) {
00317     gcbm->onx = objscheme_unbundle_double(a[7], "register-collecting-blit");
00318     if (n > 8) {
00319       gcbm->ony = objscheme_unbundle_double(a[8], "register-collecting-blit");
00320       if (n > 9) {
00321        gcbm->offx = objscheme_unbundle_double(a[9], "register-collecting-blit");
00322        if (n > 10) {
00323          gcbm->offy = objscheme_unbundle_double(a[10], "register-collecting-blit");
00324        }
00325       }
00326     }
00327   }
00328 
00329   gcbm->next = gc_bitmaps;
00330   gc_bitmaps = gcbm;
00331 
00332 #ifndef MZ_PRECISE_GC
00333   GC_general_register_disappearing_link((void **)gcbm->canvasptr, 
00334                                    *gcbm->canvasptr);
00335 #endif
00336 
00337   wxSchemeUnregisterCollectingBitmap(0, NULL);
00338 
00339   return scheme_void;
00340 }
00341 
00342 /***********************************************************************/
00343 /*                             open gl                                 */
00344 /***********************************************************************/
00345 
00346 #ifdef wx_msw
00347 # define USE_GL
00348 #endif
00349 #ifdef wx_mac
00350 # define USE_GL
00351 # ifdef OS_X
00352 #  define PROTECT_GLS
00353 # endif
00354 #endif
00355 
00356 #ifdef PROTECT_GLS
00357 static int gl_param;
00358 #endif
00359 
00360 #ifdef MPW_CPLUS
00361 extern "C" {
00362   typedef void (*DW_PRE_PTR)(void *);
00363   typedef Scheme_Object *(*DW_RUN_PTR)(void *);
00364   typedef void (*DW_POST_PTR)(void *);
00365 }
00366 # define CAST_DW_PRE (DW_PRE_PTR)
00367 # define CAST_DW_RUN (DW_RUN_PTR)
00368 # define CAST_DW_POST (DW_POST_PTR)
00369 #else
00370 # define CAST_DW_PRE /* empty */
00371 # define CAST_DW_RUN /* empty */
00372 # define CAST_DW_POST /* empty */
00373 #endif
00374 
00375 #ifdef USE_GL
00376 
00377 extern void wxGLNoContext(void);
00378 static Scheme_Object *context_sema;
00379 static Scheme_Thread *context_lock_thread;
00380 static wxGL *context_lock_holder;
00381 
00382 #ifdef PROTECT_GLS
00383 /* We can protect a GL context from other threads only if it's ok to
00384    switch the GL context at any time. It appears to be ok only under
00385    Mac OS. */
00386 static Scheme_Object *on_thread_swap(Scheme_Object *)
00387 {
00388   Scheme_Object *o;
00389   wxGL *c;
00390 
00391   o = scheme_get_param(scheme_current_config(), gl_param);
00392   if (SCHEME_TRUEP(o))
00393     c = objscheme_unbundle_wxGL(o, NULL, 0);
00394   else
00395     c = NULL;
00396  
00397   if (c)
00398     c->ThisContextCurrent();
00399   else
00400     wxGLNoContext();
00401 
00402   return NULL;
00403 }
00404 #endif
00405 
00406 static void init_gl_mgr(void)
00407 {
00408 #ifdef PROTECT_GLS
00409   scheme_set_param(scheme_current_config(), gl_param, scheme_false);
00410   scheme_add_swap_callback(on_thread_swap, NULL);
00411 #endif
00412 }
00413 
00414 static void swap_ctx(void *c)
00415      /* In the PROTECT_GLS case, We defeat this general
00416        parameterize-like swap below to keep it in sync with the lock,
00417        but maybe it will be useful some day. */
00418 {
00419   Scheme_Object *n;
00420   wxGL *gl;
00421 
00422   n = ((Scheme_Object **)c)[1];
00423 #ifdef PROTECT_GLS
00424   {
00425     Scheme_Object *o;
00426     Scheme_Config *config;
00427     config = scheme_current_config();
00428     o = scheme_get_param(config, gl_param);
00429     scheme_set_param(config, gl_param, n);
00430     ((Scheme_Object **)c)[1] = o;
00431   }
00432 #else
00433   ((Scheme_Object **)c)[1] = scheme_false;
00434 #endif
00435 
00436   if (SCHEME_TRUEP(n)) {
00437     gl = objscheme_unbundle_wxGL(n, NULL, 0);
00438     if (gl)
00439       gl->ThisContextCurrent();
00440     else
00441       wxGLNoContext();
00442   } else
00443     wxGLNoContext();
00444 }
00445 
00446 static void swap_ctx_in(void *c)
00447 {
00448   if (*(Scheme_Object **)c)
00449     swap_ctx(c);
00450 }
00451 
00452 static Scheme_Object *do_call_ctx(void *c)
00453 {
00454   return _scheme_apply_multi(((Scheme_Object **)c)[0], 0, NULL);
00455 }
00456 
00457 static void swap_ctx_out(void *c)
00458 {
00459   if (*(Scheme_Object **)c) {
00460     swap_ctx(c);
00461     *(Scheme_Object **)c = NULL;
00462     context_lock_holder = NULL;
00463     context_lock_thread = NULL;
00464     scheme_post_sema(context_sema);
00465   }
00466 }
00467 
00468 static void release_context_lock(void *c)
00469 {
00470   wxGLNoContext();
00471   context_lock_holder = NULL;
00472   context_lock_thread = NULL;
00473   scheme_post_sema(context_sema);
00474 }
00475 
00476 void *wxWithGLContext(wxGL *gl, void *thunk, void *alt_evt, int eb)
00477 {
00478   Scheme_Object **a, *wa[3], *glo, *v;
00479   Scheme_Thread *thread;
00480   int evts;
00481 
00482   if (!context_sema) {
00483     wxREGGLOB(context_lock_holder);
00484     wxREGGLOB(context_lock_thread);
00485     wxREGGLOB(context_sema);
00486     context_sema = scheme_make_sema(1);
00487   }
00488 
00489   thread = scheme_get_current_thread();
00490   if ((gl == context_lock_holder)
00491       && (context_lock_thread == thread)) {
00492     /* The lock is already held by this GL context. */
00493     return _scheme_apply_multi((Scheme_Object *)thunk, 0, NULL);
00494   }
00495 
00496   a = (Scheme_Object **)scheme_malloc(2 * sizeof(Scheme_Object *));
00497   glo = objscheme_bundle_wxGL(gl);
00498 
00499   a[0] = (Scheme_Object *)thunk;
00500   a[1] = (Scheme_Object *)alt_evt;
00501 
00502   scheme_check_proc_arity("call-as-current in gl-context<%>", 
00503                        0, 0, 
00504                        (alt_evt ? 2 : 1), a);
00505   if (alt_evt) {
00506     if (!scheme_is_evt((Scheme_Object *)alt_evt)) {
00507       scheme_wrong_type("call-as-current in gl-context<%>", "evt", 1, 2, a);
00508       return NULL;
00509     }
00510     evts = 2;
00511     wa[1] = a[1];
00512   } else
00513     evts = 1;
00514 
00515   wa[0] = context_sema;
00516 
00517   if (eb)
00518     v = scheme_sync_enable_break(evts, wa);
00519   else
00520     v = scheme_sync(evts, wa);
00521 
00522   /* Note: successful sync gets here before any kill or break */
00523 
00524   if (v == context_sema) {
00525     context_lock_holder = gl;
00526     context_lock_thread = scheme_get_current_thread();
00527 
00528     a[0] = (Scheme_Object *)thunk;
00529     a[1] = glo;
00530 
00531     BEGIN_ESCAPEABLE(release_context_lock, a);
00532     v = scheme_dynamic_wind(CAST_DW_PRE swap_ctx_in, 
00533                          CAST_DW_RUN do_call_ctx, 
00534                          CAST_DW_POST swap_ctx_out,
00535                          NULL, a);
00536     END_ESCAPEABLE();
00537   }
00538 
00539   return v;
00540 }
00541 
00542 #endif
00543 
00544 
00545 void wxscheme_early_gl_init(void)
00546 {
00547 #ifdef PROTECT_GLS
00548   gl_param = scheme_new_param();
00549 #endif
00550 }
00551 
00552 
00553 /***********************************************************************/
00554 /*                            blit util                                */
00555 /***********************************************************************/
00556 
00557 #if defined(wx_msw) || defined(wx_xt)
00558 
00559 void wxAlphaBlit(wxBitmap *label_bm, wxBitmap *bm, wxBitmap *loaded_mask, 
00560                int br, int bg, int bb)
00561 {
00562   int i, j, w, h;
00563   wxMemoryDC *src, *mask, *dest;
00564 #ifdef wx_msw
00565   int no_src_desel = 0, no_mask_desel = 0;
00566 #endif
00567 
00568   w = label_bm->GetWidth();
00569   h = label_bm->GetHeight();
00570 
00571   dest = new WXGC_PTRS wxMemoryDC();
00572   dest->SelectObject(label_bm);
00573 
00574 #ifdef wx_msw
00575   if (bm->selectedInto) {
00576     src = (wxMemoryDC *)bm->selectedInto;
00577     no_src_desel = 1;
00578   } else
00579 #endif
00580     {
00581       src = new WXGC_PTRS wxMemoryDC(1);
00582       src->SelectObject(bm);
00583     }
00584 
00585 #ifdef wx_msw
00586   if (loaded_mask == bm) {
00587     mask = src;
00588     no_mask_desel = 1;
00589   } else if (loaded_mask->selectedInto) {
00590     mask = (wxMemoryDC *)loaded_mask->selectedInto;
00591     no_mask_desel = 1;
00592   } else
00593 #endif
00594     {
00595       mask = new WXGC_PTRS wxMemoryDC(1);      
00596       mask->SelectObject(loaded_mask);
00597     }
00598 
00599   src->BeginGetPixelFast(0, 0, w, h);
00600   if (src != mask)
00601     mask->BeginGetPixelFast(0, 0, w, h);
00602   dest->BeginSetPixelFast(0, 0, w, h);
00603   for (i = 0; i < w; i++) {
00604     for (j = 0; j < h; j++) {
00605       int sr, sg, sb, mr, mg, mb, ialpha;
00606       src->GetPixelFast(i, j, &sr, &sg, &sb);
00607       mask->GetPixelFast(i, j, &mr, &mg, &mb);
00608       ialpha = (mr + mg + mb) / 3;
00609       mr = ((ialpha * br) + ((255 - ialpha) * sr)) / 255;
00610       mg = ((ialpha * bg) + ((255 - ialpha) * sg)) / 255;
00611       mb = ((ialpha * bb) + ((255 - ialpha) * sb)) / 255;
00612       dest->SetPixelFast(i, j, mr, mg, mb);
00613     }
00614   }
00615   if (src != mask)
00616     mask->EndGetPixelFast();
00617   src->EndGetPixelFast();
00618   dest->EndSetPixelFast();
00619 
00620 #ifdef wx_msw
00621   if (!no_src_desel)
00622 #endif
00623     src->SelectObject(NULL);
00624 #ifdef wx_msw
00625   if (!no_mask_desel)
00626 #endif
00627     mask->SelectObject(NULL);
00628   dest->SelectObject(NULL);
00629 }
00630 
00631 #endif
00632 
00633 /***********************************************************************/
00634 /*                          color chooser                              */
00635 /***********************************************************************/
00636 
00637 #ifdef wx_msw
00638 static BOOL do_choose_color(void *data, HWND parent)
00639 {
00640   CHOOSECOLOR *c = (CHOOSECOLOR *)data;
00641   c->hwndOwner = parent;
00642 
00643   return ChooseColor(c);
00644 }
00645 #endif
00646 
00647 #ifdef wx_mac
00648 pascal Boolean NullEventFilter(EventRecord *evt) 
00649 {
00650   // just dump them all on the color picker
00651   return false;
00652 }
00653 
00654 pascal void MyColorChangedCallback ( SInt32 userData, PMColor *newColor )
00655 {
00656   // do nothing
00657   return;
00658 }
00659 #endif
00660 
00661 static Scheme_Object *wxSchemeGetColourFromUser(int argc, Scheme_Object **argv)
00662 {
00663   char *s;
00664 #ifndef wx_x
00665   wxColour *c;
00666 # ifdef wx_msw
00667   wxWindow *parent;
00668 # endif
00669 #endif
00670 
00671   if (!argc || SCHEME_FALSEP(argv[0]))
00672     s = "Choose a color";
00673   else
00674     s = objscheme_unbundle_string(argv[0], "get-color-from-user");
00675 
00676 #ifndef wx_x
00677 # ifdef wx_msw
00678   parent = ((argc > 1)
00679            ? objscheme_unbundle_wxWindow(argv[1], "get-color-from-user", 1)
00680            : NULL);
00681 # endif
00682   c = ((argc > 2)
00683        ? objscheme_unbundle_wxColour(argv[2], "get-color-from-user", 1)
00684        : NULL);
00685 #endif
00686 
00687 #ifdef wx_x
00688   return scheme_false;
00689 #endif
00690 #ifdef wx_mac
00691 # ifdef WX_CARBON
00692   {
00693     GC_CAN_IGNORE struct ColorPickerInfo cpInfo;
00694 
00695     wxPrimDialogSetUp();
00696     
00697     cpInfo.theColor.profile = NULL; // use the default ColorSync profile
00698     if (c) {
00699       int v;
00700       v = c->Red();
00701       cpInfo.theColor.color.rgb.red = (v << 8) | v;
00702       v = c->Green();
00703       cpInfo.theColor.color.rgb.green = (v << 8) | v;
00704       v = c->Blue();
00705       cpInfo.theColor.color.rgb.blue = (v << 8) | v;
00706     } else {
00707       cpInfo.theColor.color.rgb.red = cpInfo.theColor.color.rgb.green = cpInfo.theColor.color.rgb.blue = 0;
00708     }
00709 
00710     cpInfo.dstProfile = NULL; // default Profile (again!)
00711     cpInfo.flags = 0;
00712     cpInfo.placeWhere = kCenterOnMainScreen;  
00713     cpInfo.dialogOrigin.h = 0;
00714     cpInfo.dialogOrigin.v = 0;
00715     cpInfo.pickerType = 0; 
00716     cpInfo.eventProc = NewUserEventUPP(NullEventFilter);
00717     cpInfo.colorProc = NewColorChangedUPP(MyColorChangedCallback);
00718     cpInfo.colorProcData = 0;
00719     cpInfo.mInfo.editMenuID = 128; // Not sure this will work.
00720     CopyCStringToPascal(s,cpInfo.prompt);
00721     cpInfo.newColorChosen = FALSE;
00722     
00723     if (PickColor(&cpInfo) != noErr) {
00724       return scheme_false;
00725     }
00726     if (cpInfo.newColorChosen == FALSE) {
00727       return scheme_false;
00728     }
00729     
00730     c = new WXGC_PTRS wxColour(cpInfo.theColor.color.rgb.red >> 8, 
00731                             cpInfo.theColor.color.rgb.green >> 8, 
00732                             cpInfo.theColor.color.rgb.blue >> 8);
00733 
00734     wxPrimDialogCleanUp();
00735 
00736     return objscheme_bundle_wxColour(c);
00737   }    
00738 # else
00739   int l;
00740   Point pt = {0, 0};
00741   Str255 buf;
00742   RGBColor in, out;
00743   
00744   CopyCStringToPascal(s,buf);
00745 
00746   if (c) {
00747     in.red = c->Red() << 8;
00748     in.green = c->Green() << 8;
00749     in.blue = c->Blue() << 8;
00750   } else
00751     in.red = in.green = in.blue = 0;
00752 
00753   if (!GetColor(pt, buf, &in, &out))
00754     return scheme_false;
00755 
00756   c = new WXGC_PTRS wxColour(out.red >> 8, out.green >> 8, out.blue >> 8);
00757 
00758   return objscheme_bundle_wxColour(c);
00759 # endif
00760 #endif
00761 #ifdef wx_msw
00762   {
00763     CHOOSECOLOR *cc;
00764     static unsigned long userCustomColors[16];
00765 
00766     cc = (CHOOSECOLOR *)malloc(sizeof(CHOOSECOLOR));
00767     cc->lStructSize = sizeof(CHOOSECOLOR);
00768     cc->hwndOwner = NULL; // (parent ? parent->GetHWND() : (HWND)NULL)
00769     if (c) {
00770       int rr, gg, bb;
00771       rr = c->Red();
00772       gg = c->Green();
00773       bb = c->Blue();
00774       cc->rgbResult = RGB(rr, gg, bb);
00775     }
00776     cc->Flags = (c ? CC_RGBINIT : 0);
00777     cc->lpCustColors = userCustomColors;
00778     
00779     if (!wxPrimitiveDialog(do_choose_color, cc, 0)) {
00780       free(cc);
00781       return scheme_false;
00782     }
00783     
00784     c = new WXGC_PTRS wxColour(GetRValue(cc->rgbResult), GetGValue(cc->rgbResult), GetBValue(cc->rgbResult));
00785     
00786     free(cc);
00787     cc = NULL;
00788 
00789     return objscheme_bundle_wxColour(c);
00790   }
00791 #endif
00792 }
00793 
00794 /***********************************************************************/
00795 /*                           font chooser                              */
00796 /***********************************************************************/
00797 
00798 #ifdef wx_msw
00799 static BOOL do_choose_font(void *data, HWND parent)
00800 {
00801   CHOOSEFONT *c = (CHOOSEFONT *)data;
00802   c->hwndOwner = parent;
00803 
00804   return ChooseFont(c);
00805 }
00806 #endif
00807 
00808 static Scheme_Object *wxSchemeGetFontFromUser(int argc, Scheme_Object **argv)
00809 {
00810   char *prompt;
00811 
00812   if (!argc || SCHEME_FALSEP(argv[0]))
00813     prompt = "Choose a font";
00814   else
00815     prompt = objscheme_unbundle_string(argv[0], "get-font-from-user");
00816 
00817 #ifdef wx_x
00818   return scheme_false;
00819 #endif
00820 #ifdef wx_mac
00821   return scheme_false;
00822 #endif
00823 #ifdef wx_msw
00824   {
00825     wxWindow *parent;
00826     wxFont *f;
00827     CHOOSEFONT *c;
00828     LOGFONT *lf;
00829     int len;
00830     char *s;
00831     int fontFamily = wxSWISS;
00832     int fontStyle = wxNORMAL;
00833     int fontWeight = wxNORMAL;
00834     int fontPoints = 10;
00835     Bool fontUnderline = FALSE;
00836     int lfFamily;
00837 
00838     parent = ((argc > 1)
00839                     ? objscheme_unbundle_wxWindow(argv[1], "get-font-from-user", 1)
00840                     : NULL);
00841     f = ((argc > 2)
00842         ? objscheme_unbundle_wxFont(argv[2], "get-font-from-user", 1)
00843         : NULL);
00844 
00845     lf = (LOGFONT *)malloc(sizeof(LOGFONT));
00846     c = (CHOOSEFONT *)malloc(sizeof(CHOOSEFONT));
00847 
00848     s = (f ? f->GetFaceString() : NULL);
00849     if (s) {
00850       len = strlen(s);
00851       if (len > 31)
00852        len = 31;
00853     } else
00854       len = 0;
00855   
00856     memcpy(lf->lfFaceName, s, len);
00857     lf->lfFaceName[len] = 0;
00858   
00859     lf->lfHeight = 0;
00860     lf->lfWidth = 0;
00861     lf->lfEscapement = 0;
00862     lf->lfOrientation = 0;
00863     if (f) {
00864       switch (f->GetWeight()) {
00865       case wxBOLD:
00866        lf->lfWeight = FW_BOLD;
00867        break;
00868       case wxLIGHT:
00869        lf->lfWeight = FW_LIGHT;
00870       default:
00871        lf->lfWeight = FW_NORMAL;
00872       } 
00873     } else
00874       lf->lfWeight = FW_NORMAL;
00875     if (f) {
00876       switch (f->GetStyle()) {
00877       case wxITALIC:
00878       case wxSLANT:
00879        lf->lfItalic = TRUE;
00880        break;
00881       default:
00882        lf->lfItalic = FALSE;
00883       } 
00884     } else
00885       lf->lfItalic = FALSE;
00886     if (f) {
00887       int ul;
00888       ul = f->GetUnderlined();
00889       lf->lfUnderline = ul;
00890     } else
00891       lf->lfUnderline = FALSE;
00892     lf->lfStrikeOut = FALSE;
00893     lf->lfCharSet = OEM_CHARSET;
00894     lf->lfOutPrecision = OUT_DEFAULT_PRECIS;
00895     lf->lfClipPrecision = CLIP_DEFAULT_PRECIS;
00896     lf->lfQuality = DEFAULT_QUALITY;
00897     lf->lfPitchAndFamily = DEFAULT_PITCH;
00898     if (f) {
00899       switch (f->GetFamily()) {
00900       case wxDECORATIVE:
00901        lf->lfPitchAndFamily |= FF_DECORATIVE;
00902        break;
00903       case wxMODERN:
00904        lf->lfPitchAndFamily = FIXED_PITCH | FF_MODERN;
00905        break;
00906       case wxROMAN:
00907        lf->lfPitchAndFamily |= FF_ROMAN;
00908        break;
00909       case wxSCRIPT:
00910        lf->lfPitchAndFamily |= FF_SCRIPT;
00911        break;
00912       case wxSWISS:
00913        lf->lfPitchAndFamily |= FF_SWISS;
00914        break;
00915       default:
00916       case wxDEFAULT:
00917        lf->lfPitchAndFamily |= FF_DONTCARE;
00918        break;
00919       } 
00920     } else
00921       lf->lfPitchAndFamily |= FF_DONTCARE;
00922 
00923     c->lStructSize = sizeof(CHOOSEFONT);
00924     c->hwndOwner = NULL; /* (parent ? parent->GetHWND() : (HWND)NULL) */
00925     c->lpLogFont = lf;
00926     if (f) {
00927       int ps;
00928       ps = f->GetPointSize();
00929       c->iPointSize = 10 * ps;
00930     } else
00931       c->iPointSize = 100;
00932     c->Flags = CF_INITTOLOGFONTSTRUCT | CF_SCREENFONTS;
00933 
00934     if (!wxPrimitiveDialog(do_choose_font, c, 0)) {
00935       free(c);
00936       free(lf);
00937       return scheme_false;
00938     }
00939   
00940     if (!lf->lfFaceName[0])
00941       s = NULL;
00942     else
00943       s = lf->lfFaceName;
00944     
00945     lfFamily = lf->lfPitchAndFamily;
00946     if (lfFamily & FIXED_PITCH)
00947       lfFamily -= FIXED_PITCH;
00948     if (lfFamily & VARIABLE_PITCH)
00949       lfFamily -= VARIABLE_PITCH;
00950     
00951     switch (lfFamily)
00952       {
00953       case FF_ROMAN:
00954        fontFamily = wxROMAN;
00955        break;
00956       case FF_SWISS:
00957        fontFamily = wxSWISS;
00958        break;
00959       case FF_SCRIPT:
00960        fontFamily = wxSCRIPT;
00961        break;
00962       case FF_MODERN:
00963        fontFamily = wxMODERN;
00964        break;
00965       case FF_DECORATIVE:
00966        fontFamily = wxDECORATIVE;
00967        break;
00968       default:
00969        fontFamily = wxSWISS;
00970        break;
00971       }
00972     switch (lf->lfWeight)
00973       {
00974       case FW_LIGHT:
00975        fontWeight = wxLIGHT;
00976        break;
00977       case FW_NORMAL:
00978        fontWeight = wxNORMAL;
00979        break;
00980       case FW_BOLD:
00981        fontWeight = wxBOLD;
00982        break;
00983       default:
00984        fontWeight = wxNORMAL;
00985        break;
00986       }
00987     if (lf->lfItalic)
00988       fontStyle = wxITALIC;
00989     else
00990       fontStyle = wxNORMAL;
00991 
00992     if (lf->lfUnderline)
00993       fontUnderline = TRUE;
00994 
00995     if (s)
00996       f = new WXGC_PTRS wxFont(c->iPointSize / 10, s, fontFamily, fontStyle, 
00997                             fontWeight, fontUnderline);
00998     else
00999       f = new WXGC_PTRS wxFont(c->iPointSize / 10, fontFamily, fontStyle, 
01000                             fontWeight, fontUnderline);
01001 
01002     free(c);
01003     c = NULL;
01004     free(lf);
01005     lf = NULL;
01006 
01007     return objscheme_bundle_wxFont(f);
01008   }
01009 #endif
01010 }
01011 
01012 #ifdef wx_x
01013 static int indirect_strcmp(const void *a, const void *b)
01014 {
01015   return strcmp(*(char **)a, *(char **)b);
01016 }
01017 
01018 static int is_x_monospace(char *s)
01019 {
01020   if (s[0] == '-') {
01021     /* Full X font name. Check for "-m-" or "-c-" in name. */
01022     int j;
01023     for (j = 0; s[j+2]; j++) {
01024       if ((s[j] == '-') 
01025           && ((s[j+1] == 'm') || (s[j+1] == 'c'))
01026           && (s[j+2] == '-'))
01027         return 1;
01028     }
01029   }
01030   
01031   return 0;
01032 }
01033 #endif
01034 
01035 
01036 #ifdef wx_msw
01037 typedef struct {
01038   int mono_only;
01039   int count, size;
01040   mzchar **names;
01041 } gfData;
01042 
01043 static int CALLBACK get_font(ENUMLOGFONTW FAR*  lpelf, 
01044                           NEWTEXTMETRICW FAR* lpntm, 
01045                           DWORD type, 
01046                           LPARAM _data)
01047 {
01048   gfData *data = (gfData *)_data;
01049   long ulen;
01050   mzchar *s;
01051 
01052   if (data->mono_only) {
01053     /* TMPF_FIXED_PITCH flag means not monospace */
01054     if (lpntm->tmPitchAndFamily & TMPF_FIXED_PITCH) {
01055       return 1;
01056     }
01057   }
01058   
01059   if (data->count == data->size) {
01060     mzchar **naya;
01061 
01062     data->size += (2 * data->size) + 10;
01063     naya = new WXGC_PTRS mzchar*[data->size];
01064     memcpy(naya, data->names, data->count * sizeof(mzchar *));
01065     data->names = naya;
01066   }
01067   
01068   s = scheme_utf16_to_ucs4((unsigned short *)lpelf->elfLogFont.lfFaceName, 0, 
01069                         wx_wstrlen(lpelf->elfLogFont.lfFaceName),
01070                         0, 0, &ulen, 1);
01071   s[ulen] = 0;
01072 
01073   data->names[data->count++] = s;
01074 
01075 #  ifdef MZ_PRECISE_GC
01076 #   ifndef GC_STACK_CALLEE_RESTORE
01077   /* Restore variable stack. */
01078   GC_variable_stack = (void **)__gc_var_stack__[0];
01079 #   endif
01080 #  endif
01081 
01082   return 1;
01083 }
01084 #endif
01085 
01086 #ifdef wx_mac
01087 /* The actual name of a Mac font is not what you want to see on the
01088    screen; the actual name is derived by encoding the pretty name
01089    using the font's encoding. */
01090 char *wx_get_mac_font_name(FMFontFamily fam, unsigned char *fname, int *_l) 
01091 {
01092   TextEncoding encoding;
01093   TextToUnicodeInfo uinfo;
01094   ByteCount converted = 0, ubytes = 0;
01095   UniChar us_buf[128];      
01096   OSErr err;
01097   char *s;
01098   int l;
01099 
01100   FMGetFontFamilyName(fam, fname);
01101   
01102   s = (char *)fname XFORM_OK_PLUS 1;
01103   l = fname[0];
01104 
01105   /* If the "encoded" name is all ASCII, then don't decode.
01106      Otherwise, fonts like "Symbol" and "Zaph Chancery" get funny
01107      names. */
01108   {
01109     int i;
01110     for (i = 0; i < l; i++) {
01111       if (((unsigned char *)s)[i] > 127)
01112        break;
01113     }
01114     if (i == l) {
01115       *_l = l;
01116       return s;
01117     }
01118   }
01119 
01120   FMGetFontFamilyTextEncoding(fam, &encoding);
01121 
01122   CreateTextToUnicodeInfoByEncoding(encoding, &uinfo);
01123   
01124   /* Warning: we assume that the Unicode name will fit in us_buf: */
01125   err = ConvertFromTextToUnicode(uinfo, l, s, 0,
01126                              0, NULL,
01127                              NULL, NULL,
01128                              sizeof(us_buf), &converted, &ubytes,
01129                              us_buf);
01130 
01131   DisposeTextToUnicodeInfo(&uinfo);
01132 
01133   if (!err) {
01134     long ulen = ubytes / sizeof(UniChar);
01135     l = scheme_utf8_encode((unsigned int *)us_buf, 0, ulen,
01136                         NULL, 0, 1 /* UTF-16 */);
01137     if (l < 256)
01138       s = (char *)fname;
01139     else
01140       s = new WXGC_ATOMIC char[l];
01141     l = scheme_utf8_encode((unsigned int *)us_buf, 0, ulen,
01142                         (unsigned char *)s, 0, 1 /* UTF-16 */);
01143     s[l] = 0;
01144   }
01145 
01146   *_l = l;
01147   return s;
01148 }
01149 #endif
01150 
01151 typedef int (*Indirect_Cmp_Proc)(const void *, const void *);
01152 
01153 #ifdef wx_mac
01154 extern "C" int wx_isFamilyFixedWidth(FMFontFamily fam);
01155 #endif
01156 
01157 static Scheme_Object *wxSchemeGetFontList(int argc, Scheme_Object **argv)
01158 {
01159   Scheme_Object *first = scheme_null, *last = NULL;
01160   int mono_only = 0;
01161 #ifdef wx_x
01162   int count, i = 0, pos;
01163   char **xnames, **names;
01164   int last_pos = -1, last_len = 0;
01165 #endif
01166 #ifdef wx_mac
01167   FMFontFamilyIterator iterator;
01168   FMFontFamily fam;
01169   Str255 fname;
01170 #endif
01171 #ifdef wx_msw
01172   gfData data;
01173   HDC dc;
01174   int i = 0;
01175 #endif
01176 
01177   if (argc > 0) {
01178     if (!mono_symbol) {
01179       wxREGGLOB(mono_symbol);
01180       wxREGGLOB(all_symbol);
01181       mono_symbol = scheme_intern_symbol("mono");
01182       all_symbol = scheme_intern_symbol("all");
01183     }
01184     if (SAME_OBJ(mono_symbol, argv[0]))
01185       mono_only = 1;
01186     else if (!SAME_OBJ(all_symbol, argv[0])) {
01187       scheme_wrong_type("get-face-list", "'mono or 'all symbol", 0, argc, argv);
01188       return NULL;
01189     }
01190   }
01191   
01192 #ifdef wx_x
01193   xnames = XListFonts(wxAPP_DISPLAY, "*", 50000, &count);
01194 
01195   names = (char **)scheme_malloc_atomic(sizeof(char*)*count);
01196   pos = 0;
01197   for (i = 0; i < count; i++) {
01198     if (!mono_only || is_x_monospace(xnames[i]))
01199       names[pos++] = xnames[i];
01200   }
01201 
01202   qsort(names, pos, sizeof(char *), 
01203        (Indirect_Cmp_Proc)indirect_strcmp);
01204 
01205   i = 0;
01206 #endif
01207 #ifdef wx_mac
01208 # ifndef OS_X
01209 #  define kFMDefaultIterationScope 0
01210 # endif
01211   FMCreateFontFamilyIterator(NULL, NULL, kFMDefaultIterationScope, &iterator);
01212 #endif
01213 #ifdef wx_msw
01214   data.mono_only = mono_only;
01215   data.count = data.size = 0;
01216   data.names = NULL;
01217 
01218   dc = GetDC(NULL);
01219 
01220   EnumFontFamiliesW(dc, NULL, (FONTENUMPROCW)get_font, (LPARAM)&data);
01221 #endif
01222 
01223   while (1) {
01224     char *s;
01225     int l;
01226     Scheme_Object *pr;
01227 
01228 #ifdef wx_x
01229     while ((i < pos)
01230           && ((last_pos >= 0) 
01231               && !strncmp(names[i], names[last_pos], last_len))) {
01232       i++;
01233     }
01234     if (i >= pos)
01235       break;
01236 
01237     last_pos = i;
01238     if (names[i][0] != '-') {
01239       l = strlen(names[i]);
01240     } else {
01241       int c = 0;
01242       for (l = 0; names[i][l]; l++) {
01243        if (names[i][l] == '-') {
01244          c++;
01245          if (c == 3) {
01246            /* Special case: null weight, slant, non-normal */
01247            if (names[i][l + 1] == '-') {
01248              l++;
01249              if (names[i][l + 1] == '-') {
01250               l++;
01251               if (names[i][l + 1] == '-')
01252                 l++;
01253              }
01254            }
01255            break;
01256          }
01257        }
01258       }
01259     }
01260     last_len = l;
01261     
01262     s = names[i++];
01263 #endif
01264 #ifdef wx_mac
01265     if (FMGetNextFontFamily(&iterator, &fam) != noErr)
01266       break;
01267     if (mono_only && !wx_isFamilyFixedWidth(fam))
01268       continue;
01269     s = wx_get_mac_font_name(fam, fname, &l);
01270 #endif
01271 #ifdef wx_msw
01272     if (i >= data.count)
01273       break;
01274     {
01275       mzchar *ws;
01276       ws = data.names[i++];
01277       s = scheme_utf8_encode_to_buffer(ws, scheme_char_strlen(ws), NULL, 0);
01278     }
01279     l = strlen(s);
01280 #endif
01281     
01282     pr = scheme_make_pair(scheme_make_sized_utf8_string(s, l), scheme_null);
01283     if (last)
01284       SCHEME_CDR(last) = pr;
01285     else
01286       first = pr;
01287     last = pr;
01288   }
01289 
01290 #ifdef wx_x
01291   XFreeFontNames(xnames);
01292   xnames = NULL;
01293 #endif
01294 #ifdef wx_msw
01295    ReleaseDC(NULL, dc);
01296 #endif
01297 #ifdef wx_mac
01298    FMDisposeFontFamilyIterator(&iterator);
01299 #endif
01300 
01301   /* But wait --- there's more! At least under X when Xft is enabled.
01302      In that case, we want the Xft names, too, and we put them on the
01303      front. */
01304 #ifdef WX_USE_XFT
01305   {
01306     char **fl;
01307     int len, i;
01308 
01309     fl = wxGetCompleteFaceList(&len, mono_only);
01310 
01311     for (i = 0; i < len; i++) {
01312       first = scheme_make_pair(scheme_make_utf8_string(fl[i]), first);
01313     }
01314 
01315     first = scheme_make_pair(scheme_make_utf8_string(" Sans-Serif"), first);
01316     first = scheme_make_pair(scheme_make_utf8_string(" Serif"), first);
01317     first = scheme_make_pair(scheme_make_utf8_string(" Monospace"), first);
01318   }
01319 #endif
01320 
01321   return first;
01322 }
01323 
01324 /***********************************************************************/
01325 /*                        PostScript hooks                             */
01326 /***********************************************************************/
01327 
01328 static Scheme_Object *ps_draw_text, *ps_get_text_extent, *ps_expand_name, *ps_glyph_exists;
01329 static Scheme_Object *ps_record_font, *ps_fonts_string;
01330 
01331 static Scheme_Object *SetPSProcs(int, Scheme_Object *a[])
01332 {
01333   wxREGGLOB(ps_draw_text);
01334   wxREGGLOB(ps_get_text_extent);
01335   wxREGGLOB(ps_expand_name);
01336   wxREGGLOB(ps_glyph_exists);
01337   wxREGGLOB(ps_record_font);
01338   wxREGGLOB(ps_fonts_string);
01339   ps_draw_text = a[0];
01340   ps_get_text_extent = a[1];
01341   ps_expand_name = a[2];
01342   ps_glyph_exists = a[3];
01343   ps_record_font = a[4];
01344   ps_fonts_string = a[5];
01345   return scheme_void;
01346 }
01347 
01348 void *wxPostScriptDrawText(Scheme_Object *f, const char *fontname,
01349                            const char *text, int dt, Bool combine, int use16, 
01350                            double font_size, int sym_map, void *used_fonts)
01351 {
01352   if (ps_draw_text) {
01353     Scheme_Object *a[7], *v;
01354 
01355     v = scheme_make_utf8_string(fontname);
01356     a[0] = v;
01357     a[1] = scheme_make_double(font_size);
01358     if (use16)
01359       v = scheme_make_sized_offset_char_string((mzchar *)text, dt, -1, 1);
01360     else 
01361       v = scheme_make_sized_offset_utf8_string((char *)text, dt, -1);
01362     a[2] = v;
01363     a[3] = f;
01364     a[4] = (combine ? scheme_true : scheme_false);
01365     a[5] = (sym_map ? scheme_true : scheme_false);
01366     a[6] = (used_fonts ? (Scheme_Object *)used_fonts : scheme_false);
01367 
01368     return scheme_apply(ps_draw_text, 7, a);
01369   } else
01370     return NULL;
01371 }
01372 
01373 extern void wxPostScriptGetTextExtent(const char *fontname, 
01374                                   const char *text, int dt, int slen, Bool combine, int use16, 
01375                                   double font_size,
01376                                   double *x, double *y, double *descent, double *topSpace,
01377                                   int sym_map)
01378 {
01379   if (ps_get_text_extent) {
01380     long multiple_count;
01381     Scheme_Object **multiple_array;
01382     Scheme_Object *a[5], *v;
01383 
01384     v = scheme_make_utf8_string(fontname);
01385     a[0] = v;
01386     a[1] = scheme_make_double(font_size);
01387     if (use16)
01388       v = scheme_make_sized_offset_char_string((mzchar *)text, dt, slen, 1);
01389     else 
01390       v = scheme_make_sized_offset_utf8_string((char *)text, dt, slen);
01391     a[2] = v;
01392     a[3] = (combine ? scheme_true : scheme_false);
01393     a[4] = (sym_map ? scheme_true : scheme_false);
01394 
01395     v = scheme_apply_multi(ps_get_text_extent, 5, a);
01396     
01397     multiple_count = scheme_get_multiple_count();
01398     multiple_array = scheme_get_multiple_array();
01399     if (SAME_OBJ(v, SCHEME_MULTIPLE_VALUES)
01400        && (multiple_count == 4)) {
01401       if (SCHEME_FLTP(multiple_array[0]))
01402        *x = SCHEME_FLT_VAL(multiple_array[0]);
01403       if (SCHEME_FLTP(multiple_array[1]))
01404        *y = SCHEME_FLT_VAL(multiple_array[1]);
01405       if (descent)
01406        if (SCHEME_FLTP(multiple_array[2]))
01407          *descent = SCHEME_FLT_VAL(multiple_array[2]);
01408       if (topSpace)
01409        if (SCHEME_FLTP(multiple_array[3]))
01410          *topSpace = SCHEME_FLT_VAL(multiple_array[3]);
01411     } else {
01412       *x = 0;
01413       *y = 0;
01414       if (descent) *descent = 0;
01415       if (topSpace) *topSpace = 0;
01416     }
01417     multiple_array = NULL;
01418   }
01419 }
01420 
01421 char *wxPostScriptFixupFontName(const char *fontname)
01422 {
01423   if (ps_expand_name) {
01424     Scheme_Object *a[1], *v;
01425     v = scheme_make_sized_offset_utf8_string((char *)fontname, 0, -1);
01426     a[0] = v;
01427     v = scheme_apply(ps_expand_name, 1, a);
01428     if ((v != a[0]) && SCHEME_CHAR_STRINGP(v)) {
01429       v = scheme_char_string_to_byte_string(v);
01430       fontname = SCHEME_BYTE_STR_VAL(v);
01431     }
01432   }
01433   return (char *)fontname;
01434 }
01435 
01436 Bool wxPostScriptGlyphExists(const char *fontname, int c, int sym_map)
01437 {
01438   if (ps_glyph_exists) {
01439     Scheme_Object *a[3], *v;
01440     v = scheme_make_sized_offset_utf8_string((char *)fontname, 0, -1);
01441     a[0] = v;
01442     a[1] = scheme_make_integer_value(c);
01443     a[2] = (sym_map ? scheme_true : scheme_false);
01444     v = scheme_apply(ps_glyph_exists, 3, a);
01445     return SCHEME_TRUEP(v);
01446   }
01447   return TRUE;
01448 }
01449 
01450 extern void *wxPostScriptRecordFont(const char *fontname, void *used_fonts)
01451 {
01452   if (ps_record_font) {
01453     Scheme_Object *a[2], *v;
01454     v = scheme_make_sized_offset_utf8_string((char *)fontname, 0, -1);
01455     a[0] = v;
01456     a[1] = (used_fonts ? (Scheme_Object *)used_fonts : scheme_false);
01457     return scheme_apply(ps_record_font, 2, a);
01458   }
01459   return scheme_null;
01460 }
01461 
01462 extern char *wxPostScriptFontsToString(void *used_fonts)
01463 {
01464   if (ps_fonts_string && used_fonts) {
01465     Scheme_Object *a[1], *s;
01466     a[0] = (Scheme_Object *)used_fonts;
01467     s = scheme_apply(ps_fonts_string, 1, a);
01468     if (SCHEME_CHAR_STRINGP(s)) {
01469       s = scheme_char_string_to_byte_string(s);
01470       return SCHEME_BYTE_STR_VAL(s);
01471     }
01472   }
01473   return "";
01474 }
01475 
01476 /***********************************************************************/
01477 /*                           panel color                               */
01478 /***********************************************************************/
01479 
01480 static Scheme_Object *wxSchemeGetPanelBackground(int, Scheme_Object **)
01481 {
01482   wxColour *c;
01483 
01484 #ifdef wx_x
01485   c = new WXGC_PTRS wxColour(wxGREY);
01486 #endif
01487 #ifdef wx_mac
01488   c = new WXGC_PTRS wxColour(0xE8, 0xE8, 0xE8);
01489 #endif
01490 #ifdef wx_msw
01491   DWORD v;
01492 
01493   v = GetSysColor(COLOR_BTNFACE);
01494 
01495   c = new WXGC_PTRS wxColour(GetRValue(v), GetGValue(v), GetBValue(v));
01496 #endif
01497 
01498   return objscheme_bundle_wxColour(c);
01499 }
01500 
01501 /***********************************************************************/
01502 /*                            play sound                               */
01503 /***********************************************************************/
01504 
01505 #ifndef wx_x
01506 
01507 #ifdef wx_mac
01508 
01509 # ifdef OS_X
01510 /* In MzScheme in Classic, mredmac.cxx in OS X */
01511 extern int scheme_mac_path_to_spec(const char *filename, FSSpec *spec);
01512 # endif
01513 
01514 class AsyncSoundRec {
01515 public:
01516   Movie mov;
01517   short file;
01518   AsyncSoundRec *next;
01519 };
01520 
01521 static AsyncSoundRec *playing = NULL;
01522 
01523 int IsFinished(void *movie)
01524 {
01525   MoviesTask((Movie)movie,0);
01526   return IsMovieDone((Movie)movie);
01527 }
01528 
01529 void MyCloseMovie(Movie movie, short resRefNum) 
01530 {
01531   short osErr;
01532   DisposeMovie(movie);
01533 
01534   osErr = CloseMovieFile(resRefNum);
01535   if (osErr != noErr)
01536     scheme_signal_error("cannot close movie file (errno = %d)", osErr);
01537 }
01538 
01539 int movieInitialized = FALSE;
01540 
01541 void MovieInitialize(void)
01542 {
01543   short osErr;
01544   long result;
01545   
01546   osErr = Gestalt(gestaltQuickTime, &result);
01547   if (osErr != noErr) {
01548     scheme_signal_error("Movie Toolbox not available");
01549   }
01550   
01551   if (result < 0x03000000) {
01552     scheme_signal_error("Quicktime 3.0 or later required to play sounds.");
01553   }
01554   
01555   osErr = EnterMovies();
01556   if (osErr != noErr) {
01557     scheme_signal_error("Unable to initialize Movie Toolbox (errno = %d)", osErr);
01558   }
01559   
01560   movieInitialized = TRUE;
01561 
01562   wxREGGLOB(playing);
01563 } 
01564   
01565   
01566 void wxCheckFinishedSounds(void)
01567 {
01568   AsyncSoundRec *playptr = playing;
01569   AsyncSoundRec *last_playptr = NULL;
01570   
01571   while (playptr) {
01572     if (IsFinished((void *)playptr->mov)) {
01573       if (last_playptr) {
01574         last_playptr->next = playptr->next;
01575       } else {
01576         playing = playptr->next;
01577       }
01578       MyCloseMovie(playptr->mov, playptr->file);
01579     } else
01580       last_playptr = playptr;
01581     playptr = playptr->next;
01582   }      
01583 }      
01584       
01585 void my_signal_error(char *msg, Scheme_Object *filename, int err)
01586 {
01587   scheme_signal_error("%s: \"%T\" (errno = %d)", msg, filename, err);
01588 }
01589 
01590 #endif
01591 
01592 static Scheme_Object *wxPlaySound(int argc, Scheme_Object **argv)
01593 {
01594   Bool async, ok;
01595   char *f;
01596   
01597   if (!SCHEME_PATH_STRINGP(argv[0]))
01598     scheme_wrong_type("play-sound", SCHEME_PATH_STRING_STR, 0, argc, argv);
01599   
01600   async = SCHEME_TRUEP(argv[1]);
01601   
01602   f = scheme_expand_string_filename(argv[0],
01603                                 "play-sound",
01604                                 NULL,
01605                                 SCHEME_GUARD_FILE_READ);
01606 
01607 #ifdef wx_msw  
01608   ok = PlaySoundW(wxWIDE_STRING(f), NULL, async ? SND_ASYNC : SND_SYNC);
01609 #endif
01610 #ifdef wx_mac
01611   {
01612     FSSpec spec;
01613     short osErr;
01614     short resRefNum;
01615     Movie theMovie;
01616     
01617     if (! movieInitialized) {
01618       MovieInitialize();
01619     }
01620     
01621     osErr = scheme_mac_path_to_spec(f,&spec);
01622 
01623     if (! osErr) 
01624       scheme_signal_error("cannot find file: \"%T\"", argv[0]);
01625     
01626     // load sound as "movie"
01627     
01628     osErr = OpenMovieFile(&spec,&resRefNum,fsRdPerm);
01629     if (osErr != noErr)
01630       my_signal_error("cannot open as movie file", argv[0], osErr);
01631     
01632     osErr = NewMovieFromFile(&theMovie, resRefNum, NULL, NULL, newMovieActive, NULL);
01633     if (osErr != noErr)
01634       my_signal_error("cannot create movie from file", argv[0], osErr);
01635 
01636     // play the movie once thru
01637     StartMovie(theMovie);
01638     
01639     if (!async) {
01640       wxDispatchEventsUntil(IsFinished,theMovie);
01641       MyCloseMovie(theMovie, resRefNum);
01642     } else {
01643       AsyncSoundRec *r;
01644       
01645       r = new WXGC_PTRS AsyncSoundRec;
01646 
01647       r->mov = theMovie;
01648       r->file = resRefNum;
01649       r->next = playing;
01650       playing = r;
01651     }
01652     
01653     ok = TRUE;
01654   }
01655 #endif  
01656 
01657   return (ok ? scheme_true : scheme_false);
01658 }
01659 #endif
01660 
01661 /***********************************************************************/
01662 /*                         constructor hooks                           */
01663 /***********************************************************************/
01664 
01665 static Scheme_Object *is_menu;
01666 
01667 Bool wxsCheckIsPopupMenu(void *m)
01668 {
01669   Scheme_Object *v, *a[1];
01670 
01671   a[0] = (Scheme_Object *)m;
01672   v = _scheme_apply(is_menu, 1, a);
01673   return SCHEME_TRUEP(v);
01674 }
01675 
01676 static Scheme_Object *SetIsMenu(int, Scheme_Object *a[])
01677 {
01678   wxREGGLOB(is_menu);
01679   is_menu = a[0];
01680   return scheme_void;
01681 }
01682 
01683 static Scheme_Object *SetDialogs(int, Scheme_Object *a[])
01684 {
01685   get_file = a[0];
01686   put_file = a[1];
01687   get_ps_setup_from_user = a[2];
01688   message_box = a[3];
01689   return scheme_void;
01690 }
01691 
01692 /***********************************************************************/
01693 /*                          interapp hooks                             */
01694 /***********************************************************************/
01695 
01696 #ifdef wx_mac
01697 extern short wxMacDisableMods;
01698 #define SCK_ARG p
01699 #else
01700 #define SCK_ARG 
01701 #endif
01702 
01703 Scheme_Object *wxs_app_file_proc;
01704 Scheme_Object *wxs_app_quit_proc;
01705 Scheme_Object *wxs_app_about_proc;
01706 Scheme_Object *wxs_app_pref_proc;
01707 
01708 static Scheme_Object *SpecialCtlKey(int c, Scheme_Object *SCK_ARG[])
01709 {
01710 #ifdef wx_mac
01711   if (c) {
01712     if (SCHEME_FALSEP(p[0]))
01713       wxMacDisableMods -= (wxMacDisableMods & controlKey);
01714     else
01715       wxMacDisableMods |= controlKey;
01716     return scheme_void;
01717   } else {
01718     if (wxMacDisableMods & controlKey)
01719       return scheme_true;
01720     else
01721       return scheme_false;
01722   }
01723 #else
01724   if (c)
01725     return scheme_void;
01726   else
01727     return scheme_false;
01728 #endif
01729 }
01730 
01731 static Scheme_Object *SpecialOptionKey(int c, Scheme_Object *SCK_ARG[])
01732 {
01733 #ifdef wx_mac
01734   if (c) {
01735     if (SCHEME_FALSEP(p[0]))
01736       wxMacDisableMods -= (wxMacDisableMods & optionKey);
01737     else
01738       wxMacDisableMods |= optionKey;
01739     return scheme_void;
01740   } else {
01741     if (wxMacDisableMods & optionKey)
01742       return scheme_true;
01743     else
01744       return scheme_false;
01745   }
01746 #else
01747   if (c)
01748     return scheme_void;
01749   else
01750     return scheme_false;
01751 #endif
01752 }
01753 
01754 static Scheme_Object *DefaultAppFileProc(int n, Scheme_Object *p[])
01755 {
01756   if (!SCHEME_PATH_STRINGP(p[0]))
01757     scheme_wrong_type("default-application-file-handler", SCHEME_PATH_STRING_STR,
01758                     0, n, p);
01759 
01760   return scheme_void;
01761 }
01762 
01763 static Scheme_Object *ApplicationFileProc(int n, Scheme_Object *p[])
01764 {
01765   if (!n)
01766     return wxs_app_file_proc;
01767   else {
01768     scheme_check_proc_arity("application-file-handler", 1,
01769                          0, n, p);
01770     wxs_app_file_proc = p[0];
01771     return scheme_void;
01772   }
01773 }
01774 
01775 static Scheme_Object *DefaultAppQuitProc(int, Scheme_Object **)
01776 {
01777   return scheme_void;
01778 }
01779 
01780 static Scheme_Object *ApplicationQuitProc(int n, Scheme_Object *p[])
01781 {
01782   if (!n)
01783     return wxs_app_quit_proc;
01784   else {
01785     scheme_check_proc_arity("application-quit-handler", 0, 0, n, p);
01786     wxs_app_quit_proc = p[0];
01787     return scheme_void;
01788   }
01789 }
01790 
01791 static Scheme_Object *ApplicationPrefProc(int n, Scheme_Object *p[])
01792 {
01793   if (!n)
01794     return wxs_app_pref_proc;
01795   else {
01796     wxs_app_pref_proc = p[0];
01797     return scheme_void;
01798   }
01799 }
01800 
01801 static Scheme_Object *DefaultAppAboutProc(int, Scheme_Object **)
01802 {
01803 #ifdef wx_mac
01804   wxTheApp->DoDefaultAboutItem();
01805 #endif
01806   return scheme_void;
01807 }
01808 
01809 static Scheme_Object *ApplicationAboutProc(int n, Scheme_Object *p[])
01810 {
01811   if (!n)
01812     return wxs_app_about_proc;
01813   else {
01814     scheme_check_proc_arity("application-about-handler", 0, 0, n, p);
01815     wxs_app_about_proc = p[0];
01816     return scheme_void;
01817   }
01818 }
01819 
01820 static Scheme_Object *SetExecuter(int, Scheme_Object *a[])
01821 {
01822   wxREGGLOB(executer);
01823   executer = a[0];
01824   return scheme_void;
01825 }
01826 
01827 void wxsExecute(char **argv)
01828 {
01829   int i, c;
01830   Scheme_Object **a, *aa;
01831 
01832   for (i = 0; argv[i]; i++) {
01833   }
01834 
01835   c = i;
01836   a = (Scheme_Object **)scheme_malloc(sizeof(Scheme_Object *) * c);
01837 
01838   for (i = 0; i < c; i++) {
01839     aa = scheme_make_utf8_string(argv[i]);
01840     a[i] = aa;
01841   }
01842 
01843   (void *)scheme_apply_multi(executer, c, a);
01844 }
01845 
01846 #ifdef wx_mac
01847 extern int scheme_mac_send_event(char *name, int argc, Scheme_Object **argv, 
01848                              Scheme_Object **result, 
01849                              int *err, char **stage);
01850 #endif
01851 
01852 static Scheme_Object *wxSendEvent(int c, Scheme_Object *args[])
01853 {
01854 #ifdef wx_mac
01855   int err;
01856   char *stage = "";
01857   Scheme_Object *result;
01858   if (scheme_mac_send_event("send-event", c, args, &result, &err, &stage))
01859     return result;
01860   else {
01861     scheme_raise_exn(MZEXN_FAIL, "send-event: failed (%s%e)", stage, err);
01862     return NULL;
01863   }
01864 #else
01865   scheme_raise_exn(MZEXN_FAIL_UNSUPPORTED,
01866                  "send-event: not supported on this platform");
01867   return NULL;
01868 #endif
01869 }
01870 
01871 static Scheme_Object *file_type_and_creator(int argc, Scheme_Object **argv)
01872 {
01873   char *filename;
01874   int was_dir = 0, write_failed = 0;
01875   int err;
01876 
01877   if (!SCHEME_PATH_STRINGP(argv[0]))
01878     scheme_wrong_type("file-creator-and-type", SCHEME_PATH_STRING_STR, 0, argc, argv);
01879 
01880   if (argc > 1) {
01881     if (!SCHEME_BYTE_STRINGP(argv[1]) || (SCHEME_BYTE_STRTAG_VAL(argv[1]) != 4))
01882       scheme_wrong_type("file-creator-and-type", "4-character byte string", 1, argc, argv);
01883     if (!SCHEME_BYTE_STRINGP(argv[2]) || (SCHEME_BYTE_STRTAG_VAL(argv[2]) != 4))
01884       scheme_wrong_type("file-creator-and-type", "4-character byte string", 2, argc, argv);
01885   }
01886 
01887   filename = scheme_expand_string_filename(argv[0],
01888                                       "file-creator-and-type",
01889                                       NULL,
01890                                       ((argc > 1) 
01891                                        ? SCHEME_GUARD_FILE_WRITE
01892                                        : SCHEME_GUARD_FILE_READ));
01893 
01894 #ifdef wx_mac
01895   {
01896     FSSpec spec;
01897     int spec_ok = 0;
01898     FInfo info;
01899 
01900 #ifndef OS_X
01901     spec_ok = scheme_mac_path_to_spec(filename, &spec);
01902 # else
01903     {
01904       FSRef ref;
01905       Boolean isd;
01906       
01907       err = FSPathMakeRef((UInt8*)filename, &ref, &isd);
01908       if (!err && isd)
01909        was_dir = 1;
01910       else if (!err) {
01911        err = FSGetCatalogInfo(&ref, kFSCatInfoNone, NULL, NULL, &spec, NULL);
01912        spec_ok = !err;
01913       }
01914     }
01915 # endif
01916 
01917     if (spec_ok) {
01918       err = FSpGetFInfo(&spec, &info);
01919       if (!err) {
01920        if (argc > 1) {
01921          info.fdCreator = *(unsigned long *)SCHEME_BYTE_STR_VAL(argv[1]);
01922          info.fdType = *(unsigned long *)SCHEME_BYTE_STR_VAL(argv[2]);
01923          err = FSpSetFInfo(&spec, &info);
01924 
01925          if (!err)
01926            return scheme_void;
01927          write_failed = 1;
01928        } else {
01929          Scheme_Object *a[2];
01930 
01931          a[0] = scheme_make_sized_byte_string((char *)&info.fdCreator, 4, 1);
01932          a[1] = scheme_make_sized_byte_string((char *)&info.fdType, 4, 1);
01933          return scheme_values(2, a);
01934        }
01935       }
01936     }
01937   }
01938 #else
01939   err = -1;
01940   if (scheme_file_exists(filename)) {
01941     if (argc > 1)
01942       return scheme_void;
01943     else {
01944       Scheme_Object *a[2];
01945 
01946       a[0] = scheme_make_sized_byte_string("????", 4, 0);
01947       a[1] = a[0];
01948       return scheme_values(2, a);
01949     }
01950   } else if (scheme_directory_exists(filename))
01951     was_dir = 1;
01952 #endif
01953 
01954   scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
01955                  "file-creator-and-type: %s: \"%q\" (%E)",
01956                  (was_dir 
01957                   ? "path is a directory" 
01958                   : (write_failed 
01959                      ? "error setting creator and type"
01960                      : "file not found")),
01961                  filename, err);
01962   return NULL;
01963 }
01964 
01965 
01966 #ifdef wx_mac
01967 extern void wxStartRefreshSequence(void);
01968 extern void wxEndRefreshSequence(void);
01969 #else
01970 # define wxStartRefreshSequence() /* empty */
01971 # define wxEndRefreshSequence() /* empty */
01972 #endif
01973 
01974 static Scheme_Object *BeginRefreshSeq(int, Scheme_Object **)
01975 {
01976   wxStartRefreshSequence();
01977   return scheme_void;
01978 }
01979 
01980 static Scheme_Object *EndRefreshSeq(int, Scheme_Object **)
01981 {
01982   wxEndRefreshSequence();
01983   return scheme_void;
01984 }
01985 
01986 /***********************************************************************/
01987 /*                             ps-setup                                */
01988 /***********************************************************************/
01989 
01990 static Scheme_Object *PS_Setup_p(int, Scheme_Object **argv)
01991 {
01992   return (objscheme_istype_wxPrintSetupData(argv[0], NULL, 0)
01993          ? scheme_true
01994          : scheme_false);
01995 }
01996 
01997 Scheme_Object *wxsBundlePSSetup(wxPrintSetupData *d)
01998 {
01999   return objscheme_bundle_wxPrintSetupData(d);
02000 }
02001 
02002 wxPrintSetupData *wxsUnbundlePSSetup(Scheme_Object *o)
02003 {
02004   return objscheme_unbundle_wxPrintSetupData(o, NULL, 0);
02005 }
02006 
02007 static Scheme_Object *wxSchemeCurrentPSSetup(int argc, Scheme_Object **argv)
02008 {
02009   if (!argc) {
02010     wxPrintSetupData *ps;
02011     ps = wxGetThePrintSetupData();
02012     return wxsBundlePSSetup(ps);
02013   }
02014 
02015   return scheme_param_config("current-ps-setup", 
02016                           scheme_make_integer(mred_ps_setup_param),
02017                           argc, argv,
02018                           -1, CAST_SP PS_Setup_p, "ps-setup% instance", 0);
02019 }
02020 
02021 /***********************************************************************/
02022 /*                         platform-printing                           */
02023 /***********************************************************************/
02024 
02025 #ifndef wx_xt
02026 
02027 class wxMediaPrintout : public wxPrintout
02028 {
02029 private:
02030   void *data;
02031 
02032   Bool fitToPage;
02033 
02034   Scheme_Object *begin_doc;
02035   Scheme_Object *has_page;
02036   Scheme_Object *print_page;
02037   Scheme_Object *end_doc;
02038     
02039 public:
02040   wxMediaPrintout(Bool fit,
02041                   Scheme_Object *_begin_doc,
02042                   Scheme_Object *_has_page,
02043                   Scheme_Object *_print_page,
02044                   Scheme_Object *_end_doc);
02045 
02046   Bool HasPage(int page);
02047   Bool OnPrintPage(int page);
02048   Bool OnBeginDocument(int startPage, int endPage);
02049   void OnEndDocument();
02050 };
02051 
02052 wxMediaPrintout::wxMediaPrintout(Bool fit, 
02053                                  Scheme_Object *_begin_doc,
02054                                  Scheme_Object *_has_page,
02055                                  Scheme_Object *_print_page,
02056                                  Scheme_Object *_end_doc)
02057 : wxPrintout()
02058 {
02059   fitToPage = fit;
02060   begin_doc = _begin_doc;
02061   has_page = _has_page;
02062   print_page = _print_page;
02063   end_doc = _end_doc;
02064 }
02065 
02066 Bool wxMediaPrintout::HasPage(int page)
02067 {
02068   Scheme_Object *v, *a[2];
02069   basePrinterDC *dc;
02070 
02071   dc = (basePrinterDC*)GetDC();
02072   a[0] = objscheme_bundle_basePrinterDC(dc);
02073   a[1] = scheme_make_integer(page);
02074 
02075   v = scheme_apply(has_page, 2, a);
02076 
02077   return SCHEME_TRUEP(v);
02078 }
02079 
02080 Bool wxMediaPrintout::OnPrintPage(int page)
02081 {
02082   Scheme_Object *a[2];
02083   basePrinterDC *dc;
02084 
02085   dc = (basePrinterDC*)GetDC();
02086 
02087   a[0] = objscheme_bundle_basePrinterDC(dc);
02088   a[1] = scheme_make_integer(page);
02089 
02090   scheme_apply(print_page, 2, a);
02091 
02092   return TRUE;
02093 }
02094 
02095 Bool wxMediaPrintout::OnBeginDocument(int startPage, int endPage)
02096 {
02097   if (wxPrintout::OnBeginDocument(startPage, endPage)) {
02098     basePrinterDC *dc;
02099     Scheme_Object *a[1];
02100     dc = (basePrinterDC*)GetDC();
02101     a[0] = objscheme_bundle_basePrinterDC(dc);
02102     data = scheme_apply(begin_doc, 1, a);
02103     return TRUE;
02104   } else
02105     return FALSE;
02106 }
02107 
02108 void wxMediaPrintout::OnEndDocument()
02109 {
02110   scheme_apply(end_doc, 0, NULL);
02111   wxPrintout::OnEndDocument();
02112 }
02113 
02114 #endif
02115 
02116 static Scheme_Object *run_printout(int argc, Scheme_Object **argv)
02117 {
02118 #ifndef wx_xt
02119   wxWindow *parent;
02120   wxPrinter *p;
02121   wxPrintout *o;
02122   int interactive, fitToPage;
02123   
02124   parent = (SCHEME_TRUEP(argv[0])
02125             ? objscheme_unbundle_wxWindow(argv[0], "run-printout", 1)
02126             : NULL);
02127   interactive = SCHEME_TRUEP(argv[1]);
02128   fitToPage = SCHEME_TRUEP(argv[2]);
02129 
02130   p = new WXGC_PTRS wxPrinter();
02131   o = new WXGC_PTRS wxMediaPrintout(fitToPage,
02132                                     argv[3],
02133                                     argv[4],
02134                                     argv[5],
02135                                     argv[6]);
02136   
02137   p->Print(parent, o, interactive);
02138 
02139   DELETE_OBJ o;
02140   DELETE_OBJ p;
02141 #endif
02142 
02143   return scheme_void;
02144 }
02145 
02146 /***********************************************************************/
02147 /*                            eventspaces                              */
02148 /***********************************************************************/
02149 
02150 static Scheme_Object *Eventspace_p(int, Scheme_Object **argv)
02151 {
02152   return ((SCHEME_TYPE(argv[0]) == mred_eventspace_type)
02153          ? scheme_true
02154          : scheme_false);
02155 }
02156 
02157 static Scheme_Object *wxSchemeCurrentEventspace(int argc, Scheme_Object **argv)
02158 {
02159   return scheme_param_config("current-eventspace", 
02160                           scheme_make_integer(mred_eventspace_param),
02161                           argc, argv,
02162                           -1, CAST_SP Eventspace_p, "eventspace", 0);
02163 }
02164 
02165 static Scheme_Object *wxSchemeEventDispatchHandler(int argc, Scheme_Object **argv)
02166 {
02167   return scheme_param_config("event-dispatch-handler", 
02168                           scheme_make_integer(mred_event_dispatch_param),
02169                           argc, argv,
02170                           1, NULL, NULL, 0);
02171 }
02172 
02173 static Scheme_Object *wxSchemeMakeEventspace(int, Scheme_Object **)
02174 {
02175   return (Scheme_Object *)MrEdMakeEventspace();
02176 }
02177 
02178 static Scheme_Object *wxEventspaceHandlerThread(int argc, Scheme_Object **argv)
02179 {
02180   if (SCHEME_TYPE(argv[0]) == mred_eventspace_type) {
02181     Scheme_Object *v;
02182     v = MrEdEventspaceThread(argv[0]);
02183     if (!v)
02184       v = scheme_false;
02185     return v;
02186   }
02187 
02188   scheme_wrong_type("eventspace-handler-thread", "eventspace", 0, argc, argv);
02189   return NULL;
02190 }
02191 
02192 static Scheme_Object *queue_callback(int argc, Scheme_Object **argv)
02193 {
02194   MrEd_add_q_callback("queue-callback", argc, argv);
02195   return scheme_void;
02196 }
02197 
02198 void *wxSchemeYield(void *sema)
02199 {
02200   int is_handler;
02201 
02202   if (!wait_symbol) {
02203     wxREGGLOB(wait_symbol);
02204     wait_symbol = scheme_intern_symbol("wait");
02205   }
02206 
02207   is_handler = mred_current_thread_is_handler(NULL);
02208 
02209   if (sema == wait_symbol) {
02210     if (is_handler) {
02211       mred_wait_eventspace();
02212       return scheme_true;
02213     } else
02214       return scheme_false;
02215   } else if (sema) {
02216     if (!scheme_is_evt((Scheme_Object *)sema))
02217       scheme_wrong_type("yield", "evt or 'wait", -1, 0, (Scheme_Object **)(void *)&sema);
02218 
02219     if (is_handler)
02220       return wxDispatchEventsUntilWaitable((wxDispatch_Check_Fun)NULL, NULL, (Scheme_Object *)sema);
02221     else {
02222       Scheme_Object *a[1];
02223       a[0] = (Scheme_Object *)sema;
02224       return scheme_sync(1, a);
02225     }
02226   } else {
02227     if (is_handler && wxYield())
02228       return scheme_true;
02229     else
02230       return scheme_false;
02231   }
02232 }
02233 
02234 static Scheme_Object *wxSchemeCheckForBreak(int, Scheme_Object **)
02235 {
02236   return (MrEdCheckForBreak()
02237          ? scheme_true
02238          : scheme_false);
02239 }
02240 
02241 static Scheme_Object *Shutdown_p(int argc, Scheme_Object **argv)
02242 {
02243   Scheme_Type type = SCHEME_TYPE(argv[0]);
02244 
02245   if (type == mred_eventspace_type) {
02246     return wxsIsContextShutdown((void *)argv[0]) ? scheme_true : scheme_false;
02247   }
02248 
02249   scheme_wrong_type("eventspace-shutdown?", "eventspace", 0, argc, argv);
02250   return NULL;
02251 }
02252 
02253 static Scheme_Object *main_eventspace_p(int argc, Scheme_Object **argv)
02254 {
02255   return wxIsUserMainEventspace(argv[0]) ? scheme_true : scheme_false;
02256 }
02257 
02258 extern "C" {
02259   MZ_EXTERN void scheme_start_atomic(void);
02260   MZ_EXTERN void scheme_end_atomic(void);
02261 }
02262 
02263 static Scheme_Object *wxInAtomicRegion(int, Scheme_Object **argv)
02264 {
02265   if (SCHEME_SEMAP(argv[0])) {
02266     scheme_wait_sema(argv[0], 0);
02267     /* MzScheme promises that no break or kill will happen
02268        between receiving the semaphore post and returning to us. */
02269     scheme_start_atomic();
02270   } else
02271     scheme_end_atomic();
02272 
02273   return scheme_void;
02274 }
02275 
02276 /***********************************************************************/
02277 /*                             clipboard                               */
02278 /***********************************************************************/
02279 
02280 class wxGetData {
02281 public:
02282   char *result;
02283   wxClipboardClient *clipOwner;
02284   char *format;
02285   long length;
02286   Scheme_Object *sema;
02287 };
02288 
02289 extern "C" int objscheme_something_prepared;
02290 
02291 Scheme_Object *get_data_from_client(void *_gd, int, Scheme_Object **)
02292 {
02293   wxGetData *gd = (wxGetData *)_gd;
02294   char *result;
02295   long length;
02296 
02297   result = gd->clipOwner->GetData(gd->format, &length);
02298 
02299   gd->length = length;
02300   gd->result = result;
02301   scheme_post_sema(gd->sema);
02302 
02303   return scheme_void;
02304 }
02305 
02306 char *wxsGetDataInEventspace(wxClipboardClient *clipOwner, char *format, long *length)
02307 {
02308   if (objscheme_something_prepared && clipOwner->context && (clipOwner->context != wxGetContextForFrame())) {
02309     Scheme_Object *cb, *sema;
02310     wxGetData *gd;
02311     
02312     sema = scheme_make_sema(0);
02313 
02314     gd = new WXGC_PTRS wxGetData;
02315     gd->clipOwner = clipOwner;
02316     gd->format = format;
02317     gd->sema = sema;
02318 
02319     cb = scheme_make_closed_prim((Scheme_Closed_Prim *)get_data_from_client, gd);
02320 
02321     MrEdQueueInEventspace(clipOwner->context, cb);
02322 
02323     if (!scheme_wait_sema(sema, 1)) {
02324       scheme_thread_block(0);
02325       scheme_making_progress();
02326       if (!scheme_wait_sema(sema, 1)) {
02327        scheme_thread_block(0.001);
02328        scheme_making_progress();
02329        if (!scheme_wait_sema(sema, 1)) {
02330          scheme_thread_block(0.1);
02331          scheme_making_progress();
02332          if (!scheme_wait_sema(sema, 1)) {
02333            scheme_thread_block(0.5);
02334            scheme_making_progress();
02335            if (!scheme_wait_sema(sema, 1)) {
02336              scheme_thread_block(0.5);
02337              scheme_making_progress();
02338              if (!scheme_wait_sema(sema, 1)) {
02339               /* timeout */
02340               return NULL;
02341              }
02342            }
02343          }
02344        }
02345       }
02346     }
02347 
02348     *length = gd->length;
02349     return gd->result;
02350   } else
02351     return clipOwner->GetData(format, length);
02352 }
02353 
02354 /***********************************************************************/
02355 /*                         miscellaneous gui                           */
02356 /***********************************************************************/
02357 
02358 Scheme_Object *wxsLocationToWindow(int, Scheme_Object **a)
02359 {
02360   wxWindow *w;
02361   w = wxLocationToWindow(SCHEME_INT_VAL(a[0]), SCHEME_INT_VAL(a[1]));
02362   return objscheme_bundle_wxWindow(w);
02363 }
02364 
02365 static Scheme_Object *wxSchemeGetFrameList(int, Scheme_Object **)
02366 {
02367   return MrEdGetFrameList();
02368 }
02369 
02370 static Scheme_Object *wLabelShortcutsVisible(int argc, Scheme_Object **argv)
02371 {
02372   int menu_too;
02373 
02374   if (argc)
02375     menu_too = SCHEME_TRUEP(argv[0]);
02376   else
02377     menu_too = 0;
02378 
02379 #ifdef wx_x
02380   return scheme_true;
02381   /* but the MrEd layer disables visible menu shortcuts when
02382      the default menu key is set to alt instead of ctl */
02383 #endif
02384 #ifdef wx_msw
02385   return scheme_true;
02386 #endif
02387 #ifdef wx_mac
02388   return scheme_false;
02389 #endif
02390 }
02391 
02392 /***********************************************************************/
02393 /*                         files and directories                       */
02394 /***********************************************************************/
02395 
02396 #ifdef wx_mac
02397 # ifdef OS_X
02398 /* In MzScheme in Classic, mredmac.cxx in OS X */
02399 extern char *scheme_mac_spec_to_path(FSSpec *spec);
02400 # endif
02401 # ifndef OS_X
02402 #  define wxmac_startup_directory 0
02403 # endif
02404 #endif
02405 
02406 enum {
02407   id_init_file,
02408   id_setup_file,
02409   id_x_display
02410 };
02411 
02412 #ifdef wx_msw
02413 static char *win_find_home()
02414 {
02415   char *d, *p;
02416 
02417   d = getenv("HOMEDRIVE");
02418   p = getenv("HOMEPATH");
02419 
02420   if (d && p) {
02421     char *s;
02422     s = new WXGC_ATOMIC char[strlen(d) + strlen(p) + 1];
02423     strcpy(s, d);
02424     strcat(s, p);
02425     
02426     if (scheme_directory_exists(s))
02427       return s;
02428   }
02429 
02430   {
02431     int i;
02432     char *s;
02433 
02434     p = wxTheApp->argv[0];
02435     s = copystring(p);
02436 
02437     i = strlen(s) - 1;
02438     
02439     while (i && (s[i] != '\\')) {
02440       --i;
02441     }
02442     s[i] = 0;
02443     return s;
02444   }
02445 } 
02446 #endif
02447 
02448 #ifdef wx_x
02449 static char *x_display_str;
02450 extern void wxsRememberDisplay(char *str)
02451 {
02452   x_display_str = str;
02453 }
02454 #endif
02455 
02456 static Scheme_Object *append_path(Scheme_Object *a, Scheme_Object *b)
02457 {
02458   Scheme_Object *s;
02459   s = scheme_append_byte_string(a, b);
02460   s->type = SCHEME_PLATFORM_PATH_KIND;
02461   return s;
02462 }
02463 
02464 Scheme_Object *wxSchemeFindDirectory(int argc, Scheme_Object **argv)
02465 {
02466   int which;
02467 
02468   if (argv[0] == init_file_symbol)
02469     which = id_init_file;
02470   else if (argv[0] == setup_file_symbol)
02471     which = id_setup_file;
02472   else if (argv[0] == x_display_symbol)
02473     which = id_x_display;
02474   else {
02475     scheme_wrong_type("find-graphical-system-path", "graphical path symbol",
02476                     0, argc, argv);
02477     return NULL;
02478   }
02479 
02480 #if defined(wx_x) || defined(OS_X)
02481   {
02482     Scheme_Object *home;
02483     int ends_in_slash;
02484 
02485     home = scheme_make_path(scheme_expand_user_filename("~/", 2, NULL, NULL, 0));
02486     
02487     ends_in_slash = (SCHEME_BYTE_STR_VAL(home))[SCHEME_BYTE_STRTAG_VAL(home) - 1] == '/';
02488     
02489     if (which == id_init_file)
02490       return append_path(home,
02491                       scheme_make_path("/.mredrc" + ends_in_slash));
02492     if (which == id_setup_file)
02493       return append_path(home,
02494                       scheme_make_path("/.mred.resources" + ends_in_slash));
02495 
02496     if (which == id_x_display) {
02497 # if defined(wx_x)
02498       if (x_display_str)
02499        return scheme_make_path(x_display_str);
02500 # endif
02501       return scheme_false;
02502     }
02503   }
02504 #endif
02505 
02506 #ifdef wx_msw
02507   {
02508     Scheme_Object *home;
02509     int ends_in_slash;
02510     
02511     home = scheme_make_path_without_copying(win_find_home());
02512     
02513     ends_in_slash = (SCHEME_BYTE_STR_VAL(home))[SCHEME_BYTE_STRTAG_VAL(home) - 1];
02514     ends_in_slash = ((ends_in_slash == '/') || (ends_in_slash == '\\'));
02515     
02516     if (which == id_init_file)
02517       return append_path(home,
02518                       scheme_make_path("\\mredrc.ss" + ends_in_slash));
02519     if (which == id_setup_file)
02520       return append_path(home,
02521                       scheme_make_path("\\mred.ini" + ends_in_slash));  
02522     
02523     if (which == id_x_display)
02524       return scheme_false;
02525   }
02526 #endif
02527 
02528 #if defined(wx_mac) && !defined(OS_X)
02529   OSType t;
02530   FSSpec spec;
02531   Scheme_Object *home;
02532 
02533   if (which == id_x_display)
02534     return scheme_false;
02535 
02536   switch (which) {
02537   case id_init_file:
02538   default:
02539     t = 'temp';
02540     break;
02541   }
02542 
02543   SInt16 vRefNum;
02544   SInt32 dirID;
02545   const Str255 fileName = "\p";
02546 
02547   if (!FindFolder(kOnSystemDisk, t, kCreateFolder, &vRefNum, &dirID) == noErr) {
02548     FSMakeFSSpec(vRefNum,dirID,fileName,&spec);
02549     home = scheme_make_path(scheme_mac_spec_to_path(&spec));
02550   } else if (wxmac_startup_directory) {
02551     home = scheme_make_path(wxmac_startup_directory);
02552   } else {
02553     home = scheme_make_path(scheme_os_getcwd(NULL, 0, NULL, 1));
02554   }
02555   
02556   int ends_in_colon;
02557   ends_in_colon = (SCHEME_BYTE_STR_VAL(home))[SCHEME_BYTE_STRTAG_VAL(home) - 1] == ':';
02558 
02559   if (which == id_init_file)
02560     return append_path(home,
02561                      scheme_make_path(":mredrc.ss" + ends_in_colon));
02562   if (which == id_setup_file)
02563     return append_path(home,
02564                      scheme_make_path(":mred.fnt" + ends_in_colon));  
02565 #endif
02566 
02567   return scheme_void;
02568 }
02569 
02570 char *wxsFileDialog(char *message, char *default_path, 
02571                   char *default_filename, char *default_extension, 
02572                   int is_put, wxWindow *parent)
02573 {
02574   Scheme_Object *a[6], *r;
02575   
02576   a[0] = !message ? scheme_false : scheme_make_utf8_string(message);
02577   a[1] = !parent ? scheme_false : objscheme_bundle_wxWindow(parent);
02578   a[2] = !default_path ? scheme_false : scheme_make_path(default_path);
02579   a[3] = !default_filename ? scheme_false : scheme_make_path(default_filename);
02580   a[4] = !default_extension ? scheme_false : scheme_make_utf8_string(default_extension);
02581   a[5] = scheme_null;
02582 
02583   r = scheme_apply(is_put ? put_file : get_file, 6, a);
02584 
02585   if (SCHEME_FALSEP(r))
02586     return NULL;
02587   else
02588     return SCHEME_BYTE_STR_VAL(r);
02589 }
02590 
02591 /***********************************************************************/
02592 /*                            dialog hooks                             */
02593 /***********************************************************************/
02594 
02595 extern wxPrintSetupData *wxGetThePrintSetupData();
02596 
02597 Bool wxsPrinterDialog(wxWindow *parent)
02598 {
02599   Scheme_Object *a[4], *r;
02600   
02601   a[0] = scheme_false;
02602   a[1] = !parent ? scheme_false : objscheme_bundle_wxWindow(parent);
02603   a[2] = scheme_false;
02604   a[3] = scheme_null;
02605 
02606   r = scheme_apply(get_ps_setup_from_user, 4, a);
02607 
02608   if (SCHEME_FALSEP(r)) {
02609     return 0;
02610   } else {
02611     wxPrintSetupData *p, *p2;
02612     p = objscheme_unbundle_wxPrintSetupData(r, NULL, 0);
02613     p2 = wxGetThePrintSetupData();
02614     p2->copy(p);
02615     return 1;
02616   }
02617 }
02618 
02619 int wxsMessageBox(char *message, char *caption, long style, wxWindow *parent)
02620 {
02621   Scheme_Object *a[4], *r;
02622   
02623   a[0] = scheme_make_utf8_string(caption);
02624   a[1] = scheme_make_utf8_string(message);
02625   a[2] = !parent ? scheme_false : objscheme_bundle_wxWindow(parent);
02626   a[3] = ((style & wxYES_NO)
02627          ? scheme_intern_symbol("yes-no")
02628          : ((style & wxCANCEL)
02629             ? scheme_intern_symbol("ok-cancel")
02630             : scheme_intern_symbol("ok")));
02631 
02632   a[3] = scheme_make_pair(a[3], scheme_null);    
02633 
02634   r = scheme_apply(message_box, 4, a);
02635 
02636   if (SAME_OBJ(r, scheme_intern_symbol("ok"))) {
02637     return wxOK;
02638   }
02639   if (SAME_OBJ(r, scheme_intern_symbol("cancel"))) {
02640     return wxCANCEL;
02641   }
02642   if (SAME_OBJ(r, scheme_intern_symbol("yes"))) {
02643     return wxYES;
02644   }
02645   return wxNO;
02646 }
02647 
02648 /***********************************************************************/
02649 /*                            image types                              */
02650 /***********************************************************************/
02651 
02652 int wxsGetImageType(char *fn)
02653 {
02654   FILE *f;
02655   int type;
02656 #ifndef MZ_PRECISE_GC
02657 # define GC_CAN_IGNORE 
02658 #endif
02659   GC_CAN_IGNORE unsigned char *expect = NULL;
02660 
02661   f = fopen_to_read(fn);
02662 
02663   if (f) {
02664     switch ((unsigned)fgetc(f)) {
02665     case 'B':
02666       expect = (unsigned char *)"M";
02667       type = wxBITMAP_TYPE_BMP;
02668       break;
02669     case '#':
02670       expect = (unsigned char *)"define";
02671       type = wxBITMAP_TYPE_XBM;
02672       break;
02673     case '/':
02674       expect = (unsigned char *)"* XPM */";
02675       type = wxBITMAP_TYPE_XPM;
02676       break;
02677     case 'G':
02678       expect = (unsigned char *)"IF8";
02679       type = wxBITMAP_TYPE_GIF;
02680       break;
02681     case 0xFF:
02682       expect = (unsigned char *)"\xD8\xFF";
02683       type = wxBITMAP_TYPE_JPEG;
02684       break;
02685     case 137:
02686       expect = (unsigned char *)"PNG\r\n";
02687       type = wxBITMAP_TYPE_PNG;
02688       break;
02689     default:
02690       type = 0;
02691       break;
02692     }
02693 
02694     if (expect) {
02695       while (*expect) {
02696        if (*expect != fgetc(f)) {
02697          type = 0;
02698          break;
02699        }
02700        expect++;
02701       }
02702     }
02703 
02704     fclose(f);
02705   } else
02706     type = 0;
02707 
02708   return type ? type : wxBITMAP_TYPE_XBM;
02709 }
02710 
02711 /***********************************************************************/
02712 /*                            preferences                              */
02713 /***********************************************************************/
02714 
02715 static char *pref_file_cache;
02716 static long pref_file_cache_size;
02717 #define PREF_CACHE_SEG 4096
02718 
02719 int wxGetPreference(const char *name, char *res, long len)
02720 {
02721   int offset, depth, c;
02722 
02723   /* This function duplicates a lot of work that's elsewhere,
02724      unfornatunately, due to timing constraints (i.e., it's called
02725      especially early during startup). */
02726 
02727   /******************************************/
02728   /* Step 1: load the pref file into memory */
02729   /******************************************/
02730 
02731   if (!pref_file_cache) {
02732     FILE *fp;
02733     char *home, *s;
02734     int l, ends_in_slash;
02735 
02736     wxREGGLOB(pref_file_cache);
02737 
02738     /*************** Unix ***************/
02739 
02740 #if defined(wx_xt) || defined(OS_X)
02741 # ifdef wx_mac
02742     home = scheme_expand_user_filename("~/Library/Preferences/", -1, NULL, NULL, 0);
02743 # else
02744     home = scheme_expand_user_filename("~/.plt-scheme/", -1, NULL, NULL, 0);
02745 # endif 
02746     
02747     l = strlen(home);
02748     ends_in_slash = (home[l] == '/');
02749     
02750     s = new WXGC_ATOMIC char[l + 30];
02751     memcpy(s, home, l);
02752     if (!ends_in_slash)
02753       s[l++] = '/';
02754 # ifdef wx_mac
02755     memcpy(s + l, "org.plt-scheme.prefs.ss", 24);
02756 # else
02757     memcpy(s + l, "plt-prefs.ss", 13);
02758 # endif
02759 #endif
02760 
02761     /*************** Windows ***************/
02762 
02763 #ifdef wx_msw
02764     home = win_find_home();
02765 
02766     l = strlen(home);
02767     ends_in_slash = ((home[l] == '/') || (home[l] == '\\'));
02768   
02769     s = new WXGC_ATOMIC char[l + 20];
02770     memcpy(s, home, l);
02771     if (!ends_in_slash)
02772       s[l++] = '\\';
02773     memcpy(s + l, "plt-prefs.ss", 13);
02774 #endif
02775 
02776     /*************** Mac OS Classic ***************/
02777 
02778 #if defined(wx_mac) && !defined(OS_X)
02779     {
02780       OSType t;
02781       FSSpec spec;
02782       SInt16 vRefNum;
02783       SInt32 dirID;
02784       const Str255 fileName = "\p";
02785 
02786       if (!FindFolder(kOnSystemDisk, 'pref', kCreateFolder, &vRefNum, &dirID) == noErr) {
02787        FSMakeFSSpec(vRefNum,dirID,fileName,&spec);
02788        home = scheme_mac_spec_to_path(&spec);
02789       } else if (wxmac_startup_directory) {
02790        home = wxmac_startup_directory;
02791       } else {
02792        home = scheme_os_getcwd(NULL, 0, NULL, 1);
02793       }
02794     
02795       l = strlen(home);
02796       ends_in_slash = (home[l] == ':');
02797   
02798       s = new WXGC_ATOMIC char[l + 30];
02799       memcpy(s, home, l);
02800       if (!ends_in_slash)
02801        s[l++] = ':';
02802       memcpy(s + l, "org.plt-scheme.prefs.ss", 24);
02803     }
02804 #endif
02805 
02806     /*************** Common ***************/
02807 
02808     fp = fopen_to_read(s);
02809     if (!fp)
02810       return 0;
02811 
02812     pref_file_cache_size = PREF_CACHE_SEG;
02813     pref_file_cache = new WXGC_ATOMIC char[pref_file_cache_size];
02814     offset = 0;
02815 
02816     while (!feof(fp)) {
02817       long got;
02818 
02819       if (offset + PREF_CACHE_SEG > pref_file_cache_size) {
02820        s = new WXGC_ATOMIC char[2 * pref_file_cache_size];
02821        memcpy(s, pref_file_cache, pref_file_cache_size);
02822        pref_file_cache_size *= 2;
02823        pref_file_cache = s;
02824       }
02825 
02826       got = fread(pref_file_cache + offset, 1, PREF_CACHE_SEG, fp);
02827       offset += got;
02828     }
02829     pref_file_cache_size = offset;
02830 
02831     fclose(fp);
02832   }
02833 
02834 #define cgetc() ((offset < pref_file_cache_size) ? pref_file_cache[offset++] : -1)
02835 
02836   /*******************************************/
02837   /* Step 2: a lightweight `read'.           */
02838   /* Assume a real `read' would succeed, and */
02839   /* assume there are no comments.           */
02840   /*******************************************/
02841 
02842   offset = 0;
02843   depth = 0;
02844   while (offset < pref_file_cache_size) {
02845     do {
02846       c = cgetc();
02847     } while ((c > 0) && isspace(c));
02848 
02849   top:
02850     
02851     switch (c) {
02852     case '(':
02853       depth++;
02854       if (depth == 2) {
02855        /* Maybe the entry we're looking for: */
02856        do {
02857          c = cgetc();
02858        } while ((c > 0) && isspace(c));
02859        
02860        if (c == '|') {
02861          char *prefix = "MrEd:";
02862          int i;
02863 
02864          for (i = 0; prefix[i]; i++) {
02865            c = cgetc();
02866            if (c != prefix[i])
02867              break;
02868          }
02869          if (!prefix[i]) {
02870            for (i = 0; name[i]; i++) {
02871              c = cgetc();
02872              if (c != name[i])
02873               break;
02874            }
02875            if (!name[i]) {
02876              c = cgetc();
02877              if (c == '|') {
02878               c = cgetc();
02879               if ((c > 0) && isspace(c)) {
02880                 int closer = ')';
02881                 
02882                 do {
02883                   c = cgetc();
02884                 } while ((c > 0) && isspace(c));
02885 
02886                 if (c == '"') {
02887                   closer = '"';
02888                   i = 0;
02889                 } else {
02890                   res[0] = c;
02891                   if (c == '\\')
02892                     res[0] = cgetc();
02893                   i = 1;
02894                 }
02895                 
02896                 /* Read until closing parenthesis */
02897                 for (; i < len; i++) {
02898                   res[i] = cgetc();
02899                   if (res[i] == '\\') {
02900                     res[i] = cgetc();
02901                   } else {
02902                     if (res[i] == closer) {
02903                      res[i] = 0;
02904                      break;
02905                     }
02906                   }
02907                 }
02908                 res[len - 1] =0;
02909                 
02910                 return 1;
02911               }
02912 
02913               return 0;
02914              }
02915            }
02916          }
02917          /* Need closing | */
02918          if (c != '|') {
02919            do {
02920              c = cgetc();
02921            } while (c != '|');
02922          }
02923          c = cgetc();
02924        }
02925        goto top;
02926       }
02927       break;
02928     case ')':
02929       --depth;
02930       break;
02931     case '"':
02932       do {
02933        c = cgetc();
02934        if (c == '\\')
02935          cgetc();
02936       } while ((c != '"') && (c != -1));
02937       break;
02938     case '\\':
02939       cgetc();
02940       break;
02941     case '|':
02942       do {
02943        c = cgetc();
02944       } while ((c != '|') && (c != -1));
02945       break;
02946     }
02947   }
02948 
02949   return 0;
02950 }
02951 
02952 int wxGetPreference(const char *name, int *res)
02953 {
02954   char buf[20];
02955 
02956   if (wxGetPreference(name, buf, 20)) {    
02957     long v;
02958     char *p;
02959     v = strtol(buf, &p, 10);
02960     if (p == (buf + strlen(buf))) {
02961       *res = v;
02962       return 1;
02963     }
02964   }
02965 
02966   return 0;
02967 }
02968 
02969 int wxGetBoolPreference(const char *name, int *res)
02970 {
02971   char buf[20];
02972 
02973   if (wxGetPreference(name, buf, 20)) {    
02974     if (!strcmp(buf, "#f"))
02975       *res = 0;
02976     else
02977       *res = 1;
02978     return 1;
02979   }
02980 
02981   return 0;
02982 }
02983 
02984 extern int wxMrEdGetDoubleTime(void);
02985 static Scheme_Object *get_double_time(int, Scheme_Object **) {
02986   int t;
02987   t = wxMrEdGetDoubleTime();
02988   return scheme_make_integer(t);
02989 }
02990 
02991 /***********************************************************************/
02992 /*                         strip menu codes                            */
02993 /***********************************************************************/
02994 
02995 static int starts_paren_accel(char *label, int i)
02996 {
02997   int cnt = 0;
02998   while (label[i] == ' ') {
02999     i++;
03000     cnt++;
03001   }
03002   if ((label[i] == '(')
03003       && (label[i+1] == '&')
03004       && label[i+2]
03005       && (label[i+3] == ')')) {
03006     cnt += 4;
03007     i += 4;
03008     while (label[i] == ' ') {
03009       i++;
03010       cnt++;
03011     }
03012     return cnt;
03013   }
03014 
03015   return 0;
03016 }
03017 
03018 char *wxStripMenuCodes(char *label, char *target)
03019 {
03020   int i, j, cnt;
03021   char *naya;
03022 
03023   if (!label)
03024     return NULL;
03025   
03026   for (i = 0; label[i]; i++) {
03027     if ((label[i] == '&')
03028        || (label[i] == '\t')) {
03029       /* Strip it: */
03030       if (target)
03031        naya = target;
03032       else
03033        naya = new WXGC_ATOMIC char[strlen(label) + 1];
03034       j = 0;
03035       for (i = 0; label[i]; i++) {
03036         if (label[i] == '&') {
03037           if (label[i + 1]) {
03038             naya[j++] = label[i + 1];
03039             i++;
03040           }
03041         } else if (label[i] == '\t') {
03042          break;
03043        } else if ((cnt = starts_paren_accel(label, i))) {
03044          i += (cnt - 1);
03045        } else {
03046           naya[j++] = label[i];
03047        }
03048       }
03049       naya[j] = 0;
03050       
03051       return naya;
03052     }
03053   }
03054 
03055   if (target)
03056     strcpy(target, label);
03057   
03058   return label;
03059 }
03060 
03061 /***********************************************************************/
03062 /*                            initialization                           */
03063 /***********************************************************************/
03064 
03065 static void wxScheme_Install(Scheme_Env *global_env)
03066 {
03067   wxREGGLOB(wxs_app_quit_proc);
03068   wxREGGLOB(wxs_app_file_proc);
03069   wxREGGLOB(wxs_app_about_proc);
03070   wxREGGLOB(wxs_app_pref_proc);
03071 
03072   wxs_app_file_proc = scheme_make_prim_w_arity(CAST_SP DefaultAppFileProc,
03073                                           "default-application-file-handler",
03074                                           1, 1);
03075   wxs_app_quit_proc = scheme_make_prim_w_arity(CAST_SP DefaultAppQuitProc,
03076                                           "default-application-quit-handler",
03077                                           0, 0);
03078   wxs_app_about_proc = scheme_make_prim_w_arity(CAST_SP DefaultAppAboutProc,
03079                                           "default-application-about-handler",
03080                                           0, 0);
03081   wxs_app_pref_proc = scheme_false;
03082 
03083   scheme_install_xc_global("special-control-key", 
03084                         scheme_make_prim_w_arity(CAST_SP SpecialCtlKey, 
03085                                               "special-control-key", 
03086                                               0, 1), 
03087                         global_env);
03088   scheme_install_xc_global("special-option-key", 
03089                         scheme_make_prim_w_arity(CAST_SP SpecialOptionKey, 
03090                                               "special-option-key", 
03091                                               0, 1), 
03092                         global_env);
03093   
03094   scheme_install_xc_global("application-file-handler",
03095                         scheme_make_prim_w_arity(CAST_SP ApplicationFileProc,
03096                                               "application-file-handler",
03097                                               0, 1),
03098                         global_env);
03099   scheme_install_xc_global("application-quit-handler",
03100                         scheme_make_prim_w_arity(CAST_SP ApplicationQuitProc,
03101                                               "application-quit-handler",
03102                                               0, 1),
03103                         global_env);
03104   scheme_install_xc_global("application-about-handler",
03105                         scheme_make_prim_w_arity(CAST_SP ApplicationAboutProc,
03106                                               "application-about-handler",
03107                                               0, 1),
03108                         global_env);
03109   scheme_install_xc_global("application-pref-handler",
03110                         scheme_make_prim_w_arity(CAST_SP ApplicationPrefProc,
03111                                               "application-pref-handler",
03112                                               0, 1),
03113                         global_env);
03114   
03115   scheme_install_xc_global("get-color-from-user",
03116                         scheme_make_prim_w_arity(CAST_SP wxSchemeGetColourFromUser,
03117                                               "get-color-from-user",
03118                                               0, 3),
03119                         global_env);
03120   
03121   scheme_install_xc_global("get-font-from-user",
03122                         scheme_make_prim_w_arity(CAST_SP wxSchemeGetFontFromUser,
03123                                               "get-font-from-user",
03124                                               0, 3),
03125                         global_env);
03126   
03127   scheme_install_xc_global("get-face-list",
03128                         scheme_make_prim_w_arity(CAST_SP wxSchemeGetFontList,
03129                                               "get-face-list",
03130                                               0, 1),
03131                         global_env);
03132   
03133   scheme_install_xc_global("get-panel-background",
03134                         scheme_make_prim_w_arity(CAST_SP wxSchemeGetPanelBackground,
03135                                               "get-panel-background",
03136                                               0, 0),
03137                         global_env);
03138   
03139 #ifdef wx_x
03140   scheme_install_xc_global("play-sound", scheme_false, global_env);
03141 #else
03142   scheme_install_xc_global("play-sound", 
03143                           scheme_make_prim_w_arity(CAST_SP wxPlaySound, 
03144                                                 "play-sound", 
03145                                                 2, 2), 
03146                           global_env);
03147 #endif
03148 
03149   scheme_install_xc_global("make-eventspace",
03150                           scheme_make_prim_w_arity(CAST_SP wxSchemeMakeEventspace,
03151                                                 "make-eventspace",
03152                                                 0, 0),
03153                           global_env);
03154   scheme_install_xc_global("current-eventspace",
03155                         scheme_register_parameter(CAST_SP wxSchemeCurrentEventspace,
03156                                                "current-eventspace",
03157                                                mred_eventspace_param),
03158                         global_env);
03159   scheme_install_xc_global("event-dispatch-handler",
03160                         scheme_register_parameter(CAST_SP wxSchemeEventDispatchHandler,
03161                                                "event-dispatch-handler",
03162                                                mred_event_dispatch_param),
03163                         global_env);
03164   scheme_install_xc_global("eventspace?",
03165                         scheme_make_prim_w_arity(CAST_SP Eventspace_p,
03166                                               "eventspace?",
03167                                               1, 1),
03168                         global_env);
03169 
03170   scheme_install_xc_global("current-ps-setup",
03171                         scheme_register_parameter(CAST_SP wxSchemeCurrentPSSetup,
03172                                                "current-ps-setup",
03173                                                mred_ps_setup_param),
03174                         global_env);
03175 
03176   scheme_install_xc_global("queue-callback",
03177                         scheme_make_prim_w_arity(CAST_SP queue_callback,
03178                                               "queue-callback",
03179                                               1, 2),
03180                         global_env);
03181   wxREGGLOB(MrEd_mid_queue_key);
03182   MrEd_mid_queue_key = scheme_make_pair(scheme_false, scheme_false);
03183   scheme_install_xc_global("middle-queue-key", MrEd_mid_queue_key, global_env);
03184 
03185 
03186   scheme_install_xc_global("check-for-break",
03187                         scheme_make_prim_w_arity(CAST_SP wxSchemeCheckForBreak,
03188                                               "check-for-break",
03189                                               0, 0),
03190                         global_env);
03191 
03192 
03193   scheme_install_xc_global("find-graphical-system-path",
03194                         scheme_make_prim_w_arity(CAST_SP wxSchemeFindDirectory,
03195                                               "find-graphical-system-path",
03196                                               1, 1),
03197                         global_env);
03198 
03199   scheme_install_xc_global("get-top-level-windows",
03200                         scheme_make_prim_w_arity(CAST_SP wxSchemeGetFrameList,
03201                                               "get-top-level-windows",
03202                                               0, 0),
03203                         global_env);
03204 
03205   scheme_install_xc_global("register-collecting-blit",
03206                         scheme_make_prim_w_arity(CAST_SP wxSchemeRegisterCollectingBitmap,
03207                                               "register-collecting-blit",
03208                                               7, 11),
03209                         global_env);
03210   scheme_install_xc_global("unregister-collecting-blit",
03211                         scheme_make_prim_w_arity(CAST_SP wxSchemeUnregisterCollectingBitmap,
03212                                               "unregister-collecting-blit",
03213                                               1, 1),
03214                         global_env);
03215 
03216   scheme_install_xc_global("shortcut-visible-in-label?",
03217                         scheme_make_prim_w_arity(CAST_SP wLabelShortcutsVisible,
03218                                               "shortcut-visible-in-label?",
03219                                               0, 1),
03220                         global_env);
03221 
03222 
03223   scheme_install_xc_global("eventspace-shutdown?",
03224                         scheme_make_prim_w_arity(CAST_SP Shutdown_p,
03225                                               "eventspace-shutdown?",
03226                                               1, 1),
03227                         global_env);
03228   scheme_install_xc_global("main-eventspace?",
03229                         scheme_make_prim_w_arity(CAST_SP main_eventspace_p,
03230                                               "main-eventspace?",
03231                                               1, 1),
03232                         global_env);
03233   scheme_install_xc_global("eventspace-handler-thread",
03234                         scheme_make_prim_w_arity(CAST_SP wxEventspaceHandlerThread,
03235                                               "eventspace-handler-thread",
03236                                               1, 1),
03237                         global_env);
03238 
03239   scheme_install_xc_global("in-atomic-region",
03240                         scheme_make_prim_w_arity(CAST_SP wxInAtomicRegion,
03241                                               "in-atomic-region",
03242                                               1, 1),
03243                         global_env);
03244 
03245   scheme_install_xc_global("set-executer",
03246                         scheme_make_prim_w_arity(CAST_SP SetExecuter,
03247                                               "set-executer",
03248                                               1, 1),
03249                         global_env);
03250   scheme_install_xc_global("set-menu-tester",
03251                         scheme_make_prim_w_arity(CAST_SP SetIsMenu,
03252                                               "set-menu-tester",
03253                                               1, 1),
03254                         global_env);
03255   
03256   scheme_install_xc_global("location->window",
03257                         scheme_make_prim_w_arity(CAST_SP wxsLocationToWindow,
03258                                               "location->window",
03259                                               2, 2),
03260                         global_env);
03261 
03262   scheme_install_xc_global("set-dialogs",
03263                         scheme_make_prim_w_arity(CAST_SP SetDialogs,
03264                                               "set-dialogs",
03265                                               4, 4),
03266                         global_env);
03267 
03268   scheme_install_xc_global("send-event",
03269                         scheme_make_prim_w_arity(CAST_SP wxSendEvent,
03270                                               "send-event",
03271                                               3, 5),
03272                         global_env);
03273 
03274   scheme_install_xc_global("file-creator-and-type", 
03275                         scheme_make_prim_w_arity(CAST_SP file_type_and_creator,
03276                                               "file-creator-and-type", 
03277                                               1, 3), 
03278                         global_env);
03279 
03280   scheme_install_xc_global("set-ps-procs",
03281                         scheme_make_prim_w_arity(CAST_SP SetPSProcs,
03282                                               "set-ps-procs",
03283                                               6, 6),
03284                         global_env);
03285 
03286   scheme_install_xc_global("begin-refresh-sequence",
03287                         scheme_make_prim_w_arity(CAST_SP BeginRefreshSeq,
03288                                               "begin-refresh-sequence",
03289                                               0, 0),
03290                         global_env);
03291   scheme_install_xc_global("end-refresh-sequence",
03292                         scheme_make_prim_w_arity(CAST_SP EndRefreshSeq,
03293                                               "end-refresh-sequence",
03294                                               0, 0),
03295                         global_env);
03296   scheme_install_xc_global("run-printout",
03297                            scheme_make_prim_w_arity(CAST_SP run_printout,
03298                                                     "run-printout",
03299                                                     7, 7),
03300                            global_env);
03301   scheme_install_xc_global("get-double-click-time",
03302                            scheme_make_prim_w_arity(CAST_SP get_double_time,
03303                                                     "get-double-click-time",
03304                                                     0, 0),
03305                            global_env);
03306 
03307 #ifdef USE_GL
03308   init_gl_mgr();
03309 #endif
03310 
03311   /* Order is important! Base class must be initialized before derived. */
03312   objscheme_setup_wxObject(global_env);
03313   objscheme_setup_wxWindow(global_env);
03314   objscheme_setup_wxFrame(global_env);
03315   objscheme_setup_wxColour(global_env);
03316   objscheme_setup_wxColourDatabase(global_env);
03317   objscheme_setup_wxPoint(global_env);
03318   objscheme_setup_wxBrush(global_env);
03319   objscheme_setup_wxBrushList(global_env);
03320   objscheme_setup_wxPen(global_env);
03321   objscheme_setup_wxPenList(global_env);
03322   objscheme_setup_wxBitmap(global_env);
03323   objscheme_setup_wxCursor(global_env);
03324   objscheme_setup_wxRegion(global_env);
03325   objscheme_setup_wxPath(global_env);
03326   objscheme_setup_wxFont(global_env);
03327   objscheme_setup_wxFontList(global_env);
03328   objscheme_setup_wxFontNameDirectory(global_env);
03329   objscheme_setup_wxGDIGlobal(global_env);
03330   objscheme_setup_wxChoiceGlobal(global_env);
03331   objscheme_setup_wxItem(global_env);
03332   objscheme_setup_wxMessage(global_env);
03333   objscheme_setup_wxButton(global_env);
03334   objscheme_setup_wxRadioBox(global_env);
03335   objscheme_setup_wxCheckBox(global_env);
03336   objscheme_setup_wxListBox(global_env);
03337   objscheme_setup_wxChoice(global_env);
03338   objscheme_setup_wxSlider(global_env);
03339   objscheme_setup_wxsGauge(global_env);
03340   objscheme_setup_wxTabChoice(global_env);
03341   objscheme_setup_wxGroupBox(global_env);
03342   objscheme_setup_wxMenu(global_env);
03343   objscheme_setup_wxMenuBar(global_env);
03344   objscheme_setup_wxsMenuItem(global_env);
03345   objscheme_setup_wxEvent(global_env);
03346   objscheme_setup_wxCommandEvent(global_env);
03347   objscheme_setup_wxPopupEvent(global_env);
03348   objscheme_setup_wxScrollEvent(global_env);
03349   objscheme_setup_wxKeyEvent(global_env);
03350   objscheme_setup_wxKeyEventGlobal(global_env);
03351   objscheme_setup_wxMouseEvent(global_env);
03352   objscheme_setup_wxDC(global_env);
03353   objscheme_setup_wxDCGlobal(global_env);
03354   objscheme_setup_wxMemoryDC(global_env);
03355   objscheme_setup_wxPostScriptDC(global_env);
03356   objscheme_setup_basePrinterDC(global_env);
03357   objscheme_setup_wxGL(global_env);
03358   objscheme_setup_wxGLConfig(global_env);
03359   objscheme_setup_wxCanvas(global_env);
03360   objscheme_setup_wxPanel(global_env);
03361   objscheme_setup_wxDialogBox(global_env);
03362 #if 0
03363   objscheme_setup_baseMetaFile(global_env);
03364   objscheme_setup_baseMetaFileDC(global_env);
03365 #endif
03366   objscheme_setup_wxTimer(global_env);
03367   objscheme_setup_wxClipboard(global_env);
03368   objscheme_setup_wxClipboardGlobal(global_env);
03369   objscheme_setup_wxClipboardClient(global_env);
03370   objscheme_setup_wxPrintSetupData(global_env);
03371   objscheme_setup_wxPrintSetupGlobal(global_env);
03372 
03373   objscheme_setup_wxsGlobal(global_env);
03374   objscheme_setup_wxsMenuItemGlobal(global_env);
03375 }