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