From 8baab3c8d7a6f22888bd581cd5c6098fd2e4b5a8 Mon Sep 17 00:00:00 2001 From: Daniel Baumann Date: Mon, 6 May 2024 04:44:24 +0200 Subject: Adding upstream version 2:8.1.0875. Signed-off-by: Daniel Baumann --- src/if_mzsch.c | 3824 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 3824 insertions(+) create mode 100644 src/if_mzsch.c (limited to 'src/if_mzsch.c') diff --git a/src/if_mzsch.c b/src/if_mzsch.c new file mode 100644 index 0000000..16c4c88 --- /dev/null +++ b/src/if_mzsch.c @@ -0,0 +1,3824 @@ +/* vi:set ts=8 sts=4 sw=4 noet: + * + * MzScheme interface by Sergey Khorev + * Based on work by Brent Fulgham + * (Based on lots of help from Matthew Flatt) + * + * This consists of six parts: + * 1. MzScheme interpreter main program + * 2. Routines that handle the external interface between MzScheme and + * Vim. + * 3. MzScheme input/output handlers: writes output via [e]msg(). + * 4. Implementation of the Vim Features for MzScheme + * 5. Vim Window-related Manipulation Functions. + * 6. Vim Buffer-related Manipulation Functions + * + * NOTES + * 1. Memory, allocated with scheme_malloc*, need not to be freed explicitly, + * garbage collector will do it self + * 2. Requires at least NORMAL features. I can't imagine why one may want + * to build with SMALL or TINY features but with MzScheme interface. + * 3. I don't use K&R-style functions. Anyways, MzScheme headers are ANSI. + */ + +#include "vim.h" + +#include "if_mzsch.h" + +/* Only do the following when the feature is enabled. Needed for "make + * depend". */ +#if defined(FEAT_MZSCHEME) || defined(PROTO) + +#ifdef PROTO +typedef int Scheme_Object; +typedef int Scheme_Closed_Prim; +typedef int Scheme_Env; +typedef int Scheme_Hash_Table; +typedef int Scheme_Type; +typedef int Scheme_Thread; +typedef int Scheme_Closed_Prim; +typedef int mzshort; +typedef int Scheme_Prim; +typedef int HINSTANCE; +#endif + +/* + * scheme_register_tls_space is only available on 32-bit Windows until + * racket-6.3. See + * http://docs.racket-lang.org/inside/im_memoryalloc.html?q=scheme_register_tls_space + */ +#if MZSCHEME_VERSION_MAJOR >= 500 && defined(WIN32) \ + && defined(USE_THREAD_LOCAL) \ + && (!defined(_WIN64) || MZSCHEME_VERSION_MAJOR >= 603) +# define HAVE_TLS_SPACE 1 +#endif + +/* + * Since version 4.x precise GC requires trampolined startup. + * Futures and places in version 5.x need it too. + */ +#if defined(MZ_PRECISE_GC) && MZSCHEME_VERSION_MAJOR >= 400 \ + || MZSCHEME_VERSION_MAJOR >= 500 \ + && (defined(MZ_USE_FUTURES) || defined(MZ_USE_PLACES)) +# define TRAMPOLINED_MZVIM_STARTUP +#endif + +/* Base data structures */ +#define SCHEME_VIMBUFFERP(obj) SAME_TYPE(SCHEME_TYPE(obj), mz_buffer_type) +#define SCHEME_VIMWINDOWP(obj) SAME_TYPE(SCHEME_TYPE(obj), mz_window_type) + +typedef struct +{ + Scheme_Object so; + buf_T *buf; +} vim_mz_buffer; + +#define INVALID_BUFFER_VALUE ((buf_T *)(-1)) + +typedef struct +{ + Scheme_Object so; + win_T *win; +} vim_mz_window; + +#define INVALID_WINDOW_VALUE ((win_T *)(-1)) + +/* + * Prims that form MzScheme Vim interface + */ +typedef struct +{ + Scheme_Closed_Prim *prim; + char *name; + int mina; /* arity information */ + int maxa; +} Vim_Prim; + +typedef struct +{ + char *name; + Scheme_Object *port; +} Port_Info; + +/* + *======================================================================== + * Vim-Control Commands + *======================================================================== + */ +/* + *======================================================================== + * Utility functions for the vim/mzscheme interface + *======================================================================== + */ +#ifdef HAVE_SANDBOX +static Scheme_Object *sandbox_file_guard(int, Scheme_Object **); +static Scheme_Object *sandbox_network_guard(int, Scheme_Object **); +static void sandbox_check(void); +#endif +/* Buffer-related commands */ +static Scheme_Object *buffer_new(buf_T *buf); +static Scheme_Object *get_buffer_by_num(void *, int, Scheme_Object **); +static vim_mz_buffer *get_vim_curr_buffer(void); + +/* Window-related commands */ +static Scheme_Object *window_new(win_T *win); +static vim_mz_window *get_vim_curr_window(void); + +/* + *======================================================================== + * Internal Function Prototypes + *======================================================================== + */ +static int vim_error_check(void); +static int do_mzscheme_command(exarg_T *, void *, Scheme_Closed_Prim *what); +static int startup_mzscheme(void); +static char *string_to_line(Scheme_Object *obj); +#if MZSCHEME_VERSION_MAJOR >= 501 +# define OUTPUT_LEN_TYPE intptr_t +#else +# define OUTPUT_LEN_TYPE long +#endif +static void do_output(char *mesg, OUTPUT_LEN_TYPE len); +static void do_printf(char *format, ...); +static void do_flush(void); +static Scheme_Object *_apply_thunk_catch_exceptions( + Scheme_Object *, Scheme_Object **); +static Scheme_Object *extract_exn_message(Scheme_Object *v); +static Scheme_Object *do_eval(void *, int noargc, Scheme_Object **noargv); +static Scheme_Object *do_load(void *, int noargc, Scheme_Object **noargv); +static void register_vim_exn(void); +static vim_mz_buffer *get_buffer_arg(const char *fname, int argnum, + int argc, Scheme_Object **argv); +static vim_mz_window *get_window_arg(const char *fname, int argnum, + int argc, Scheme_Object **argv); +static int line_in_range(linenr_T, buf_T *); +static void check_line_range(linenr_T, buf_T *); +static void mz_fix_cursor(int lo, int hi, int extra); + +static int eval_with_exn_handling(void *, Scheme_Closed_Prim *, + Scheme_Object **ret); +static void make_modules(void); +static void init_exn_catching_apply(void); +static int mzscheme_env_main(Scheme_Env *env, int argc, char **argv); +static int mzscheme_init(void); +#ifdef FEAT_EVAL +static Scheme_Object *vim_to_mzscheme(typval_T *vim_value); +static Scheme_Object *vim_to_mzscheme_impl(typval_T *vim_value, int depth, + Scheme_Hash_Table *visited); +static int mzscheme_to_vim(Scheme_Object *obj, typval_T *tv); +static int mzscheme_to_vim_impl(Scheme_Object *obj, typval_T *tv, int depth, + Scheme_Hash_Table *visited); +static Scheme_Object *vim_funcref(void *data, int argc, Scheme_Object **argv); +#endif + +#ifdef MZ_PRECISE_GC +static int buffer_size_proc(void *obj UNUSED) +{ + return gcBYTES_TO_WORDS(sizeof(vim_mz_buffer)); +} +static int buffer_mark_proc(void *obj) +{ + return buffer_size_proc(obj); +} +static int buffer_fixup_proc(void *obj) +{ + /* apparently not needed as the object will be uncollectable while + * the buffer is alive + */ + /* + vim_mz_buffer* buf = (vim_mz_buffer*) obj; + buf->buf->b_mzscheme_ref = GC_fixup_self(obj); + */ + return buffer_size_proc(obj); +} +static int window_size_proc(void *obj UNUSED) +{ + return gcBYTES_TO_WORDS(sizeof(vim_mz_window)); +} +static int window_mark_proc(void *obj) +{ + return window_size_proc(obj); +} +static int window_fixup_proc(void *obj) +{ + /* apparently not needed as the object will be uncollectable while + * the window is alive + */ + /* + vim_mz_window* win = (vim_mz_window*) obj; + win->win->w_mzscheme_ref = GC_fixup_self(obj); + */ + return window_size_proc(obj); +} +/* with precise GC, w_mzscheme_ref and b_mzscheme_ref are immobile boxes + * containing pointers to a window/buffer + * with conservative GC these are simply pointers*/ +# define WINDOW_REF(win) *(vim_mz_window **)((win)->w_mzscheme_ref) +# define BUFFER_REF(buf) *(vim_mz_buffer **)((buf)->b_mzscheme_ref) +#else +# define WINDOW_REF(win) (vim_mz_window *)((win)->w_mzscheme_ref) +# define BUFFER_REF(buf) (vim_mz_buffer *)((buf)->b_mzscheme_ref) +#endif + +#if defined(DYNAMIC_MZSCHEME) || defined(PROTO) +static Scheme_Object *dll_scheme_eof; +static Scheme_Object *dll_scheme_false; +static Scheme_Object *dll_scheme_void; +static Scheme_Object *dll_scheme_null; +static Scheme_Object *dll_scheme_true; + +static Scheme_Thread **dll_scheme_current_thread_ptr; + +static void (**dll_scheme_console_printf_ptr)(char *str, ...); +static void (**dll_scheme_console_output_ptr)(char *str, OUTPUT_LEN_TYPE len); +static void (**dll_scheme_notify_multithread_ptr)(int on); + +static void *(*dll_GC_malloc)(size_t size_in_bytes); +static void *(*dll_GC_malloc_atomic)(size_t size_in_bytes); +static Scheme_Env *(*dll_scheme_basic_env)(void); +static void (*dll_scheme_check_threads)(void); +static void (*dll_scheme_register_static)(void *ptr, long size); +static void (*dll_scheme_set_stack_base)(void *base, int no_auto_statics); +static void (*dll_scheme_add_global)(const char *name, Scheme_Object *val, + Scheme_Env *env); +static void (*dll_scheme_add_global_symbol)(Scheme_Object *name, + Scheme_Object *val, Scheme_Env *env); +static Scheme_Object *(*dll_scheme_apply)(Scheme_Object *rator, int num_rands, + Scheme_Object **rands); +static Scheme_Object *(*dll_scheme_builtin_value)(const char *name); +# if MZSCHEME_VERSION_MAJOR >= 299 +static Scheme_Object *(*dll_scheme_byte_string_to_char_string)(Scheme_Object *s); +static Scheme_Object *(*dll_scheme_make_path)(const char *chars); +# endif +static void (*dll_scheme_close_input_port)(Scheme_Object *port); +static void (*dll_scheme_count_lines)(Scheme_Object *port); +#if MZSCHEME_VERSION_MAJOR < 360 +static Scheme_Object *(*dll_scheme_current_continuation_marks)(void); +#else +static Scheme_Object *(*dll_scheme_current_continuation_marks)(Scheme_Object *prompt_tag); +#endif +static void (*dll_scheme_display)(Scheme_Object *obj, Scheme_Object *port); +static char *(*dll_scheme_display_to_string)(Scheme_Object *obj, OUTPUT_LEN_TYPE *len); +static int (*dll_scheme_eq)(Scheme_Object *obj1, Scheme_Object *obj2); +static Scheme_Object *(*dll_scheme_do_eval)(Scheme_Object *obj, + int _num_rands, Scheme_Object **rands, int val); +static void (*dll_scheme_dont_gc_ptr)(void *p); +static Scheme_Object *(*dll_scheme_eval)(Scheme_Object *obj, Scheme_Env *env); +static Scheme_Object *(*dll_scheme_eval_string)(const char *str, + Scheme_Env *env); +static Scheme_Object *(*dll_scheme_eval_string_all)(const char *str, + Scheme_Env *env, int all); +static void (*dll_scheme_finish_primitive_module)(Scheme_Env *env); +# if MZSCHEME_VERSION_MAJOR < 299 +static char *(*dll_scheme_format)(char *format, int flen, int argc, + Scheme_Object **argv, long *rlen); +# else +static char *(*dll_scheme_format_utf8)(char *format, int flen, int argc, + Scheme_Object **argv, OUTPUT_LEN_TYPE *rlen); +static Scheme_Object *(*dll_scheme_get_param)(Scheme_Config *c, int pos); +# endif +static void (*dll_scheme_gc_ptr_ok)(void *p); +# if MZSCHEME_VERSION_MAJOR < 299 +static char *(*dll_scheme_get_sized_string_output)(Scheme_Object *, + long *len); +# else +static char *(*dll_scheme_get_sized_byte_string_output)(Scheme_Object *, + OUTPUT_LEN_TYPE *len); +# endif +static Scheme_Object *(*dll_scheme_intern_symbol)(const char *name); +static Scheme_Object *(*dll_scheme_lookup_global)(Scheme_Object *symbol, + Scheme_Env *env); +static Scheme_Object *(*dll_scheme_make_closed_prim_w_arity) + (Scheme_Closed_Prim *prim, void *data, const char *name, mzshort mina, + mzshort maxa); +static Scheme_Object *(*dll_scheme_make_integer_value)(long i); +static Scheme_Object *(*dll_scheme_make_pair)(Scheme_Object *car, + Scheme_Object *cdr); +static Scheme_Object *(*dll_scheme_make_prim_w_arity)(Scheme_Prim *prim, + const char *name, mzshort mina, mzshort maxa); +# if MZSCHEME_VERSION_MAJOR < 299 +static Scheme_Object *(*dll_scheme_make_string)(const char *chars); +static Scheme_Object *(*dll_scheme_make_string_output_port)(); +# else +static Scheme_Object *(*dll_scheme_make_byte_string)(const char *chars); +static Scheme_Object *(*dll_scheme_make_byte_string_output_port)(); +# endif +static Scheme_Object *(*dll_scheme_make_struct_instance)(Scheme_Object *stype, + int argc, Scheme_Object **argv); +static Scheme_Object **(*dll_scheme_make_struct_names)(Scheme_Object *base, + Scheme_Object *field_names, int flags, int *count_out); +static Scheme_Object *(*dll_scheme_make_struct_type)(Scheme_Object *base, + Scheme_Object *parent, Scheme_Object *inspector, int num_fields, + int num_uninit_fields, Scheme_Object *uninit_val, + Scheme_Object *properties +# if MZSCHEME_VERSION_MAJOR >= 299 + , Scheme_Object *guard +# endif + ); +static Scheme_Object **(*dll_scheme_make_struct_values)( + Scheme_Object *struct_type, Scheme_Object **names, int count, + int flags); +static Scheme_Type (*dll_scheme_make_type)(const char *name); +static Scheme_Object *(*dll_scheme_make_vector)(int size, + Scheme_Object *fill); +static void *(*dll_scheme_malloc_fail_ok)(void *(*f)(size_t), size_t); +static Scheme_Object *(*dll_scheme_open_input_file)(const char *name, + const char *who); +static Scheme_Env *(*dll_scheme_primitive_module)(Scheme_Object *name, + Scheme_Env *for_env); +static int (*dll_scheme_proper_list_length)(Scheme_Object *list); +static void (*dll_scheme_raise)(Scheme_Object *exn); +static Scheme_Object *(*dll_scheme_read)(Scheme_Object *port); +static void (*dll_scheme_signal_error)(const char *msg, ...); +static void (*dll_scheme_wrong_type)(const char *name, const char *expected, + int which, int argc, Scheme_Object **argv); +# if MZSCHEME_VERSION_MAJOR >= 299 +static void (*dll_scheme_set_param)(Scheme_Config *c, int pos, + Scheme_Object *o); +static Scheme_Config *(*dll_scheme_current_config)(void); +static Scheme_Object *(*dll_scheme_char_string_to_byte_string) + (Scheme_Object *s); +static Scheme_Object *(*dll_scheme_char_string_to_path) + (Scheme_Object *s); +static void *(*dll_scheme_set_collects_path)(Scheme_Object *p); +# endif +static Scheme_Hash_Table *(*dll_scheme_make_hash_table)(int type); +static void (*dll_scheme_hash_set)(Scheme_Hash_Table *table, + Scheme_Object *key, Scheme_Object *value); +static Scheme_Object *(*dll_scheme_hash_get)(Scheme_Hash_Table *table, + Scheme_Object *key); +static Scheme_Object *(*dll_scheme_make_double)(double d); +static Scheme_Object *(*dll_scheme_make_sized_byte_string)(char *chars, + long len, int copy); +static Scheme_Object *(*dll_scheme_namespace_require)(Scheme_Object *req); +static Scheme_Object *(*dll_scheme_dynamic_wind)(void (*pre)(void *), Scheme_Object *(* volatile act)(void *), void (* volatile post)(void *), Scheme_Object *(*jmp_handler)(void *), void * volatile data); +# ifdef MZ_PRECISE_GC +static void *(*dll_GC_malloc_one_tagged)(size_t size_in_bytes); +static void (*dll_GC_register_traversers)(short tag, Size_Proc size, Mark_Proc mark, Fixup_Proc fixup, int is_constant_size, int is_atomic); +# endif +# if MZSCHEME_VERSION_MAJOR >= 400 +static void (*dll_scheme_init_collection_paths)(Scheme_Env *global_env, Scheme_Object *extra_dirs); +static void **(*dll_scheme_malloc_immobile_box)(void *p); +static void (*dll_scheme_free_immobile_box)(void **b); +# endif +# if MZSCHEME_VERSION_MAJOR >= 500 +# ifdef TRAMPOLINED_MZVIM_STARTUP +static int (*dll_scheme_main_setup)(int no_auto_statics, Scheme_Env_Main _main, int argc, char **argv); +# if defined(IMPLEMENT_THREAD_LOCAL_VIA_WIN_TLS) || MZSCHEME_VERSION_MAJOR >= 603 +static void (*dll_scheme_register_tls_space)(void *tls_space, int _tls_index); +# endif +# endif +# if defined(IMPLEMENT_THREAD_LOCAL_VIA_WIN_TLS) || defined(IMPLEMENT_THREAD_LOCAL_EXTERNALLY_VIA_PROC) +static Thread_Local_Variables *(*dll_scheme_external_get_thread_local_variables)(void); +# endif +# endif +# if MZSCHEME_VERSION_MAJOR >= 600 +static void (*dll_scheme_embedded_load)(intptr_t len, const char *s, int predefined); +static void (*dll_scheme_register_embedded_load)(intptr_t len, const char *s); +static void (*dll_scheme_set_config_path)(Scheme_Object *p); +# endif + +#if defined(DYNAMIC_MZSCHEME) /* not when defined(PROTO) */ + +/* arrays are imported directly */ +# define scheme_eof dll_scheme_eof +# define scheme_false dll_scheme_false +# define scheme_void dll_scheme_void +# define scheme_null dll_scheme_null +# define scheme_true dll_scheme_true + +/* pointers are GetProceAddress'ed as pointers to pointer */ +#if !defined(USE_THREAD_LOCAL) && !defined(LINK_EXTENSIONS_BY_TABLE) +# define scheme_current_thread (*dll_scheme_current_thread_ptr) +# endif +# define scheme_console_printf (*dll_scheme_console_printf_ptr) +# define scheme_console_output (*dll_scheme_console_output_ptr) +# define scheme_notify_multithread (*dll_scheme_notify_multithread_ptr) + +/* and functions in a usual way */ +# define GC_malloc dll_GC_malloc +# define GC_malloc_atomic dll_GC_malloc_atomic + +# define scheme_add_global dll_scheme_add_global +# define scheme_add_global_symbol dll_scheme_add_global_symbol +# define scheme_apply dll_scheme_apply +# define scheme_basic_env dll_scheme_basic_env +# define scheme_builtin_value dll_scheme_builtin_value +# if MZSCHEME_VERSION_MAJOR >= 299 +# define scheme_byte_string_to_char_string dll_scheme_byte_string_to_char_string +# define scheme_make_path dll_scheme_make_path +# endif +# define scheme_check_threads dll_scheme_check_threads +# define scheme_close_input_port dll_scheme_close_input_port +# define scheme_count_lines dll_scheme_count_lines +# define scheme_current_continuation_marks \ + dll_scheme_current_continuation_marks +# define scheme_display dll_scheme_display +# define scheme_display_to_string dll_scheme_display_to_string +# define scheme_do_eval dll_scheme_do_eval +# define scheme_dont_gc_ptr dll_scheme_dont_gc_ptr +# define scheme_eq dll_scheme_eq +# define scheme_eval dll_scheme_eval +# define scheme_eval_string dll_scheme_eval_string +# define scheme_eval_string_all dll_scheme_eval_string_all +# define scheme_finish_primitive_module dll_scheme_finish_primitive_module +# if MZSCHEME_VERSION_MAJOR < 299 +# define scheme_format dll_scheme_format +# else +# define scheme_format_utf8 dll_scheme_format_utf8 +# endif +# define scheme_gc_ptr_ok dll_scheme_gc_ptr_ok +# if MZSCHEME_VERSION_MAJOR < 299 +# define scheme_get_sized_byte_string_output dll_scheme_get_sized_string_output +# else +# define scheme_get_sized_byte_string_output \ + dll_scheme_get_sized_byte_string_output +# define scheme_get_param dll_scheme_get_param +# endif +# define scheme_intern_symbol dll_scheme_intern_symbol +# define scheme_lookup_global dll_scheme_lookup_global +# define scheme_make_closed_prim_w_arity dll_scheme_make_closed_prim_w_arity +# define scheme_make_integer_value dll_scheme_make_integer_value +# define scheme_make_pair dll_scheme_make_pair +# define scheme_make_prim_w_arity dll_scheme_make_prim_w_arity +# if MZSCHEME_VERSION_MAJOR < 299 +# define scheme_make_byte_string dll_scheme_make_string +# define scheme_make_byte_string_output_port dll_scheme_make_string_output_port +# else +# define scheme_make_byte_string dll_scheme_make_byte_string +# define scheme_make_byte_string_output_port \ + dll_scheme_make_byte_string_output_port +# endif +# define scheme_make_struct_instance dll_scheme_make_struct_instance +# define scheme_make_struct_names dll_scheme_make_struct_names +# define scheme_make_struct_type dll_scheme_make_struct_type +# define scheme_make_struct_values dll_scheme_make_struct_values +# define scheme_make_type dll_scheme_make_type +# define scheme_make_vector dll_scheme_make_vector +# define scheme_malloc_fail_ok dll_scheme_malloc_fail_ok +# define scheme_open_input_file dll_scheme_open_input_file +# define scheme_primitive_module dll_scheme_primitive_module +# define scheme_proper_list_length dll_scheme_proper_list_length +# define scheme_raise dll_scheme_raise +# define scheme_read dll_scheme_read +# define scheme_register_static dll_scheme_register_static +# define scheme_set_stack_base dll_scheme_set_stack_base +# define scheme_signal_error dll_scheme_signal_error +# define scheme_wrong_type dll_scheme_wrong_type +# if MZSCHEME_VERSION_MAJOR >= 299 +# define scheme_set_param dll_scheme_set_param +# define scheme_current_config dll_scheme_current_config +# define scheme_char_string_to_byte_string \ + dll_scheme_char_string_to_byte_string +# define scheme_char_string_to_path \ + dll_scheme_char_string_to_path +# define scheme_set_collects_path dll_scheme_set_collects_path +# endif +# define scheme_make_hash_table dll_scheme_make_hash_table +# define scheme_hash_set dll_scheme_hash_set +# define scheme_hash_get dll_scheme_hash_get +# define scheme_make_double dll_scheme_make_double +# define scheme_make_sized_byte_string dll_scheme_make_sized_byte_string +# define scheme_namespace_require dll_scheme_namespace_require +# define scheme_dynamic_wind dll_scheme_dynamic_wind +# ifdef MZ_PRECISE_GC +# define GC_malloc_one_tagged dll_GC_malloc_one_tagged +# define GC_register_traversers dll_GC_register_traversers +# endif +# if MZSCHEME_VERSION_MAJOR >= 400 +# ifdef TRAMPOLINED_MZVIM_STARTUP +# define scheme_main_setup dll_scheme_main_setup +# if defined(IMPLEMENT_THREAD_LOCAL_VIA_WIN_TLS) || MZSCHEME_VERSION_MAJOR >= 603 +# define scheme_register_tls_space dll_scheme_register_tls_space +# endif +# endif +# define scheme_init_collection_paths dll_scheme_init_collection_paths +# define scheme_malloc_immobile_box dll_scheme_malloc_immobile_box +# define scheme_free_immobile_box dll_scheme_free_immobile_box +# endif +# if MZSCHEME_VERSION_MAJOR >= 600 +# define scheme_embedded_load dll_scheme_embedded_load +# define scheme_register_embedded_load dll_scheme_register_embedded_load +# define scheme_set_config_path dll_scheme_set_config_path +# endif + +# if MZSCHEME_VERSION_MAJOR >= 500 +# if defined(IMPLEMENT_THREAD_LOCAL_VIA_WIN_TLS) || defined(IMPLEMENT_THREAD_LOCAL_EXTERNALLY_VIA_PROC) +/* define as function for macro in schthread.h */ +Thread_Local_Variables * +scheme_external_get_thread_local_variables(void) +{ + return dll_scheme_external_get_thread_local_variables(); +} +# endif +# endif + +#endif + +typedef struct +{ + char *name; + void **ptr; +} Thunk_Info; + +static Thunk_Info mzgc_imports[] = { + {"GC_malloc", (void **)&dll_GC_malloc}, + {"GC_malloc_atomic", (void **)&dll_GC_malloc_atomic}, + {NULL, NULL}}; + +static Thunk_Info mzsch_imports[] = { + {"scheme_eof", (void **)&dll_scheme_eof}, + {"scheme_false", (void **)&dll_scheme_false}, + {"scheme_void", (void **)&dll_scheme_void}, + {"scheme_null", (void **)&dll_scheme_null}, + {"scheme_true", (void **)&dll_scheme_true}, +#if !defined(USE_THREAD_LOCAL) && !defined(LINK_EXTENSIONS_BY_TABLE) + {"scheme_current_thread", (void **)&dll_scheme_current_thread_ptr}, +#endif + {"scheme_console_printf", (void **)&dll_scheme_console_printf_ptr}, + {"scheme_console_output", (void **)&dll_scheme_console_output_ptr}, + {"scheme_notify_multithread", + (void **)&dll_scheme_notify_multithread_ptr}, + {"scheme_add_global", (void **)&dll_scheme_add_global}, + {"scheme_add_global_symbol", (void **)&dll_scheme_add_global_symbol}, + {"scheme_apply", (void **)&dll_scheme_apply}, + {"scheme_basic_env", (void **)&dll_scheme_basic_env}, +# if MZSCHEME_VERSION_MAJOR >= 299 + {"scheme_byte_string_to_char_string", (void **)&dll_scheme_byte_string_to_char_string}, + {"scheme_make_path", (void **)&dll_scheme_make_path}, +# endif + {"scheme_builtin_value", (void **)&dll_scheme_builtin_value}, + {"scheme_check_threads", (void **)&dll_scheme_check_threads}, + {"scheme_close_input_port", (void **)&dll_scheme_close_input_port}, + {"scheme_count_lines", (void **)&dll_scheme_count_lines}, + {"scheme_current_continuation_marks", + (void **)&dll_scheme_current_continuation_marks}, + {"scheme_display", (void **)&dll_scheme_display}, + {"scheme_display_to_string", (void **)&dll_scheme_display_to_string}, + {"scheme_do_eval", (void **)&dll_scheme_do_eval}, + {"scheme_dont_gc_ptr", (void **)&dll_scheme_dont_gc_ptr}, + {"scheme_eq", (void **)&dll_scheme_eq}, + {"scheme_eval", (void **)&dll_scheme_eval}, + {"scheme_eval_string", (void **)&dll_scheme_eval_string}, + {"scheme_eval_string_all", (void **)&dll_scheme_eval_string_all}, + {"scheme_finish_primitive_module", + (void **)&dll_scheme_finish_primitive_module}, +# if MZSCHEME_VERSION_MAJOR < 299 + {"scheme_format", (void **)&dll_scheme_format}, +# else + {"scheme_format_utf8", (void **)&dll_scheme_format_utf8}, + {"scheme_get_param", (void **)&dll_scheme_get_param}, +#endif + {"scheme_gc_ptr_ok", (void **)&dll_scheme_gc_ptr_ok}, +# if MZSCHEME_VERSION_MAJOR < 299 + {"scheme_get_sized_string_output", + (void **)&dll_scheme_get_sized_string_output}, +# else + {"scheme_get_sized_byte_string_output", + (void **)&dll_scheme_get_sized_byte_string_output}, +#endif + {"scheme_intern_symbol", (void **)&dll_scheme_intern_symbol}, + {"scheme_lookup_global", (void **)&dll_scheme_lookup_global}, + {"scheme_make_closed_prim_w_arity", + (void **)&dll_scheme_make_closed_prim_w_arity}, + {"scheme_make_integer_value", (void **)&dll_scheme_make_integer_value}, + {"scheme_make_pair", (void **)&dll_scheme_make_pair}, + {"scheme_make_prim_w_arity", (void **)&dll_scheme_make_prim_w_arity}, +# if MZSCHEME_VERSION_MAJOR < 299 + {"scheme_make_string", (void **)&dll_scheme_make_string}, + {"scheme_make_string_output_port", + (void **)&dll_scheme_make_string_output_port}, +# else + {"scheme_make_byte_string", (void **)&dll_scheme_make_byte_string}, + {"scheme_make_byte_string_output_port", + (void **)&dll_scheme_make_byte_string_output_port}, +# endif + {"scheme_make_struct_instance", + (void **)&dll_scheme_make_struct_instance}, + {"scheme_make_struct_names", (void **)&dll_scheme_make_struct_names}, + {"scheme_make_struct_type", (void **)&dll_scheme_make_struct_type}, + {"scheme_make_struct_values", (void **)&dll_scheme_make_struct_values}, + {"scheme_make_type", (void **)&dll_scheme_make_type}, + {"scheme_make_vector", (void **)&dll_scheme_make_vector}, + {"scheme_malloc_fail_ok", (void **)&dll_scheme_malloc_fail_ok}, + {"scheme_open_input_file", (void **)&dll_scheme_open_input_file}, + {"scheme_primitive_module", (void **)&dll_scheme_primitive_module}, + {"scheme_proper_list_length", (void **)&dll_scheme_proper_list_length}, + {"scheme_raise", (void **)&dll_scheme_raise}, + {"scheme_read", (void **)&dll_scheme_read}, + {"scheme_register_static", (void **)&dll_scheme_register_static}, + {"scheme_set_stack_base", (void **)&dll_scheme_set_stack_base}, + {"scheme_signal_error", (void **)&dll_scheme_signal_error}, + {"scheme_wrong_type", (void **)&dll_scheme_wrong_type}, +# if MZSCHEME_VERSION_MAJOR >= 299 + {"scheme_set_param", (void **)&dll_scheme_set_param}, + {"scheme_current_config", (void **)&dll_scheme_current_config}, + {"scheme_char_string_to_byte_string", + (void **)&dll_scheme_char_string_to_byte_string}, + {"scheme_char_string_to_path", (void **)&dll_scheme_char_string_to_path}, + {"scheme_set_collects_path", (void **)&dll_scheme_set_collects_path}, +# endif + {"scheme_make_hash_table", (void **)&dll_scheme_make_hash_table}, + {"scheme_hash_set", (void **)&dll_scheme_hash_set}, + {"scheme_hash_get", (void **)&dll_scheme_hash_get}, + {"scheme_make_double", (void **)&dll_scheme_make_double}, + {"scheme_make_sized_byte_string", (void **)&dll_scheme_make_sized_byte_string}, + {"scheme_namespace_require", (void **)&dll_scheme_namespace_require}, + {"scheme_dynamic_wind", (void **)&dll_scheme_dynamic_wind}, +# ifdef MZ_PRECISE_GC + {"GC_malloc_one_tagged", (void **)&dll_GC_malloc_one_tagged}, + {"GC_register_traversers", (void **)&dll_GC_register_traversers}, +# endif +# if MZSCHEME_VERSION_MAJOR >= 400 +# ifdef TRAMPOLINED_MZVIM_STARTUP + {"scheme_main_setup", (void **)&dll_scheme_main_setup}, +# if defined(IMPLEMENT_THREAD_LOCAL_VIA_WIN_TLS) || MZSCHEME_VERSION_MAJOR >= 603 + {"scheme_register_tls_space", (void **)&dll_scheme_register_tls_space}, +# endif +# endif + {"scheme_init_collection_paths", (void **)&dll_scheme_init_collection_paths}, + {"scheme_malloc_immobile_box", (void **)&dll_scheme_malloc_immobile_box}, + {"scheme_free_immobile_box", (void **)&dll_scheme_free_immobile_box}, +# endif +# if MZSCHEME_VERSION_MAJOR >= 500 +# if defined(IMPLEMENT_THREAD_LOCAL_VIA_WIN_TLS) || defined(IMPLEMENT_THREAD_LOCAL_EXTERNALLY_VIA_PROC) + {"scheme_external_get_thread_local_variables", (void **)&dll_scheme_external_get_thread_local_variables}, +# endif +# endif +# if MZSCHEME_VERSION_MAJOR >= 600 + {"scheme_embedded_load", (void **)&dll_scheme_embedded_load}, + {"scheme_register_embedded_load", (void **)&dll_scheme_register_embedded_load}, + {"scheme_set_config_path", (void **)&dll_scheme_set_config_path}, +# endif + {NULL, NULL}}; + +static HINSTANCE hMzGC = 0; +static HINSTANCE hMzSch = 0; + +static void dynamic_mzscheme_end(void); +static int mzscheme_runtime_link_init(char *sch_dll, char *gc_dll, + int verbose); + + static int +mzscheme_runtime_link_init(char *sch_dll, char *gc_dll, int verbose) +{ + Thunk_Info *thunk = NULL; + + if (hMzGC && hMzSch) + return OK; + hMzSch = vimLoadLib(sch_dll); + hMzGC = vimLoadLib(gc_dll); + + if (!hMzGC) + { + if (verbose) + semsg(_(e_loadlib), gc_dll); + return FAIL; + } + + if (!hMzSch) + { + if (verbose) + semsg(_(e_loadlib), sch_dll); + return FAIL; + } + + for (thunk = mzsch_imports; thunk->name; thunk++) + { + if ((*thunk->ptr = + (void *)GetProcAddress(hMzSch, thunk->name)) == NULL) + { + FreeLibrary(hMzSch); + hMzSch = 0; + FreeLibrary(hMzGC); + hMzGC = 0; + if (verbose) + semsg(_(e_loadfunc), thunk->name); + return FAIL; + } + } + for (thunk = mzgc_imports; thunk->name; thunk++) + { + if ((*thunk->ptr = + (void *)GetProcAddress(hMzGC, thunk->name)) == NULL) + { + FreeLibrary(hMzSch); + hMzSch = 0; + FreeLibrary(hMzGC); + hMzGC = 0; + if (verbose) + semsg(_(e_loadfunc), thunk->name); + return FAIL; + } + } + return OK; +} + + int +mzscheme_enabled(int verbose) +{ + return mzscheme_runtime_link_init( + (char *)p_mzschemedll, (char *)p_mzschemegcdll, verbose) == OK; +} + + static void +dynamic_mzscheme_end(void) +{ + if (hMzSch) + { + FreeLibrary(hMzSch); + hMzSch = 0; + } + if (hMzGC) + { + FreeLibrary(hMzGC); + hMzGC = 0; + } +} +#endif /* DYNAMIC_MZSCHEME */ + +#if MZSCHEME_VERSION_MAJOR < 299 +# define GUARANTEED_STRING_ARG(proc, num) GUARANTEE_STRING(proc, num) +#else + static Scheme_Object * +guaranteed_byte_string_arg(char *proc, int num, int argc, Scheme_Object **argv) +{ + if (SCHEME_BYTE_STRINGP(argv[num])) + { + return argv[num]; + } + else if (SCHEME_CHAR_STRINGP(argv[num])) + { + Scheme_Object *tmp = NULL; + MZ_GC_DECL_REG(2); + MZ_GC_VAR_IN_REG(0, argv[num]); + MZ_GC_VAR_IN_REG(1, tmp); + MZ_GC_REG(); + tmp = scheme_char_string_to_byte_string(argv[num]); + MZ_GC_UNREG(); + return tmp; + } + else + scheme_wrong_type(proc, "string", num, argc, argv); + /* unreachable */ + return scheme_void; +} +# define GUARANTEED_STRING_ARG(proc, num) guaranteed_byte_string_arg(proc, num, argc, argv) +#endif + +/* need to put it here for dynamic stuff to work */ +#if defined(INCLUDE_MZSCHEME_BASE) +# include "mzscheme_base.c" +#endif + +/* + *======================================================================== + * 1. MzScheme interpreter startup + *======================================================================== + */ + +static Scheme_Type mz_buffer_type; +static Scheme_Type mz_window_type; + +static int initialized = FALSE; +#ifdef DYNAMIC_MZSCHEME +static int disabled = FALSE; +#endif +static int load_base_module_failed = FALSE; + +/* global environment */ +static Scheme_Env *environment = NULL; +/* output/error handlers */ +static Scheme_Object *curout = NULL; +static Scheme_Object *curerr = NULL; +/* exn:vim exception */ +static Scheme_Object *exn_catching_apply = NULL; +static Scheme_Object *exn_p = NULL; +static Scheme_Object *exn_message = NULL; +static Scheme_Object *vim_exn = NULL; /* Vim Error exception */ + +#if !defined(MZ_PRECISE_GC) || MZSCHEME_VERSION_MAJOR < 400 +static void *stack_base = NULL; +#endif + +static long range_start; +static long range_end; + +/* MzScheme threads scheduling stuff */ +static int mz_threads_allow = 0; + +#if defined(FEAT_GUI_W32) +static void CALLBACK timer_proc(HWND, UINT, UINT_PTR, DWORD); +static UINT timer_id = 0; +#elif defined(FEAT_GUI_GTK) +static gboolean timer_proc(gpointer); +static guint timer_id = 0; +#elif defined(FEAT_GUI_MOTIF) || defined(FEAT_GUI_ATHENA) +static void timer_proc(XtPointer, XtIntervalId *); +static XtIntervalId timer_id = (XtIntervalId)0; +#elif defined(FEAT_GUI_MAC) +pascal void timer_proc(EventLoopTimerRef, void *); +static EventLoopTimerRef timer_id = NULL; +static EventLoopTimerUPP timerUPP; +#endif + +#ifndef FEAT_GUI_W32 /* Win32 console and Unix */ + void +mzvim_check_threads(void) +{ + /* Last time MzScheme threads were scheduled */ + static time_t mz_last_time = 0; + + if (mz_threads_allow && p_mzq > 0) + { + time_t now = time(NULL); + + if ((now - mz_last_time) * 1000 > p_mzq) + { + mz_last_time = now; + scheme_check_threads(); + } + } +} +#endif + +#if defined(MZSCHEME_GUI_THREADS) || defined(PROTO) +static void setup_timer(void); +static void remove_timer(void); + +/* timers are presented in GUI only */ +# if defined(FEAT_GUI_W32) + static void CALLBACK +timer_proc(HWND hwnd UNUSED, UINT uMsg UNUSED, UINT_PTR idEvent UNUSED, DWORD dwTime UNUSED) +# elif defined(FEAT_GUI_GTK) + static gboolean +timer_proc(gpointer data UNUSED) +# elif defined(FEAT_GUI_MOTIF) || defined(FEAT_GUI_ATHENA) + static void +timer_proc(XtPointer timed_out UNUSED, XtIntervalId *interval_id UNUSED) +# elif defined(FEAT_GUI_MAC) + pascal void +timer_proc(EventLoopTimerRef theTimer UNUSED, void *userData UNUSED) +# endif +{ + scheme_check_threads(); +# if defined(FEAT_GUI_GTK) + return TRUE; /* continue receiving notifications */ +# elif defined(FEAT_GUI_MOTIF) || defined(FEAT_GUI_ATHENA) + /* renew timeout */ + if (mz_threads_allow && p_mzq > 0) + timer_id = XtAppAddTimeOut(app_context, p_mzq, + timer_proc, NULL); +# endif +} + + static void +setup_timer(void) +{ +# if defined(FEAT_GUI_W32) + timer_id = SetTimer(NULL, 0, p_mzq, timer_proc); +# elif defined(FEAT_GUI_GTK) + timer_id = g_timeout_add((guint)p_mzq, (GSourceFunc)timer_proc, NULL); +# elif defined(FEAT_GUI_MOTIF) || defined(FEAT_GUI_ATHENA) + timer_id = XtAppAddTimeOut(app_context, p_mzq, timer_proc, NULL); +# elif defined(FEAT_GUI_MAC) + timerUPP = NewEventLoopTimerUPP(timer_proc); + InstallEventLoopTimer(GetMainEventLoop(), p_mzq * kEventDurationMillisecond, + p_mzq * kEventDurationMillisecond, timerUPP, NULL, &timer_id); +# endif +} + + static void +remove_timer(void) +{ +# if defined(FEAT_GUI_W32) + KillTimer(NULL, timer_id); +# elif defined(FEAT_GUI_GTK) + g_source_remove(timer_id); +# elif defined(FEAT_GUI_MOTIF) || defined(FEAT_GUI_ATHENA) + XtRemoveTimeOut(timer_id); +# elif defined(FEAT_GUI_MAC) + RemoveEventLoopTimer(timer_id); + DisposeEventLoopTimerUPP(timerUPP); +# endif + timer_id = 0; +} + + void +mzvim_reset_timer(void) +{ + if (timer_id != 0) + remove_timer(); + if (mz_threads_allow && p_mzq > 0 && gui.in_use) + setup_timer(); +} + +#endif /* MZSCHEME_GUI_THREADS */ + + static void +notify_multithread(int on) +{ + mz_threads_allow = on; +#ifdef MZSCHEME_GUI_THREADS + if (on && timer_id == 0 && p_mzq > 0 && gui.in_use) + setup_timer(); + if (!on && timer_id != 0) + remove_timer(); +#endif +} + + void +mzscheme_end(void) +{ + /* We can not unload the DLL. Racket's thread might be still alive. */ +#if 0 +#ifdef DYNAMIC_MZSCHEME + dynamic_mzscheme_end(); +#endif +#endif +} + +#if HAVE_TLS_SPACE +# if defined(_MSC_VER) +static __declspec(thread) void *tls_space; +extern intptr_t _tls_index; +# elif defined(__MINGW32__) +static __thread void *tls_space; +extern intptr_t _tls_index; +# else +static THREAD_LOCAL void *tls_space; +static intptr_t _tls_index = 0; +# endif +#endif + +/* + * mzscheme_main() is called early in main(). + * We may call scheme_main_setup() which calls mzscheme_env_main() which then + * trampolines into vim_main2(), which never returns. + */ + int +mzscheme_main(void) +{ + int argc = 0; + char *argv = NULL; + +#ifdef DYNAMIC_MZSCHEME + /* + * Racket requires trampolined startup. We can not load it later. + * If dynamic dll loading is failed, disable it. + */ + if (!mzscheme_enabled(FALSE)) + { + disabled = TRUE; + return vim_main2(); + } +#endif +#ifdef HAVE_TLS_SPACE + scheme_register_tls_space(&tls_space, _tls_index); +#endif +#ifdef TRAMPOLINED_MZVIM_STARTUP + return scheme_main_setup(TRUE, mzscheme_env_main, argc, &argv); +#else + return mzscheme_env_main(NULL, argc, &argv); +#endif +} + + static int +mzscheme_env_main(Scheme_Env *env, int argc UNUSED, char **argv UNUSED) +{ +#ifdef TRAMPOLINED_MZVIM_STARTUP + /* Scheme has created the environment for us */ + environment = env; +#else +# ifdef MZ_PRECISE_GC + Scheme_Object *dummy = NULL; + MZ_GC_DECL_REG(1); + MZ_GC_VAR_IN_REG(0, dummy); + + stack_base = &__gc_var_stack__; +# else + int dummy = 0; + stack_base = (void *)&dummy; +# endif +#endif + + vim_main2(); + /* not reached, vim_main2() will loop until exit() */ + + return 0; +} + + static Scheme_Object* +load_base_module(void *data) +{ + scheme_namespace_require(scheme_intern_symbol((char *)data)); + return scheme_null; +} + + static Scheme_Object * +load_base_module_on_error(void *data UNUSED) +{ + load_base_module_failed = TRUE; + return scheme_null; +} + + static int +startup_mzscheme(void) +{ +#ifndef TRAMPOLINED_MZVIM_STARTUP + scheme_set_stack_base(stack_base, 1); +#endif + +#ifndef TRAMPOLINED_MZVIM_STARTUP + /* in newer versions of precise GC the initial env has been created */ + environment = scheme_basic_env(); +#endif + + MZ_REGISTER_STATIC(environment); + MZ_REGISTER_STATIC(curout); + MZ_REGISTER_STATIC(curerr); + MZ_REGISTER_STATIC(exn_catching_apply); + MZ_REGISTER_STATIC(exn_p); + MZ_REGISTER_STATIC(exn_message); + MZ_REGISTER_STATIC(vim_exn); + + MZ_GC_CHECK(); + +#ifdef INCLUDE_MZSCHEME_BASE + /* invoke function from generated and included mzscheme_base.c */ + declare_modules(environment); +#endif + + /* setup 'current-library-collection-paths' parameter */ +# if MZSCHEME_VERSION_MAJOR >= 299 + { + Scheme_Object *coll_path = NULL; + int mustfree = FALSE; + char_u *s; + + MZ_GC_DECL_REG(1); + MZ_GC_VAR_IN_REG(0, coll_path); + MZ_GC_REG(); + /* workaround for dynamic loading on windows */ + s = vim_getenv((char_u *)"PLTCOLLECTS", &mustfree); + if (s != NULL) + { + coll_path = scheme_make_path((char *)s); + MZ_GC_CHECK(); + if (mustfree) + vim_free(s); + } +# ifdef MZSCHEME_COLLECTS + if (coll_path == NULL) + { + coll_path = scheme_make_path(MZSCHEME_COLLECTS); + MZ_GC_CHECK(); + } +# endif + if (coll_path != NULL) + { + scheme_set_collects_path(coll_path); + MZ_GC_CHECK(); + } + MZ_GC_UNREG(); + } +# else +# ifdef MZSCHEME_COLLECTS + { + Scheme_Object *coll_string = NULL; + Scheme_Object *coll_pair = NULL; + Scheme_Config *config = NULL; + + MZ_GC_DECL_REG(3); + MZ_GC_VAR_IN_REG(0, coll_string); + MZ_GC_VAR_IN_REG(1, coll_pair); + MZ_GC_VAR_IN_REG(2, config); + MZ_GC_REG(); + coll_string = scheme_make_byte_string(MZSCHEME_COLLECTS); + MZ_GC_CHECK(); + coll_pair = scheme_make_pair(coll_string, scheme_null); + MZ_GC_CHECK(); + config = scheme_current_config(); + MZ_GC_CHECK(); + scheme_set_param(config, MZCONFIG_COLLECTION_PATHS, coll_pair); + MZ_GC_CHECK(); + MZ_GC_UNREG(); + } +# endif +#endif + +# if MZSCHEME_VERSION_MAJOR >= 600 + { + Scheme_Object *config_path = NULL; + int mustfree = FALSE; + char_u *s; + + MZ_GC_DECL_REG(1); + MZ_GC_VAR_IN_REG(0, config_path); + MZ_GC_REG(); + /* workaround for dynamic loading on windows */ + s = vim_getenv((char_u *)"PLTCONFIGDIR", &mustfree); + if (s != NULL) + { + config_path = scheme_make_path((char *)s); + MZ_GC_CHECK(); + if (mustfree) + vim_free(s); + } +#ifdef MZSCHEME_CONFIGDIR + if (config_path == NULL) + { + config_path = scheme_make_path(MZSCHEME_CONFIGDIR); + MZ_GC_CHECK(); + } +#endif + if (config_path != NULL) + { + scheme_set_config_path(config_path); + MZ_GC_CHECK(); + } + MZ_GC_UNREG(); + } +# endif + +#if MZSCHEME_VERSION_MAJOR >= 400 + scheme_init_collection_paths(environment, scheme_null); +#endif + + /* + * versions 4.x do not provide Scheme bindings by default + * we need to add them explicitly + */ + { + /* use error handler to avoid abort */ + scheme_dynamic_wind(NULL, load_base_module, NULL, + load_base_module_on_error, "racket/base"); + if (load_base_module_failed) + { + load_base_module_failed = FALSE; + scheme_dynamic_wind(NULL, load_base_module, NULL, + load_base_module_on_error, "scheme/base"); + if (load_base_module_failed) + return -1; + } + } + + register_vim_exn(); + /* use new environment to initialise exception handling */ + init_exn_catching_apply(); + + /* redirect output */ + scheme_console_output = do_output; + scheme_console_printf = do_printf; + +#ifdef HAVE_SANDBOX + { + Scheme_Object *make_security_guard = NULL; + MZ_GC_DECL_REG(1); + MZ_GC_VAR_IN_REG(0, make_security_guard); + MZ_GC_REG(); + +#if MZSCHEME_VERSION_MAJOR < 400 + { + Scheme_Object *make_security_guard_symbol = NULL; + MZ_GC_DECL_REG(1); + MZ_GC_VAR_IN_REG(0, make_security_guard_symbol); + MZ_GC_REG(); + make_security_guard_symbol = scheme_intern_symbol("make-security-guard"); + MZ_GC_CHECK(); + make_security_guard = scheme_lookup_global( + make_security_guard_symbol, environment); + MZ_GC_UNREG(); + } +#else + make_security_guard = scheme_builtin_value("make-security-guard"); + MZ_GC_CHECK(); +#endif + + /* setup sandbox guards */ + if (make_security_guard != NULL) + { + Scheme_Object *args[3] = {NULL, NULL, NULL}; + Scheme_Object *guard = NULL; + Scheme_Config *config = NULL; + MZ_GC_DECL_REG(5); + MZ_GC_ARRAY_VAR_IN_REG(0, args, 3); + MZ_GC_VAR_IN_REG(3, guard); + MZ_GC_VAR_IN_REG(4, config); + MZ_GC_REG(); + config = scheme_current_config(); + MZ_GC_CHECK(); + args[0] = scheme_get_param(config, MZCONFIG_SECURITY_GUARD); + MZ_GC_CHECK(); + args[1] = scheme_make_prim_w_arity(sandbox_file_guard, + "sandbox-file-guard", 3, 3); + args[2] = scheme_make_prim_w_arity(sandbox_network_guard, + "sandbox-network-guard", 4, 4); + guard = scheme_apply(make_security_guard, 3, args); + MZ_GC_CHECK(); + scheme_set_param(config, MZCONFIG_SECURITY_GUARD, guard); + MZ_GC_CHECK(); + MZ_GC_UNREG(); + } + MZ_GC_UNREG(); + } +#endif + /* Create buffer and window types for use in Scheme code */ + mz_buffer_type = scheme_make_type(""); + MZ_GC_CHECK(); + mz_window_type = scheme_make_type(""); + MZ_GC_CHECK(); +#ifdef MZ_PRECISE_GC + GC_register_traversers(mz_buffer_type, + buffer_size_proc, buffer_mark_proc, buffer_fixup_proc, + TRUE, TRUE); + GC_register_traversers(mz_window_type, + window_size_proc, window_mark_proc, window_fixup_proc, + TRUE, TRUE); +#endif + + make_modules(); + + /* + * setup callback to receive notifications + * whether thread scheduling is (or not) required + */ + scheme_notify_multithread = notify_multithread; + + return 0; +} + +/* + * This routine is called for each new invocation of MzScheme + * to make sure things are properly initialized. + */ + static int +mzscheme_init(void) +{ + if (!initialized) + { +#ifdef DYNAMIC_MZSCHEME + if (disabled || !mzscheme_enabled(TRUE)) + { + emsg(_("E815: Sorry, this command is disabled, the MzScheme libraries could not be loaded.")); + return -1; + } +#endif + if (load_base_module_failed || startup_mzscheme()) + { + emsg(_("E895: Sorry, this command is disabled, the MzScheme's racket/base module could not be loaded.")); + return -1; + } + initialized = TRUE; + } + { + Scheme_Config *config = NULL; + MZ_GC_DECL_REG(1); + MZ_GC_VAR_IN_REG(0, config); + MZ_GC_REG(); + config = scheme_current_config(); + MZ_GC_CHECK(); + /* recreate ports each call effectively clearing these ones */ + curout = scheme_make_byte_string_output_port(); + MZ_GC_CHECK(); + curerr = scheme_make_byte_string_output_port(); + MZ_GC_CHECK(); + scheme_set_param(config, MZCONFIG_OUTPUT_PORT, curout); + MZ_GC_CHECK(); + scheme_set_param(config, MZCONFIG_ERROR_PORT, curerr); + MZ_GC_CHECK(); + MZ_GC_UNREG(); + } + + return 0; +} + +/* + *======================================================================== + * 2. External Interface + *======================================================================== + */ + +/* + * Evaluate command with exception handling + */ + static int +eval_with_exn_handling(void *data, Scheme_Closed_Prim *what, Scheme_Object **ret) +{ + Scheme_Object *value = NULL; + Scheme_Object *exn = NULL; + Scheme_Object *prim = NULL; + + MZ_GC_DECL_REG(3); + MZ_GC_VAR_IN_REG(0, value); + MZ_GC_VAR_IN_REG(1, exn); + MZ_GC_VAR_IN_REG(2, prim); + MZ_GC_REG(); + + prim = scheme_make_closed_prim_w_arity(what, data, "mzvim", 0, 0); + MZ_GC_CHECK(); + value = _apply_thunk_catch_exceptions(prim, &exn); + MZ_GC_CHECK(); + + if (!value) + { + value = extract_exn_message(exn); + /* Got an exn? */ + if (value) + { + scheme_display(value, curerr); /* Send to stderr-vim */ + MZ_GC_CHECK(); + do_flush(); + } + MZ_GC_UNREG(); + /* `raise' was called on some arbitrary value */ + return FAIL; + } + + if (ret != NULL) /* if pointer to retval supported give it up */ + *ret = value; + /* Print any result, as long as it's not a void */ + else if (!SCHEME_VOIDP(value)) + { + scheme_display(value, curout); /* Send to stdout-vim */ + MZ_GC_CHECK(); + } + + do_flush(); + MZ_GC_UNREG(); + return OK; +} + +/* :mzscheme */ + static int +do_mzscheme_command(exarg_T *eap, void *data, Scheme_Closed_Prim *what) +{ + if (mzscheme_init()) + return FAIL; + + range_start = eap->line1; + range_end = eap->line2; + + return eval_with_exn_handling(data, what, NULL); +} + +/* + * Routine called by VIM when deleting a buffer + */ + void +mzscheme_buffer_free(buf_T *buf) +{ + if (buf->b_mzscheme_ref) + { + vim_mz_buffer *bp = NULL; + MZ_GC_DECL_REG(1); + MZ_GC_VAR_IN_REG(0, bp); + MZ_GC_REG(); + + bp = BUFFER_REF(buf); + bp->buf = INVALID_BUFFER_VALUE; +#ifndef MZ_PRECISE_GC + scheme_gc_ptr_ok(bp); +#else + scheme_free_immobile_box(buf->b_mzscheme_ref); +#endif + buf->b_mzscheme_ref = NULL; + MZ_GC_CHECK(); + MZ_GC_UNREG(); + } +} + +/* + * Routine called by VIM when deleting a Window + */ + void +mzscheme_window_free(win_T *win) +{ + if (win->w_mzscheme_ref) + { + vim_mz_window *wp = NULL; + MZ_GC_DECL_REG(1); + MZ_GC_VAR_IN_REG(0, wp); + MZ_GC_REG(); + wp = WINDOW_REF(win); + wp->win = INVALID_WINDOW_VALUE; +#ifndef MZ_PRECISE_GC + scheme_gc_ptr_ok(wp); +#else + scheme_free_immobile_box(win->w_mzscheme_ref); +#endif + win->w_mzscheme_ref = NULL; + MZ_GC_CHECK(); + MZ_GC_UNREG(); + } +} + +/* + * ":mzscheme" (or ":mz") + */ + void +ex_mzscheme(exarg_T *eap) +{ + char_u *script; + + script = script_get(eap, eap->arg); + if (!eap->skip) + { + if (script == NULL) + do_mzscheme_command(eap, eap->arg, do_eval); + else + { + do_mzscheme_command(eap, script, do_eval); + vim_free(script); + } + } +} + + static Scheme_Object * +do_load(void *data, int noargc UNUSED, Scheme_Object **noargv UNUSED) +{ + Scheme_Object *expr = NULL; + Scheme_Object *result = NULL; + char *file = NULL; + Port_Info *pinfo = (Port_Info *)data; + + MZ_GC_DECL_REG(3); + MZ_GC_VAR_IN_REG(0, expr); + MZ_GC_VAR_IN_REG(1, result); + MZ_GC_VAR_IN_REG(2, file); + MZ_GC_REG(); + + file = (char *)scheme_malloc_fail_ok(scheme_malloc_atomic, MAXPATHL + 1); + MZ_GC_CHECK(); + + /* make Vim expansion */ + expand_env((char_u *)pinfo->name, (char_u *)file, MAXPATHL); + pinfo->port = scheme_open_input_file(file, "mzfile"); + MZ_GC_CHECK(); + scheme_count_lines(pinfo->port); /* to get accurate read error location*/ + MZ_GC_CHECK(); + + /* Like REPL but print only last result */ + while (!SCHEME_EOFP(expr = scheme_read(pinfo->port))) + { + result = scheme_eval(expr, environment); + MZ_GC_CHECK(); + } + + /* errors will be caught in do_mzscheme_command and ex_mzfile */ + scheme_close_input_port(pinfo->port); + MZ_GC_CHECK(); + pinfo->port = NULL; + MZ_GC_UNREG(); + return result; +} + +/* :mzfile */ + void +ex_mzfile(exarg_T *eap) +{ + Port_Info pinfo = {NULL, NULL}; + + MZ_GC_DECL_REG(1); + MZ_GC_VAR_IN_REG(0, pinfo.port); + MZ_GC_REG(); + + pinfo.name = (char *)eap->arg; + if (do_mzscheme_command(eap, &pinfo, do_load) != OK + && pinfo.port != NULL) /* looks like port was not closed */ + { + scheme_close_input_port(pinfo.port); + MZ_GC_CHECK(); + } + MZ_GC_UNREG(); +} + + +/* + *======================================================================== + * Exception handling code -- cribbed form the MzScheme sources and + * Matthew Flatt's "Inside PLT MzScheme" document. + *======================================================================== + */ + static void +init_exn_catching_apply(void) +{ + if (!exn_catching_apply) + { + char *e = + "(lambda (thunk) " + "(with-handlers ([void (lambda (exn) (cons #f exn))]) " + "(cons #t (thunk))))"; + + exn_catching_apply = scheme_eval_string(e, environment); + MZ_GC_CHECK(); + exn_p = scheme_builtin_value("exn?"); + MZ_GC_CHECK(); + exn_message = scheme_builtin_value("exn-message"); + MZ_GC_CHECK(); + } +} + +/* + * This function applies a thunk, returning the Scheme value if there's + * no exception, otherwise returning NULL and setting *exn to the raised + * value (usually an exn structure). + */ + static Scheme_Object * +_apply_thunk_catch_exceptions(Scheme_Object *f, Scheme_Object **exn) +{ + Scheme_Object *v; + + v = _scheme_apply(exn_catching_apply, 1, &f); + /* v is a pair: (cons #t value) or (cons #f exn) */ + + if (SCHEME_TRUEP(SCHEME_CAR(v))) + return SCHEME_CDR(v); + else + { + *exn = SCHEME_CDR(v); + return NULL; + } +} + + static Scheme_Object * +extract_exn_message(Scheme_Object *v) +{ + if (SCHEME_TRUEP(_scheme_apply(exn_p, 1, &v))) + return _scheme_apply(exn_message, 1, &v); + else + return NULL; /* Not an exn structure */ +} + + static Scheme_Object * +do_eval(void *s, int noargc UNUSED, Scheme_Object **noargv UNUSED) +{ + return scheme_eval_string_all((char *)s, environment, TRUE); +} + +/* + *======================================================================== + * 3. MzScheme I/O Handlers + *======================================================================== + */ + static void +do_intrnl_output(char *mesg, int error) +{ + char *p, *prev; + + prev = mesg; + p = strchr(prev, '\n'); + while (p) + { + *p = '\0'; + if (error) + emsg(prev); + else + msg(prev); + prev = p + 1; + p = strchr(prev, '\n'); + } + + if (error) + emsg(prev); + else + msg(prev); +} + + static void +do_output(char *mesg, OUTPUT_LEN_TYPE len UNUSED) +{ + /* TODO: use len, the string may not be NUL terminated */ + do_intrnl_output(mesg, 0); +} + + static void +do_err_output(char *mesg) +{ + do_intrnl_output(mesg, 1); +} + + static void +do_printf(char *format, ...) +{ + do_intrnl_output(format, 1); +} + + static void +do_flush(void) +{ + char *buff; + OUTPUT_LEN_TYPE length; + + buff = scheme_get_sized_byte_string_output(curerr, &length); + MZ_GC_CHECK(); + if (length) + { + do_err_output(buff); + return; + } + + buff = scheme_get_sized_byte_string_output(curout, &length); + MZ_GC_CHECK(); + if (length) + do_output(buff, length); +} + +/* + *======================================================================== + * 4. Implementation of the Vim Features for MzScheme + *======================================================================== + */ + +/* (command {command-string}) */ + static Scheme_Object * +vim_command(void *data, int argc, Scheme_Object **argv) +{ + Vim_Prim *prim = (Vim_Prim *)data; + Scheme_Object *cmd = NULL; + MZ_GC_DECL_REG(1); + MZ_GC_VAR_IN_REG(0, cmd); + MZ_GC_REG(); + cmd = GUARANTEED_STRING_ARG(prim->name, 0); + + /* may be use do_cmdline_cmd? */ + do_cmdline(BYTE_STRING_VALUE(cmd), NULL, NULL, DOCMD_NOWAIT|DOCMD_VERBOSE); + update_screen(VALID); + + MZ_GC_UNREG(); + raise_if_error(); + return scheme_void; +} + +/* (eval {expr-string}) */ + static Scheme_Object * +vim_eval(void *data UNUSED, int argc UNUSED, Scheme_Object **argv UNUSED) +{ +#ifdef FEAT_EVAL + Vim_Prim *prim = (Vim_Prim *)data; + Scheme_Object *result = NULL; + typval_T *vim_result; + Scheme_Object *expr = NULL; + MZ_GC_DECL_REG(2); + MZ_GC_VAR_IN_REG(0, result); + MZ_GC_VAR_IN_REG(1, expr); + MZ_GC_REG(); + expr = GUARANTEED_STRING_ARG(prim->name, 0); + + vim_result = eval_expr(BYTE_STRING_VALUE(expr), NULL); + + if (vim_result == NULL) + raise_vim_exn(_("invalid expression")); + + result = vim_to_mzscheme(vim_result); + MZ_GC_CHECK(); + free_tv(vim_result); + + MZ_GC_UNREG(); + return result; +#else + raise_vim_exn(_("expressions disabled at compile time")); + /* unreachable */ + return scheme_false; +#endif +} + +/* (range-start) */ + static Scheme_Object * +get_range_start(void *data UNUSED, int argc UNUSED, Scheme_Object **argv UNUSED) +{ + return scheme_make_integer(range_start); +} + +/* (range-end) */ + static Scheme_Object * +get_range_end(void *data UNUSED, int argc UNUSED, Scheme_Object **argv UNUSED) +{ + return scheme_make_integer(range_end); +} + +/* (beep) */ + static Scheme_Object * +mzscheme_beep(void *data UNUSED, int argc UNUSED, Scheme_Object **argv UNUSED) +{ + vim_beep(BO_LANG); + return scheme_void; +} + +static Scheme_Object *M_global = NULL; + +/* (get-option {option-name}) [buffer/window] */ + static Scheme_Object * +get_option(void *data, int argc, Scheme_Object **argv) +{ + Vim_Prim *prim = (Vim_Prim *)data; + long value; + char *strval; + int rc; + Scheme_Object *rval = NULL; + Scheme_Object *name = NULL; + int opt_flags = 0; + buf_T *save_curb = curbuf; + win_T *save_curw = curwin; + + MZ_GC_DECL_REG(2); + MZ_GC_VAR_IN_REG(0, rval); + MZ_GC_VAR_IN_REG(1, name); + MZ_GC_REG(); + + name = GUARANTEED_STRING_ARG(prim->name, 0); + + if (argc > 1) + { + if (M_global == NULL) + { + MZ_REGISTER_STATIC(M_global); + M_global = scheme_intern_symbol("global"); + MZ_GC_CHECK(); + } + + if (argv[1] == M_global) + opt_flags = OPT_GLOBAL; + else if (SCHEME_VIMBUFFERP(argv[1])) + { + curbuf = get_valid_buffer(argv[1]); + opt_flags = OPT_LOCAL; + } + else if (SCHEME_VIMWINDOWP(argv[1])) + { + win_T *win = get_valid_window(argv[1]); + + curwin = win; + curbuf = win->w_buffer; + opt_flags = OPT_LOCAL; + } + else + scheme_wrong_type(prim->name, "vim-buffer/window", 1, argc, argv); + } + + rc = get_option_value(BYTE_STRING_VALUE(name), &value, (char_u **)&strval, opt_flags); + curbuf = save_curb; + curwin = save_curw; + + switch (rc) + { + case 1: + MZ_GC_UNREG(); + return scheme_make_integer_value(value); + case 0: + rval = scheme_make_byte_string(strval); + MZ_GC_CHECK(); + vim_free(strval); + MZ_GC_UNREG(); + return rval; + case -1: + case -2: + MZ_GC_UNREG(); + raise_vim_exn(_("hidden option")); + case -3: + MZ_GC_UNREG(); + raise_vim_exn(_("unknown option")); + } + /* unreachable */ + return scheme_void; +} + +/* (set-option {option-changing-string} [buffer/window]) */ + static Scheme_Object * +set_option(void *data, int argc, Scheme_Object **argv) +{ + char_u *command = NULL; + int opt_flags = 0; + buf_T *save_curb = curbuf; + win_T *save_curw = curwin; + Vim_Prim *prim = (Vim_Prim *)data; + Scheme_Object *cmd = NULL; + + MZ_GC_DECL_REG(1); + MZ_GC_VAR_IN_REG(0, cmd); + MZ_GC_REG(); + cmd = GUARANTEED_STRING_ARG(prim->name, 0); + + if (argc > 1) + { + if (M_global == NULL) + { + MZ_REGISTER_STATIC(M_global); + M_global = scheme_intern_symbol("global"); + MZ_GC_CHECK(); + } + + if (argv[1] == M_global) + opt_flags = OPT_GLOBAL; + else if (SCHEME_VIMBUFFERP(argv[1])) + { + curbuf = get_valid_buffer(argv[1]); + opt_flags = OPT_LOCAL; + } + else if (SCHEME_VIMWINDOWP(argv[1])) + { + win_T *win = get_valid_window(argv[1]); + curwin = win; + curbuf = win->w_buffer; + opt_flags = OPT_LOCAL; + } + else + scheme_wrong_type(prim->name, "vim-buffer/window", 1, argc, argv); + } + + /* do_set can modify cmd, make copy */ + command = vim_strsave(BYTE_STRING_VALUE(cmd)); + MZ_GC_UNREG(); + do_set(command, opt_flags); + vim_free(command); + update_screen(NOT_VALID); + curbuf = save_curb; + curwin = save_curw; + raise_if_error(); + return scheme_void; +} + +/* + *=========================================================================== + * 5. Vim Window-related Manipulation Functions + *=========================================================================== + */ + +/* (curr-win) */ + static Scheme_Object * +get_curr_win(void *data UNUSED, int argc UNUSED, Scheme_Object **argv UNUSED) +{ + return (Scheme_Object *)get_vim_curr_window(); +} + +/* (win-count) */ + static Scheme_Object * +get_window_count(void *data UNUSED, int argc UNUSED, Scheme_Object **argv UNUSED) +{ + int n = 0; + win_T *w; + + FOR_ALL_WINDOWS(w) + ++n; + return scheme_make_integer(n); +} + +/* (get-win-list [buffer]) */ + static Scheme_Object * +get_window_list(void *data, int argc, Scheme_Object **argv) +{ + Vim_Prim *prim = (Vim_Prim *)data; + vim_mz_buffer *buf; + Scheme_Object *list; + win_T *w = firstwin; + + buf = get_buffer_arg(prim->name, 0, argc, argv); + list = scheme_null; + + for ( ; w != NULL; w = w->w_next) + if (w->w_buffer == buf->buf) + { + list = scheme_make_pair(window_new(w), list); + MZ_GC_CHECK(); + } + + return list; +} + + static Scheme_Object * +window_new(win_T *win) +{ + vim_mz_window *self = NULL; + + MZ_GC_DECL_REG(1); + MZ_GC_VAR_IN_REG(0, self); + + /* We need to handle deletion of windows underneath us. + * If we add a "w_mzscheme_ref" field to the win_T structure, + * then we can get at it in win_free() in vim. + * + * On a win_free() we set the Scheme object's win_T *field + * to an invalid value. We trap all uses of a window + * object, and reject them if the win_T *field is invalid. + */ + if (win->w_mzscheme_ref != NULL) + return (Scheme_Object *)WINDOW_REF(win); + + MZ_GC_REG(); + self = scheme_malloc_fail_ok(scheme_malloc_tagged, sizeof(vim_mz_window)); + vim_memset(self, 0, sizeof(vim_mz_window)); +#ifndef MZ_PRECISE_GC + scheme_dont_gc_ptr(self); /* because win isn't visible to GC */ +#else + win->w_mzscheme_ref = scheme_malloc_immobile_box(NULL); +#endif + MZ_GC_CHECK(); + WINDOW_REF(win) = self; + MZ_GC_CHECK(); + self->win = win; + self->so.type = mz_window_type; + + MZ_GC_UNREG(); + return (Scheme_Object *)self; +} + +/* (get-win-num [window]) */ + static Scheme_Object * +get_window_num(void *data UNUSED, int argc UNUSED, Scheme_Object **argv UNUSED) +{ + int nr = 1; + Vim_Prim *prim = (Vim_Prim *)data; + win_T *win = get_window_arg(prim->name, 0, argc, argv)->win; + win_T *wp; + + for (wp = firstwin; wp != win; wp = wp->w_next) + ++nr; + + return scheme_make_integer(nr); +} + +/* (get-win-by-num {windownum}) */ + static Scheme_Object * +get_window_by_num(void *data, int argc, Scheme_Object **argv) +{ + Vim_Prim *prim = (Vim_Prim *)data; + win_T *win = firstwin; + int fnum; + + fnum = SCHEME_INT_VAL(GUARANTEE_INTEGER(prim->name, 0)); + if (fnum < 1) + scheme_signal_error(_("window index is out of range")); + + for ( ; win != NULL; win = win->w_next, --fnum) + if (fnum == 1) /* to be 1-based */ + return window_new(win); + + return scheme_false; +} + +/* (get-win-buffer [window]) */ + static Scheme_Object * +get_window_buffer(void *data, int argc, Scheme_Object **argv) +{ + Vim_Prim *prim = (Vim_Prim *)data; + vim_mz_window *win = get_window_arg(prim->name, 0, argc, argv); + + return buffer_new(win->win->w_buffer); +} + +/* (get-win-height [window]) */ + static Scheme_Object * +get_window_height(void *data, int argc, Scheme_Object **argv) +{ + Vim_Prim *prim = (Vim_Prim *)data; + vim_mz_window *win = get_window_arg(prim->name, 0, argc, argv); + + return scheme_make_integer(win->win->w_height); +} + +/* (set-win-height {height} [window]) */ + static Scheme_Object * +set_window_height(void *data, int argc, Scheme_Object **argv) +{ + Vim_Prim *prim = (Vim_Prim *)data; + vim_mz_window *win; + win_T *savewin; + int height; + + win = get_window_arg(prim->name, 1, argc, argv); + height = SCHEME_INT_VAL(GUARANTEE_INTEGER(prim->name, 0)); + +#ifdef FEAT_GUI + need_mouse_correct = TRUE; +#endif + + savewin = curwin; + curwin = win->win; + win_setheight(height); + curwin = savewin; + + raise_if_error(); + return scheme_void; +} + +/* (get-win-width [window]) */ + static Scheme_Object * +get_window_width(void *data, int argc, Scheme_Object **argv) +{ + Vim_Prim *prim = (Vim_Prim *)data; + vim_mz_window *win = get_window_arg(prim->name, 0, argc, argv); + + return scheme_make_integer(win->win->w_width); +} + +/* (set-win-width {width} [window]) */ + static Scheme_Object * +set_window_width(void *data, int argc, Scheme_Object **argv) +{ + Vim_Prim *prim = (Vim_Prim *)data; + vim_mz_window *win; + win_T *savewin; + int width = 0; + + win = get_window_arg(prim->name, 1, argc, argv); + width = SCHEME_INT_VAL(GUARANTEE_INTEGER(prim->name, 0)); + +# ifdef FEAT_GUI + need_mouse_correct = TRUE; +# endif + + savewin = curwin; + curwin = win->win; + win_setwidth(width); + curwin = savewin; + + raise_if_error(); + return scheme_void; +} + +/* (get-cursor [window]) -> (line . col) */ + static Scheme_Object * +get_cursor(void *data, int argc, Scheme_Object **argv) +{ + Vim_Prim *prim = (Vim_Prim *)data; + vim_mz_window *win; + pos_T pos; + + win = get_window_arg(prim->name, 0, argc, argv); + pos = win->win->w_cursor; + return scheme_make_pair(scheme_make_integer_value((long)pos.lnum), + scheme_make_integer_value((long)pos.col + 1)); +} + +/* (set-cursor (line . col) [window]) */ + static Scheme_Object * +set_cursor(void *data, int argc, Scheme_Object **argv) +{ + Vim_Prim *prim = (Vim_Prim *)data; + vim_mz_window *win; + long lnum = 0; + long col = 0; + +#ifdef HAVE_SANDBOX + sandbox_check(); +#endif + win = get_window_arg(prim->name, 1, argc, argv); + GUARANTEE_PAIR(prim->name, 0); + + if (!SCHEME_INTP(SCHEME_CAR(argv[0])) + || !SCHEME_INTP(SCHEME_CDR(argv[0]))) + scheme_wrong_type(prim->name, "integer pair", 0, argc, argv); + + lnum = SCHEME_INT_VAL(SCHEME_CAR(argv[0])); + col = SCHEME_INT_VAL(SCHEME_CDR(argv[0])) - 1; + + check_line_range(lnum, win->win->w_buffer); + /* don't know how to catch invalid column value */ + + win->win->w_cursor.lnum = lnum; + win->win->w_cursor.col = col; + win->win->w_set_curswant = TRUE; + update_screen(VALID); + + raise_if_error(); + return scheme_void; +} +/* + *=========================================================================== + * 6. Vim Buffer-related Manipulation Functions + *=========================================================================== + */ + +/* (open-buff {filename}) */ + static Scheme_Object * +mzscheme_open_buffer(void *data, int argc, Scheme_Object **argv) +{ + Vim_Prim *prim = (Vim_Prim *)data; + int num = 0; + Scheme_Object *onum = NULL; + Scheme_Object *buf = NULL; + Scheme_Object *fname; + + MZ_GC_DECL_REG(3); + MZ_GC_VAR_IN_REG(0, onum); + MZ_GC_VAR_IN_REG(1, buf); + MZ_GC_VAR_IN_REG(2, fname); + MZ_GC_REG(); + fname = GUARANTEED_STRING_ARG(prim->name, 0); + +#ifdef HAVE_SANDBOX + sandbox_check(); +#endif + /* TODO make open existing file */ + num = buflist_add(BYTE_STRING_VALUE(fname), BLN_LISTED | BLN_CURBUF); + + if (num == 0) + raise_vim_exn(_("couldn't open buffer")); + + onum = scheme_make_integer(num); + buf = get_buffer_by_num(data, 1, &onum); + MZ_GC_UNREG(); + return buf; +} + +/* (get-buff-by-num {buffernum}) */ + static Scheme_Object * +get_buffer_by_num(void *data, int argc, Scheme_Object **argv) +{ + Vim_Prim *prim = (Vim_Prim *)data; + buf_T *buf; + int fnum; + + fnum = SCHEME_INT_VAL(GUARANTEE_INTEGER(prim->name, 0)); + + FOR_ALL_BUFFERS(buf) + if (buf->b_fnum == fnum) + return buffer_new(buf); + + return scheme_false; +} + +/* (get-buff-by-name {buffername}) */ + static Scheme_Object * +get_buffer_by_name(void *data, int argc, Scheme_Object **argv) +{ + Vim_Prim *prim = (Vim_Prim *)data; + buf_T *buf; + Scheme_Object *buffer = NULL; + Scheme_Object *fname = NULL; + + MZ_GC_DECL_REG(2); + MZ_GC_VAR_IN_REG(0, buffer); + MZ_GC_VAR_IN_REG(1, fname); + MZ_GC_REG(); + fname = GUARANTEED_STRING_ARG(prim->name, 0); + buffer = scheme_false; + + FOR_ALL_BUFFERS(buf) + { + if (buf->b_ffname == NULL || buf->b_sfname == NULL) + /* empty string */ + { + if (BYTE_STRING_VALUE(fname)[0] == NUL) + buffer = buffer_new(buf); + } + else if (!fnamecmp(buf->b_ffname, BYTE_STRING_VALUE(fname)) + || !fnamecmp(buf->b_sfname, BYTE_STRING_VALUE(fname))) + { + /* either short or long filename matches */ + buffer = buffer_new(buf); + } + } + + MZ_GC_UNREG(); + return buffer; +} + +/* (get-next-buff [buffer]) */ + static Scheme_Object * +get_next_buffer(void *data, int argc, Scheme_Object **argv) +{ + Vim_Prim *prim = (Vim_Prim *)data; + buf_T *buf = get_buffer_arg(prim->name, 0, argc, argv)->buf; + + if (buf->b_next == NULL) + return scheme_false; + else + return buffer_new(buf->b_next); +} + +/* (get-prev-buff [buffer]) */ + static Scheme_Object * +get_prev_buffer(void *data, int argc, Scheme_Object **argv) +{ + Vim_Prim *prim = (Vim_Prim *)data; + buf_T *buf = get_buffer_arg(prim->name, 0, argc, argv)->buf; + + if (buf->b_prev == NULL) + return scheme_false; + else + return buffer_new(buf->b_prev); +} + +/* (get-buff-num [buffer]) */ + static Scheme_Object * +get_buffer_num(void *data, int argc, Scheme_Object **argv) +{ + Vim_Prim *prim = (Vim_Prim *)data; + vim_mz_buffer *buf = get_buffer_arg(prim->name, 0, argc, argv); + + return scheme_make_integer(buf->buf->b_fnum); +} + +/* (buff-count) */ + static Scheme_Object * +get_buffer_count(void *data UNUSED, int argc UNUSED, Scheme_Object **argv UNUSED) +{ + buf_T *b; + int n = 0; + + FOR_ALL_BUFFERS(b) ++n; + return scheme_make_integer(n); +} + +/* (get-buff-name [buffer]) */ + static Scheme_Object * +get_buffer_name(void *data, int argc, Scheme_Object **argv) +{ + Vim_Prim *prim = (Vim_Prim *)data; + vim_mz_buffer *buf = get_buffer_arg(prim->name, 0, argc, argv); + + return scheme_make_byte_string((char *)buf->buf->b_ffname); +} + +/* (curr-buff) */ + static Scheme_Object * +get_curr_buffer(void *data UNUSED, int argc UNUSED, Scheme_Object **argv UNUSED) +{ + return (Scheme_Object *)get_vim_curr_buffer(); +} + + static Scheme_Object * +buffer_new(buf_T *buf) +{ + vim_mz_buffer *self = NULL; + + MZ_GC_DECL_REG(1); + MZ_GC_VAR_IN_REG(0, self); + + /* We need to handle deletion of buffers underneath us. + * If we add a "b_mzscheme_ref" field to the buf_T structure, + * then we can get at it in buf_freeall() in vim. + */ + if (buf->b_mzscheme_ref) + return (Scheme_Object *)BUFFER_REF(buf); + + MZ_GC_REG(); + self = scheme_malloc_fail_ok(scheme_malloc_tagged, sizeof(vim_mz_buffer)); + vim_memset(self, 0, sizeof(vim_mz_buffer)); +#ifndef MZ_PRECISE_GC + scheme_dont_gc_ptr(self); /* because buf isn't visible to GC */ +#else + buf->b_mzscheme_ref = scheme_malloc_immobile_box(NULL); +#endif + MZ_GC_CHECK(); + BUFFER_REF(buf) = self; + MZ_GC_CHECK(); + self->buf = buf; + self->so.type = mz_buffer_type; + + MZ_GC_UNREG(); + return (Scheme_Object *)self; +} + +/* + * (get-buff-size [buffer]) + * + * Get the size (number of lines) in the current buffer. + */ + static Scheme_Object * +get_buffer_size(void *data, int argc, Scheme_Object **argv) +{ + Vim_Prim *prim = (Vim_Prim *)data; + vim_mz_buffer *buf = get_buffer_arg(prim->name, 0, argc, argv); + + return scheme_make_integer(buf->buf->b_ml.ml_line_count); +} + +/* + * (get-buff-line {linenr} [buffer]) + * + * Get a line from the specified buffer. The line number is + * in Vim format (1-based). The line is returned as a MzScheme + * string object. + */ + static Scheme_Object * +get_buffer_line(void *data, int argc, Scheme_Object **argv) +{ + Vim_Prim *prim = (Vim_Prim *)data; + vim_mz_buffer *buf; + int linenr; + char_u *line; + + buf = get_buffer_arg(prim->name, 1, argc, argv); + linenr = SCHEME_INT_VAL(GUARANTEE_INTEGER(prim->name, 0)); + line = ml_get_buf(buf->buf, (linenr_T)linenr, FALSE); + + raise_if_error(); + return scheme_make_byte_string((char *)line); +} + + +/* + * (get-buff-line-list {start} {end} [buffer]) + * + * Get a list of lines from the specified buffer. The line numbers + * are in Vim format (1-based). The range is from lo up to, but not + * including, hi. The list is returned as a list of string objects. + */ + static Scheme_Object * +get_buffer_line_list(void *data, int argc, Scheme_Object **argv) +{ + Vim_Prim *prim = (Vim_Prim *)data; + vim_mz_buffer *buf; + int i, hi, lo, n; + Scheme_Object *list = NULL; + + MZ_GC_DECL_REG(1); + MZ_GC_VAR_IN_REG(0, list); + MZ_GC_REG(); + + buf = get_buffer_arg(prim->name, 2, argc, argv); + list = scheme_null; + hi = SCHEME_INT_VAL(GUARANTEE_INTEGER(prim->name, 1)); + lo = SCHEME_INT_VAL(GUARANTEE_INTEGER(prim->name, 0)); + + /* + * Handle some error conditions + */ + if (lo < 0) + lo = 0; + + if (hi < 0) + hi = 0; + if (hi < lo) + hi = lo; + + n = hi - lo; + + for (i = n; i >= 0; --i) + { + Scheme_Object *str = scheme_make_byte_string( + (char *)ml_get_buf(buf->buf, (linenr_T)(lo+i), FALSE)); + raise_if_error(); + + /* Set the list item */ + list = scheme_make_pair(str, list); + MZ_GC_CHECK(); + } + MZ_GC_UNREG(); + return list; +} + +/* + * (set-buff-line {linenr} {string/#f} [buffer]) + * + * Replace a line in the specified buffer. The line number is + * in Vim format (1-based). The replacement line is given as + * an MzScheme string object. The object is checked for validity + * and correct format. An exception is thrown if the values are not + * the correct format. + * + * It returns a Scheme Object that indicates the length of the + * string changed. + */ + static Scheme_Object * +set_buffer_line(void *data, int argc, Scheme_Object **argv) +{ + /* First of all, we check the value of the supplied MzScheme object. + * There are three cases: + * 1. #f - this is a deletion. + * 2. A string - this is a replacement. + * 3. Anything else - this is an error. + */ + Vim_Prim *prim = (Vim_Prim *)data; + vim_mz_buffer *buf; + Scheme_Object *line = NULL; + char *save; + int n; + + MZ_GC_DECL_REG(1); + MZ_GC_VAR_IN_REG(0, line); + MZ_GC_REG(); + +#ifdef HAVE_SANDBOX + sandbox_check(); +#endif + n = SCHEME_INT_VAL(GUARANTEE_INTEGER(prim->name, 0)); + if (!SCHEME_STRINGP(argv[1]) && !SCHEME_FALSEP(argv[1])) + scheme_wrong_type(prim->name, "string or #f", 1, argc, argv); + line = argv[1]; + buf = get_buffer_arg(prim->name, 2, argc, argv); + + check_line_range(n, buf->buf); + + if (SCHEME_FALSEP(line)) + { + buf_T *savebuf = curbuf; + + curbuf = buf->buf; + + if (u_savedel((linenr_T)n, 1L) == FAIL) + { + curbuf = savebuf; + raise_vim_exn(_("cannot save undo information")); + } + else if (ml_delete((linenr_T)n, FALSE) == FAIL) + { + curbuf = savebuf; + raise_vim_exn(_("cannot delete line")); + } + if (buf->buf == curwin->w_buffer) + mz_fix_cursor(n, n + 1, -1); + deleted_lines_mark((linenr_T)n, 1L); + + curbuf = savebuf; + + MZ_GC_UNREG(); + raise_if_error(); + return scheme_void; + } + else + { + /* Otherwise it's a line */ + buf_T *savebuf = curbuf; + + save = string_to_line(line); + + curbuf = buf->buf; + + if (u_savesub((linenr_T)n) == FAIL) + { + curbuf = savebuf; + vim_free(save); + raise_vim_exn(_("cannot save undo information")); + } + else if (ml_replace((linenr_T)n, (char_u *)save, TRUE) == FAIL) + { + curbuf = savebuf; + vim_free(save); + raise_vim_exn(_("cannot replace line")); + } + else + { + vim_free(save); + changed_bytes((linenr_T)n, 0); + } + + curbuf = savebuf; + + /* Check that the cursor is not beyond the end of the line now. */ + if (buf->buf == curwin->w_buffer) + check_cursor_col(); + + MZ_GC_UNREG(); + raise_if_error(); + return scheme_void; + } +} + + static void +free_array(char **array) +{ + char **curr = array; + while (*curr != NULL) + vim_free(*curr++); + vim_free(array); +} + +/* + * (set-buff-line-list {start} {end} {string-list/#f/null} [buffer]) + * + * Replace a range of lines in the specified buffer. The line numbers are in + * Vim format (1-based). The range is from lo up to, but not including, hi. + * The replacement lines are given as a Scheme list of string objects. The + * list is checked for validity and correct format. + * + * Errors are returned as a value of FAIL. The return value is OK on success. + * If OK is returned and len_change is not NULL, *len_change is set to the + * change in the buffer length. + */ + static Scheme_Object * +set_buffer_line_list(void *data, int argc, Scheme_Object **argv) +{ + /* First of all, we check the type of the supplied MzScheme object. + * There are three cases: + * 1. #f - this is a deletion. + * 2. A list - this is a replacement. + * 3. Anything else - this is an error. + */ + Vim_Prim *prim = (Vim_Prim *)data; + vim_mz_buffer *buf = NULL; + Scheme_Object *line_list = NULL; + int i, old_len, new_len, hi, lo; + long extra; + + MZ_GC_DECL_REG(1); + MZ_GC_VAR_IN_REG(0, line_list); + MZ_GC_REG(); + +#ifdef HAVE_SANDBOX + sandbox_check(); +#endif + lo = SCHEME_INT_VAL(GUARANTEE_INTEGER(prim->name, 0)); + hi = SCHEME_INT_VAL(GUARANTEE_INTEGER(prim->name, 1)); + if (!SCHEME_PAIRP(argv[2]) + && !SCHEME_FALSEP(argv[2]) && !SCHEME_NULLP(argv[2])) + scheme_wrong_type(prim->name, "list or #f", 2, argc, argv); + line_list = argv[2]; + buf = get_buffer_arg(prim->name, 3, argc, argv); + old_len = hi - lo; + if (old_len < 0) /* process inverse values wisely */ + { + i = lo; + lo = hi; + hi = i; + old_len = -old_len; + } + extra = 0; + + check_line_range(lo, buf->buf); /* inclusive */ + check_line_range(hi - 1, buf->buf); /* exclusive */ + + if (SCHEME_FALSEP(line_list) || SCHEME_NULLP(line_list)) + { + buf_T *savebuf = curbuf; + curbuf = buf->buf; + + if (u_savedel((linenr_T)lo, (long)old_len) == FAIL) + { + curbuf = savebuf; + raise_vim_exn(_("cannot save undo information")); + } + else + { + for (i = 0; i < old_len; i++) + if (ml_delete((linenr_T)lo, FALSE) == FAIL) + { + curbuf = savebuf; + raise_vim_exn(_("cannot delete line")); + } + if (buf->buf == curwin->w_buffer) + mz_fix_cursor(lo, hi, -old_len); + deleted_lines_mark((linenr_T)lo, (long)old_len); + } + + curbuf = savebuf; + + MZ_GC_UNREG(); + raise_if_error(); + return scheme_void; + } + else + { + buf_T *savebuf = curbuf; + + /* List */ + new_len = scheme_proper_list_length(line_list); + MZ_GC_CHECK(); + if (new_len < 0) /* improper or cyclic list */ + scheme_wrong_type(prim->name, "proper list", + 2, argc, argv); + else + { + char **array = NULL; + Scheme_Object *line = NULL; + Scheme_Object *rest = NULL; + + MZ_GC_DECL_REG(2); + MZ_GC_VAR_IN_REG(0, line); + MZ_GC_VAR_IN_REG(1, rest); + MZ_GC_REG(); + + array = (char **)alloc((new_len+1)* sizeof(char *)); + vim_memset(array, 0, (new_len+1) * sizeof(char *)); + + rest = line_list; + for (i = 0; i < new_len; ++i) + { + line = SCHEME_CAR(rest); + rest = SCHEME_CDR(rest); + if (!SCHEME_STRINGP(line)) + { + free_array(array); + scheme_wrong_type(prim->name, "string-list", 2, argc, argv); + } + array[i] = string_to_line(line); + } + + curbuf = buf->buf; + + if (u_save((linenr_T)(lo-1), (linenr_T)hi) == FAIL) + { + curbuf = savebuf; + free_array(array); + raise_vim_exn(_("cannot save undo information")); + } + + /* + * If the size of the range is reducing (ie, new_len < old_len) we + * need to delete some old_len. We do this at the start, by + * repeatedly deleting line "lo". + */ + for (i = 0; i < old_len - new_len; ++i) + { + if (ml_delete((linenr_T)lo, FALSE) == FAIL) + { + curbuf = savebuf; + free_array(array); + raise_vim_exn(_("cannot delete line")); + } + extra--; + } + + /* + * For as long as possible, replace the existing old_len with the + * new old_len. This is a more efficient operation, as it requires + * less memory allocation and freeing. + */ + for (i = 0; i < old_len && i < new_len; i++) + if (ml_replace((linenr_T)(lo+i), (char_u *)array[i], TRUE) == FAIL) + { + curbuf = savebuf; + free_array(array); + raise_vim_exn(_("cannot replace line")); + } + + /* + * Now we may need to insert the remaining new_len. We don't need to + * free the string passed back because MzScheme has control of that + * memory. + */ + while (i < new_len) + { + if (ml_append((linenr_T)(lo + i - 1), + (char_u *)array[i], 0, FALSE) == FAIL) + { + curbuf = savebuf; + free_array(array); + raise_vim_exn(_("cannot insert line")); + } + ++i; + ++extra; + } + MZ_GC_UNREG(); + free_array(array); + } + + /* + * Adjust marks. Invalidate any which lie in the + * changed range, and move any in the remainder of the buffer. + */ + mark_adjust((linenr_T)lo, (linenr_T)(hi - 1), + (long)MAXLNUM, (long)extra); + changed_lines((linenr_T)lo, 0, (linenr_T)hi, (long)extra); + + if (buf->buf == curwin->w_buffer) + mz_fix_cursor(lo, hi, extra); + curbuf = savebuf; + + MZ_GC_UNREG(); + raise_if_error(); + return scheme_void; + } +} + +/* + * (insert-buff-line-list {linenr} {string/string-list} [buffer]) + * + * Insert a number of lines into the specified buffer after the specified line. + * The line number is in Vim format (1-based). The lines to be inserted are + * given as an MzScheme list of string objects or as a single string. The lines + * to be added are checked for validity and correct format. Errors are + * returned as a value of FAIL. The return value is OK on success. + * If OK is returned and len_change is not NULL, *len_change + * is set to the change in the buffer length. + */ + static Scheme_Object * +insert_buffer_line_list(void *data, int argc, Scheme_Object **argv) +{ + Vim_Prim *prim = (Vim_Prim *)data; + vim_mz_buffer *buf = NULL; + Scheme_Object *list = NULL; + char *str = NULL; + int i, n, size; + + MZ_GC_DECL_REG(1); + MZ_GC_VAR_IN_REG(0, list); + MZ_GC_REG(); + +#ifdef HAVE_SANDBOX + sandbox_check(); +#endif + /* + * First of all, we check the type of the supplied MzScheme object. + * It must be a string or a list, or the call is in error. + */ + n = SCHEME_INT_VAL(GUARANTEE_INTEGER(prim->name, 0)); + list = argv[1]; + + if (!SCHEME_STRINGP(list) && !SCHEME_PAIRP(list)) + scheme_wrong_type(prim->name, "string or list", 1, argc, argv); + buf = get_buffer_arg(prim->name, 2, argc, argv); + + if (n != 0) /* 0 can be used in insert */ + check_line_range(n, buf->buf); + if (SCHEME_STRINGP(list)) + { + buf_T *savebuf = curbuf; + + str = string_to_line(list); + curbuf = buf->buf; + + if (u_save((linenr_T)n, (linenr_T)(n+1)) == FAIL) + { + curbuf = savebuf; + vim_free(str); + raise_vim_exn(_("cannot save undo information")); + } + else if (ml_append((linenr_T)n, (char_u *)str, 0, FALSE) == FAIL) + { + curbuf = savebuf; + vim_free(str); + raise_vim_exn(_("cannot insert line")); + } + else + { + vim_free(str); + appended_lines_mark((linenr_T)n, 1L); + } + + curbuf = savebuf; + update_screen(VALID); + + MZ_GC_UNREG(); + raise_if_error(); + return scheme_void; + } + + /* List */ + size = scheme_proper_list_length(list); + MZ_GC_CHECK(); + if (size < 0) /* improper or cyclic list */ + scheme_wrong_type(prim->name, "proper list", + 2, argc, argv); + else + { + Scheme_Object *line = NULL; + Scheme_Object *rest = NULL; + char **array; + buf_T *savebuf = curbuf; + + MZ_GC_DECL_REG(2); + MZ_GC_VAR_IN_REG(0, line); + MZ_GC_VAR_IN_REG(1, rest); + MZ_GC_REG(); + + array = (char **)alloc((size+1) * sizeof(char *)); + vim_memset(array, 0, (size+1) * sizeof(char *)); + + rest = list; + for (i = 0; i < size; ++i) + { + line = SCHEME_CAR(rest); + rest = SCHEME_CDR(rest); + array[i] = string_to_line(line); + } + + curbuf = buf->buf; + + if (u_save((linenr_T)n, (linenr_T)(n + 1)) == FAIL) + { + curbuf = savebuf; + free_array(array); + raise_vim_exn(_("cannot save undo information")); + } + else + { + for (i = 0; i < size; ++i) + if (ml_append((linenr_T)(n + i), (char_u *)array[i], + 0, FALSE) == FAIL) + { + curbuf = savebuf; + free_array(array); + raise_vim_exn(_("cannot insert line")); + } + + if (i > 0) + appended_lines_mark((linenr_T)n, (long)i); + } + free_array(array); + MZ_GC_UNREG(); + curbuf = savebuf; + update_screen(VALID); + } + + MZ_GC_UNREG(); + raise_if_error(); + return scheme_void; +} + +/* + * Predicates + */ +/* (buff? obj) */ + static Scheme_Object * +vim_bufferp(void *data UNUSED, int argc UNUSED, Scheme_Object **argv) +{ + if (SCHEME_VIMBUFFERP(argv[0])) + return scheme_true; + else + return scheme_false; +} + +/* (win? obj) */ + static Scheme_Object * +vim_windowp(void *data UNUSED, int argc UNUSED, Scheme_Object **argv) +{ + if (SCHEME_VIMWINDOWP(argv[0])) + return scheme_true; + else + return scheme_false; +} + +/* (buff-valid? obj) */ + static Scheme_Object * +vim_buffer_validp(void *data UNUSED, int argc UNUSED, Scheme_Object **argv) +{ + if (SCHEME_VIMBUFFERP(argv[0]) + && ((vim_mz_buffer *)argv[0])->buf != INVALID_BUFFER_VALUE) + return scheme_true; + else + return scheme_false; +} + +/* (win-valid? obj) */ + static Scheme_Object * +vim_window_validp(void *data UNUSED, int argc UNUSED, Scheme_Object **argv) +{ + if (SCHEME_VIMWINDOWP(argv[0]) + && ((vim_mz_window *)argv[0])->win != INVALID_WINDOW_VALUE) + return scheme_true; + else + return scheme_false; +} + +/* + *=========================================================================== + * Utilities + *=========================================================================== + */ + +/* + * Convert an MzScheme string into a Vim line. + * + * All internal nulls are replaced by newline characters. + * It is an error for the string to contain newline characters. + * + * Returns pointer to Vim allocated memory + */ + static char * +string_to_line(Scheme_Object *obj) +{ + char *scheme_str = NULL; + char *vim_str = NULL; + OUTPUT_LEN_TYPE len; + int i; + + scheme_str = scheme_display_to_string(obj, &len); + + /* Error checking: String must not contain newlines, as we + * are replacing a single line, and we must replace it with + * a single line. + */ + if (memchr(scheme_str, '\n', len)) + scheme_signal_error(_("string cannot contain newlines")); + + vim_str = (char *)alloc(len + 1); + + /* Create a copy of the string, with internal nulls replaced by + * newline characters, as is the vim convention. + */ + for (i = 0; i < len; ++i) + { + if (scheme_str[i] == '\0') + vim_str[i] = '\n'; + else + vim_str[i] = scheme_str[i]; + } + + vim_str[i] = '\0'; + + MZ_GC_CHECK(); + return vim_str; +} + +#ifdef FEAT_EVAL +/* + * Convert Vim value into MzScheme, adopted from if_python.c + */ + static Scheme_Object * +vim_to_mzscheme(typval_T *vim_value) +{ + Scheme_Object *result = NULL; + /* hash table to store visited values to avoid infinite loops */ + Scheme_Hash_Table *visited = NULL; + + MZ_GC_DECL_REG(2); + MZ_GC_VAR_IN_REG(0, result); + MZ_GC_VAR_IN_REG(1, visited); + MZ_GC_REG(); + + visited = scheme_make_hash_table(SCHEME_hash_ptr); + MZ_GC_CHECK(); + + result = vim_to_mzscheme_impl(vim_value, 1, visited); + + MZ_GC_UNREG(); + return result; +} + + static Scheme_Object * +vim_to_mzscheme_impl(typval_T *vim_value, int depth, Scheme_Hash_Table *visited) +{ + Scheme_Object *result = NULL; + int new_value = TRUE; + + MZ_GC_DECL_REG(2); + MZ_GC_VAR_IN_REG(0, result); + MZ_GC_VAR_IN_REG(1, visited); + MZ_GC_REG(); + + /* Avoid infinite recursion */ + if (depth > 100) + { + MZ_GC_UNREG(); + return scheme_void; + } + + /* Check if we run into a recursive loop. The item must be in visited + * then and we can use it again. + */ + result = scheme_hash_get(visited, (Scheme_Object *)vim_value); + MZ_GC_CHECK(); + if (result != NULL) /* found, do nothing */ + new_value = FALSE; + else if (vim_value->v_type == VAR_STRING) + { + result = scheme_make_byte_string((char *)vim_value->vval.v_string); + MZ_GC_CHECK(); + } + else if (vim_value->v_type == VAR_NUMBER) + { + result = scheme_make_integer((long)vim_value->vval.v_number); + MZ_GC_CHECK(); + } +# ifdef FEAT_FLOAT + else if (vim_value->v_type == VAR_FLOAT) + { + result = scheme_make_double((double)vim_value->vval.v_float); + MZ_GC_CHECK(); + } +# endif + else if (vim_value->v_type == VAR_LIST) + { + list_T *list = vim_value->vval.v_list; + listitem_T *curr; + + if (list == NULL || list->lv_first == NULL) + result = scheme_null; + else + { + Scheme_Object *obj = NULL; + + MZ_GC_DECL_REG(1); + MZ_GC_VAR_IN_REG(0, obj); + MZ_GC_REG(); + + curr = list->lv_last; + obj = vim_to_mzscheme_impl(&curr->li_tv, depth + 1, visited); + result = scheme_make_pair(obj, scheme_null); + MZ_GC_CHECK(); + + while (curr != list->lv_first) + { + curr = curr->li_prev; + obj = vim_to_mzscheme_impl(&curr->li_tv, depth + 1, visited); + result = scheme_make_pair(obj, result); + MZ_GC_CHECK(); + } + } + MZ_GC_UNREG(); + } + else if (vim_value->v_type == VAR_DICT) + { + Scheme_Object *key = NULL; + Scheme_Object *obj = NULL; + + MZ_GC_DECL_REG(2); + MZ_GC_VAR_IN_REG(0, key); + MZ_GC_VAR_IN_REG(1, obj); + MZ_GC_REG(); + + result = (Scheme_Object *)scheme_make_hash_table(SCHEME_hash_ptr); + MZ_GC_CHECK(); + if (vim_value->vval.v_dict != NULL) + { + hashtab_T *ht = &vim_value->vval.v_dict->dv_hashtab; + long_u todo = ht->ht_used; + hashitem_T *hi; + dictitem_T *di; + + for (hi = ht->ht_array; todo > 0; ++hi) + { + if (!HASHITEM_EMPTY(hi)) + { + --todo; + + di = dict_lookup(hi); + obj = vim_to_mzscheme_impl(&di->di_tv, depth + 1, visited); + key = scheme_make_byte_string((char *)hi->hi_key); + MZ_GC_CHECK(); + scheme_hash_set((Scheme_Hash_Table *)result, key, obj); + MZ_GC_CHECK(); + } + } + } + MZ_GC_UNREG(); + } + else if (vim_value->v_type == VAR_FUNC) + { + Scheme_Object *funcname = NULL; + + MZ_GC_DECL_REG(1); + MZ_GC_VAR_IN_REG(0, funcname); + MZ_GC_REG(); + + /* FIXME: func_ref() and func_unref() are needed. */ + funcname = scheme_make_byte_string((char *)vim_value->vval.v_string); + MZ_GC_CHECK(); + result = scheme_make_closed_prim_w_arity(vim_funcref, funcname, + (const char *)BYTE_STRING_VALUE(funcname), 0, -1); + MZ_GC_CHECK(); + + MZ_GC_UNREG(); + } + else if (vim_value->v_type == VAR_PARTIAL) + { + if (vim_value->vval.v_partial == NULL) + result = scheme_null; + else + { + Scheme_Object *funcname = NULL; + + MZ_GC_DECL_REG(1); + MZ_GC_VAR_IN_REG(0, funcname); + MZ_GC_REG(); + + /* FIXME: func_ref() and func_unref() are needed. */ + /* TODO: Support pt_dict and pt_argv. */ + funcname = scheme_make_byte_string( + (char *)partial_name(vim_value->vval.v_partial)); + MZ_GC_CHECK(); + result = scheme_make_closed_prim_w_arity(vim_funcref, funcname, + (const char *)BYTE_STRING_VALUE(funcname), 0, -1); + MZ_GC_CHECK(); + + MZ_GC_UNREG(); + } + } + else if (vim_value->v_type == VAR_SPECIAL) + { + if (vim_value->vval.v_number <= VVAL_TRUE) + result = scheme_make_integer((long)vim_value->vval.v_number); + else + result = scheme_null; + MZ_GC_CHECK(); + } + else + { + result = scheme_void; + new_value = FALSE; + } + if (new_value) + { + scheme_hash_set(visited, (Scheme_Object *)vim_value, result); + MZ_GC_CHECK(); + } + MZ_GC_UNREG(); + return result; +} + + static int +mzscheme_to_vim(Scheme_Object *obj, typval_T *tv) +{ + int i, status; + Scheme_Hash_Table *visited = NULL; + + MZ_GC_DECL_REG(2); + MZ_GC_VAR_IN_REG(0, obj); + MZ_GC_VAR_IN_REG(1, visited); + MZ_GC_REG(); + + visited = scheme_make_hash_table(SCHEME_hash_ptr); + MZ_GC_CHECK(); + + status = mzscheme_to_vim_impl(obj, tv, 1, visited); + for (i = 0; i < visited->size; ++i) + { + /* free up remembered objects */ + if (visited->vals[i] != NULL) + free_tv((typval_T *)visited->vals[i]); + } + + MZ_GC_UNREG(); + return status; +} + static int +mzscheme_to_vim_impl(Scheme_Object *obj, typval_T *tv, int depth, + Scheme_Hash_Table *visited) +{ + int status = OK; + typval_T *found; + + MZ_GC_DECL_REG(2); + MZ_GC_VAR_IN_REG(0, obj); + MZ_GC_VAR_IN_REG(1, visited); + MZ_GC_REG(); + + MZ_GC_CHECK(); + if (depth > 100) /* limit the deepest recursion level */ + { + tv->v_type = VAR_NUMBER; + tv->vval.v_number = 0; + return FAIL; + } + + found = (typval_T *)scheme_hash_get(visited, obj); + if (found != NULL) + copy_tv(found, tv); + else if (SCHEME_VOIDP(obj)) + { + tv->v_type = VAR_SPECIAL; + tv->vval.v_number = VVAL_NULL; + } + else if (SCHEME_INTP(obj)) + { + tv->v_type = VAR_NUMBER; + tv->vval.v_number = SCHEME_INT_VAL(obj); + } + else if (SCHEME_BOOLP(obj)) + { + tv->v_type = VAR_SPECIAL; + tv->vval.v_number = SCHEME_TRUEP(obj); + } +# ifdef FEAT_FLOAT + else if (SCHEME_DBLP(obj)) + { + tv->v_type = VAR_FLOAT; + tv->vval.v_float = SCHEME_DBL_VAL(obj); + } +# endif + else if (SCHEME_BYTE_STRINGP(obj)) + { + tv->v_type = VAR_STRING; + tv->vval.v_string = vim_strsave(BYTE_STRING_VALUE(obj)); + } +# if MZSCHEME_VERSION_MAJOR >= 299 + else if (SCHEME_CHAR_STRINGP(obj)) + { + Scheme_Object *tmp = NULL; + MZ_GC_DECL_REG(1); + MZ_GC_VAR_IN_REG(0, tmp); + MZ_GC_REG(); + + tmp = scheme_char_string_to_byte_string(obj); + tv->v_type = VAR_STRING; + tv->vval.v_string = vim_strsave(BYTE_STRING_VALUE(tmp)); + MZ_GC_UNREG(); + } +#endif + else if (SCHEME_VECTORP(obj) || SCHEME_NULLP(obj) + || SCHEME_PAIRP(obj) || SCHEME_MUTABLE_PAIRP(obj)) + { + list_T *list = list_alloc(); + if (list == NULL) + status = FAIL; + else + { + int i; + Scheme_Object *curr = NULL; + Scheme_Object *cval = NULL; + /* temporary var to hold current element of vectors and pairs */ + typval_T *v; + + MZ_GC_DECL_REG(2); + MZ_GC_VAR_IN_REG(0, curr); + MZ_GC_VAR_IN_REG(1, cval); + MZ_GC_REG(); + + tv->v_type = VAR_LIST; + tv->vval.v_list = list; + ++list->lv_refcount; + + v = (typval_T *)alloc(sizeof(typval_T)); + if (v == NULL) + status = FAIL; + else + { + /* add the value in advance to allow handling of self-referential + * data structures */ + typval_T *visited_tv = (typval_T *)alloc(sizeof(typval_T)); + copy_tv(tv, visited_tv); + scheme_hash_set(visited, obj, (Scheme_Object *)visited_tv); + + if (SCHEME_VECTORP(obj)) + { + for (i = 0; i < SCHEME_VEC_SIZE(obj); ++i) + { + cval = SCHEME_VEC_ELS(obj)[i]; + status = mzscheme_to_vim_impl(cval, v, depth + 1, visited); + if (status == FAIL) + break; + status = list_append_tv(list, v); + clear_tv(v); + if (status == FAIL) + break; + } + } + else if (SCHEME_PAIRP(obj) || SCHEME_MUTABLE_PAIRP(obj)) + { + for (curr = obj; + SCHEME_PAIRP(curr) || SCHEME_MUTABLE_PAIRP(curr); + curr = SCHEME_CDR(curr)) + { + cval = SCHEME_CAR(curr); + status = mzscheme_to_vim_impl(cval, v, depth + 1, visited); + if (status == FAIL) + break; + status = list_append_tv(list, v); + clear_tv(v); + if (status == FAIL) + break; + } + /* improper list not terminated with null + * need to handle the last element */ + if (status == OK && !SCHEME_NULLP(curr)) + { + status = mzscheme_to_vim_impl(cval, v, depth + 1, visited); + if (status == OK) + { + status = list_append_tv(list, v); + clear_tv(v); + } + } + } + /* nothing to do for scheme_null */ + vim_free(v); + } + MZ_GC_UNREG(); + } + } + else if (SCHEME_HASHTP(obj)) + { + int i; + dict_T *dict; + Scheme_Object *key = NULL; + Scheme_Object *val = NULL; + + MZ_GC_DECL_REG(2); + MZ_GC_VAR_IN_REG(0, key); + MZ_GC_VAR_IN_REG(1, val); + MZ_GC_REG(); + + dict = dict_alloc(); + if (dict == NULL) + status = FAIL; + else + { + typval_T *visited_tv = (typval_T *)alloc(sizeof(typval_T)); + + tv->v_type = VAR_DICT; + tv->vval.v_dict = dict; + ++dict->dv_refcount; + + copy_tv(tv, visited_tv); + scheme_hash_set(visited, obj, (Scheme_Object *)visited_tv); + + for (i = 0; i < ((Scheme_Hash_Table *)obj)->size; ++i) + { + if (((Scheme_Hash_Table *) obj)->vals[i] != NULL) + { + /* generate item for `display'ed Scheme key */ + dictitem_T *item = dictitem_alloc((char_u *)string_to_line( + ((Scheme_Hash_Table *) obj)->keys[i])); + /* convert Scheme val to Vim and add it to the dict */ + if (mzscheme_to_vim_impl(((Scheme_Hash_Table *) obj)->vals[i], + &item->di_tv, depth + 1, visited) == FAIL + || dict_add(dict, item) == FAIL) + { + dictitem_free(item); + status = FAIL; + break; + } + } + + } + } + MZ_GC_UNREG(); + } + else + { + /* `display' any other value to string */ + tv->v_type = VAR_STRING; + tv->vval.v_string = (char_u *)string_to_line(obj); + } + MZ_GC_UNREG(); + return status; +} + +/* Scheme prim procedure wrapping Vim funcref */ + static Scheme_Object * +vim_funcref(void *name, int argc, Scheme_Object **argv) +{ + int i; + typval_T args; + int status = OK; + Scheme_Object *result = NULL; + list_T *list = list_alloc(); + + MZ_GC_DECL_REG(1); + MZ_GC_VAR_IN_REG(0, result); + MZ_GC_REG(); + + result = scheme_void; + if (list == NULL) + status = FAIL; + else + { + args.v_type = VAR_LIST; + args.vval.v_list = list; + ++list->lv_refcount; + for (i = 0; status == OK && i < argc; ++i) + { + typval_T *v = (typval_T *)alloc(sizeof(typval_T)); + if (v == NULL) + status = FAIL; + else + { + status = mzscheme_to_vim(argv[i], v); + if (status == OK) + { + status = list_append_tv(list, v); + clear_tv(v); + } + vim_free(v); + } + } + if (status == OK) + { + typval_T ret; + ret.v_type = VAR_UNKNOWN; + + mzscheme_call_vim(BYTE_STRING_VALUE((Scheme_Object *)name), &args, &ret); + MZ_GC_CHECK(); + result = vim_to_mzscheme(&ret); + clear_tv(&ret); + MZ_GC_CHECK(); + } + } + clear_tv(&args); + MZ_GC_UNREG(); + if (status != OK) + raise_vim_exn(_("error converting Scheme values to Vim")); + else + raise_if_error(); + return result; +} + + void +do_mzeval(char_u *str, typval_T *rettv) +{ + Scheme_Object *ret = NULL; + + MZ_GC_DECL_REG(1); + MZ_GC_VAR_IN_REG(0, ret); + MZ_GC_REG(); + + if (mzscheme_init()) + { + MZ_GC_UNREG(); + return; + } + + MZ_GC_CHECK(); + if (eval_with_exn_handling(str, do_eval, &ret) == OK) + mzscheme_to_vim(ret, rettv); + + MZ_GC_UNREG(); +} +#endif + +/* + * Check to see whether a Vim error has been reported, or a keyboard + * interrupt (from vim --> got_int) has been detected. + */ + static int +vim_error_check(void) +{ + return (got_int || did_emsg); +} + +/* + * register Scheme exn:vim + */ + static void +register_vim_exn(void) +{ + int nc = 0; + int i; + Scheme_Object *struct_exn = NULL; + Scheme_Object *exn_name = NULL; + + MZ_GC_DECL_REG(2); + MZ_GC_VAR_IN_REG(0, struct_exn); + MZ_GC_VAR_IN_REG(1, exn_name); + MZ_GC_REG(); + + exn_name = scheme_intern_symbol("exn:vim"); + MZ_GC_CHECK(); + struct_exn = scheme_builtin_value("struct:exn"); + MZ_GC_CHECK(); + + if (vim_exn == NULL) + vim_exn = scheme_make_struct_type(exn_name, + struct_exn, NULL, 0, 0, NULL, NULL +#if MZSCHEME_VERSION_MAJOR >= 299 + , NULL +#endif + ); + + + { + Scheme_Object **tmp = NULL; + Scheme_Object *exn_names[5] = {NULL, NULL, NULL, NULL, NULL}; + Scheme_Object *exn_values[5] = {NULL, NULL, NULL, NULL, NULL}; + MZ_GC_DECL_REG(6); + MZ_GC_ARRAY_VAR_IN_REG(0, exn_names, 5); + MZ_GC_ARRAY_VAR_IN_REG(3, exn_values, 5); + MZ_GC_REG(); + + tmp = scheme_make_struct_names(exn_name, scheme_null, 0, &nc); + mch_memmove(exn_names, tmp, nc * sizeof(Scheme_Object *)); + MZ_GC_CHECK(); + + tmp = scheme_make_struct_values(vim_exn, exn_names, nc, 0); + mch_memmove(exn_values, tmp, nc * sizeof(Scheme_Object *)); + MZ_GC_CHECK(); + + for (i = 0; i < nc; i++) + { + scheme_add_global_symbol(exn_names[i], + exn_values[i], environment); + MZ_GC_CHECK(); + } + MZ_GC_UNREG(); + } + MZ_GC_UNREG(); +} + +/* + * raise exn:vim, may be with additional info string + */ + void +raise_vim_exn(const char *add_info) +{ + char *fmt = _("Vim error: ~a"); + Scheme_Object *argv[2] = {NULL, NULL}; + Scheme_Object *exn = NULL; + Scheme_Object *byte_string = NULL; + + MZ_GC_DECL_REG(5); + MZ_GC_ARRAY_VAR_IN_REG(0, argv, 2); + MZ_GC_VAR_IN_REG(3, exn); + MZ_GC_VAR_IN_REG(4, byte_string); + MZ_GC_REG(); + + if (add_info != NULL) + { + char *c_string = NULL; + Scheme_Object *info = NULL; + + MZ_GC_DECL_REG(3); + MZ_GC_VAR_IN_REG(0, c_string); + MZ_GC_VAR_IN_REG(2, info); + MZ_GC_REG(); + + info = scheme_make_byte_string(add_info); + MZ_GC_CHECK(); + c_string = scheme_format_utf8(fmt, (int)STRLEN(fmt), 1, &info, NULL); + MZ_GC_CHECK(); + byte_string = scheme_make_byte_string(c_string); + MZ_GC_CHECK(); + argv[0] = scheme_byte_string_to_char_string(byte_string); + SCHEME_SET_IMMUTABLE(argv[0]); + MZ_GC_UNREG(); + } + else + { + byte_string = scheme_make_byte_string(_("Vim error")); + MZ_GC_CHECK(); + argv[0] = scheme_byte_string_to_char_string(byte_string); + MZ_GC_CHECK(); + } + MZ_GC_CHECK(); + +#if MZSCHEME_VERSION_MAJOR < 360 + argv[1] = scheme_current_continuation_marks(); + MZ_GC_CHECK(); +#else + argv[1] = scheme_current_continuation_marks(NULL); + MZ_GC_CHECK(); +#endif + + exn = scheme_make_struct_instance(vim_exn, 2, argv); + MZ_GC_CHECK(); + scheme_raise(exn); + MZ_GC_UNREG(); +} + + void +raise_if_error(void) +{ + if (vim_error_check()) + raise_vim_exn(NULL); +} + +/* get buffer: + * either current + * or passed as argv[argnum] with checks + */ + static vim_mz_buffer * +get_buffer_arg(const char *fname, int argnum, int argc, Scheme_Object **argv) +{ + vim_mz_buffer *b; + + if (argc < argnum + 1) + return get_vim_curr_buffer(); + if (!SCHEME_VIMBUFFERP(argv[argnum])) + scheme_wrong_type(fname, "vim-buffer", argnum, argc, argv); + b = (vim_mz_buffer *)argv[argnum]; + (void)get_valid_buffer(argv[argnum]); + return b; +} + +/* get window: + * either current + * or passed as argv[argnum] with checks + */ + static vim_mz_window * +get_window_arg(const char *fname, int argnum, int argc, Scheme_Object **argv) +{ + vim_mz_window *w; + + if (argc < argnum + 1) + return get_vim_curr_window(); + w = (vim_mz_window *)argv[argnum]; + if (!SCHEME_VIMWINDOWP(argv[argnum])) + scheme_wrong_type(fname, "vim-window", argnum, argc, argv); + (void)get_valid_window(argv[argnum]); + return w; +} + +/* get valid Vim buffer from Scheme_Object* */ +buf_T *get_valid_buffer(void *obj) +{ + buf_T *buf = ((vim_mz_buffer *)obj)->buf; + + if (buf == INVALID_BUFFER_VALUE) + scheme_signal_error(_("buffer is invalid")); + return buf; +} + +/* get valid Vim window from Scheme_Object* */ +win_T *get_valid_window(void *obj) +{ + win_T *win = ((vim_mz_window *)obj)->win; + if (win == INVALID_WINDOW_VALUE) + scheme_signal_error(_("window is invalid")); + return win; +} + + int +mzthreads_allowed(void) +{ + return mz_threads_allow; +} + + static int +line_in_range(linenr_T lnum, buf_T *buf) +{ + return (lnum > 0 && lnum <= buf->b_ml.ml_line_count); +} + + static void +check_line_range(linenr_T lnum, buf_T *buf) +{ + if (!line_in_range(lnum, buf)) + scheme_signal_error(_("linenr out of range")); +} + +/* + * Check if deleting lines made the cursor position invalid + * (or you'll get msg from Vim about invalid linenr). + * Changed the lines from "lo" to "hi" and added "extra" lines (negative if + * deleted). Got from if_python.c + */ + static void +mz_fix_cursor(int lo, int hi, int extra) +{ + if (curwin->w_cursor.lnum >= lo) + { + /* Adjust the cursor position if it's in/after the changed + * lines. */ + if (curwin->w_cursor.lnum >= hi) + { + curwin->w_cursor.lnum += extra; + check_cursor_col(); + } + else if (extra < 0) + { + curwin->w_cursor.lnum = lo; + check_cursor(); + } + else + check_cursor_col(); + changed_cline_bef_curs(); + } + invalidate_botline(); +} + +static Vim_Prim prims[]= +{ + /* + * Buffer-related commands + */ + {get_buffer_line, "get-buff-line", 1, 2}, + {set_buffer_line, "set-buff-line", 2, 3}, + {get_buffer_line_list, "get-buff-line-list", 2, 3}, + {get_buffer_name, "get-buff-name", 0, 1}, + {get_buffer_num, "get-buff-num", 0, 1}, + {get_buffer_size, "get-buff-size", 0, 1}, + {set_buffer_line_list, "set-buff-line-list", 3, 4}, + {insert_buffer_line_list, "insert-buff-line-list", 2, 3}, + {get_curr_buffer, "curr-buff", 0, 0}, + {get_buffer_count, "buff-count", 0, 0}, + {get_next_buffer, "get-next-buff", 0, 1}, + {get_prev_buffer, "get-prev-buff", 0, 1}, + {mzscheme_open_buffer, "open-buff", 1, 1}, + {get_buffer_by_name, "get-buff-by-name", 1, 1}, + {get_buffer_by_num, "get-buff-by-num", 1, 1}, + /* + * Window-related commands + */ + {get_curr_win, "curr-win", 0, 0}, + {get_window_count, "win-count", 0, 0}, + {get_window_by_num, "get-win-by-num", 1, 1}, + {get_window_num, "get-win-num", 0, 1}, + {get_window_buffer, "get-win-buffer", 0, 1}, + {get_window_height, "get-win-height", 0, 1}, + {set_window_height, "set-win-height", 1, 2}, + {get_window_width, "get-win-width", 0, 1}, + {set_window_width, "set-win-width", 1, 2}, + {get_cursor, "get-cursor", 0, 1}, + {set_cursor, "set-cursor", 1, 2}, + {get_window_list, "get-win-list", 0, 1}, + /* + * Vim-related commands + */ + {vim_command, "command", 1, 1}, + {vim_eval, "eval", 1, 1}, + {get_range_start, "range-start", 0, 0}, + {get_range_end, "range-end", 0, 0}, + {mzscheme_beep, "beep", 0, 0}, + {get_option, "get-option", 1, 2}, + {set_option, "set-option", 1, 2}, + /* + * small utilities + */ + {vim_bufferp, "buff?", 1, 1}, + {vim_windowp, "win?", 1, 1}, + {vim_buffer_validp, "buff-valid?", 1, 1}, + {vim_window_validp, "win-valid?", 1, 1} +}; + +/* return MzScheme wrapper for curbuf */ + static vim_mz_buffer * +get_vim_curr_buffer(void) +{ + if (curbuf->b_mzscheme_ref == NULL) + return (vim_mz_buffer *)buffer_new(curbuf); + else + return BUFFER_REF(curbuf); +} + +/* return MzScheme wrapper for curwin */ + static vim_mz_window * +get_vim_curr_window(void) +{ + if (curwin->w_mzscheme_ref == NULL) + return (vim_mz_window *)window_new(curwin); + else + return WINDOW_REF(curwin); +} + + static void +make_modules(void) +{ + int i; + Scheme_Env *mod = NULL; + Scheme_Object *vimext_symbol = NULL; + Scheme_Object *closed_prim = NULL; + + MZ_GC_DECL_REG(3); + MZ_GC_VAR_IN_REG(0, mod); + MZ_GC_VAR_IN_REG(1, vimext_symbol); + MZ_GC_VAR_IN_REG(2, closed_prim); + MZ_GC_REG(); + + vimext_symbol = scheme_intern_symbol("vimext"); + MZ_GC_CHECK(); + mod = scheme_primitive_module(vimext_symbol, environment); + MZ_GC_CHECK(); + /* all prims made closed so they can access their own names */ + for (i = 0; i < (int)(sizeof(prims)/sizeof(prims[0])); i++) + { + Vim_Prim *prim = prims + i; + closed_prim = scheme_make_closed_prim_w_arity(prim->prim, prim, prim->name, + prim->mina, prim->maxa); + scheme_add_global(prim->name, closed_prim, mod); + MZ_GC_CHECK(); + } + scheme_finish_primitive_module(mod); + MZ_GC_CHECK(); + MZ_GC_UNREG(); +} + +#ifdef HAVE_SANDBOX +static Scheme_Object *M_write = NULL; +static Scheme_Object *M_read = NULL; +static Scheme_Object *M_execute = NULL; +static Scheme_Object *M_delete = NULL; + + static void +sandbox_check(void) +{ + if (sandbox) + raise_vim_exn(_("not allowed in the Vim sandbox")); +} + +/* security guards to force Vim's sandbox restrictions on MzScheme level */ + static Scheme_Object * +sandbox_file_guard(int argc UNUSED, Scheme_Object **argv) +{ + if (sandbox) + { + Scheme_Object *requested_access = argv[2]; + + if (M_write == NULL) + { + MZ_REGISTER_STATIC(M_write); + M_write = scheme_intern_symbol("write"); + MZ_GC_CHECK(); + } + if (M_read == NULL) + { + MZ_REGISTER_STATIC(M_read); + M_read = scheme_intern_symbol("read"); + MZ_GC_CHECK(); + } + if (M_execute == NULL) + { + MZ_REGISTER_STATIC(M_execute); + M_execute = scheme_intern_symbol("execute"); + MZ_GC_CHECK(); + } + if (M_delete == NULL) + { + MZ_REGISTER_STATIC(M_delete); + M_delete = scheme_intern_symbol("delete"); + MZ_GC_CHECK(); + } + + while (!SCHEME_NULLP(requested_access)) + { + Scheme_Object *item = SCHEME_CAR(requested_access); + if (scheme_eq(item, M_write) || scheme_eq(item, M_read) + || scheme_eq(item, M_execute) || scheme_eq(item, M_delete)) + { + raise_vim_exn(_("not allowed in the Vim sandbox")); + } + requested_access = SCHEME_CDR(requested_access); + } + } + return scheme_void; +} + + static Scheme_Object * +sandbox_network_guard(int argc UNUSED, Scheme_Object **argv UNUSED) +{ + return scheme_void; +} +#endif + +#endif -- cgit v1.2.3