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