src/if_mzsch.c

   1 /* vi:set ts=8 sts=4 sw=4:
   2  *
   3  * MzScheme interface by Sergey Khorev <sergey.khorev@gmail.com>
   4  * Original work by Brent Fulgham <bfulgham@debian.org>
   5  * (Based on lots of help from Matthew Flatt)
   6  *
   7  * TODO Convert byte-strings to char strings?
   8  *
   9  * This consists of six parts:
  10  * 1. MzScheme interpreter main program
  11  * 2. Routines that handle the external interface between MzScheme and
  12  *    Vim.
  13  * 3. MzScheme input/output handlers: writes output via [e]msg().
  14  * 4. Implementation of the Vim Features for MzScheme
  15  * 5. Vim Window-related Manipulation Functions.
  16  * 6. Vim Buffer-related Manipulation Functions
  17  *
  18  * NOTES
  19  * 1. Memory, allocated with scheme_malloc*, need not to be freed explicitly,
  20  *    garbage collector will do it self
  21  * 2. Requires at least NORMAL features. I can't imagine why one may want
  22  *    to build with SMALL or TINY features but with MzScheme interface.
  23  * 3. I don't use K&R-style functions. Anyways, MzScheme headers are ANSI.
  24  */
  25
  26 #include "vim.h"
  27
  28 #include "if_mzsch.h"
  29
  30 /* Only do the following when the feature is enabled.  Needed for "make
  31  * depend". */
  32 #if defined(FEAT_MZSCHEME) || defined(PROTO)
  33
  34 #include <assert.h>
  35
  36 /* Base data structures */
  37 #define SCHEME_VIMBUFFERP(obj)  SAME_TYPE(SCHEME_TYPE(obj), mz_buffer_type)
  38 #define SCHEME_VIMWINDOWP(obj)  SAME_TYPE(SCHEME_TYPE(obj), mz_window_type)
  39
  40 typedef struct
  41 {
  42     Scheme_Object   so;
  43     buf_T           *buf;
  44 } vim_mz_buffer;
  45
  46 #define INVALID_BUFFER_VALUE ((buf_T *)(-1))
  47
  48 typedef struct
  49 {
  50     Scheme_Object   so;
  51     win_T           *win;
  52 } vim_mz_window;
  53
  54 #define INVALID_WINDOW_VALUE ((win_T *)(-1))
  55
  56 /*
  57  * Prims that form MzScheme Vim interface
  58  */
  59 typedef struct
  60 {
  61     Scheme_Closed_Prim  *prim;
  62     char        *name;
  63     int         mina;   /* arity information */
  64     int         maxa;
  65 } Vim_Prim;
  66
  67 typedef struct
  68 {
  69     char            *name;
  70     Scheme_Object   *port;
  71 } Port_Info;
  72
  73 /* info for do_apply */
  74 typedef struct
  75 {
  76     Scheme_Object   *proc;
  77     int             argc;
  78     Scheme_Object   **argv;
  79 } Apply_Info;
  80
  81 /*
  82  *========================================================================
  83  *  Vim-Control Commands
  84  *========================================================================
  85  */
  86 /*
  87  *========================================================================
  88  *  Utility functions for the vim/mzscheme interface
  89  *========================================================================
  90  */
  91 #ifdef HAVE_SANDBOX
  92 static Scheme_Object *sandbox_file_guard(int, Scheme_Object **);
  93 static Scheme_Object *sandbox_network_guard(int, Scheme_Object **);
  94 static void sandbox_check(void);
  95 #endif
  96 /*  Buffer-related commands */
  97 static Scheme_Object *buffer_new(buf_T *buf);
  98 static Scheme_Object *get_buffer_by_name(void *, int, Scheme_Object **);
  99 static Scheme_Object *get_buffer_by_num(void *, int, Scheme_Object **);
 100 static Scheme_Object *get_buffer_count(void *, int, Scheme_Object **);
 101 static Scheme_Object *get_buffer_line(void *, int, Scheme_Object **);
 102 static Scheme_Object *get_buffer_line_list(void *, int, Scheme_Object **);
 103 static Scheme_Object *get_buffer_name(void *, int, Scheme_Object **);
 104 static Scheme_Object *get_buffer_num(void *, int, Scheme_Object **);
 105 static Scheme_Object *get_buffer_size(void *, int, Scheme_Object **);
 106 static Scheme_Object *get_curr_buffer(void *, int, Scheme_Object **);
 107 static Scheme_Object *get_next_buffer(void *, int, Scheme_Object **);
 108 static Scheme_Object *get_prev_buffer(void *, int, Scheme_Object **);
 109 static Scheme_Object *mzscheme_open_buffer(void *, int, Scheme_Object **);
 110 static Scheme_Object *set_buffer_line(void *, int, Scheme_Object **);
 111 static Scheme_Object *set_buffer_line_list(void *, int, Scheme_Object **);
 112 static Scheme_Object *insert_buffer_line_list(void *, int, Scheme_Object **);
 113 static Scheme_Object *get_range_start(void *, int, Scheme_Object **);
 114 static Scheme_Object *get_range_end(void *, int, Scheme_Object **);
 115 static vim_mz_buffer *get_vim_curr_buffer(void);
 116
 117 /*  Window-related commands */
 118 static Scheme_Object *window_new(win_T *win);
 119 static Scheme_Object *get_curr_win(void *, int, Scheme_Object **);
 120 static Scheme_Object *get_window_count(void *, int, Scheme_Object **);
 121 static Scheme_Object *get_window_by_num(void *, int, Scheme_Object **);
 122 static Scheme_Object *get_window_num(void *, int, Scheme_Object **);
 123 static Scheme_Object *get_window_buffer(void *, int, Scheme_Object **);
 124 static Scheme_Object *get_window_height(void *, int, Scheme_Object **);
 125 static Scheme_Object *set_window_height(void *, int, Scheme_Object **);
 126 #ifdef FEAT_VERTSPLIT
 127 static Scheme_Object *get_window_width(void *, int, Scheme_Object **);
 128 static Scheme_Object *set_window_width(void *, int, Scheme_Object **);
 129 #endif
 130 static Scheme_Object *get_cursor(void *, int, Scheme_Object **);
 131 static Scheme_Object *set_cursor(void *, int, Scheme_Object **);
 132 static Scheme_Object *get_window_list(void *, int, Scheme_Object **);
 133 static vim_mz_window *get_vim_curr_window(void);
 134
 135 /*  Vim-related commands */
 136 static Scheme_Object *mzscheme_beep(void *, int, Scheme_Object **);
 137 static Scheme_Object *get_option(void *, int, Scheme_Object **);
 138 static Scheme_Object *set_option(void *, int, Scheme_Object **);
 139 static Scheme_Object *vim_command(void *, int, Scheme_Object **);
 140 static Scheme_Object *vim_eval(void *, int, Scheme_Object **);
 141 static Scheme_Object *vim_bufferp(void *data, int, Scheme_Object **);
 142 static Scheme_Object *vim_windowp(void *data, int, Scheme_Object **);
 143 static Scheme_Object *vim_buffer_validp(void *data, int, Scheme_Object **);
 144 static Scheme_Object *vim_window_validp(void *data, int, Scheme_Object **);
 145
 146 /*
 147  *========================================================================
 148  *  Internal Function Prototypes
 149  *========================================================================
 150  */
 151 static int vim_error_check(void);
 152 static int do_mzscheme_command(exarg_T *, void *, Scheme_Closed_Prim *what);
 153 static void startup_mzscheme(void);
 154 static char *string_to_line(Scheme_Object *obj);
 155 static void do_output(char *mesg, long len);
 156 static void do_printf(char *format, ...);
 157 static void do_flush(void);
 158 static Scheme_Object *_apply_thunk_catch_exceptions(
 159         Scheme_Object *, Scheme_Object **);
 160 static Scheme_Object *extract_exn_message(Scheme_Object *v);
 161 static Scheme_Object *do_eval(void *, int noargc, Scheme_Object **noargv);
 162 static Scheme_Object *do_load(void *, int noargc, Scheme_Object **noargv);
 163 static Scheme_Object *do_apply(void *, int noargc, Scheme_Object **noargv);
 164 static void register_vim_exn(void);
 165 static vim_mz_buffer *get_buffer_arg(const char *fname, int argnum,
 166         int argc, Scheme_Object **argv);
 167 static vim_mz_window *get_window_arg(const char *fname, int argnum,
 168         int argc, Scheme_Object **argv);
 169 static int line_in_range(linenr_T, buf_T *);
 170 static void check_line_range(linenr_T, buf_T *);
 171 static void mz_fix_cursor(int lo, int hi, int extra);
 172
 173 static int eval_with_exn_handling(void *, Scheme_Closed_Prim *,
 174             Scheme_Object **ret);
 175 static void make_modules(void);
 176 static void init_exn_catching_apply(void);
 177 static int mzscheme_env_main(Scheme_Env *env, int argc, char **argv);
 178 static int mzscheme_init(void);
 179 #ifdef FEAT_EVAL
 180 static Scheme_Object *vim_to_mzscheme(typval_T *vim_value, int depth,
 181         Scheme_Hash_Table *visited);
 182 #endif
 183
 184 #ifdef MZ_PRECISE_GC
 185 static int buffer_size_proc(void *obj)
 186 {
 187     return gcBYTES_TO_WORDS(sizeof(vim_mz_buffer));
 188 }
 189 static int buffer_mark_proc(void *obj)
 190 {
 191     return buffer_size_proc(obj);
 192 }
 193 static int buffer_fixup_proc(void *obj)
 194 {
 195     return buffer_size_proc(obj);
 196 }
 197 static int window_size_proc(void *obj)
 198 {
 199     return gcBYTES_TO_WORDS(sizeof(vim_mz_window));
 200 }
 201 static int window_mark_proc(void *obj)
 202 {
 203     return window_size_proc(obj);
 204 }
 205 static int window_fixup_proc(void *obj)
 206 {
 207     return window_size_proc(obj);
 208 }
 209 #endif
 210
 211 #ifdef DYNAMIC_MZSCHEME
 212
 213 static Scheme_Object *dll_scheme_eof;
 214 static Scheme_Object *dll_scheme_false;
 215 static Scheme_Object *dll_scheme_void;
 216 static Scheme_Object *dll_scheme_null;
 217 static Scheme_Object *dll_scheme_true;
 218
 219 static Scheme_Thread **dll_scheme_current_thread_ptr;
 220
 221 static void (**dll_scheme_console_printf_ptr)(char *str, ...);
 222 static void (**dll_scheme_console_output_ptr)(char *str, long len);
 223 static void (**dll_scheme_notify_multithread_ptr)(int on);
 224
 225 static void *(*dll_GC_malloc)(size_t size_in_bytes);
 226 static void *(*dll_GC_malloc_atomic)(size_t size_in_bytes);
 227 static Scheme_Env *(*dll_scheme_basic_env)(void);
 228 static void (*dll_scheme_check_threads)(void);
 229 static void (*dll_scheme_register_static)(void *ptr, long size);
 230 static void (*dll_scheme_set_stack_base)(void *base, int no_auto_statics);
 231 static void (*dll_scheme_add_global)(const char *name, Scheme_Object *val,
 232         Scheme_Env *env);
 233 static void (*dll_scheme_add_global_symbol)(Scheme_Object *name,
 234         Scheme_Object *val, Scheme_Env *env);
 235 static Scheme_Object *(*dll_scheme_apply)(Scheme_Object *rator, int num_rands,
 236         Scheme_Object **rands);
 237 static Scheme_Object *(*dll_scheme_builtin_value)(const char *name);
 238 # if MZSCHEME_VERSION_MAJOR >= 299
 239 static Scheme_Object *(*dll_scheme_byte_string_to_char_string)(Scheme_Object *s);
 240 # endif
 241 static void (*dll_scheme_close_input_port)(Scheme_Object *port);
 242 static void (*dll_scheme_count_lines)(Scheme_Object *port);
 243 #if MZSCHEME_VERSION_MAJOR < 360
 244 static Scheme_Object *(*dll_scheme_current_continuation_marks)(void);
 245 #else
 246 static Scheme_Object *(*dll_scheme_current_continuation_marks)(Scheme_Object *prompt_tag);
 247 #endif
 248 static void (*dll_scheme_display)(Scheme_Object *obj, Scheme_Object *port);
 249 static char *(*dll_scheme_display_to_string)(Scheme_Object *obj, long *len);
 250 static int (*dll_scheme_eq)(Scheme_Object *obj1, Scheme_Object *obj2);
 251 static Scheme_Object *(*dll_scheme_do_eval)(Scheme_Object *obj,
 252         int _num_rands, Scheme_Object **rands, int val);
 253 static void (*dll_scheme_dont_gc_ptr)(void *p);
 254 static Scheme_Object *(*dll_scheme_eval)(Scheme_Object *obj, Scheme_Env *env);
 255 static Scheme_Object *(*dll_scheme_eval_string)(const char *str,
 256         Scheme_Env *env);
 257 static Scheme_Object *(*dll_scheme_eval_string_all)(const char *str,
 258         Scheme_Env *env, int all);
 259 static void (*dll_scheme_finish_primitive_module)(Scheme_Env *env);
 260 # if MZSCHEME_VERSION_MAJOR < 299
 261 static char *(*dll_scheme_format)(char *format, int flen, int argc,
 262         Scheme_Object **argv, long *rlen);
 263 # else
 264 static char *(*dll_scheme_format_utf8)(char *format, int flen, int argc,
 265         Scheme_Object **argv, long *rlen);
 266 static Scheme_Object *(*dll_scheme_get_param)(Scheme_Config *c, int pos);
 267 # endif
 268 static void (*dll_scheme_gc_ptr_ok)(void *p);
 269 # if MZSCHEME_VERSION_MAJOR < 299
 270 static char *(*dll_scheme_get_sized_string_output)(Scheme_Object *,
 271         long *len);
 272 # else
 273 static char *(*dll_scheme_get_sized_byte_string_output)(Scheme_Object *,
 274         long *len);
 275 # endif
 276 static Scheme_Object *(*dll_scheme_intern_symbol)(const char *name);
 277 static Scheme_Object *(*dll_scheme_lookup_global)(Scheme_Object *symbol,
 278         Scheme_Env *env);
 279 static Scheme_Object *(*dll_scheme_make_closed_prim_w_arity)
 280     (Scheme_Closed_Prim *prim, void *data, const char *name, mzshort mina,
 281      mzshort maxa);
 282 static Scheme_Object *(*dll_scheme_make_integer_value)(long i);
 283 static Scheme_Object *(*dll_scheme_make_pair)(Scheme_Object *car,
 284         Scheme_Object *cdr);
 285 static Scheme_Object *(*dll_scheme_make_prim_w_arity)(Scheme_Prim *prim,
 286         const char *name, mzshort mina, mzshort maxa);
 287 # if MZSCHEME_VERSION_MAJOR < 299
 288 static Scheme_Object *(*dll_scheme_make_string)(const char *chars);
 289 static Scheme_Object *(*dll_scheme_make_string_output_port)();
 290 # else
 291 static Scheme_Object *(*dll_scheme_make_byte_string)(const char *chars);
 292 static Scheme_Object *(*dll_scheme_make_byte_string_output_port)();
 293 # endif
 294 static Scheme_Object *(*dll_scheme_make_struct_instance)(Scheme_Object *stype,
 295         int argc, Scheme_Object **argv);
 296 static Scheme_Object **(*dll_scheme_make_struct_names)(Scheme_Object *base,
 297         Scheme_Object *field_names, int flags, int *count_out);
 298 static Scheme_Object *(*dll_scheme_make_struct_type)(Scheme_Object *base,
 299         Scheme_Object *parent, Scheme_Object *inspector, int num_fields,
 300         int num_uninit_fields, Scheme_Object *uninit_val,
 301         Scheme_Object *properties
 302 # if MZSCHEME_VERSION_MAJOR >= 299
 303         , Scheme_Object *guard
 304 # endif
 305         );
 306 static Scheme_Object **(*dll_scheme_make_struct_values)(
 307         Scheme_Object *struct_type, Scheme_Object **names, int count,
 308         int flags);
 309 static Scheme_Type (*dll_scheme_make_type)(const char *name);
 310 static Scheme_Object *(*dll_scheme_make_vector)(int size,
 311         Scheme_Object *fill);
 312 static void *(*dll_scheme_malloc_fail_ok)(void *(*f)(size_t), size_t);
 313 static Scheme_Object *(*dll_scheme_open_input_file)(const char *name,
 314         const char *who);
 315 static Scheme_Env *(*dll_scheme_primitive_module)(Scheme_Object *name,
 316         Scheme_Env *for_env);
 317 static int (*dll_scheme_proper_list_length)(Scheme_Object *list);
 318 static void (*dll_scheme_raise)(Scheme_Object *exn);
 319 static Scheme_Object *(*dll_scheme_read)(Scheme_Object *port);
 320 static void (*dll_scheme_signal_error)(const char *msg, ...);
 321 static void (*dll_scheme_wrong_type)(const char *name, const char *expected,
 322         int which, int argc, Scheme_Object **argv);
 323 # if MZSCHEME_VERSION_MAJOR >= 299
 324 static void (*dll_scheme_set_param)(Scheme_Config *c, int pos,
 325         Scheme_Object *o);
 326 static Scheme_Config *(*dll_scheme_current_config)(void);
 327 static Scheme_Object *(*dll_scheme_char_string_to_byte_string)
 328     (Scheme_Object *s);
 329 static Scheme_Object *(*dll_scheme_char_string_to_path)
 330     (Scheme_Object *s);
 331 # endif
 332 static Scheme_Hash_Table *(*dll_scheme_make_hash_table)(int type);
 333 static void (*dll_scheme_hash_set)(Scheme_Hash_Table *table,
 334         Scheme_Object *key, Scheme_Object *value);
 335 static Scheme_Object *(*dll_scheme_hash_get)(Scheme_Hash_Table *table,
 336         Scheme_Object *key);
 337 static Scheme_Object *(*dll_scheme_make_double)(double d);
 338 # ifdef INCLUDE_MZSCHEME_BASE
 339 static Scheme_Object *(*dll_scheme_make_sized_byte_string)(char *chars,
 340         long len, int copy);
 341 static Scheme_Object *(*dll_scheme_namespace_require)(Scheme_Object *req);
 342 # endif
 343
 344 /* arrays are imported directly */
 345 # define scheme_eof dll_scheme_eof
 346 # define scheme_false dll_scheme_false
 347 # define scheme_void dll_scheme_void
 348 # define scheme_null dll_scheme_null
 349 # define scheme_true dll_scheme_true
 350
 351 /* pointers are GetProceAddress'ed as pointers to pointer */
 352 # define scheme_current_thread (*dll_scheme_current_thread_ptr)
 353 # define scheme_console_printf (*dll_scheme_console_printf_ptr)
 354 # define scheme_console_output (*dll_scheme_console_output_ptr)
 355 # define scheme_notify_multithread (*dll_scheme_notify_multithread_ptr)
 356
 357 /* and functions in a usual way */
 358 # define GC_malloc dll_GC_malloc
 359 # define GC_malloc_atomic dll_GC_malloc_atomic
 360
 361 # define scheme_add_global dll_scheme_add_global
 362 # define scheme_add_global_symbol dll_scheme_add_global_symbol
 363 # define scheme_apply dll_scheme_apply
 364 # define scheme_basic_env dll_scheme_basic_env
 365 # define scheme_builtin_value dll_scheme_builtin_value
 366 # if MZSCHEME_VERSION_MAJOR >= 299
 367 #  define scheme_byte_string_to_char_string dll_scheme_byte_string_to_char_string
 368 # endif
 369 # define scheme_check_threads dll_scheme_check_threads
 370 # define scheme_close_input_port dll_scheme_close_input_port
 371 # define scheme_count_lines dll_scheme_count_lines
 372 # define scheme_current_continuation_marks \
 373     dll_scheme_current_continuation_marks
 374 # define scheme_display dll_scheme_display
 375 # define scheme_display_to_string dll_scheme_display_to_string
 376 # define scheme_do_eval dll_scheme_do_eval
 377 # define scheme_dont_gc_ptr dll_scheme_dont_gc_ptr
 378 # define scheme_eq dll_scheme_eq
 379 # define scheme_eval dll_scheme_eval
 380 # define scheme_eval_string dll_scheme_eval_string
 381 # define scheme_eval_string_all dll_scheme_eval_string_all
 382 # define scheme_finish_primitive_module dll_scheme_finish_primitive_module
 383 # if MZSCHEME_VERSION_MAJOR < 299
 384 #  define scheme_format dll_scheme_format
 385 # else
 386 #  define scheme_format_utf8 dll_scheme_format_utf8
 387 # endif
 388 # define scheme_gc_ptr_ok dll_scheme_gc_ptr_ok
 389 # if MZSCHEME_VERSION_MAJOR < 299
 390 #  define scheme_get_sized_string_output dll_scheme_get_sized_string_output
 391 # else
 392 #  define scheme_get_sized_byte_string_output \
 393     dll_scheme_get_sized_byte_string_output
 394 # define scheme_get_param dll_scheme_get_param
 395 # endif
 396 # define scheme_intern_symbol dll_scheme_intern_symbol
 397 # define scheme_lookup_global dll_scheme_lookup_global
 398 # define scheme_make_closed_prim_w_arity dll_scheme_make_closed_prim_w_arity
 399 # define scheme_make_integer_value dll_scheme_make_integer_value
 400 # define scheme_make_pair dll_scheme_make_pair
 401 # define scheme_make_prim_w_arity dll_scheme_make_prim_w_arity
 402 # if MZSCHEME_VERSION_MAJOR < 299
 403 #  define scheme_make_string dll_scheme_make_string
 404 #  define scheme_make_string_output_port dll_scheme_make_string_output_port
 405 # else
 406 #  define scheme_make_byte_string dll_scheme_make_byte_string
 407 #  define scheme_make_byte_string_output_port \
 408     dll_scheme_make_byte_string_output_port
 409 # endif
 410 # define scheme_make_struct_instance dll_scheme_make_struct_instance
 411 # define scheme_make_struct_names dll_scheme_make_struct_names
 412 # define scheme_make_struct_type dll_scheme_make_struct_type
 413 # define scheme_make_struct_values dll_scheme_make_struct_values
 414 # define scheme_make_type dll_scheme_make_type
 415 # define scheme_make_vector dll_scheme_make_vector
 416 # define scheme_malloc_fail_ok dll_scheme_malloc_fail_ok
 417 # define scheme_open_input_file dll_scheme_open_input_file
 418 # define scheme_primitive_module dll_scheme_primitive_module
 419 # define scheme_proper_list_length dll_scheme_proper_list_length
 420 # define scheme_raise dll_scheme_raise
 421 # define scheme_read dll_scheme_read
 422 # define scheme_register_static dll_scheme_register_static
 423 # define scheme_set_stack_base dll_scheme_set_stack_base
 424 # define scheme_signal_error dll_scheme_signal_error
 425 # define scheme_wrong_type dll_scheme_wrong_type
 426 # if MZSCHEME_VERSION_MAJOR >= 299
 427 #  define scheme_set_param dll_scheme_set_param
 428 #  define scheme_current_config dll_scheme_current_config
 429 #  define scheme_char_string_to_byte_string \
 430     dll_scheme_char_string_to_byte_string
 431 #  define scheme_char_string_to_path \
 432     dll_scheme_char_string_to_path
 433 # endif
 434 # define scheme_make_hash_table dll_scheme_make_hash_table
 435 # define scheme_hash_set dll_scheme_hash_set
 436 # define scheme_hash_get dll_scheme_hash_get
 437 # define scheme_make_double dll_scheme_make_double
 438 # ifdef INCLUDE_MZSCHEME_BASE
 439 #  define scheme_make_sized_byte_string dll_scheme_make_sized_byte_string
 440 #  define scheme_namespace_require dll_scheme_namespace_require
 441 # endif
 442
 443 typedef struct
 444 {
 445     char    *name;
 446     void    **ptr;
 447 } Thunk_Info;
 448
 449 static Thunk_Info mzgc_imports[] = {
 450     {"GC_malloc", (void **)&dll_GC_malloc},
 451     {"GC_malloc_atomic", (void **)&dll_GC_malloc_atomic},
 452     {NULL, NULL}};
 453
 454 static Thunk_Info mzsch_imports[] = {
 455     {"scheme_eof", (void **)&dll_scheme_eof},
 456     {"scheme_false", (void **)&dll_scheme_false},
 457     {"scheme_void", (void **)&dll_scheme_void},
 458     {"scheme_null", (void **)&dll_scheme_null},
 459     {"scheme_true", (void **)&dll_scheme_true},
 460     {"scheme_current_thread", (void **)&dll_scheme_current_thread_ptr},
 461     {"scheme_console_printf", (void **)&dll_scheme_console_printf_ptr},
 462     {"scheme_console_output", (void **)&dll_scheme_console_output_ptr},
 463     {"scheme_notify_multithread",
 464         (void **)&dll_scheme_notify_multithread_ptr},
 465     {"scheme_add_global", (void **)&dll_scheme_add_global},
 466     {"scheme_add_global_symbol", (void **)&dll_scheme_add_global_symbol},
 467     {"scheme_apply", (void **)&dll_scheme_apply},
 468     {"scheme_basic_env", (void **)&dll_scheme_basic_env},
 469 # if MZSCHEME_VERSION_MAJOR >= 299
 470     {"scheme_byte_string_to_char_string", (void **)&dll_scheme_byte_string_to_char_string},
 471 # endif
 472     {"scheme_builtin_value", (void **)&dll_scheme_builtin_value},
 473     {"scheme_check_threads", (void **)&dll_scheme_check_threads},
 474     {"scheme_close_input_port", (void **)&dll_scheme_close_input_port},
 475     {"scheme_count_lines", (void **)&dll_scheme_count_lines},
 476     {"scheme_current_continuation_marks",
 477         (void **)&dll_scheme_current_continuation_marks},
 478     {"scheme_display", (void **)&dll_scheme_display},
 479     {"scheme_display_to_string", (void **)&dll_scheme_display_to_string},
 480     {"scheme_do_eval", (void **)&dll_scheme_do_eval},
 481     {"scheme_dont_gc_ptr", (void **)&dll_scheme_dont_gc_ptr},
 482     {"scheme_eq", (void **)&dll_scheme_eq},
 483     {"scheme_eval", (void **)&dll_scheme_eval},
 484     {"scheme_eval_string", (void **)&dll_scheme_eval_string},
 485     {"scheme_eval_string_all", (void **)&dll_scheme_eval_string_all},
 486     {"scheme_finish_primitive_module",
 487         (void **)&dll_scheme_finish_primitive_module},
 488 # if MZSCHEME_VERSION_MAJOR < 299
 489     {"scheme_format", (void **)&dll_scheme_format},
 490 # else
 491     {"scheme_format_utf8", (void **)&dll_scheme_format_utf8},
 492     {"scheme_get_param", (void **)&dll_scheme_get_param},
 493 #endif
 494     {"scheme_gc_ptr_ok", (void **)&dll_scheme_gc_ptr_ok},
 495 # if MZSCHEME_VERSION_MAJOR < 299
 496     {"scheme_get_sized_string_output",
 497         (void **)&dll_scheme_get_sized_string_output},
 498 # else
 499     {"scheme_get_sized_byte_string_output",
 500         (void **)&dll_scheme_get_sized_byte_string_output},
 501 #endif
 502     {"scheme_intern_symbol", (void **)&dll_scheme_intern_symbol},
 503     {"scheme_lookup_global", (void **)&dll_scheme_lookup_global},
 504     {"scheme_make_closed_prim_w_arity",
 505         (void **)&dll_scheme_make_closed_prim_w_arity},
 506     {"scheme_make_integer_value", (void **)&dll_scheme_make_integer_value},
 507     {"scheme_make_pair", (void **)&dll_scheme_make_pair},
 508     {"scheme_make_prim_w_arity", (void **)&dll_scheme_make_prim_w_arity},
 509 # if MZSCHEME_VERSION_MAJOR < 299
 510     {"scheme_make_string", (void **)&dll_scheme_make_string},
 511     {"scheme_make_string_output_port",
 512         (void **)&dll_scheme_make_string_output_port},
 513 # else
 514     {"scheme_make_byte_string", (void **)&dll_scheme_make_byte_string},
 515     {"scheme_make_byte_string_output_port",
 516         (void **)&dll_scheme_make_byte_string_output_port},
 517 # endif
 518     {"scheme_make_struct_instance",
 519         (void **)&dll_scheme_make_struct_instance},
 520     {"scheme_make_struct_names", (void **)&dll_scheme_make_struct_names},
 521     {"scheme_make_struct_type", (void **)&dll_scheme_make_struct_type},
 522     {"scheme_make_struct_values", (void **)&dll_scheme_make_struct_values},
 523     {"scheme_make_type", (void **)&dll_scheme_make_type},
 524     {"scheme_make_vector", (void **)&dll_scheme_make_vector},
 525     {"scheme_malloc_fail_ok", (void **)&dll_scheme_malloc_fail_ok},
 526     {"scheme_open_input_file", (void **)&dll_scheme_open_input_file},
 527     {"scheme_primitive_module", (void **)&dll_scheme_primitive_module},
 528     {"scheme_proper_list_length", (void **)&dll_scheme_proper_list_length},
 529     {"scheme_raise", (void **)&dll_scheme_raise},
 530     {"scheme_read", (void **)&dll_scheme_read},
 531     {"scheme_register_static", (void **)&dll_scheme_register_static},
 532     {"scheme_set_stack_base", (void **)&dll_scheme_set_stack_base},
 533     {"scheme_signal_error", (void **)&dll_scheme_signal_error},
 534     {"scheme_wrong_type", (void **)&dll_scheme_wrong_type},
 535 # if MZSCHEME_VERSION_MAJOR >= 299
 536     {"scheme_set_param", (void **)&dll_scheme_set_param},
 537     {"scheme_current_config", (void **)&dll_scheme_current_config},
 538     {"scheme_char_string_to_byte_string",
 539         (void **)&dll_scheme_char_string_to_byte_string},
 540     {"scheme_char_string_to_path", (void **)&dll_scheme_char_string_to_path},
 541 # endif
 542     {"scheme_make_hash_table", (void **)&dll_scheme_make_hash_table},
 543     {"scheme_hash_set", (void **)&dll_scheme_hash_set},
 544     {"scheme_hash_get", (void **)&dll_scheme_hash_get},
 545     {"scheme_make_double", (void **)&dll_scheme_make_double},
 546 # ifdef INCLUDE_MZSCHEME_BASE
 547     {"scheme_make_sized_byte_string", (void **)&dll_scheme_make_sized_byte_string},
 548     {"scheme_namespace_require", (void **)&dll_scheme_namespace_require},
 549 #endif
 550     {NULL, NULL}};
 551
 552 static HINSTANCE hMzGC = 0;
 553 static HINSTANCE hMzSch = 0;
 554
 555 static void dynamic_mzscheme_end(void);
 556 static int mzscheme_runtime_link_init(char *sch_dll, char *gc_dll,
 557         int verbose);
 558
 559     static int
 560 mzscheme_runtime_link_init(char *sch_dll, char *gc_dll, int verbose)
 561 {
 562     Thunk_Info *thunk = NULL;
 563
 564     if (hMzGC && hMzSch)
 565         return OK;
 566     hMzSch = LoadLibrary(sch_dll);
 567     hMzGC = LoadLibrary(gc_dll);
 568
 569     if (!hMzSch)
 570     {
 571         if (verbose)
 572             EMSG2(_(e_loadlib), sch_dll);
 573         return FAIL;
 574     }
 575
 576     if (!hMzGC)
 577     {
 578         if (verbose)
 579             EMSG2(_(e_loadlib), gc_dll);
 580         return FAIL;
 581     }
 582
 583     for (thunk = mzsch_imports; thunk->name; thunk++)
 584     {
 585         if ((*thunk->ptr =
 586                     (void *)GetProcAddress(hMzSch, thunk->name)) == NULL)
 587         {
 588             FreeLibrary(hMzSch);
 589             hMzSch = 0;
 590             FreeLibrary(hMzGC);
 591             hMzGC = 0;
 592             if (verbose)
 593                 EMSG2(_(e_loadfunc), thunk->name);
 594             return FAIL;
 595         }
 596     }
 597     for (thunk = mzgc_imports; thunk->name; thunk++)
 598     {
 599         if ((*thunk->ptr =
 600                     (void *)GetProcAddress(hMzGC, thunk->name)) == NULL)
 601         {
 602             FreeLibrary(hMzSch);
 603             hMzSch = 0;
 604             FreeLibrary(hMzGC);
 605             hMzGC = 0;
 606             if (verbose)
 607                 EMSG2(_(e_loadfunc), thunk->name);
 608             return FAIL;
 609         }
 610     }
 611     return OK;
 612 }
 613
 614     int
 615 mzscheme_enabled(int verbose)
 616 {
 617     return mzscheme_runtime_link_init(
 618             DYNAMIC_MZSCH_DLL, DYNAMIC_MZGC_DLL, verbose) == OK;
 619 }
 620
 621     static void
 622 dynamic_mzscheme_end(void)
 623 {
 624     if (hMzSch)
 625     {
 626         FreeLibrary(hMzSch);
 627         hMzSch = 0;
 628     }
 629     if (hMzGC)
 630     {
 631         FreeLibrary(hMzGC);
 632         hMzGC = 0;
 633     }
 634 }
 635 #endif /* DYNAMIC_MZSCHEME */
 636
 637 /* need to put it here for dynamic stuff to work */
 638 #if defined(INCLUDE_MZSCHEME_BASE)
 639 # include "mzscheme_base.c"
 640 #elif MZSCHEME_VERSION_MAJOR >= 400
 641 # error MzScheme 4.x must include mzscheme_base.c, for MinGW32 you need to define MZSCHEME_GENERATE_BASE=yes
 642 #endif
 643
 644 /*
 645  *========================================================================
 646  *  1. MzScheme interpreter startup
 647  *========================================================================
 648  */
 649
 650 static Scheme_Type mz_buffer_type;
 651 static Scheme_Type mz_window_type;
 652
 653 static int initialized = FALSE;
 654
 655 /* global environment */
 656 static Scheme_Env    *environment = NULL;
 657 /* output/error handlers */
 658 static Scheme_Object *curout = NULL;
 659 static Scheme_Object *curerr = NULL;
 660 /* exn:vim exception */
 661 static Scheme_Object *exn_catching_apply = NULL;
 662 static Scheme_Object *exn_p = NULL;
 663 static Scheme_Object *exn_message = NULL;
 664 static Scheme_Object *vim_exn = NULL; /* Vim Error exception */
 665
 666 #if !defined(MZ_PRECISE_GC) || MZSCHEME_VERSION_MAJOR < 400
 667 static void *stack_base = NULL;
 668 #endif
 669
 670 static long range_start;
 671 static long range_end;
 672
 673 /* MzScheme threads scheduling stuff */
 674 static int mz_threads_allow = 0;
 675
 676 #if defined(FEAT_GUI_W32)
 677 static void CALLBACK timer_proc(HWND, UINT, UINT, DWORD);
 678 static UINT timer_id = 0;
 679 #elif defined(FEAT_GUI_GTK)
 680 static gint timer_proc(gpointer);
 681 static guint timer_id = 0;
 682 #elif defined(FEAT_GUI_MOTIF) || defined(FEAT_GUI_ATHENA)
 683 static void timer_proc(XtPointer, XtIntervalId *);
 684 static XtIntervalId timer_id = (XtIntervalId)0;
 685 #elif defined(FEAT_GUI_MAC)
 686 pascal void timer_proc(EventLoopTimerRef, void *);
 687 static EventLoopTimerRef timer_id = NULL;
 688 static EventLoopTimerUPP timerUPP;
 689 #endif
 690
 691 #ifndef FEAT_GUI_W32 /* Win32 console and Unix */
 692     void
 693 mzvim_check_threads(void)
 694 {
 695     /* Last time MzScheme threads were scheduled */
 696     static time_t mz_last_time = 0;
 697
 698     if (mz_threads_allow && p_mzq > 0)
 699     {
 700         time_t now = time(NULL);
 701
 702         if ((now - mz_last_time) * 1000 > p_mzq)
 703         {
 704             mz_last_time = now;
 705             scheme_check_threads();
 706         }
 707     }
 708 }
 709 #endif
 710
 711 #ifdef MZSCHEME_GUI_THREADS
 712 static void setup_timer(void);
 713 static void remove_timer(void);
 714
 715 /* timers are presented in GUI only */
 716 # if defined(FEAT_GUI_W32)
 717     static void CALLBACK
 718 timer_proc(HWND hwnd, UINT uMsg, UINT idEvent, DWORD dwTime)
 719 # elif defined(FEAT_GUI_GTK)
 720     static gint
 721 timer_proc(gpointer data)
 722 # elif defined(FEAT_GUI_MOTIF) || defined(FEAT_GUI_ATHENA)
 723     static void
 724 timer_proc(XtPointer timed_out, XtIntervalId *interval_id)
 725 # elif defined(FEAT_GUI_MAC)
 726     pascal void
 727 timer_proc(EventLoopTimerRef theTimer, void *userData)
 728 # endif
 729 {
 730     scheme_check_threads();
 731 # if defined(FEAT_GUI_GTK)
 732     return TRUE; /* continue receiving notifications */
 733 # elif defined(FEAT_GUI_MOTIF) || defined(FEAT_GUI_ATHENA)
 734     /* renew timeout */
 735     if (mz_threads_allow && p_mzq > 0)
 736         timer_id = XtAppAddTimeOut(app_context, p_mzq,
 737                 timer_proc, NULL);
 738 # endif
 739 }
 740
 741     static void
 742 setup_timer(void)
 743 {
 744 # if defined(FEAT_GUI_W32)
 745     timer_id = SetTimer(NULL, 0, p_mzq, timer_proc);
 746 # elif defined(FEAT_GUI_GTK)
 747     timer_id = gtk_timeout_add((guint32)p_mzq, (GtkFunction)timer_proc, NULL);
 748 # elif defined(FEAT_GUI_MOTIF) || defined(FEAT_GUI_ATHENA)
 749     timer_id = XtAppAddTimeOut(app_context, p_mzq, timer_proc, NULL);
 750 # elif defined(FEAT_GUI_MAC)
 751     timerUPP = NewEventLoopTimerUPP(timer_proc);
 752     InstallEventLoopTimer(GetMainEventLoop(), p_mzq * kEventDurationMillisecond,
 753                 p_mzq * kEventDurationMillisecond, timerUPP, NULL, &timer_id);
 754 # endif
 755 }
 756
 757     static void
 758 remove_timer(void)
 759 {
 760 # if defined(FEAT_GUI_W32)
 761     KillTimer(NULL, timer_id);
 762 # elif defined(FEAT_GUI_GTK)
 763     gtk_timeout_remove(timer_id);
 764 # elif defined(FEAT_GUI_MOTIF) || defined(FEAT_GUI_ATHENA)
 765     XtRemoveTimeOut(timer_id);
 766 # elif defined(FEAT_GUI_MAC)
 767     RemoveEventLoopTimer(timer_id);
 768     DisposeEventLoopTimerUPP(timerUPP);
 769 # endif
 770     timer_id = 0;
 771 }
 772
 773     void
 774 mzvim_reset_timer(void)
 775 {
 776     if (timer_id != 0)
 777         remove_timer();
 778     if (mz_threads_allow && p_mzq > 0 && gui.in_use)
 779         setup_timer();
 780 }
 781
 782 #endif /* MZSCHEME_GUI_THREADS */
 783
 784     static void
 785 notify_multithread(int on)
 786 {
 787     mz_threads_allow = on;
 788 #ifdef MZSCHEME_GUI_THREADS
 789     if (on && timer_id == 0 && p_mzq > 0 && gui.in_use)
 790         setup_timer();
 791     if (!on && timer_id != 0)
 792         remove_timer();
 793 #endif
 794 }
 795
 796     void
 797 mzscheme_end(void)
 798 {
 799 #ifdef DYNAMIC_MZSCHEME
 800     dynamic_mzscheme_end();
 801 #endif
 802 }
 803
 804     void
 805 mzscheme_main(void)
 806 {
 807 #if defined(MZ_PRECISE_GC) && MZSCHEME_VERSION_MAJOR >= 400
 808     /* use trampoline for precise GC in MzScheme >= 4.x */
 809     scheme_main_setup(TRUE, mzscheme_env_main, 0, NULL);
 810 #else
 811     mzscheme_env_main(NULL, 0, NULL);
 812 #endif
 813 }
 814
 815     static int
 816 mzscheme_env_main(Scheme_Env *env, int argc, char **argv)
 817 {
 818     /* neither argument nor return values are used */
 819 #ifdef MZ_PRECISE_GC
 820 # if MZSCHEME_VERSION_MAJOR < 400
 821     /*
 822      * Starting from version 4.x, embedding applications must use
 823      * scheme_main_setup/scheme_main_stack_setup trampolines
 824      * rather than setting stack base directly with scheme_set_stack_base
 825      */
 826     Scheme_Object   *dummy = NULL;
 827     MZ_GC_DECL_REG(1);
 828     MZ_GC_VAR_IN_REG(0, dummy);
 829
 830     stack_base = &__gc_var_stack__;
 831 # else
 832     /* environment has been created by us by Scheme */
 833     environment = env;
 834 # endif
 835     /*
 836      * In 4.x, all activities must be performed inside trampoline
 837      * so we are forced to initialise GC immediately
 838      * This can be postponed in 3.x but I see no point in implementing
 839      * a feature which will work in older versions only.
 840      * One would better use conservative GC if he needs dynamic MzScheme
 841      */
 842     mzscheme_init();
 843 #else
 844     int dummy = 0;
 845     stack_base = (void *)&dummy;
 846 #endif
 847     main_loop(FALSE, FALSE);
 848 #if defined(MZ_PRECISE_GC) && MZSCHEME_VERSION_MAJOR < 400
 849     /* releasing dummy */
 850     MZ_GC_REG();
 851     MZ_GC_UNREG();
 852 #endif
 853     return 0;
 854 }
 855
 856     static void
 857 startup_mzscheme(void)
 858 {
 859 #if !defined(MZ_PRECISE_GC) || MZSCHEME_VERSION_MAJOR < 400
 860     scheme_set_stack_base(stack_base, 1);
 861 #endif
 862
 863     MZ_REGISTER_STATIC(environment);
 864     MZ_REGISTER_STATIC(curout);
 865     MZ_REGISTER_STATIC(curerr);
 866     MZ_REGISTER_STATIC(exn_catching_apply);
 867     MZ_REGISTER_STATIC(exn_p);
 868     MZ_REGISTER_STATIC(exn_message);
 869     MZ_REGISTER_STATIC(vim_exn);
 870
 871 #if !defined(MZ_PRECISE_GC) || MZSCHEME_VERSION_MAJOR < 400
 872     /* in newer versions of precise GC the initial env has been created */
 873     environment = scheme_basic_env();
 874 #endif
 875     MZ_GC_CHECK();
 876
 877 #ifdef INCLUDE_MZSCHEME_BASE
 878     {
 879         /*
 880          * versions 4.x do not provide Scheme bindings by default
 881          * we need to add them explicitly
 882          */
 883         Scheme_Object *scheme_base_symbol = NULL;
 884         MZ_GC_DECL_REG(1);
 885         MZ_GC_VAR_IN_REG(0, scheme_base_symbol);
 886         MZ_GC_REG();
 887         /* invoke function from generated and included mzscheme_base.c */
 888         declare_modules(environment);
 889         scheme_base_symbol = scheme_intern_symbol("scheme/base");
 890         MZ_GC_CHECK();
 891         scheme_namespace_require(scheme_base_symbol);
 892         MZ_GC_CHECK();
 893         MZ_GC_UNREG();
 894     }
 895 #endif
 896     register_vim_exn();
 897     /* use new environment to initialise exception handling */
 898     init_exn_catching_apply();
 899
 900     /* redirect output */
 901     scheme_console_output = do_output;
 902     scheme_console_printf = do_printf;
 903
 904 #ifdef MZSCHEME_COLLECTS
 905     /* setup 'current-library-collection-paths' parameter */
 906 # if MZSCHEME_VERSION_MAJOR >= 299
 907     {
 908         Scheme_Object   *coll_byte_string = NULL;
 909         Scheme_Object   *coll_char_string = NULL;
 910         Scheme_Object   *coll_path = NULL;
 911         Scheme_Object   *coll_pair = NULL;
 912         Scheme_Config   *config = NULL;
 913
 914         MZ_GC_DECL_REG(5);
 915         MZ_GC_VAR_IN_REG(0, coll_byte_string);
 916         MZ_GC_VAR_IN_REG(1, coll_char_string);
 917         MZ_GC_VAR_IN_REG(2, coll_path);
 918         MZ_GC_VAR_IN_REG(3, coll_pair);
 919         MZ_GC_VAR_IN_REG(4, config);
 920         MZ_GC_REG();
 921         coll_byte_string = scheme_make_byte_string(MZSCHEME_COLLECTS);
 922         MZ_GC_CHECK();
 923         coll_char_string = scheme_byte_string_to_char_string(coll_byte_string);
 924         MZ_GC_CHECK();
 925         coll_path = scheme_char_string_to_path(coll_char_string);
 926         MZ_GC_CHECK();
 927         coll_pair = scheme_make_pair(coll_path, scheme_null);
 928         MZ_GC_CHECK();
 929         config = scheme_config;
 930         MZ_GC_CHECK();
 931         scheme_set_param(config, MZCONFIG_COLLECTION_PATHS, coll_pair);
 932         MZ_GC_CHECK();
 933         MZ_GC_UNREG();
 934     }
 935 # else
 936     {
 937         Scheme_Object   *coll_string = NULL;
 938         Scheme_Object   *coll_pair = NULL;
 939         Scheme_Config   *config = NULL;
 940
 941         MZ_GC_DECL_REG(3);
 942         MZ_GC_VAR_IN_REG(0, coll_string);
 943         MZ_GC_VAR_IN_REG(1, coll_pair);
 944         MZ_GC_VAR_IN_REG(2, config);
 945         MZ_GC_REG();
 946         coll_string = scheme_make_string(MZSCHEME_COLLECTS);
 947         MZ_GC_CHECK();
 948         coll_pair = scheme_make_pair(coll_string, scheme_null);
 949         MZ_GC_CHECK();
 950         config = scheme_config;
 951         MZ_GC_CHECK();
 952         scheme_set_param(config, MZCONFIG_COLLECTION_PATHS, coll_pair);
 953         MZ_GC_CHECK();
 954         MZ_GC_UNREG();
 955     }
 956 # endif
 957 #endif
 958 #ifdef HAVE_SANDBOX
 959     {
 960         Scheme_Object   *make_security_guard = NULL;
 961         MZ_GC_DECL_REG(1);
 962         MZ_GC_VAR_IN_REG(0, make_security_guard);
 963         MZ_GC_REG();
 964
 965 #if MZSCHEME_VERSION_MAJOR < 400
 966         {
 967             Scheme_Object       *make_security_guard_symbol = NULL;
 968             MZ_GC_DECL_REG(1);
 969             MZ_GC_VAR_IN_REG(0, make_security_guard_symbol);
 970             MZ_GC_REG();
 971             make_security_guard_symbol = scheme_intern_symbol("make-security-guard");
 972             MZ_GC_CHECK();
 973             make_security_guard = scheme_lookup_global(
 974                     make_security_guard_symbol, environment);
 975             MZ_GC_UNREG();
 976         }
 977 #else
 978         make_security_guard = scheme_builtin_value("make-security-guard");
 979         MZ_GC_CHECK();
 980 #endif
 981
 982         /* setup sandbox guards */
 983         if (make_security_guard != NULL)
 984         {
 985             Scheme_Object   *args[3] = {NULL, NULL, NULL};
 986             Scheme_Object   *guard = NULL;
 987             Scheme_Config   *config = NULL;
 988             MZ_GC_DECL_REG(5);
 989             MZ_GC_ARRAY_VAR_IN_REG(0, args, 3);
 990             MZ_GC_VAR_IN_REG(3, guard);
 991             MZ_GC_VAR_IN_REG(4, config);
 992             MZ_GC_REG();
 993             config = scheme_config;
 994             MZ_GC_CHECK();
 995             args[0] = scheme_get_param(config, MZCONFIG_SECURITY_GUARD);
 996             MZ_GC_CHECK();
 997             args[1] = scheme_make_prim_w_arity(sandbox_file_guard,
 998                     "sandbox-file-guard", 3, 3);
 999             args[2] = scheme_make_prim_w_arity(sandbox_network_guard,
1000                     "sandbox-network-guard", 4, 4);
1001             guard = scheme_apply(make_security_guard, 3, args);
1002             MZ_GC_CHECK();
1003             scheme_set_param(config, MZCONFIG_SECURITY_GUARD, guard);
1004             MZ_GC_CHECK();
1005             MZ_GC_UNREG();
1006         }
1007         MZ_GC_UNREG();
1008     }
1009 #endif
1010     /* Create buffer and window types for use in Scheme code */
1011     mz_buffer_type = scheme_make_type("<vim-buffer>");
1012     MZ_GC_CHECK();
1013     mz_window_type = scheme_make_type("<vim-window>");
1014     MZ_GC_CHECK();
1015 #ifdef MZ_PRECISE_GC
1016     GC_register_traversers(mz_buffer_type,
1017             buffer_size_proc, buffer_mark_proc, buffer_fixup_proc,
1018             TRUE, TRUE);
1019     GC_register_traversers(mz_window_type,
1020             window_size_proc, window_mark_proc, window_fixup_proc,
1021             TRUE, TRUE);
1022 #endif
1023
1024     make_modules();
1025
1026     /*
1027      * setup callback to receive notifications
1028      * whether thread scheduling is (or not) required
1029      */
1030     scheme_notify_multithread = notify_multithread;
1031 }
1032
1033 /*
1034  * This routine is called for each new invocation of MzScheme
1035  * to make sure things are properly initialized.
1036  */
1037     static int
1038 mzscheme_init(void)
1039 {
1040     if (!initialized)
1041     {
1042 #ifdef DYNAMIC_MZSCHEME
1043         if (!mzscheme_enabled(TRUE))
1044         {
1045             EMSG(_("E815: Sorry, this command is disabled, the MzScheme libraries could not be loaded."));
1046             return -1;
1047         }
1048 #endif
1049         startup_mzscheme();
1050         initialized = TRUE;
1051     }
1052     {
1053         Scheme_Config   *config = NULL;
1054         MZ_GC_DECL_REG(1);
1055         MZ_GC_VAR_IN_REG(0, config);
1056         MZ_GC_REG();
1057         config = scheme_config;
1058         MZ_GC_CHECK();
1059         /* recreate ports each call effectivelly clearing these ones */
1060         curout = scheme_make_string_output_port();
1061         MZ_GC_CHECK();
1062         curerr = scheme_make_string_output_port();
1063         MZ_GC_CHECK();
1064         scheme_set_param(config, MZCONFIG_OUTPUT_PORT, curout);
1065         MZ_GC_CHECK();
1066         scheme_set_param(config, MZCONFIG_ERROR_PORT, curerr);
1067         MZ_GC_CHECK();
1068         MZ_GC_UNREG();
1069     }
1070
1071     return 0;
1072 }
1073
1074 /*
1075  *========================================================================
1076  *  2.  External Interface
1077  *========================================================================
1078  */
1079
1080 /*
1081  * Evaluate command with exception handling
1082  */
1083     static int
1084 eval_with_exn_handling(void *data, Scheme_Closed_Prim *what, Scheme_Object **ret)
1085 {
1086     Scheme_Object   *value = NULL;
1087     Scheme_Object   *exn = NULL;
1088     Scheme_Object   *prim = NULL;
1089
1090     MZ_GC_DECL_REG(3);
1091     MZ_GC_VAR_IN_REG(0, value);
1092     MZ_GC_VAR_IN_REG(1, exn);
1093     MZ_GC_VAR_IN_REG(2, prim);
1094     MZ_GC_REG();
1095
1096     prim = scheme_make_closed_prim_w_arity(what, data, "mzvim", 0, 0);
1097     MZ_GC_CHECK();
1098     value = _apply_thunk_catch_exceptions(prim, &exn);
1099     MZ_GC_CHECK();
1100
1101     if (!value)
1102     {
1103         value = extract_exn_message(exn);
1104         /* Got an exn? */
1105         if (value)
1106         {
1107             scheme_display(value, curerr);   /*  Send to stderr-vim */
1108             MZ_GC_CHECK();
1109             do_flush();
1110         }
1111         MZ_GC_UNREG();
1112         /* `raise' was called on some arbitrary value */
1113         return FAIL;
1114     }
1115
1116     if (ret != NULL)    /* if pointer to retval supported give it up */
1117         *ret = value;
1118     /* Print any result, as long as it's not a void */
1119     else if (!SCHEME_VOIDP(value))
1120     {
1121         scheme_display(value, curout);  /* Send to stdout-vim */
1122         MZ_GC_CHECK();
1123     }
1124
1125     do_flush();
1126     MZ_GC_UNREG();
1127     return OK;
1128 }
1129
1130 /* :mzscheme */
1131     static int
1132 do_mzscheme_command(exarg_T *eap, void *data, Scheme_Closed_Prim *what)
1133 {
1134     if (mzscheme_init())
1135         return FAIL;
1136
1137     range_start = eap->line1;
1138     range_end = eap->line2;
1139
1140     return eval_with_exn_handling(data, what, NULL);
1141 }
1142
1143 /*
1144  * Routine called by VIM when deleting a buffer
1145  */
1146     void
1147 mzscheme_buffer_free(buf_T *buf)
1148 {
1149     if (buf->b_mzscheme_ref)
1150     {
1151         vim_mz_buffer *bp;
1152
1153         bp = buf->b_mzscheme_ref;
1154         bp->buf = INVALID_BUFFER_VALUE;
1155         buf->b_mzscheme_ref = NULL;
1156         scheme_gc_ptr_ok(bp);
1157         MZ_GC_CHECK();
1158     }
1159 }
1160
1161 /*
1162  * Routine called by VIM when deleting a Window
1163  */
1164     void
1165 mzscheme_window_free(win_T *win)
1166 {
1167     if (win->w_mzscheme_ref)
1168     {
1169         vim_mz_window *wp;
1170         wp = win->w_mzscheme_ref;
1171         wp->win = INVALID_WINDOW_VALUE;
1172         win->w_mzscheme_ref = NULL;
1173         scheme_gc_ptr_ok(wp);
1174         MZ_GC_CHECK();
1175     }
1176 }
1177
1178 /*
1179  * ":mzscheme" (or ":mz")
1180  */
1181     void
1182 ex_mzscheme(exarg_T *eap)
1183 {
1184     char_u      *script;
1185
1186     script = script_get(eap, eap->arg);
1187     if (!eap->skip)
1188     {
1189         if (script == NULL)
1190             do_mzscheme_command(eap, eap->arg, do_eval);
1191         else
1192         {
1193             do_mzscheme_command(eap, script, do_eval);
1194             vim_free(script);
1195         }
1196     }
1197 }
1198
1199 /*
1200  * apply MzScheme procedure with arguments,
1201  * handling errors
1202  */
1203     Scheme_Object *
1204 mzvim_apply(Scheme_Object *proc, int argc, Scheme_Object **argv)
1205 {
1206     if (mzscheme_init())
1207         return FAIL;
1208     else
1209     {
1210         Apply_Info      data = {NULL, 0, NULL};
1211         Scheme_Object   *ret = NULL;
1212
1213         MZ_GC_DECL_REG(5);
1214         MZ_GC_VAR_IN_REG(0, ret);
1215         MZ_GC_VAR_IN_REG(1, data.proc);
1216         MZ_GC_ARRAY_VAR_IN_REG(2, data.argv, argc);
1217         MZ_GC_REG();
1218
1219         data.proc = proc;
1220         data.argc = argc;
1221         data.argv = argv;
1222
1223         eval_with_exn_handling(&data, do_apply, &ret);
1224         MZ_GC_UNREG();
1225         return ret;
1226     }
1227 }
1228
1229     static Scheme_Object *
1230 do_load(void *data, int noargc, Scheme_Object **noargv)
1231 {
1232     Scheme_Object   *expr = NULL;
1233     Scheme_Object   *result = NULL;
1234     char            *file = NULL;
1235     Port_Info       *pinfo = (Port_Info *)data;
1236
1237     MZ_GC_DECL_REG(3);
1238     MZ_GC_VAR_IN_REG(0, expr);
1239     MZ_GC_VAR_IN_REG(1, result);
1240     MZ_GC_VAR_IN_REG(2, file);
1241     MZ_GC_REG();
1242
1243     file = (char *)scheme_malloc_fail_ok(scheme_malloc_atomic, MAXPATHL + 1);
1244     MZ_GC_CHECK();
1245
1246     /* make Vim expansion */
1247     expand_env((char_u *)pinfo->name, (char_u *)file, MAXPATHL);
1248     pinfo->port = scheme_open_input_file(file, "mzfile");
1249     MZ_GC_CHECK();
1250     scheme_count_lines(pinfo->port);  /* to get accurate read error location*/
1251     MZ_GC_CHECK();
1252
1253     /* Like REPL but print only last result */
1254     while (!SCHEME_EOFP(expr = scheme_read(pinfo->port)))
1255     {
1256         result = scheme_eval(expr, environment);
1257         MZ_GC_CHECK();
1258     }
1259
1260     /* errors will be caught in do_mzscheme_comamnd and ex_mzfile */
1261     scheme_close_input_port(pinfo->port);
1262     MZ_GC_CHECK();
1263     pinfo->port = NULL;
1264     MZ_GC_UNREG();
1265     return result;
1266 }
1267
1268 /* :mzfile */
1269     void
1270 ex_mzfile(exarg_T *eap)
1271 {
1272     Port_Info   pinfo = {NULL, NULL};
1273
1274     MZ_GC_DECL_REG(1);
1275     MZ_GC_VAR_IN_REG(0, pinfo.port);
1276     MZ_GC_REG();
1277
1278     pinfo.name = (char *)eap->arg;
1279     if (do_mzscheme_command(eap, &pinfo, do_load) != OK
1280             && pinfo.port != NULL)      /* looks like port was not closed */
1281     {
1282         scheme_close_input_port(pinfo.port);
1283         MZ_GC_CHECK();
1284     }
1285     MZ_GC_UNREG();
1286 }
1287
1288
1289 /*
1290  *========================================================================
1291  * Exception handling code -- cribbed form the MzScheme sources and
1292  * Matthew Flatt's "Inside PLT MzScheme" document.
1293  *========================================================================
1294  */
1295     static void
1296 init_exn_catching_apply(void)
1297 {
1298     if (!exn_catching_apply)
1299     {
1300         char *e =
1301             "(lambda (thunk) "
1302                 "(with-handlers ([void (lambda (exn) (cons #f exn))]) "
1303                 "(cons #t (thunk))))";
1304
1305         exn_catching_apply = scheme_eval_string(e, environment);
1306         MZ_GC_CHECK();
1307         exn_p = scheme_builtin_value("exn?");
1308         MZ_GC_CHECK();
1309         exn_message = scheme_builtin_value("exn-message");
1310         MZ_GC_CHECK();
1311     }
1312 }
1313
1314 /*
1315  * This function applies a thunk, returning the Scheme value if there's
1316  * no exception, otherwise returning NULL and setting *exn to the raised
1317  * value (usually an exn structure).
1318  */
1319     static Scheme_Object *
1320 _apply_thunk_catch_exceptions(Scheme_Object *f, Scheme_Object **exn)
1321 {
1322     Scheme_Object *v;
1323
1324     v = _scheme_apply(exn_catching_apply, 1, &f);
1325     /* v is a pair: (cons #t value) or (cons #f exn) */
1326
1327     if (SCHEME_TRUEP(SCHEME_CAR(v)))
1328         return SCHEME_CDR(v);
1329     else
1330     {
1331         *exn = SCHEME_CDR(v);
1332         return NULL;
1333     }
1334 }
1335
1336     static Scheme_Object *
1337 extract_exn_message(Scheme_Object *v)
1338 {
1339     if (SCHEME_TRUEP(_scheme_apply(exn_p, 1, &v)))
1340         return _scheme_apply(exn_message, 1, &v);
1341     else
1342         return NULL; /* Not an exn structure */
1343 }
1344
1345     static Scheme_Object *
1346 do_eval(void *s, int noargc, Scheme_Object **noargv)
1347 {
1348     return scheme_eval_string_all((char *)s, environment, TRUE);
1349 }
1350
1351     static Scheme_Object *
1352 do_apply(void *a, int noargc, Scheme_Object **noargv)
1353 {
1354     Apply_Info  *info = (Apply_Info *)a;
1355     return scheme_apply(info->proc, info->argc, info->argv);
1356 }
1357
1358 /*
1359  *========================================================================
1360  *  3.  MzScheme I/O Handlers
1361  *========================================================================
1362  */
1363     static void
1364 do_intrnl_output(char *mesg, long len, int error)
1365 {
1366     char *p, *prev;
1367
1368     prev = mesg;
1369     p = strchr(prev, '\n');
1370     while (p)
1371     {
1372         *p = '\0';
1373         if (error)
1374             EMSG(prev);
1375         else
1376             MSG(prev);
1377         prev = p + 1;
1378         p = strchr(prev, '\n');
1379     }
1380
1381     if (error)
1382         EMSG(prev);
1383     else
1384         MSG(prev);
1385 }
1386
1387     static void
1388 do_output(char *mesg, long len)
1389 {
1390     do_intrnl_output(mesg, len, 0);
1391 }
1392
1393     static void
1394 do_err_output(char *mesg, long len)
1395 {
1396     do_intrnl_output(mesg, len, 1);
1397 }
1398
1399     static void
1400 do_printf(char *format, ...)
1401 {
1402     do_intrnl_output(format, STRLEN(format), 1);
1403 }
1404
1405     static void
1406 do_flush(void)
1407 {
1408     char *buff;
1409     long length;
1410
1411     buff = scheme_get_sized_string_output(curerr, &length);
1412     MZ_GC_CHECK();
1413     if (length)
1414     {
1415         do_err_output(buff, length);
1416         return;
1417     }
1418
1419     buff = scheme_get_sized_string_output(curout, &length);
1420     MZ_GC_CHECK();
1421     if (length)
1422         do_output(buff, length);
1423 }
1424
1425 /*
1426  *========================================================================
1427  *  4. Implementation of the Vim Features for MzScheme
1428  *========================================================================
1429  */
1430
1431 /* (command {command-string}) */
1432     static Scheme_Object *
1433 vim_command(void *data, int argc, Scheme_Object **argv)
1434 {
1435     Vim_Prim    *prim = (Vim_Prim *)data;
1436     char        *cmd = SCHEME_STR_VAL(GUARANTEE_STRING(prim->name, 0));
1437
1438     /* may be use do_cmdline_cmd? */
1439     do_cmdline((char_u *)cmd, NULL, NULL, DOCMD_NOWAIT|DOCMD_VERBOSE);
1440     update_screen(VALID);
1441
1442     raise_if_error();
1443     return scheme_void;
1444 }
1445
1446 /* (eval {expr-string}) */
1447     static Scheme_Object *
1448 vim_eval(void *data, int argc, Scheme_Object **argv)
1449 {
1450 #ifdef FEAT_EVAL
1451     Vim_Prim            *prim = (Vim_Prim *)data;
1452     char                *expr;
1453     Scheme_Object       *result;
1454     /* hash table to store visited values to avoid infinite loops */
1455     Scheme_Hash_Table   *visited = NULL;
1456     typval_T            *vim_result;
1457
1458     MZ_GC_DECL_REG(1);
1459     MZ_GC_VAR_IN_REG(0, visited);
1460     MZ_GC_REG();
1461
1462     visited = scheme_make_hash_table(SCHEME_hash_ptr);
1463     MZ_GC_CHECK();
1464
1465     expr = SCHEME_STR_VAL(GUARANTEE_STRING(prim->name, 0));
1466     vim_result = eval_expr((char_u *)expr, NULL);
1467
1468     if (vim_result == NULL)
1469         raise_vim_exn(_("invalid expression"));
1470
1471     result = vim_to_mzscheme(vim_result, 1, visited);
1472     free_tv(vim_result);
1473
1474     MZ_GC_UNREG();
1475     return result;
1476 #else
1477     raise_vim_exn(_("expressions disabled at compile time"));
1478     /* unreachable */
1479     return scheme_false;
1480 #endif
1481 }
1482
1483 /* (range-start) */
1484     static Scheme_Object *
1485 get_range_start(void *data, int argc, Scheme_Object **argv)
1486 {
1487     return scheme_make_integer(range_start);
1488 }
1489
1490 /* (range-end) */
1491     static Scheme_Object *
1492 get_range_end(void *data, int argc, Scheme_Object **argv)
1493 {
1494     return scheme_make_integer(range_end);
1495 }
1496
1497 /* (beep) */
1498     static Scheme_Object *
1499 mzscheme_beep(void *data, int argc, Scheme_Object **argv)
1500 {
1501     vim_beep();
1502     return scheme_void;
1503 }
1504
1505 static Scheme_Object *M_global = NULL;
1506
1507 /* (get-option {option-name}) [buffer/window] */
1508     static Scheme_Object *
1509 get_option(void *data, int argc, Scheme_Object **argv)
1510 {
1511     Vim_Prim        *prim = (Vim_Prim *)data;
1512     char_u          *name;
1513     long            value;
1514     char            *strval;
1515     int             rc;
1516     Scheme_Object   *rval;
1517     int             opt_flags = 0;
1518     buf_T           *save_curb = curbuf;
1519     win_T           *save_curw = curwin;
1520
1521     name = (char_u *)SCHEME_STR_VAL(GUARANTEE_STRING(prim->name, 0));
1522
1523     if (argc > 1)
1524     {
1525         if (M_global == NULL)
1526         {
1527             MZ_REGISTER_STATIC(M_global);
1528             M_global = scheme_intern_symbol("global");
1529             MZ_GC_CHECK();
1530         }
1531
1532         if (argv[1] == M_global)
1533             opt_flags = OPT_GLOBAL;
1534         else if (SCHEME_VIMBUFFERP(argv[1]))
1535         {
1536             curbuf = get_valid_buffer(argv[1]);
1537             opt_flags = OPT_LOCAL;
1538         }
1539         else if (SCHEME_VIMWINDOWP(argv[1]))
1540         {
1541             win_T *win = get_valid_window(argv[1]);
1542
1543             curwin = win;
1544             curbuf = win->w_buffer;
1545             opt_flags = OPT_LOCAL;
1546         }
1547         else
1548             scheme_wrong_type(prim->name, "vim-buffer/window", 1, argc, argv);
1549     }
1550
1551     rc = get_option_value(name, &value, (char_u **)&strval, opt_flags);
1552     curbuf = save_curb;
1553     curwin = save_curw;
1554
1555     switch (rc)
1556     {
1557     case 1:
1558         return scheme_make_integer_value(value);
1559     case 0:
1560         rval = scheme_make_string(strval);
1561         MZ_GC_CHECK();
1562         vim_free(strval);
1563         return rval;
1564     case -1:
1565     case -2:
1566         raise_vim_exn(_("hidden option"));
1567     case -3:
1568         raise_vim_exn(_("unknown option"));
1569     }
1570     /* unreachable */
1571     return scheme_void;
1572 }
1573
1574 /* (set-option {option-changing-string} [buffer/window]) */
1575     static Scheme_Object *
1576 set_option(void *data, int argc, Scheme_Object **argv)
1577 {
1578     char_u      *cmd;
1579     int         opt_flags = 0;
1580     buf_T       *save_curb = curbuf;
1581     win_T       *save_curw = curwin;
1582     Vim_Prim    *prim = (Vim_Prim *)data;
1583
1584     GUARANTEE_STRING(prim->name, 0);
1585     if (argc > 1)
1586     {
1587         if (M_global == NULL)
1588         {
1589             MZ_REGISTER_STATIC(M_global);
1590             M_global = scheme_intern_symbol("global");
1591             MZ_GC_CHECK();
1592         }
1593
1594         if (argv[1] == M_global)
1595             opt_flags = OPT_GLOBAL;
1596         else if (SCHEME_VIMBUFFERP(argv[1]))
1597         {
1598             curbuf = get_valid_buffer(argv[1]);
1599             opt_flags = OPT_LOCAL;
1600         }
1601         else if (SCHEME_VIMWINDOWP(argv[1]))
1602         {
1603             win_T *win = get_valid_window(argv[1]);
1604             curwin = win;
1605             curbuf = win->w_buffer;
1606             opt_flags = OPT_LOCAL;
1607         }
1608         else
1609             scheme_wrong_type(prim->name, "vim-buffer/window", 1, argc, argv);
1610     }
1611
1612     /* do_set can modify cmd, make copy */
1613     cmd = vim_strsave((char_u *)SCHEME_STR_VAL(argv[0]));
1614     do_set(cmd, opt_flags);
1615     vim_free(cmd);
1616     update_screen(NOT_VALID);
1617     curbuf = save_curb;
1618     curwin = save_curw;
1619     raise_if_error();
1620     return scheme_void;
1621 }
1622
1623 /*
1624  *===========================================================================
1625  *  5. Vim Window-related Manipulation Functions
1626  *===========================================================================
1627  */
1628
1629 /* (curr-win) */
1630     static Scheme_Object *
1631 get_curr_win(void *data, int argc, Scheme_Object **argv)
1632 {
1633     return (Scheme_Object *)get_vim_curr_window();
1634 }
1635
1636 /* (win-count) */
1637     static Scheme_Object *
1638 get_window_count(void *data, int argc, Scheme_Object **argv)
1639 {
1640     win_T   *w;
1641     int     n = 0;
1642
1643     for (w = firstwin; w != NULL; w = w->w_next)
1644         ++n;
1645     return scheme_make_integer(n);
1646 }
1647
1648 /* (get-win-list [buffer]) */
1649     static Scheme_Object *
1650 get_window_list(void *data, int argc, Scheme_Object **argv)
1651 {
1652     Vim_Prim        *prim = (Vim_Prim *)data;
1653     vim_mz_buffer   *buf;
1654     Scheme_Object   *list;
1655     win_T           *w;
1656
1657     buf = get_buffer_arg(prim->name, 0, argc, argv);
1658     list = scheme_null;
1659
1660     for (w = firstwin; w != NULL; w = w->w_next)
1661         if (w->w_buffer == buf->buf)
1662         {
1663             list = scheme_make_pair(window_new(w), list);
1664             MZ_GC_CHECK();
1665         }
1666
1667     return list;
1668 }
1669
1670     static Scheme_Object *
1671 window_new(win_T *win)
1672 {
1673     vim_mz_window *self = NULL;
1674
1675     MZ_GC_DECL_REG(1);
1676     MZ_GC_VAR_IN_REG(0, self);
1677     MZ_GC_REG();
1678
1679     /* We need to handle deletion of windows underneath us.
1680      * If we add a "w_mzscheme_ref" field to the win_T structure,
1681      * then we can get at it in win_free() in vim.
1682      *
1683      * On a win_free() we set the Scheme object's win_T *field
1684      * to an invalid value. We trap all uses of a window
1685      * object, and reject them if the win_T *field is invalid.
1686      */
1687     if (win->w_mzscheme_ref != NULL)
1688         return win->w_mzscheme_ref;
1689
1690     self = scheme_malloc_fail_ok(scheme_malloc, sizeof(vim_mz_window));
1691     vim_memset(self, 0, sizeof(vim_mz_window));
1692     scheme_dont_gc_ptr(self);   /* because win isn't visible to GC */
1693     MZ_GC_CHECK();
1694     win->w_mzscheme_ref = self;
1695     self->win = win;
1696     self->so.type = mz_window_type;
1697
1698     MZ_GC_UNREG();
1699     return (Scheme_Object *)(self);
1700 }
1701
1702 /* (get-win-num [window]) */
1703     static Scheme_Object *
1704 get_window_num(void *data, int argc, Scheme_Object **argv)
1705 {
1706     Vim_Prim    *prim = (Vim_Prim *)data;
1707     win_T       *win = get_window_arg(prim->name, 0, argc, argv)->win;
1708     int         nr = 1;
1709     win_T       *wp;
1710
1711     for (wp = firstwin; wp != win; wp = wp->w_next)
1712         ++nr;
1713
1714     return scheme_make_integer(nr);
1715 }
1716
1717 /* (get-win-by-num {windownum}) */
1718     static Scheme_Object *
1719 get_window_by_num(void *data, int argc, Scheme_Object **argv)
1720 {
1721     Vim_Prim    *prim = (Vim_Prim *)data;
1722     win_T       *win;
1723     int         fnum;
1724
1725     fnum = SCHEME_INT_VAL(GUARANTEE_INTEGER(prim->name, 0));
1726     if (fnum < 1)
1727         scheme_signal_error(_("window index is out of range"));
1728
1729     for (win = firstwin; win != NULL; win = win->w_next, --fnum)
1730         if (fnum == 1)      /* to be 1-based */
1731             return window_new(win);
1732
1733     return scheme_false;
1734 }
1735
1736 /* (get-win-buffer [window]) */
1737     static Scheme_Object *
1738 get_window_buffer(void *data, int argc, Scheme_Object **argv)
1739 {
1740     Vim_Prim        *prim = (Vim_Prim *)data;
1741     vim_mz_window   *win = get_window_arg(prim->name, 0, argc, argv);
1742
1743     return buffer_new(win->win->w_buffer);
1744 }
1745
1746 /* (get-win-height [window]) */
1747     static Scheme_Object *
1748 get_window_height(void *data, int argc, Scheme_Object **argv)
1749 {
1750     Vim_Prim        *prim = (Vim_Prim *)data;
1751     vim_mz_window   *win = get_window_arg(prim->name, 0, argc, argv);
1752
1753     return scheme_make_integer(win->win->w_height);
1754 }
1755
1756 /* (set-win-height {height} [window]) */
1757     static Scheme_Object *
1758 set_window_height(void *data, int argc, Scheme_Object **argv)
1759 {
1760     Vim_Prim        *prim = (Vim_Prim *)data;
1761     vim_mz_window   *win;
1762     win_T           *savewin;
1763     int             height;
1764
1765     win = get_window_arg(prim->name, 1, argc, argv);
1766     height = SCHEME_INT_VAL(GUARANTEE_INTEGER(prim->name, 0));
1767
1768 #ifdef FEAT_GUI
1769     need_mouse_correct = TRUE;
1770 #endif
1771
1772     savewin = curwin;
1773     curwin = win->win;
1774     win_setheight(height);
1775     curwin = savewin;
1776
1777     raise_if_error();
1778     return scheme_void;
1779 }
1780
1781 #ifdef FEAT_VERTSPLIT
1782 /* (get-win-width [window]) */
1783     static Scheme_Object *
1784 get_window_width(void *data, int argc, Scheme_Object **argv)
1785 {
1786     Vim_Prim        *prim = (Vim_Prim *)data;
1787     vim_mz_window   *win = get_window_arg(prim->name, 0, argc, argv);
1788
1789     return scheme_make_integer(W_WIDTH(win->win));
1790 }
1791
1792 /* (set-win-width {width} [window]) */
1793     static Scheme_Object *
1794 set_window_width(void *data, int argc, Scheme_Object **argv)
1795 {
1796     Vim_Prim        *prim = (Vim_Prim *)data;
1797     vim_mz_window   *win;
1798     win_T           *savewin;
1799     int             width = 0;
1800
1801     win = get_window_arg(prim->name, 1, argc, argv);
1802     width = SCHEME_INT_VAL(GUARANTEE_INTEGER(prim->name, 0));
1803
1804 # ifdef FEAT_GUI
1805     need_mouse_correct = TRUE;
1806 # endif
1807
1808     savewin = curwin;
1809     curwin = win->win;
1810     win_setwidth(width);
1811     curwin = savewin;
1812
1813     raise_if_error();
1814     return scheme_void;
1815 }
1816 #endif
1817
1818 /* (get-cursor [window]) -> (line . col) */
1819     static Scheme_Object *
1820 get_cursor(void *data, int argc, Scheme_Object **argv)
1821 {
1822     Vim_Prim        *prim = (Vim_Prim *)data;
1823     vim_mz_window   *win;
1824     pos_T           pos;
1825
1826     win = get_window_arg(prim->name, 0, argc, argv);
1827     pos = win->win->w_cursor;
1828     return scheme_make_pair(scheme_make_integer_value((long)pos.lnum),
1829                     scheme_make_integer_value((long)pos.col + 1));
1830 }
1831
1832 /* (set-cursor (line . col) [window]) */
1833     static Scheme_Object *
1834 set_cursor(void *data, int argc, Scheme_Object **argv)
1835 {
1836     Vim_Prim        *prim = (Vim_Prim *)data;
1837     vim_mz_window   *win;
1838     long            lnum = 0;
1839     long            col = 0;
1840
1841 #ifdef HAVE_SANDBOX
1842     sandbox_check();
1843 #endif
1844     win = get_window_arg(prim->name, 1, argc, argv);
1845     GUARANTEE_PAIR(prim->name, 0);
1846
1847     if (!SCHEME_INTP(SCHEME_CAR(argv[0]))
1848             || !SCHEME_INTP(SCHEME_CDR(argv[0])))
1849         scheme_wrong_type(prim->name, "integer pair", 0, argc, argv);
1850
1851     lnum = SCHEME_INT_VAL(SCHEME_CAR(argv[0]));
1852     col = SCHEME_INT_VAL(SCHEME_CDR(argv[0])) - 1;
1853
1854     check_line_range(lnum, win->win->w_buffer);
1855     /* don't know how to catch invalid column value */
1856
1857     win->win->w_cursor.lnum = lnum;
1858     win->win->w_cursor.col = col;
1859     update_screen(VALID);
1860
1861     raise_if_error();
1862     return scheme_void;
1863 }
1864 /*
1865  *===========================================================================
1866  *  6. Vim Buffer-related Manipulation Functions
1867  *===========================================================================
1868  */
1869
1870 /* (open-buff {filename}) */
1871     static Scheme_Object *
1872 mzscheme_open_buffer(void *data, int argc, Scheme_Object **argv)
1873 {
1874     Vim_Prim        *prim = (Vim_Prim *)data;
1875     char_u          *fname;
1876     int             num = 0;
1877     Scheme_Object   *onum;
1878
1879 #ifdef HAVE_SANDBOX
1880     sandbox_check();
1881 #endif
1882     fname = (char_u *)SCHEME_STR_VAL(GUARANTEE_STRING(prim->name, 0));
1883     /* TODO make open existing file */
1884     num = buflist_add(fname, BLN_LISTED | BLN_CURBUF);
1885
1886     if (num == 0)
1887         raise_vim_exn(_("couldn't open buffer"));
1888
1889     onum = scheme_make_integer(num);
1890     return get_buffer_by_num(data, 1, &onum);
1891 }
1892
1893 /* (get-buff-by-num {buffernum}) */
1894     static Scheme_Object *
1895 get_buffer_by_num(void *data, int argc, Scheme_Object **argv)
1896 {
1897     Vim_Prim    *prim = (Vim_Prim *)data;
1898     buf_T       *buf;
1899     int         fnum;
1900
1901     fnum = SCHEME_INT_VAL(GUARANTEE_INTEGER(prim->name, 0));
1902
1903     for (buf = firstbuf; buf; buf = buf->b_next)
1904         if (buf->b_fnum == fnum)
1905             return buffer_new(buf);
1906
1907     return scheme_false;
1908 }
1909
1910 /* (get-buff-by-name {buffername}) */
1911     static Scheme_Object *
1912 get_buffer_by_name(void *data, int argc, Scheme_Object **argv)
1913 {
1914     Vim_Prim    *prim = (Vim_Prim *)data;
1915     buf_T       *buf;
1916     char_u      *fname;
1917
1918     fname = (char_u *)SCHEME_STR_VAL(GUARANTEE_STRING(prim->name, 0));
1919
1920     for (buf = firstbuf; buf; buf = buf->b_next)
1921         if (buf->b_ffname == NULL || buf->b_sfname == NULL)
1922             /* empty string */
1923         {
1924             if (fname[0] == NUL)
1925                 return buffer_new(buf);
1926         }
1927         else if (!fnamecmp(buf->b_ffname, fname)
1928                 || !fnamecmp(buf->b_sfname, fname))
1929             /* either short or long filename matches */
1930             return buffer_new(buf);
1931
1932     return scheme_false;
1933 }
1934
1935 /* (get-next-buff [buffer]) */
1936     static Scheme_Object *
1937 get_next_buffer(void *data, int argc, Scheme_Object **argv)
1938 {
1939     Vim_Prim    *prim = (Vim_Prim *)data;
1940     buf_T       *buf = get_buffer_arg(prim->name, 0, argc, argv)->buf;
1941
1942     if (buf->b_next == NULL)
1943         return scheme_false;
1944     else
1945         return buffer_new(buf->b_next);
1946 }
1947
1948 /* (get-prev-buff [buffer]) */
1949     static Scheme_Object *
1950 get_prev_buffer(void *data, int argc, Scheme_Object **argv)
1951 {
1952     Vim_Prim    *prim = (Vim_Prim *)data;
1953     buf_T       *buf = get_buffer_arg(prim->name, 0, argc, argv)->buf;
1954
1955     if (buf->b_prev == NULL)
1956         return scheme_false;
1957     else
1958         return buffer_new(buf->b_prev);
1959 }
1960
1961 /* (get-buff-num [buffer]) */
1962     static Scheme_Object *
1963 get_buffer_num(void *data, int argc, Scheme_Object **argv)
1964 {
1965     Vim_Prim        *prim = (Vim_Prim *)data;
1966     vim_mz_buffer   *buf = get_buffer_arg(prim->name, 0, argc, argv);
1967
1968     return scheme_make_integer(buf->buf->b_fnum);
1969 }
1970
1971 /* (buff-count) */
1972     static Scheme_Object *
1973 get_buffer_count(void *data, int argc, Scheme_Object **argv)
1974 {
1975     buf_T   *b;
1976     int     n = 0;
1977
1978     for (b = firstbuf; b; b = b->b_next) ++n;
1979     return scheme_make_integer(n);
1980 }
1981
1982 /* (get-buff-name [buffer]) */
1983     static Scheme_Object *
1984 get_buffer_name(void *data, int argc, Scheme_Object **argv)
1985 {
1986     Vim_Prim        *prim = (Vim_Prim *)data;
1987     vim_mz_buffer   *buf = get_buffer_arg(prim->name, 0, argc, argv);
1988
1989     return scheme_make_string((char *)buf->buf->b_ffname);
1990 }
1991
1992 /* (curr-buff) */
1993     static Scheme_Object *
1994 get_curr_buffer(void *data, int argc, Scheme_Object **argv)
1995 {
1996     return (Scheme_Object *)get_vim_curr_buffer();
1997 }
1998
1999     static Scheme_Object *
2000 buffer_new(buf_T *buf)
2001 {
2002     vim_mz_buffer *self = NULL;
2003
2004     MZ_GC_DECL_REG(1);
2005     MZ_GC_VAR_IN_REG(0, self);
2006     MZ_GC_REG();
2007
2008     /* We need to handle deletion of buffers underneath us.
2009      * If we add a "b_mzscheme_ref" field to the buf_T structure,
2010      * then we can get at it in buf_freeall() in vim.
2011      */
2012     if (buf->b_mzscheme_ref)
2013         return buf->b_mzscheme_ref;
2014
2015     self = scheme_malloc_fail_ok(scheme_malloc, sizeof(vim_mz_buffer));
2016     vim_memset(self, 0, sizeof(vim_mz_buffer));
2017     scheme_dont_gc_ptr(self); /* because buf isn't visible to GC */
2018     MZ_GC_CHECK();
2019     buf->b_mzscheme_ref = self;
2020     self->buf = buf;
2021     self->so.type = mz_buffer_type;
2022
2023     MZ_GC_UNREG();
2024     return (Scheme_Object *)(self);
2025 }
2026
2027 /*
2028  * (get-buff-size [buffer])
2029  *
2030  * Get the size (number of lines) in the current buffer.
2031  */
2032     static Scheme_Object *
2033 get_buffer_size(void *data, int argc, Scheme_Object **argv)
2034 {
2035     Vim_Prim        *prim = (Vim_Prim *)data;
2036     vim_mz_buffer   *buf = get_buffer_arg(prim->name, 0, argc, argv);
2037
2038     return scheme_make_integer(buf->buf->b_ml.ml_line_count);
2039 }
2040
2041 /*
2042  * (get-buff-line {linenr} [buffer])
2043  *
2044  * Get a line from the specified buffer. The line number is
2045  * in Vim format (1-based). The line is returned as a MzScheme
2046  * string object.
2047  */
2048     static Scheme_Object *
2049 get_buffer_line(void *data, int argc, Scheme_Object **argv)
2050 {
2051     Vim_Prim        *prim = (Vim_Prim *)data;
2052     vim_mz_buffer   *buf;
2053     int             linenr;
2054     char_u          *line;
2055
2056     buf = get_buffer_arg(prim->name, 1, argc, argv);
2057     linenr = SCHEME_INT_VAL(GUARANTEE_INTEGER(prim->name, 0));
2058     line = ml_get_buf(buf->buf, (linenr_T)linenr, FALSE);
2059
2060     raise_if_error();
2061     return scheme_make_string((char *)line);
2062 }
2063
2064
2065 /*
2066  * (get-buff-line-list {start} {end} [buffer])
2067  *
2068  * Get a list of lines from the specified buffer. The line numbers
2069  * are in Vim format (1-based). The range is from lo up to, but not
2070  * including, hi. The list is returned as a list of string objects.
2071  */
2072     static Scheme_Object *
2073 get_buffer_line_list(void *data, int argc, Scheme_Object **argv)
2074 {
2075     Vim_Prim        *prim = (Vim_Prim *)data;
2076     vim_mz_buffer   *buf;
2077     int             i, hi, lo, n;
2078     Scheme_Object   *list = NULL;
2079
2080     MZ_GC_DECL_REG(1);
2081     MZ_GC_VAR_IN_REG(0, list);
2082     MZ_GC_REG();
2083
2084     buf = get_buffer_arg(prim->name, 2, argc, argv);
2085     list = scheme_null;
2086     hi = SCHEME_INT_VAL(GUARANTEE_INTEGER(prim->name, 1));
2087     lo = SCHEME_INT_VAL(GUARANTEE_INTEGER(prim->name, 0));
2088
2089     /*
2090      * Handle some error conditions
2091      */
2092     if (lo < 0)
2093         lo = 0;
2094
2095     if (hi < 0)
2096         hi = 0;
2097     if (hi < lo)
2098         hi = lo;
2099
2100     n = hi - lo;
2101
2102     for (i = n; i >= 0; --i)
2103     {
2104         Scheme_Object *str = scheme_make_string(
2105                        (char *)ml_get_buf(buf->buf, (linenr_T)(lo+i), FALSE));
2106         raise_if_error();
2107
2108         /* Set the list item */
2109         list = scheme_make_pair(str, list);
2110         MZ_GC_CHECK();
2111     }
2112     MZ_GC_UNREG();
2113     return list;
2114 }
2115
2116 /*
2117  * (set-buff-line {linenr} {string/#f} [buffer])
2118  *
2119  * Replace a line in the specified buffer. The line number is
2120  * in Vim format (1-based). The replacement line is given as
2121  * an MzScheme string object. The object is checked for validity
2122  * and correct format. An exception is thrown if the values are not
2123  * the correct format.
2124  *
2125  * It returns a Scheme Object that indicates the length of the
2126  * string changed.
2127  */
2128     static Scheme_Object *
2129 set_buffer_line(void *data, int argc, Scheme_Object **argv)
2130 {
2131     /* First of all, we check the the of the supplied MzScheme object.
2132      * There are three cases:
2133      *    1. #f - this is a deletion.
2134      *    2. A string      - this is a replacement.
2135      *    3. Anything else - this is an error.
2136      */
2137     Vim_Prim        *prim = (Vim_Prim *)data;
2138     vim_mz_buffer   *buf;
2139     Scheme_Object   *line = NULL;
2140     char            *save;
2141     int             n;
2142
2143     MZ_GC_DECL_REG(1);
2144     MZ_GC_VAR_IN_REG(0, line);
2145     MZ_GC_REG();
2146
2147 #ifdef HAVE_SANDBOX
2148     sandbox_check();
2149 #endif
2150     n = SCHEME_INT_VAL(GUARANTEE_INTEGER(prim->name, 0));
2151     if (!SCHEME_STRINGP(argv[1]) && !SCHEME_FALSEP(argv[1]))
2152         scheme_wrong_type(prim->name, "string or #f", 1, argc, argv);
2153     line = argv[1];
2154     buf = get_buffer_arg(prim->name, 2, argc, argv);
2155
2156     check_line_range(n, buf->buf);
2157
2158     if (SCHEME_FALSEP(line))
2159     {
2160         buf_T       *savebuf = curbuf;
2161
2162         curbuf = buf->buf;
2163
2164         if (u_savedel((linenr_T)n, 1L) == FAIL)
2165         {
2166             curbuf = savebuf;
2167             raise_vim_exn(_("cannot save undo information"));
2168         }
2169         else if (ml_delete((linenr_T)n, FALSE) == FAIL)
2170         {
2171             curbuf = savebuf;
2172             raise_vim_exn(_("cannot delete line"));
2173         }
2174         if (buf->buf == curwin->w_buffer)
2175             mz_fix_cursor(n, n + 1, -1);
2176         deleted_lines_mark((linenr_T)n, 1L);
2177
2178         curbuf = savebuf;
2179
2180         MZ_GC_UNREG();
2181         raise_if_error();
2182         return scheme_void;
2183     }
2184     else
2185     {
2186         /* Otherwise it's a line */
2187         buf_T       *savebuf = curbuf;
2188
2189         save = string_to_line(line);
2190
2191         curbuf = buf->buf;
2192
2193         if (u_savesub((linenr_T)n) == FAIL)
2194         {
2195             curbuf = savebuf;
2196             vim_free(save);
2197             raise_vim_exn(_("cannot save undo information"));
2198         }
2199         else if (ml_replace((linenr_T)n, (char_u *)save, TRUE) == FAIL)
2200         {
2201             curbuf = savebuf;
2202             vim_free(save);
2203             raise_vim_exn(_("cannot replace line"));
2204         }
2205         else
2206         {
2207             vim_free(save);
2208             changed_bytes((linenr_T)n, 0);
2209         }
2210
2211         curbuf = savebuf;
2212
2213         /* Check that the cursor is not beyond the end of the line now. */
2214         if (buf->buf == curwin->w_buffer)
2215             check_cursor_col();
2216
2217         MZ_GC_UNREG();
2218         raise_if_error();
2219         return scheme_void;
2220     }
2221 }
2222
2223     static void
2224 free_array(char **array)
2225 {
2226     char **curr = array;
2227     while (*curr != NULL)
2228         vim_free(*curr++);
2229     vim_free(array);
2230 }
2231
2232 /*
2233  * (set-buff-line-list {start} {end} {string-list/#f/null} [buffer])
2234  *
2235  * Replace a range of lines in the specified buffer. The line numbers are in
2236  * Vim format (1-based). The range is from lo up to, but not including, hi.
2237  * The replacement lines are given as a Scheme list of string objects. The
2238  * list is checked for validity and correct format.
2239  *
2240  * Errors are returned as a value of FAIL. The return value is OK on success.
2241  * If OK is returned and len_change is not NULL, *len_change is set to the
2242  * change in the buffer length.
2243  */
2244     static Scheme_Object *
2245 set_buffer_line_list(void *data, int argc, Scheme_Object **argv)
2246 {
2247     /* First of all, we check the type of the supplied MzScheme object.
2248      * There are three cases:
2249      *    1. #f - this is a deletion.
2250      *    2. A list        - this is a replacement.
2251      *    3. Anything else - this is an error.
2252      */
2253     Vim_Prim        *prim = (Vim_Prim *)data;
2254     vim_mz_buffer   *buf = NULL;
2255     Scheme_Object   *line_list = NULL;
2256     int             i, old_len, new_len, hi, lo;
2257     long            extra;
2258
2259     MZ_GC_DECL_REG(1);
2260     MZ_GC_VAR_IN_REG(0, line_list);
2261     MZ_GC_REG();
2262
2263 #ifdef HAVE_SANDBOX
2264     sandbox_check();
2265 #endif
2266     lo = SCHEME_INT_VAL(GUARANTEE_INTEGER(prim->name, 0));
2267     hi = SCHEME_INT_VAL(GUARANTEE_INTEGER(prim->name, 1));
2268     if (!SCHEME_PAIRP(argv[2])
2269             && !SCHEME_FALSEP(argv[2]) && !SCHEME_NULLP(argv[2]))
2270         scheme_wrong_type(prim->name, "list or #f", 2, argc, argv);
2271     line_list = argv[2];
2272     buf = get_buffer_arg(prim->name, 3, argc, argv);
2273     old_len = hi - lo;
2274     if (old_len < 0) /* process inverse values wisely */
2275     {
2276         i = lo;
2277         lo = hi;
2278         hi = i;
2279         old_len = -old_len;
2280     }
2281     extra = 0;
2282
2283     check_line_range(lo, buf->buf);         /* inclusive */
2284     check_line_range(hi - 1, buf->buf);     /* exclusive */
2285
2286     if (SCHEME_FALSEP(line_list) || SCHEME_NULLP(line_list))
2287     {
2288         buf_T   *savebuf = curbuf;
2289         curbuf = buf->buf;
2290
2291         if (u_savedel((linenr_T)lo, (long)old_len) == FAIL)
2292         {
2293             curbuf = savebuf;
2294             raise_vim_exn(_("cannot save undo information"));
2295         }
2296         else
2297         {
2298             for (i = 0; i < old_len; i++)
2299                 if (ml_delete((linenr_T)lo, FALSE) == FAIL)
2300                 {
2301                     curbuf = savebuf;
2302                     raise_vim_exn(_("cannot delete line"));
2303                 }
2304             if (buf->buf == curwin->w_buffer)
2305                 mz_fix_cursor(lo, hi, -old_len);
2306             deleted_lines_mark((linenr_T)lo, (long)old_len);
2307         }
2308
2309         curbuf = savebuf;
2310
2311         MZ_GC_UNREG();
2312         raise_if_error();
2313         return scheme_void;
2314     }
2315     else
2316     {
2317         buf_T   *savebuf = curbuf;
2318
2319         /* List */
2320         new_len = scheme_proper_list_length(line_list);
2321         MZ_GC_CHECK();
2322         if (new_len < 0)        /* improper or cyclic list */
2323             scheme_wrong_type(prim->name, "proper list",
2324                     2, argc, argv);
2325         else
2326         {
2327             char                **array = NULL;
2328             Scheme_Object   *line = NULL;
2329             Scheme_Object   *rest = NULL;
2330
2331             MZ_GC_DECL_REG(2);
2332             MZ_GC_VAR_IN_REG(0, line);
2333             MZ_GC_VAR_IN_REG(1, rest);
2334             MZ_GC_REG();
2335
2336             array = (char **)alloc(new_len * sizeof(char *));
2337             vim_memset(array, 0, new_len * sizeof(char *));
2338
2339             rest = line_list;
2340             for (i = 0; i < new_len; ++i)
2341             {
2342                 line = SCHEME_CAR(rest);
2343                 rest = SCHEME_CDR(rest);
2344                 if (!SCHEME_STRINGP(line))
2345                 {
2346                     free_array(array);
2347                     scheme_wrong_type(prim->name, "string-list", 2, argc, argv);
2348                 }
2349                 array[i] = string_to_line(line);
2350             }
2351
2352             curbuf = buf->buf;
2353
2354             if (u_save((linenr_T)(lo-1), (linenr_T)hi) == FAIL)
2355             {
2356                 curbuf = savebuf;
2357                 free_array(array);
2358                 raise_vim_exn(_("cannot save undo information"));
2359             }
2360
2361             /*
2362              * If the size of the range is reducing (ie, new_len < old_len) we
2363              * need to delete some old_len. We do this at the start, by
2364              * repeatedly deleting line "lo".
2365              */
2366             for (i = 0; i < old_len - new_len; ++i)
2367             {
2368                 if (ml_delete((linenr_T)lo, FALSE) == FAIL)
2369                 {
2370                     curbuf = savebuf;
2371                     free_array(array);
2372                     raise_vim_exn(_("cannot delete line"));
2373                 }
2374                 extra--;
2375             }
2376
2377             /*
2378              * For as long as possible, replace the existing old_len with the
2379              * new old_len. This is a more efficient operation, as it requires
2380              * less memory allocation and freeing.
2381              */
2382             for (i = 0; i < old_len && i < new_len; i++)
2383                 if (ml_replace((linenr_T)(lo+i), (char_u *)array[i], TRUE) == FAIL)
2384                 {
2385                     curbuf = savebuf;
2386                     free_array(array);
2387                     raise_vim_exn(_("cannot replace line"));
2388                 }
2389
2390             /*
2391              * Now we may need to insert the remaining new_len.  We don't need to
2392              * free the string passed back because MzScheme has control of that
2393              * memory.
2394              */
2395             while (i < new_len)
2396             {
2397                 if (ml_append((linenr_T)(lo + i - 1),
2398                             (char_u *)array[i], 0, FALSE) == FAIL)
2399                 {
2400                     curbuf = savebuf;
2401                     free_array(array);
2402                     raise_vim_exn(_("cannot insert line"));
2403                 }
2404                 ++i;
2405                 ++extra;
2406             }
2407             MZ_GC_UNREG();
2408             free_array(array);
2409         }
2410
2411         /*
2412          * Adjust marks. Invalidate any which lie in the
2413          * changed range, and move any in the remainder of the buffer.
2414          */
2415         mark_adjust((linenr_T)lo, (linenr_T)(hi - 1), (long)MAXLNUM, (long)extra);
2416         changed_lines((linenr_T)lo, 0, (linenr_T)hi, (long)extra);
2417
2418         if (buf->buf == curwin->w_buffer)
2419             mz_fix_cursor(lo, hi, extra);
2420         curbuf = savebuf;
2421
2422         MZ_GC_UNREG();
2423         raise_if_error();
2424         return scheme_void;
2425     }
2426 }
2427
2428 /*
2429  * (insert-buff-line-list {linenr} {string/string-list} [buffer])
2430  *
2431  * Insert a number of lines into the specified buffer after the specifed line.
2432  * The line number is in Vim format (1-based). The lines to be inserted are
2433  * given as an MzScheme list of string objects or as a single string. The lines
2434  * to be added are checked for validity and correct format. Errors are
2435  * returned as a value of FAIL.  The return value is OK on success.
2436  * If OK is returned and len_change is not NULL, *len_change
2437  * is set to the change in the buffer length.
2438  */
2439     static Scheme_Object *
2440 insert_buffer_line_list(void *data, int argc, Scheme_Object **argv)
2441 {
2442     Vim_Prim        *prim = (Vim_Prim *)data;
2443     vim_mz_buffer   *buf = NULL;
2444     Scheme_Object   *list = NULL;
2445     char            *str = NULL;
2446     int             i, n, size;
2447
2448     MZ_GC_DECL_REG(1);
2449     MZ_GC_VAR_IN_REG(0, list);
2450     MZ_GC_REG();
2451
2452 #ifdef HAVE_SANDBOX
2453     sandbox_check();
2454 #endif
2455     /*
2456      * First of all, we check the type of the supplied MzScheme object.
2457      * It must be a string or a list, or the call is in error.
2458      */
2459     n = SCHEME_INT_VAL(GUARANTEE_INTEGER(prim->name, 0));
2460     list = argv[1];
2461
2462     if (!SCHEME_STRINGP(list) && !SCHEME_PAIRP(list))
2463         scheme_wrong_type(prim->name, "string or list", 1, argc, argv);
2464     buf = get_buffer_arg(prim->name, 2, argc, argv);
2465
2466     if (n != 0)     /* 0 can be used in insert */
2467         check_line_range(n, buf->buf);
2468     if (SCHEME_STRINGP(list))
2469     {
2470         buf_T       *savebuf = curbuf;
2471
2472         str = string_to_line(list);
2473         curbuf = buf->buf;
2474
2475         if (u_save((linenr_T)n, (linenr_T)(n+1)) == FAIL)
2476         {
2477             curbuf = savebuf;
2478             vim_free(str);
2479             raise_vim_exn(_("cannot save undo information"));
2480         }
2481         else if (ml_append((linenr_T)n, (char_u *)str, 0, FALSE) == FAIL)
2482         {
2483             curbuf = savebuf;
2484             vim_free(str);
2485             raise_vim_exn(_("cannot insert line"));
2486         }
2487         else
2488         {
2489             vim_free(str);
2490             appended_lines_mark((linenr_T)n, 1L);
2491         }
2492
2493         curbuf = savebuf;
2494         update_screen(VALID);
2495
2496         MZ_GC_UNREG();
2497         raise_if_error();
2498         return scheme_void;
2499     }
2500
2501     /* List */
2502     size = scheme_proper_list_length(list);
2503     MZ_GC_CHECK();
2504     if (size < 0)       /* improper or cyclic list */
2505         scheme_wrong_type(prim->name, "proper list",
2506                 2, argc, argv);
2507     else
2508     {
2509         Scheme_Object   *line = NULL;
2510         Scheme_Object   *rest = NULL;
2511         char            **array;
2512         buf_T           *savebuf = curbuf;
2513
2514         MZ_GC_DECL_REG(2);
2515         MZ_GC_VAR_IN_REG(0, line);
2516         MZ_GC_VAR_IN_REG(1, rest);
2517         MZ_GC_REG();
2518
2519         array = (char **)alloc(size * sizeof(char *));
2520         vim_memset(array, 0, size * sizeof(char *));
2521
2522         rest = list;
2523         for (i = 0; i < size; ++i)
2524         {
2525             line = SCHEME_CAR(rest);
2526             rest = SCHEME_CDR(rest);
2527             array[i] = string_to_line(line);
2528         }
2529
2530         curbuf = buf->buf;
2531
2532         if (u_save((linenr_T)n, (linenr_T)(n + 1)) == FAIL)
2533         {
2534             curbuf = savebuf;
2535             free_array(array);
2536             raise_vim_exn(_("cannot save undo information"));
2537         }
2538         else
2539         {
2540             for (i = 0; i < size; ++i)
2541                 if (ml_append((linenr_T)(n + i), (char_u *)array[i],
2542                             0, FALSE) == FAIL)
2543                 {
2544                     curbuf = savebuf;
2545                     free_array(array);
2546                     raise_vim_exn(_("cannot insert line"));
2547                 }
2548
2549             if (i > 0)
2550                 appended_lines_mark((linenr_T)n, (long)i);
2551         }
2552         free_array(array);
2553         MZ_GC_UNREG();
2554         curbuf = savebuf;
2555         update_screen(VALID);
2556     }
2557
2558     MZ_GC_UNREG();
2559     raise_if_error();
2560     return scheme_void;
2561 }
2562
2563 /*
2564  * Predicates
2565  */
2566 /* (buff? obj) */
2567     static Scheme_Object *
2568 vim_bufferp(void *data, int argc, Scheme_Object **argv)
2569 {
2570     if (SCHEME_VIMBUFFERP(argv[0]))
2571         return scheme_true;
2572     else
2573         return scheme_false;
2574 }
2575
2576 /* (win? obj) */
2577     static Scheme_Object *
2578 vim_windowp(void *data, int argc, Scheme_Object **argv)
2579 {
2580     if (SCHEME_VIMWINDOWP(argv[0]))
2581         return scheme_true;
2582     else
2583         return scheme_false;
2584 }
2585
2586 /* (buff-valid? obj) */
2587     static Scheme_Object *
2588 vim_buffer_validp(void *data, int argc, Scheme_Object **argv)
2589 {
2590     if (SCHEME_VIMBUFFERP(argv[0])
2591             && ((vim_mz_buffer *)argv[0])->buf != INVALID_BUFFER_VALUE)
2592         return scheme_true;
2593     else
2594         return scheme_false;
2595 }
2596
2597 /* (win-valid? obj) */
2598     static Scheme_Object *
2599 vim_window_validp(void *data, int argc, Scheme_Object **argv)
2600 {
2601     if (SCHEME_VIMWINDOWP(argv[0])
2602             && ((vim_mz_window *)argv[0])->win != INVALID_WINDOW_VALUE)
2603         return scheme_true;
2604     else
2605         return scheme_false;
2606 }
2607
2608 /*
2609  *===========================================================================
2610  * Utilities
2611  *===========================================================================
2612  */
2613
2614 /*
2615  * Convert an MzScheme string into a Vim line.
2616  *
2617  * All internal nulls are replaced by newline characters.
2618  * It is an error for the string to contain newline characters.
2619  *
2620  * Returns pointer to Vim allocated memory
2621  */
2622     static char *
2623 string_to_line(Scheme_Object *obj)
2624 {
2625     char        *scheme_str = NULL;
2626     char        *vim_str = NULL;
2627     long        len;
2628     int         i;
2629
2630     scheme_str = scheme_display_to_string(obj, &len);
2631
2632     /* Error checking: String must not contain newlines, as we
2633      * are replacing a single line, and we must replace it with
2634      * a single line.
2635      */
2636     if (memchr(scheme_str, '\n', len))
2637         scheme_signal_error(_("string cannot contain newlines"));
2638
2639     vim_str = (char *)alloc(len + 1);
2640
2641     /* Create a copy of the string, with internal nulls replaced by
2642      * newline characters, as is the vim convention.
2643      */
2644     for (i = 0; i < len; ++i)
2645     {
2646         if (scheme_str[i] == '\0')
2647             vim_str[i] = '\n';
2648         else
2649             vim_str[i] = scheme_str[i];
2650     }
2651
2652     vim_str[i] = '\0';
2653
2654     MZ_GC_CHECK();
2655     return vim_str;
2656 }
2657
2658 #ifdef FEAT_EVAL
2659 /*
2660  * Convert Vim value into MzScheme, adopted from if_python.c
2661  */
2662     static Scheme_Object *
2663 vim_to_mzscheme(typval_T *vim_value, int depth, Scheme_Hash_Table *visited)
2664 {
2665     Scheme_Object   *result = NULL;
2666     int             new_value = TRUE;
2667
2668     MZ_GC_DECL_REG(1);
2669     MZ_GC_VAR_IN_REG(0, result);
2670     MZ_GC_REG();
2671
2672     /* Avoid infinite recursion */
2673     if (depth > 100)
2674     {
2675         MZ_GC_UNREG();
2676         return scheme_void;
2677     }
2678
2679     /* Check if we run into a recursive loop.  The item must be in visited
2680      * then and we can use it again.
2681      */
2682     result = scheme_hash_get(visited, (Scheme_Object *)vim_value);
2683     MZ_GC_CHECK();
2684     if (result != NULL) /* found, do nothing */
2685         new_value = FALSE;
2686     else if (vim_value->v_type == VAR_STRING)
2687     {
2688         result = scheme_make_string((char *)vim_value->vval.v_string);
2689         MZ_GC_CHECK();
2690     }
2691     else if (vim_value->v_type == VAR_NUMBER)
2692     {
2693         result = scheme_make_integer((long)vim_value->vval.v_number);
2694         MZ_GC_CHECK();
2695     }
2696 # ifdef FEAT_FLOAT
2697     else if (vim_value->v_type == VAR_FLOAT)
2698     {
2699         result = scheme_make_double((double)vim_value->vval.v_float);
2700         MZ_GC_CHECK();
2701     }
2702 # endif
2703     else if (vim_value->v_type == VAR_LIST)
2704     {
2705         list_T          *list = vim_value->vval.v_list;
2706         listitem_T      *curr;
2707
2708         if (list == NULL || list->lv_first == NULL)
2709             result = scheme_null;
2710         else
2711         {
2712             Scheme_Object   *obj = NULL;
2713
2714             MZ_GC_DECL_REG(1);
2715             MZ_GC_VAR_IN_REG(0, obj);
2716             MZ_GC_REG();
2717
2718             curr = list->lv_last;
2719             obj = vim_to_mzscheme(&curr->li_tv, depth + 1, visited);
2720             result = scheme_make_pair(obj, scheme_null);
2721             MZ_GC_CHECK();
2722
2723             while (curr != list->lv_first)
2724             {
2725                 curr = curr->li_prev;
2726                 obj = vim_to_mzscheme(&curr->li_tv, depth + 1, visited);
2727                 result = scheme_make_pair(obj, result);
2728                 MZ_GC_CHECK();
2729             }
2730         }
2731         MZ_GC_UNREG();
2732     }
2733     else if (vim_value->v_type == VAR_DICT)
2734     {
2735         Scheme_Object     *key = NULL;
2736         Scheme_Object     *obj = NULL;
2737
2738         MZ_GC_DECL_REG(2);
2739         MZ_GC_VAR_IN_REG(0, key);
2740         MZ_GC_VAR_IN_REG(1, obj);
2741         MZ_GC_REG();
2742
2743         result = (Scheme_Object *)scheme_make_hash_table(SCHEME_hash_ptr);
2744         MZ_GC_CHECK();
2745         if (vim_value->vval.v_dict != NULL)
2746         {
2747             hashtab_T   *ht = &vim_value->vval.v_dict->dv_hashtab;
2748             long_u      todo = ht->ht_used;
2749             hashitem_T  *hi;
2750             dictitem_T  *di;
2751
2752             for (hi = ht->ht_array; todo > 0; ++hi)
2753             {
2754                 if (!HASHITEM_EMPTY(hi))
2755                 {
2756                     --todo;
2757
2758                     di = dict_lookup(hi);
2759                     obj = vim_to_mzscheme(&di->di_tv, depth + 1, visited);
2760                     key = scheme_make_string((char *)hi->hi_key);
2761                     MZ_GC_CHECK();
2762                     scheme_hash_set((Scheme_Hash_Table *)result, key, obj);
2763                     MZ_GC_CHECK();
2764                 }
2765             }
2766         }
2767         MZ_GC_UNREG();
2768     }
2769     else
2770     {
2771         result = scheme_void;
2772         new_value = FALSE;
2773     }
2774     if (new_value)
2775     {
2776         scheme_hash_set(visited, (Scheme_Object *)vim_value, result);
2777         MZ_GC_CHECK();
2778     }
2779     MZ_GC_UNREG();
2780     return result;
2781 }
2782 #endif
2783
2784 /*
2785  * Check to see whether a Vim error has been reported, or a keyboard
2786  * interrupt (from vim --> got_int) has been detected.
2787  */
2788     static int
2789 vim_error_check(void)
2790 {
2791     return (got_int || did_emsg);
2792 }
2793
2794 /*
2795  * register Scheme exn:vim
2796  */
2797     static void
2798 register_vim_exn(void)
2799 {
2800     int nc = 0;
2801     int i;
2802     Scheme_Object   *struct_exn = NULL;
2803     Scheme_Object   *exn_name = NULL;
2804
2805     MZ_GC_DECL_REG(2);
2806     MZ_GC_VAR_IN_REG(0, struct_exn);
2807     MZ_GC_VAR_IN_REG(1, exn_name);
2808     MZ_GC_REG();
2809
2810     exn_name = scheme_intern_symbol("exn:vim");
2811     MZ_GC_CHECK();
2812     struct_exn = scheme_builtin_value("struct:exn");
2813     MZ_GC_CHECK();
2814
2815     if (vim_exn == NULL)
2816         vim_exn = scheme_make_struct_type(exn_name,
2817                 struct_exn, NULL, 0, 0, NULL, NULL
2818 #if MZSCHEME_VERSION_MAJOR >= 299
2819                 , NULL
2820 #endif
2821                 );
2822
2823
2824     {
2825         Scheme_Object   **tmp = NULL;
2826         Scheme_Object   *exn_names[5] = {NULL, NULL, NULL, NULL, NULL};
2827         Scheme_Object   *exn_values[5] = {NULL, NULL, NULL, NULL, NULL};
2828         MZ_GC_DECL_REG(6);
2829         MZ_GC_ARRAY_VAR_IN_REG(0, exn_names, 5);
2830         MZ_GC_ARRAY_VAR_IN_REG(3, exn_values, 5);
2831         MZ_GC_REG();
2832
2833         tmp = scheme_make_struct_names(exn_name, scheme_null, 0, &nc);
2834         assert(nc <= 5);
2835         mch_memmove(exn_names, tmp, nc * sizeof(Scheme_Object *));
2836         MZ_GC_CHECK();
2837
2838         tmp = scheme_make_struct_values(vim_exn, exn_names, nc, 0);
2839         mch_memmove(exn_values, tmp, nc * sizeof(Scheme_Object *));
2840         MZ_GC_CHECK();
2841
2842         for (i = 0; i < nc; i++)
2843         {
2844             scheme_add_global_symbol(exn_names[i],
2845                     exn_values[i], environment);
2846             MZ_GC_CHECK();
2847         }
2848         MZ_GC_UNREG();
2849     }
2850     MZ_GC_UNREG();
2851 }
2852
2853 /*
2854  * raise exn:vim, may be with additional info string
2855  */
2856     void
2857 raise_vim_exn(const char *add_info)
2858 {
2859     char            *fmt = _("Vim error: ~a");
2860     Scheme_Object   *argv[2] = {NULL, NULL};
2861     Scheme_Object   *exn = NULL;
2862
2863     MZ_GC_DECL_REG(4);
2864     MZ_GC_ARRAY_VAR_IN_REG(0, argv, 2);
2865     MZ_GC_VAR_IN_REG(3, exn);
2866     MZ_GC_REG();
2867
2868     if (add_info != NULL)
2869     {
2870         char            *c_string = NULL;
2871         Scheme_Object   *byte_string = NULL;
2872         Scheme_Object   *info = NULL;
2873
2874         MZ_GC_DECL_REG(3);
2875         MZ_GC_VAR_IN_REG(0, c_string);
2876         MZ_GC_VAR_IN_REG(1, byte_string);
2877         MZ_GC_VAR_IN_REG(2, info);
2878         MZ_GC_REG();
2879
2880         info = scheme_make_string(add_info);
2881         MZ_GC_CHECK();
2882         c_string = scheme_format(fmt, STRLEN(fmt), 1, &info, NULL);
2883         MZ_GC_CHECK();
2884         byte_string = scheme_make_string(c_string);
2885         MZ_GC_CHECK();
2886         argv[0] = scheme_byte_string_to_char_string(byte_string);
2887         MZ_GC_CHECK();
2888         SCHEME_SET_IMMUTABLE(argv[0]);
2889         MZ_GC_UNREG();
2890     }
2891     else
2892         argv[0] = scheme_make_string(_("Vim error"));
2893     MZ_GC_CHECK();
2894
2895 #if MZSCHEME_VERSION_MAJOR < 360
2896     argv[1] = scheme_current_continuation_marks();
2897     MZ_GC_CHECK();
2898 #else
2899     argv[1] = scheme_current_continuation_marks(NULL);
2900     MZ_GC_CHECK();
2901 #endif
2902
2903     exn = scheme_make_struct_instance(vim_exn, 2, argv);
2904     MZ_GC_CHECK();
2905     scheme_raise(exn);
2906     MZ_GC_UNREG();
2907 }
2908
2909     void
2910 raise_if_error(void)
2911 {
2912     if (vim_error_check())
2913         raise_vim_exn(NULL);
2914 }
2915
2916 /* get buffer:
2917  * either current
2918  * or passed as argv[argnum] with checks
2919  */
2920     static vim_mz_buffer *
2921 get_buffer_arg(const char *fname, int argnum, int argc, Scheme_Object **argv)
2922 {
2923     vim_mz_buffer *b;
2924
2925     if (argc < argnum + 1)
2926         return get_vim_curr_buffer();
2927     if (!SCHEME_VIMBUFFERP(argv[argnum]))
2928         scheme_wrong_type(fname, "vim-buffer", argnum, argc, argv);
2929     b = (vim_mz_buffer *)argv[argnum];
2930     (void)get_valid_buffer(argv[argnum]);
2931     return b;
2932 }
2933
2934 /* get window:
2935  * either current
2936  * or passed as argv[argnum] with checks
2937  */
2938     static vim_mz_window *
2939 get_window_arg(const char *fname, int argnum, int argc, Scheme_Object **argv)
2940 {
2941     vim_mz_window *w;
2942
2943     if (argc < argnum + 1)
2944         return get_vim_curr_window();
2945     w = (vim_mz_window *)argv[argnum];
2946     if (!SCHEME_VIMWINDOWP(argv[argnum]))
2947         scheme_wrong_type(fname, "vim-window", argnum, argc, argv);
2948     (void)get_valid_window(argv[argnum]);
2949     return w;
2950 }
2951
2952 /* get valid Vim buffer from Scheme_Object* */
2953 buf_T *get_valid_buffer(void *obj)
2954 {
2955     buf_T *buf = ((vim_mz_buffer *)obj)->buf;
2956
2957     if (buf == INVALID_BUFFER_VALUE)
2958         scheme_signal_error(_("buffer is invalid"));
2959     return buf;
2960 }
2961
2962 /* get valid Vim window from Scheme_Object* */
2963 win_T *get_valid_window(void *obj)
2964 {
2965     win_T *win = ((vim_mz_window *)obj)->win;
2966     if (win == INVALID_WINDOW_VALUE)
2967         scheme_signal_error(_("window is invalid"));
2968     return win;
2969 }
2970
2971     int
2972 mzthreads_allowed(void)
2973 {
2974     return mz_threads_allow;
2975 }
2976
2977     static int
2978 line_in_range(linenr_T lnum, buf_T *buf)
2979 {
2980     return (lnum > 0 && lnum <= buf->b_ml.ml_line_count);
2981 }
2982
2983     static void
2984 check_line_range(linenr_T lnum, buf_T *buf)
2985 {
2986     if (!line_in_range(lnum, buf))
2987         scheme_signal_error(_("linenr out of range"));
2988 }
2989
2990 /*
2991  * Check if deleting lines made the cursor position invalid
2992  * (or you'll get msg from Vim about invalid linenr).
2993  * Changed the lines from "lo" to "hi" and added "extra" lines (negative if
2994  * deleted). Got from if_python.c
2995  */
2996     static void
2997 mz_fix_cursor(int lo, int hi, int extra)
2998 {
2999     if (curwin->w_cursor.lnum >= lo)
3000     {
3001         /* Adjust the cursor position if it's in/after the changed
3002          * lines. */
3003         if (curwin->w_cursor.lnum >= hi)
3004         {
3005             curwin->w_cursor.lnum += extra;
3006             check_cursor_col();
3007         }
3008         else if (extra < 0)
3009         {
3010             curwin->w_cursor.lnum = lo;
3011             check_cursor();
3012         }
3013         else
3014             check_cursor_col();
3015         changed_cline_bef_curs();
3016     }
3017     invalidate_botline();
3018 }
3019
3020 static Vim_Prim prims[]=
3021 {
3022     /*
3023      * Buffer-related commands
3024      */
3025     {get_buffer_line, "get-buff-line", 1, 2},
3026     {set_buffer_line, "set-buff-line", 2, 3},
3027     {get_buffer_line_list, "get-buff-line-list", 2, 3},
3028     {get_buffer_name, "get-buff-name", 0, 1},
3029     {get_buffer_num, "get-buff-num", 0, 1},
3030     {get_buffer_size, "get-buff-size", 0, 1},
3031     {set_buffer_line_list, "set-buff-line-list", 3, 4},
3032     {insert_buffer_line_list, "insert-buff-line-list", 2, 3},
3033     {get_curr_buffer, "curr-buff", 0, 0},
3034     {get_buffer_count, "buff-count", 0, 0},
3035     {get_next_buffer, "get-next-buff", 0, 1},
3036     {get_prev_buffer, "get-prev-buff", 0, 1},
3037     {mzscheme_open_buffer, "open-buff", 1, 1},
3038     {get_buffer_by_name, "get-buff-by-name", 1, 1},
3039     {get_buffer_by_num, "get-buff-by-num", 1, 1},
3040     /*
3041      * Window-related commands
3042      */
3043     {get_curr_win, "curr-win", 0, 0},
3044     {get_window_count, "win-count", 0, 0},
3045     {get_window_by_num, "get-win-by-num", 1, 1},
3046     {get_window_num, "get-win-num", 0, 1},
3047     {get_window_buffer, "get-win-buffer", 0, 1},
3048     {get_window_height, "get-win-height", 0, 1},
3049     {set_window_height, "set-win-height", 1, 2},
3050 #ifdef FEAT_VERTSPLIT
3051     {get_window_width, "get-win-width", 0, 1},
3052     {set_window_width, "set-win-width", 1, 2},
3053 #endif
3054     {get_cursor, "get-cursor", 0, 1},
3055     {set_cursor, "set-cursor", 1, 2},
3056     {get_window_list, "get-win-list", 0, 1},
3057     /*
3058      * Vim-related commands
3059      */
3060     {vim_command, "command", 1, 1},
3061     {vim_eval, "eval", 1, 1},
3062     {get_range_start, "range-start", 0, 0},
3063     {get_range_end, "range-end", 0, 0},
3064     {mzscheme_beep, "beep", 0, 0},
3065     {get_option, "get-option", 1, 2},
3066     {set_option, "set-option", 1, 2},
3067     /*
3068      * small utilities
3069      */
3070     {vim_bufferp, "buff?", 1, 1},
3071     {vim_windowp, "win?", 1, 1},
3072     {vim_buffer_validp, "buff-valid?", 1, 1},
3073     {vim_window_validp, "win-valid?", 1, 1}
3074 };
3075
3076 /* return MzScheme wrapper for curbuf */
3077     static vim_mz_buffer *
3078 get_vim_curr_buffer(void)
3079 {
3080     if (curbuf->b_mzscheme_ref == NULL)
3081         return (vim_mz_buffer *)buffer_new(curbuf);
3082     else
3083         return (vim_mz_buffer *)curbuf->b_mzscheme_ref;
3084 }
3085
3086 /* return MzScheme wrapper for curwin */
3087     static vim_mz_window *
3088 get_vim_curr_window(void)
3089 {
3090     if (curwin->w_mzscheme_ref == NULL)
3091         return (vim_mz_window *)window_new(curwin);
3092     else
3093         return (vim_mz_window *)curwin->w_mzscheme_ref;
3094 }
3095
3096     static void
3097 make_modules()
3098 {
3099     int             i;
3100     Scheme_Env      *mod = NULL;
3101     Scheme_Object   *vimext_symbol = NULL;
3102     Scheme_Object   *closed_prim = NULL;
3103
3104     MZ_GC_DECL_REG(3);
3105     MZ_GC_VAR_IN_REG(0, mod);
3106     MZ_GC_VAR_IN_REG(1, vimext_symbol);
3107     MZ_GC_VAR_IN_REG(2, closed_prim);
3108     MZ_GC_REG();
3109
3110     vimext_symbol = scheme_intern_symbol("vimext");
3111     MZ_GC_CHECK();
3112     mod = scheme_primitive_module(vimext_symbol, environment);
3113     MZ_GC_CHECK();
3114     /* all prims made closed so they can access their own names */
3115     for (i = 0; i < (int)(sizeof(prims)/sizeof(prims[0])); i++)
3116     {
3117         Vim_Prim *prim = prims + i;
3118         closed_prim = scheme_make_closed_prim_w_arity(prim->prim, prim, prim->name,
3119                             prim->mina, prim->maxa);
3120         scheme_add_global(prim->name, closed_prim, mod);
3121         MZ_GC_CHECK();
3122     }
3123     scheme_finish_primitive_module(mod);
3124     MZ_GC_CHECK();
3125     MZ_GC_UNREG();
3126 }
3127
3128 #ifdef HAVE_SANDBOX
3129 static Scheme_Object *M_write = NULL;
3130 static Scheme_Object *M_read = NULL;
3131 static Scheme_Object *M_execute = NULL;
3132 static Scheme_Object *M_delete = NULL;
3133
3134     static void
3135 sandbox_check(void)
3136 {
3137     if (sandbox)
3138         raise_vim_exn(_("not allowed in the Vim sandbox"));
3139 }
3140
3141 /* security guards to force Vim's sandbox restrictions on MzScheme level */
3142     static Scheme_Object *
3143 sandbox_file_guard(int argc, Scheme_Object **argv)
3144 {
3145     if (sandbox)
3146     {
3147         Scheme_Object *requested_access = argv[2];
3148
3149         if (M_write == NULL)
3150         {
3151             MZ_REGISTER_STATIC(M_write);
3152             M_write = scheme_intern_symbol("write");
3153             MZ_GC_CHECK();
3154         }
3155         if (M_read == NULL)
3156         {
3157             MZ_REGISTER_STATIC(M_read);
3158             M_read = scheme_intern_symbol("read");
3159             MZ_GC_CHECK();
3160         }
3161         if (M_execute == NULL)
3162         {
3163             MZ_REGISTER_STATIC(M_execute);
3164             M_execute = scheme_intern_symbol("execute");
3165             MZ_GC_CHECK();
3166         }
3167         if (M_delete == NULL)
3168         {
3169             MZ_REGISTER_STATIC(M_delete);
3170             M_delete = scheme_intern_symbol("delete");
3171             MZ_GC_CHECK();
3172         }
3173
3174         while (!SCHEME_NULLP(requested_access))
3175         {
3176             Scheme_Object *item = SCHEME_CAR(requested_access);
3177             if (scheme_eq(item, M_write) || scheme_eq(item, M_read)
3178                     || scheme_eq(item, M_execute) || scheme_eq(item, M_delete))
3179             {
3180                 raise_vim_exn(_("not allowed in the Vim sandbox"));
3181             }
3182             requested_access = SCHEME_CDR(requested_access);
3183         }
3184     }
3185     return scheme_void;
3186 }
3187
3188     static Scheme_Object *
3189 sandbox_network_guard(int argc, Scheme_Object **argv)
3190 {
3191     return scheme_void;
3192 }
3193 #endif
3194
3195 #endif