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