Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

3378 lines (3008 sloc) 92.966 kb
/* vi:set ts=8 sts=4 sw=4:
*
* MzScheme interface by Sergey Khorev <sergey.khorev@gmail.com>
* Original work by Brent Fulgham <bfulgham@debian.org>
* (Based on lots of help from Matthew Flatt)
*
* TODO Convert byte-strings to char strings?
*
* 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)
/* 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_name(void *, int, Scheme_Object **);
static Scheme_Object *get_buffer_by_num(void *, int, Scheme_Object **);
static Scheme_Object *get_buffer_count(void *, int, Scheme_Object **);
static Scheme_Object *get_buffer_line(void *, int, Scheme_Object **);
static Scheme_Object *get_buffer_line_list(void *, int, Scheme_Object **);
static Scheme_Object *get_buffer_name(void *, int, Scheme_Object **);
static Scheme_Object *get_buffer_num(void *, int, Scheme_Object **);
static Scheme_Object *get_buffer_size(void *, int, Scheme_Object **);
static Scheme_Object *get_curr_buffer(void *, int, Scheme_Object **);
static Scheme_Object *get_next_buffer(void *, int, Scheme_Object **);
static Scheme_Object *get_prev_buffer(void *, int, Scheme_Object **);
static Scheme_Object *mzscheme_open_buffer(void *, int, Scheme_Object **);
static Scheme_Object *set_buffer_line(void *, int, Scheme_Object **);
static Scheme_Object *set_buffer_line_list(void *, int, Scheme_Object **);
static Scheme_Object *insert_buffer_line_list(void *, int, Scheme_Object **);
static Scheme_Object *get_range_start(void *, int, Scheme_Object **);
static Scheme_Object *get_range_end(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 Scheme_Object *get_curr_win(void *, int, Scheme_Object **);
static Scheme_Object *get_window_count(void *, int, Scheme_Object **);
static Scheme_Object *get_window_by_num(void *, int, Scheme_Object **);
static Scheme_Object *get_window_num(void *, int, Scheme_Object **);
static Scheme_Object *get_window_buffer(void *, int, Scheme_Object **);
static Scheme_Object *get_window_height(void *, int, Scheme_Object **);
static Scheme_Object *set_window_height(void *, int, Scheme_Object **);
#ifdef FEAT_VERTSPLIT
static Scheme_Object *get_window_width(void *, int, Scheme_Object **);
static Scheme_Object *set_window_width(void *, int, Scheme_Object **);
#endif
static Scheme_Object *get_cursor(void *, int, Scheme_Object **);
static Scheme_Object *set_cursor(void *, int, Scheme_Object **);
static Scheme_Object *get_window_list(void *, int, Scheme_Object **);
static vim_mz_window *get_vim_curr_window(void);
/* Vim-related commands */
static Scheme_Object *mzscheme_beep(void *, int, Scheme_Object **);
static Scheme_Object *get_option(void *, int, Scheme_Object **);
static Scheme_Object *set_option(void *, int, Scheme_Object **);
static Scheme_Object *vim_command(void *, int, Scheme_Object **);
static Scheme_Object *vim_eval(void *, int, Scheme_Object **);
static Scheme_Object *vim_bufferp(void *data, int, Scheme_Object **);
static Scheme_Object *vim_windowp(void *data, int, Scheme_Object **);
static Scheme_Object *vim_buffer_validp(void *data, int, Scheme_Object **);
static Scheme_Object *vim_window_validp(void *data, int, Scheme_Object **);
/*
*========================================================================
* Internal Function Prototypes
*========================================================================
*/
static int vim_error_check(void);
static int do_mzscheme_command(exarg_T *, void *, Scheme_Closed_Prim *what);
static void startup_mzscheme(void);
static char *string_to_line(Scheme_Object *obj);
static void do_output(char *mesg, long 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, int depth,
Scheme_Hash_Table *visited);
static int mzscheme_to_vim(Scheme_Object *obj, typval_T *tv, int depth,
Scheme_Hash_Table *visited);
#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)
{
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)
{
return window_size_proc(obj);
}
#endif
#ifdef DYNAMIC_MZSCHEME
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, long 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);
# 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, long *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, long *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 *,
long *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);
# 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);
# ifdef INCLUDE_MZSCHEME_BASE
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);
# endif
/* 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 */
# define scheme_current_thread (*dll_scheme_current_thread_ptr)
# 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
# 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_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_string dll_scheme_make_string
# define scheme_make_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
# 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
# ifdef INCLUDE_MZSCHEME_BASE
# define scheme_make_sized_byte_string dll_scheme_make_sized_byte_string
# define scheme_namespace_require dll_scheme_namespace_require
# 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},
{"scheme_current_thread", (void **)&dll_scheme_current_thread_ptr},
{"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},
# 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},
# 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},
# ifdef INCLUDE_MZSCHEME_BASE
{"scheme_make_sized_byte_string", (void **)&dll_scheme_make_sized_byte_string},
{"scheme_namespace_require", (void **)&dll_scheme_namespace_require},
#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)
EMSG2(_(e_loadlib), gc_dll);
return FAIL;
}
if (!hMzSch)
{
if (verbose)
EMSG2(_(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)
EMSG2(_(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)
EMSG2(_(e_loadfunc), thunk->name);
return FAIL;
}
}
return OK;
}
int
mzscheme_enabled(int verbose)
{
return mzscheme_runtime_link_init(
DYNAMIC_MZSCH_DLL, DYNAMIC_MZGC_DLL, verbose) == OK;
}
static void
dynamic_mzscheme_end(void)
{
if (hMzSch)
{
FreeLibrary(hMzSch);
hMzSch = 0;
}
if (hMzGC)
{
FreeLibrary(hMzGC);
hMzGC = 0;
}
}
#endif /* DYNAMIC_MZSCHEME */
/* need to put it here for dynamic stuff to work */
#if defined(INCLUDE_MZSCHEME_BASE)
# include "mzscheme_base.c"
#elif MZSCHEME_VERSION_MAJOR >= 400
# error MzScheme 4.x must include mzscheme_base.c, for MinGW32 you need to define MZSCHEME_GENERATE_BASE=yes
#endif
/*
*========================================================================
* 1. MzScheme interpreter startup
*========================================================================
*/
static Scheme_Type mz_buffer_type;
static Scheme_Type mz_window_type;
static int initialized = 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, DWORD);
static UINT timer_id = 0;
#elif defined(FEAT_GUI_GTK)
static gint 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
#ifdef MZSCHEME_GUI_THREADS
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 idEvent UNUSED, DWORD dwTime UNUSED)
# elif defined(FEAT_GUI_GTK)
static gint
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 = gtk_timeout_add((guint32)p_mzq, (GtkFunction)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)
gtk_timeout_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)
{
#ifdef DYNAMIC_MZSCHEME
dynamic_mzscheme_end();
#endif
}
#if MZSCHEME_VERSION_MAJOR >= 500 && defined(WIN32) && defined(USE_THREAD_LOCAL)
static __declspec(thread) void *tls_space;
#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))
# ifdef DYNAMIC_MZSCHEME
# error Precise GC v.4+ or Racket with futures/places do not support dynamic MzScheme
# endif
# define TRAMPOLINED_MZVIM_STARTUP
#endif
int
mzscheme_main(int argc, char** argv)
{
#if MZSCHEME_VERSION_MAJOR >= 500 && defined(WIN32) && defined(USE_THREAD_LOCAL)
scheme_register_tls_space(&tls_space, 0);
#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, char **argv)
{
int vim_main_result;
#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
/* mzscheme_main is called as a trampoline from main.
* We trampoline into vim_main2
* Passing argc, argv through from mzscheme_main
*/
vim_main_result = vim_main2(argc, argv);
#if !defined(TRAMPOLINED_MZVIM_STARTUP) && defined(MZ_PRECISE_GC)
/* releasing dummy */
MZ_GC_REG();
MZ_GC_UNREG();
#endif
return vim_main_result;
}
static void
startup_mzscheme(void)
{
#ifndef TRAMPOLINED_MZVIM_STARTUP
scheme_set_stack_base(stack_base, 1);
#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);
#ifndef TRAMPOLINED_MZVIM_STARTUP
/* in newer versions of precise GC the initial env has been created */
environment = scheme_basic_env();
#endif
MZ_GC_CHECK();
#ifdef INCLUDE_MZSCHEME_BASE
{
/*
* versions 4.x do not provide Scheme bindings by default
* we need to add them explicitly
*/
Scheme_Object *scheme_base_symbol = NULL;
MZ_GC_DECL_REG(1);
MZ_GC_VAR_IN_REG(0, scheme_base_symbol);
MZ_GC_REG();
/* invoke function from generated and included mzscheme_base.c */
declare_modules(environment);
scheme_base_symbol = scheme_intern_symbol("scheme/base");
MZ_GC_CHECK();
scheme_namespace_require(scheme_base_symbol);
MZ_GC_CHECK();
MZ_GC_UNREG();
}
#endif
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 MZSCHEME_COLLECTS
/* setup 'current-library-collection-paths' parameter */
# if MZSCHEME_VERSION_MAJOR >= 299
{
Scheme_Object *coll_byte_string = NULL;
Scheme_Object *coll_char_string = NULL;
Scheme_Object *coll_path = NULL;
Scheme_Object *coll_pair = NULL;
Scheme_Config *config = NULL;
MZ_GC_DECL_REG(5);
MZ_GC_VAR_IN_REG(0, coll_byte_string);
MZ_GC_VAR_IN_REG(1, coll_char_string);
MZ_GC_VAR_IN_REG(2, coll_path);
MZ_GC_VAR_IN_REG(3, coll_pair);
MZ_GC_VAR_IN_REG(4, config);
MZ_GC_REG();
coll_byte_string = scheme_make_byte_string(MZSCHEME_COLLECTS);
MZ_GC_CHECK();
coll_char_string = scheme_byte_string_to_char_string(coll_byte_string);
MZ_GC_CHECK();
coll_path = scheme_char_string_to_path(coll_char_string);
MZ_GC_CHECK();
coll_pair = scheme_make_pair(coll_path, scheme_null);
MZ_GC_CHECK();
config = scheme_config;
MZ_GC_CHECK();
scheme_set_param(config, MZCONFIG_COLLECTION_PATHS, coll_pair);
MZ_GC_CHECK();
MZ_GC_UNREG();
}
# else
{
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_string(MZSCHEME_COLLECTS);
MZ_GC_CHECK();
coll_pair = scheme_make_pair(coll_string, scheme_null);
MZ_GC_CHECK();
config = scheme_config;
MZ_GC_CHECK();
scheme_set_param(config, MZCONFIG_COLLECTION_PATHS, coll_pair);
MZ_GC_CHECK();
MZ_GC_UNREG();
}
# endif
#endif
#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_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("<vim-buffer>");
MZ_GC_CHECK();
mz_window_type = scheme_make_type("<vim-window>");
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;
}
/*
* 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 (!mzscheme_enabled(TRUE))
{
EMSG(_("E815: Sorry, this command is disabled, the MzScheme libraries could not be loaded."));
return -1;
}
#endif
startup_mzscheme();
initialized = TRUE;
}
{
Scheme_Config *config = NULL;
MZ_GC_DECL_REG(1);
MZ_GC_VAR_IN_REG(0, config);
MZ_GC_REG();
config = scheme_config;
MZ_GC_CHECK();
/* recreate ports each call effectively clearing these ones */
curout = scheme_make_string_output_port();
MZ_GC_CHECK();
curerr = scheme_make_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;
bp = buf->b_mzscheme_ref;
bp->buf = INVALID_BUFFER_VALUE;
buf->b_mzscheme_ref = NULL;
scheme_gc_ptr_ok(bp);
MZ_GC_CHECK();
}
}
/*
* Routine called by VIM when deleting a Window
*/
void
mzscheme_window_free(win_T *win)
{
if (win->w_mzscheme_ref)
{
vim_mz_window *wp;
wp = win->w_mzscheme_ref;
wp->win = INVALID_WINDOW_VALUE;
win->w_mzscheme_ref = NULL;
scheme_gc_ptr_ok(wp);
MZ_GC_CHECK();
}
}
/*
* ":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, long len UNUSED)
{
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;
long length;
buff = scheme_get_sized_string_output(curerr, &length);
MZ_GC_CHECK();
if (length)
{
do_err_output(buff);
return;
}
buff = scheme_get_sized_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;
char *cmd = SCHEME_STR_VAL(GUARANTEE_STRING(prim->name, 0));
/* may be use do_cmdline_cmd? */
do_cmdline((char_u *)cmd, NULL, NULL, DOCMD_NOWAIT|DOCMD_VERBOSE);
update_screen(VALID);
raise_if_error();
return scheme_void;
}
/* (eval {expr-string}) */
static Scheme_Object *
vim_eval(void *data, int argc, Scheme_Object **argv)
{
#ifdef FEAT_EVAL
Vim_Prim *prim = (Vim_Prim *)data;
char *expr;
Scheme_Object *result;
/* hash table to store visited values to avoid infinite loops */
Scheme_Hash_Table *visited = NULL;
typval_T *vim_result;
MZ_GC_DECL_REG(1);
MZ_GC_VAR_IN_REG(0, visited);
MZ_GC_REG();
visited = scheme_make_hash_table(SCHEME_hash_ptr);
MZ_GC_CHECK();
expr = SCHEME_STR_VAL(GUARANTEE_STRING(prim->name, 0));
vim_result = eval_expr((char_u *)expr, NULL);
if (vim_result == NULL)
raise_vim_exn(_("invalid expression"));
result = vim_to_mzscheme(vim_result, 1, visited);
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();
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;
char_u *name;
long value;
char *strval;
int rc;
Scheme_Object *rval;
int opt_flags = 0;
buf_T *save_curb = curbuf;
win_T *save_curw = curwin;
name = (char_u *)SCHEME_STR_VAL(GUARANTEE_STRING(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(name, &value, (char_u **)&strval, opt_flags);
curbuf = save_curb;
curwin = save_curw;
switch (rc)
{
case 1:
return scheme_make_integer_value(value);
case 0:
rval = scheme_make_string(strval);
MZ_GC_CHECK();
vim_free(strval);
return rval;
case -1:
case -2:
raise_vim_exn(_("hidden option"));
case -3:
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 *cmd;
int opt_flags = 0;
buf_T *save_curb = curbuf;
win_T *save_curw = curwin;
Vim_Prim *prim = (Vim_Prim *)data;
GUARANTEE_STRING(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 */
cmd = vim_strsave((char_u *)SCHEME_STR_VAL(argv[0]));
do_set(cmd, opt_flags);
vim_free(cmd);
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)
{
win_T *w;
int n = 0;
for (w = firstwin; w != NULL; w = w->w_next)
++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;
buf = get_buffer_arg(prim->name, 0, argc, argv);
list = scheme_null;
for (w = firstwin; 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);
MZ_GC_REG();
/* 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 win->w_mzscheme_ref;
self = scheme_malloc_fail_ok(scheme_malloc, sizeof(vim_mz_window));
vim_memset(self, 0, sizeof(vim_mz_window));
scheme_dont_gc_ptr(self); /* because win isn't visible to GC */
MZ_GC_CHECK();
win->w_mzscheme_ref = self;
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, int argc, Scheme_Object **argv)
{
Vim_Prim *prim = (Vim_Prim *)data;
win_T *win = get_window_arg(prim->name, 0, argc, argv)->win;
int nr = 1;
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;
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 = firstwin; 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;
}
#ifdef FEAT_VERTSPLIT
/* (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(W_WIDTH(win->win));
}
/* (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;
}
#endif
/* (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;
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;
char_u *fname;
int num = 0;
Scheme_Object *onum;
#ifdef HAVE_SANDBOX
sandbox_check();
#endif
fname = (char_u *)SCHEME_STR_VAL(GUARANTEE_STRING(prim->name, 0));
/* TODO make open existing file */
num = buflist_add(fname, BLN_LISTED | BLN_CURBUF);
if (num == 0)
raise_vim_exn(_("couldn't open buffer"));
onum = scheme_make_integer(num);
return get_buffer_by_num(data, 1, &onum);
}
/* (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 (buf = firstbuf; buf; buf = buf->b_next)
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;
char_u *fname;
fname = (char_u *)SCHEME_STR_VAL(GUARANTEE_STRING(prim->name, 0));
for (buf = firstbuf; buf; buf = buf->b_next)
if (buf->b_ffname == NULL || buf->b_sfname == NULL)
/* empty string */
{
if (fname[0] == NUL)
return buffer_new(buf);
}
else if (!fnamecmp(buf->b_ffname, fname)
|| !fnamecmp(buf->b_sfname, fname))
/* either short or long filename matches */
return buffer_new(buf);
return scheme_false;
}
/* (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 (b = firstbuf; b; b = b->b_next) ++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_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);
MZ_GC_REG();
/* 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 buf->b_mzscheme_ref;
self = scheme_malloc_fail_ok(scheme_malloc, sizeof(vim_mz_buffer));
vim_memset(self, 0, sizeof(vim_mz_buffer));
scheme_dont_gc_ptr(self); /* because buf isn't visible to GC */
MZ_GC_CHECK();
buf->b_mzscheme_ref = self;
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_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_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 * sizeof(char *));
vim_memset(array, 0, new_len * 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 * sizeof(char *));
vim_memset(array, 0, size * 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;
long 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, int depth, Scheme_Hash_Table *visited)
{
Scheme_Object *result = NULL;
int new_value = TRUE;
MZ_GC_DECL_REG(1);
MZ_GC_VAR_IN_REG(0, result);
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_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(&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(&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(&di->di_tv, depth + 1, visited);
key = scheme_make_string((char *)hi->hi_key);
MZ_GC_CHECK();
scheme_hash_set((Scheme_Hash_Table *)result, key, obj);
MZ_GC_CHECK();
}
}
}
MZ_GC_UNREG();
}
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 depth,
Scheme_Hash_Table *visited)
{
int status = OK;
typval_T *found;
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_NUMBER;
tv->vval.v_number = 0;
}
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_NUMBER;
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_STRINGP(obj))
{
tv->v_type = VAR_STRING;
tv->vval.v_string = vim_strsave((char_u *)SCHEME_STR_VAL(obj));
}
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-referencial
* 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(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(cval, v, depth + 1, visited);
if (status == FAIL)
break;
status = list_append_tv(list, v);
clear_tv(v);
if (status == FAIL)
break;
}
/* impoper list not terminated with null
* need to handle the last element */
if (status == OK && !SCHEME_NULLP(curr))
{
status = mzscheme_to_vim(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 `diplay'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(((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);
}
return status;
}
void
do_mzeval(char_u *str, typval_T *rettv)
{
int i;
Scheme_Object *ret = NULL;
Scheme_Hash_Table *visited = NULL;
MZ_GC_DECL_REG(2);
MZ_GC_VAR_IN_REG(0, ret);
MZ_GC_VAR_IN_REG(0, visited);
MZ_GC_REG();
if (mzscheme_init())
{
MZ_GC_UNREG();
return;
}
MZ_GC_CHECK();
visited = scheme_make_hash_table(SCHEME_hash_ptr);
MZ_GC_CHECK();
if (eval_with_exn_handling(str, do_eval, &ret) == OK)
mzscheme_to_vim(ret, rettv, 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();
}
#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;
MZ_GC_DECL_REG(4);
MZ_GC_ARRAY_VAR_IN_REG(0, argv, 2);
MZ_GC_VAR_IN_REG(3, exn);
MZ_GC_REG();
if (add_info != NULL)
{
char *c_string = NULL;
Scheme_Object *byte_string = NULL;
Scheme_Object *info = NULL;
MZ_GC_DECL_REG(3);
MZ_GC_VAR_IN_REG(0, c_string);
MZ_GC_VAR_IN_REG(1, byte_string);
MZ_GC_VAR_IN_REG(2, info);
MZ_GC_REG();
info = scheme_make_string(add_info);
MZ_GC_CHECK();
c_string = scheme_format(fmt, STRLEN(fmt), 1, &info, NULL);
MZ_GC_CHECK();
byte_string = scheme_make_string(c_string);
MZ_GC_CHECK();
argv[0] = scheme_byte_string_to_char_string(byte_string);
MZ_GC_CHECK();
SCHEME_SET_IMMUTABLE(argv[0]);
MZ_GC_UNREG();
}
else
argv[0] = scheme_make_string(_("Vim error"));
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},
#ifdef FEAT_VERTSPLIT
{get_window_width, "get-win-width", 0, 1},
{set_window_width, "set-win-width", 1, 2},
#endif
{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 (vim_mz_buffer *)curbuf->b_mzscheme_ref;
}
/* 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 (vim_mz_window *)curwin->w_mzscheme_ref;
}
static void
make_modules()
{
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
Jump to Line
Something went wrong with that request. Please try again.