?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Patch 7.0.105
[MacVim/jjgod.git] / src / if_mzsch.c
blob706f4ca8c2da0bc48e4f0f5e3a6a41c88d82ad14
1 /* vi:set ts=8 sts=4 sw=4:
2 *
3 * MzScheme interface by Sergey Khorev <sergey.khorev@gmail.com>
4 * Original work by Brent Fulgham <bfulgham@debian.org>
5 * (Based on lots of help from Matthew Flatt)
6 *
7 * This consists of six parts:
8 * 1. MzScheme interpreter main program
9 * 2. Routines that handle the external interface between MzScheme and
10 * Vim.
11 * 3. MzScheme input/output handlers: writes output via [e]msg().
12 * 4. Implementation of the Vim Features for MzScheme
13 * 5. Vim Window-related Manipulation Functions.
14 * 6. Vim Buffer-related Manipulation Functions
15 *
16 * NOTES
17 * 1. Memory, allocated with scheme_malloc*, need not to be freed explicitly,
18 * garbage collector will do it self
19 * 2. Requires at least NORMAL features. I can't imagine why one may want
20 * to build with SMALL or TINY features but with MzScheme interface.
21 * 3. I don't use K&R-style functions. Anyway, MzScheme headers are ANSI.
22 */
23
24 #include "vim.h"
25 #include "if_mzsch.h"
26
27 /* Only do the following when the feature is enabled. Needed for "make
28 * depend". */
29 #if defined(FEAT_MZSCHEME) || defined(PROTO)
30
31 /* Base data structures */
32 #define SCHEME_VIMBUFFERP(obj) SAME_TYPE(SCHEME_TYPE(obj), mz_buffer_type)
33 #define SCHEME_VIMWINDOWP(obj) SAME_TYPE(SCHEME_TYPE(obj), mz_window_type)
34
35 typedef struct
36 {
37 Scheme_Type tag;
38 Scheme_Env *env;
39 buf_T *buf;
40 } vim_mz_buffer;
41
42 #define INVALID_BUFFER_VALUE ((buf_T *)(-1))
43
44 typedef struct
45 {
46 Scheme_Type tag;
47 win_T *win;
48 } vim_mz_window;
49
50 #define INVALID_WINDOW_VALUE ((win_T *)(-1))
51
52 /*
53 * Prims that form MzScheme Vim interface
54 */
55 typedef struct
56 {
57 Scheme_Closed_Prim *prim;
58 char *name;
59 int mina; /* arity information */
60 int maxa;
61 } Vim_Prim;
62
63 typedef struct
64 {
65 char *name;
66 Scheme_Object *port;
67 } Port_Info;
68
69 /* info for closed prim */
70 /*
71 * data have different means:
72 * for do_eval it is char*
73 * for do_apply is Apply_Onfo*
74 * for do_load is Port_Info*
75 */
76 typedef struct
77 {
78 void *data;
79 Scheme_Env *env;
80 } Cmd_Info;
81
82 /* info for do_apply */
83 typedef struct
84 {
85 Scheme_Object *proc;
86 int argc;
87 Scheme_Object **argv;
88 } Apply_Info;
89
90 /*
91 *========================================================================
92 * Vim-Control Commands
93 *========================================================================
94 */
95 /*
96 *========================================================================
97 * Utility functions for the vim/mzscheme interface
98 *========================================================================
99 */
100 #ifdef HAVE_SANDBOX
101 static Scheme_Object *sandbox_file_guard(int, Scheme_Object **);
102 static Scheme_Object *sandbox_network_guard(int, Scheme_Object **);
103 static void sandbox_check();
104 #endif
105 /* Buffer-related commands */
106 static Scheme_Object *buffer_new(buf_T *buf);
107 static Scheme_Object *get_buffer_by_name(void *, int, Scheme_Object **);
108 static Scheme_Object *get_buffer_by_num(void *, int, Scheme_Object **);
109 static Scheme_Object *get_buffer_count(void *, int, Scheme_Object **);
110 static Scheme_Object *get_buffer_line(void *, int, Scheme_Object **);
111 static Scheme_Object *get_buffer_line_list(void *, int, Scheme_Object **);
112 static Scheme_Object *get_buffer_name(void *, int, Scheme_Object **);
113 static Scheme_Object *get_buffer_num(void *, int, Scheme_Object **);
114 static Scheme_Object *get_buffer_size(void *, int, Scheme_Object **);
115 static Scheme_Object *get_curr_buffer(void *, int, Scheme_Object **);
116 static Scheme_Object *get_next_buffer(void *, int, Scheme_Object **);
117 static Scheme_Object *get_prev_buffer(void *, int, Scheme_Object **);
118 static Scheme_Object *mzscheme_open_buffer(void *, int, Scheme_Object **);
119 static Scheme_Object *set_buffer_line(void *, int, Scheme_Object **);
120 static Scheme_Object *set_buffer_line_list(void *, int, Scheme_Object **);
121 static Scheme_Object *insert_buffer_line_list(void *, int, Scheme_Object **);
122 static Scheme_Object *get_range_start(void *, int, Scheme_Object **);
123 static Scheme_Object *get_range_end(void *, int, Scheme_Object **);
124 static Scheme_Object *get_buffer_namespace(void *, int, Scheme_Object **);
125 static vim_mz_buffer *get_vim_curr_buffer(void);
126
127 /* Window-related commands */
128 static Scheme_Object *window_new(win_T *win);
129 static Scheme_Object *get_curr_win(void *, int, Scheme_Object **);
130 static Scheme_Object *get_window_count(void *, int, Scheme_Object **);
131 static Scheme_Object *get_window_by_num(void *, int, Scheme_Object **);
132 static Scheme_Object *get_window_num(void *, int, Scheme_Object **);
133 static Scheme_Object *get_window_buffer(void *, int, Scheme_Object **);
134 static Scheme_Object *get_window_height(void *, int, Scheme_Object **);
135 static Scheme_Object *set_window_height(void *, int, Scheme_Object **);
136 #ifdef FEAT_VERTSPLIT
137 static Scheme_Object *get_window_width(void *, int, Scheme_Object **);
138 static Scheme_Object *set_window_width(void *, int, Scheme_Object **);
139 #endif
140 static Scheme_Object *get_cursor(void *, int, Scheme_Object **);
141 static Scheme_Object *set_cursor(void *, int, Scheme_Object **);
142 static Scheme_Object *get_window_list(void *, int, Scheme_Object **);
143 static vim_mz_window *get_vim_curr_window(void);
144
145 /* Vim-related commands */
146 static Scheme_Object *mzscheme_beep(void *, int, Scheme_Object **);
147 static Scheme_Object *get_option(void *, int, Scheme_Object **);
148 static Scheme_Object *set_option(void *, int, Scheme_Object **);
149 static Scheme_Object *vim_command(void *, int, Scheme_Object **);
150 static Scheme_Object *vim_eval(void *, int, Scheme_Object **);
151 static Scheme_Object *vim_bufferp(void *data, int, Scheme_Object **);
152 static Scheme_Object *vim_windowp(void *data, int, Scheme_Object **);
153 static Scheme_Object *vim_buffer_validp(void *data, int, Scheme_Object **);
154 static Scheme_Object *vim_window_validp(void *data, int, Scheme_Object **);
155
156 /*
157 *========================================================================
158 * Internal Function Prototypes
159 *========================================================================
160 */
161 static int vim_error_check(void);
162 static int do_mzscheme_command(exarg_T *, void *, Scheme_Closed_Prim *what);
163 static void startup_mzscheme(void);
164 static char *string_to_line(Scheme_Object *obj);
165 static int mzscheme_io_init(void);
166 static void mzscheme_interface_init(vim_mz_buffer *self);
167 static void do_output(char *mesg, long len);
168 static void do_printf(char *format, ...);
169 static void do_flush(void);
170 static Scheme_Object *_apply_thunk_catch_exceptions(
171 Scheme_Object *, Scheme_Object **);
172 static Scheme_Object *extract_exn_message(Scheme_Object *v);
173 static Scheme_Object *do_eval(void *, int noargc, Scheme_Object **noargv);
174 static Scheme_Object *do_load(void *, int noargc, Scheme_Object **noargv);
175 static Scheme_Object *do_apply(void *, int noargc, Scheme_Object **noargv);
176 static void register_vim_exn(Scheme_Env *env);
177 static vim_mz_buffer *get_buffer_arg(const char *fname, int argnum,
178 int argc, Scheme_Object **argv);
179 static vim_mz_window *get_window_arg(const char *fname, int argnum,
180 int argc, Scheme_Object **argv);
181 static void add_vim_exn(Scheme_Env *env);
182 static int line_in_range(linenr_T, buf_T *);
183 static void check_line_range(linenr_T, buf_T *);
184 static void mz_fix_cursor(int lo, int hi, int extra);
185
186 static int eval_in_namespace(void *, Scheme_Closed_Prim *, Scheme_Env *,
187 Scheme_Object **ret);
188 static void make_modules(Scheme_Env *);
189
190 #ifdef DYNAMIC_MZSCHEME
191
192 static Scheme_Object *dll_scheme_eof;
193 static Scheme_Object *dll_scheme_false;
194 static Scheme_Object *dll_scheme_void;
195 static Scheme_Object *dll_scheme_null;
196 static Scheme_Object *dll_scheme_true;
197
198 static Scheme_Thread **dll_scheme_current_thread_ptr;
199
200 static void (**dll_scheme_console_printf_ptr)(char *str, ...);
201 static void (**dll_scheme_console_output_ptr)(char *str, long len);
202 static void (**dll_scheme_notify_multithread_ptr)(int on);
203
204 static void *(*dll_GC_malloc)(size_t size_in_bytes);
205 static void *(*dll_GC_malloc_atomic)(size_t size_in_bytes);
206 static Scheme_Env *(*dll_scheme_basic_env)(void);
207 static void (*dll_scheme_check_threads)(void);
208 static void (*dll_scheme_register_static)(void *ptr, long size);
209 static void (*dll_scheme_set_stack_base)(void *base, int no_auto_statics);
210 static void (*dll_scheme_add_global)(const char *name, Scheme_Object *val,
211 Scheme_Env *env);
212 static void (*dll_scheme_add_global_symbol)(Scheme_Object *name,
213 Scheme_Object *val, Scheme_Env *env);
214 static Scheme_Object *(*dll_scheme_apply)(Scheme_Object *rator, int num_rands,
215 Scheme_Object **rands);
216 static Scheme_Object *(*dll_scheme_builtin_value)(const char *name);
217 # if MZSCHEME_VERSION_MAJOR >= 299
218 static Scheme_Object *(*dll_scheme_byte_string_to_char_string)(Scheme_Object *s);
219 # endif
220 static void (*dll_scheme_close_input_port)(Scheme_Object *port);
221 static void (*dll_scheme_count_lines)(Scheme_Object *port);
222 static Scheme_Object *(*dll_scheme_current_continuation_marks)(void);
223 static void (*dll_scheme_display)(Scheme_Object *obj, Scheme_Object *port);
224 static char *(*dll_scheme_display_to_string)(Scheme_Object *obj, long *len);
225 static int (*dll_scheme_eq)(Scheme_Object *obj1, Scheme_Object *obj2);
226 static Scheme_Object *(*dll_scheme_do_eval)(Scheme_Object *obj,
227 int _num_rands, Scheme_Object **rands, int val);
228 static void (*dll_scheme_dont_gc_ptr)(void *p);
229 static Scheme_Object *(*dll_scheme_eval)(Scheme_Object *obj, Scheme_Env *env);
230 static Scheme_Object *(*dll_scheme_eval_string)(const char *str,
231 Scheme_Env *env);
232 static Scheme_Object *(*dll_scheme_eval_string_all)(const char *str,
233 Scheme_Env *env, int all);
234 static void (*dll_scheme_finish_primitive_module)(Scheme_Env *env);
235 # if MZSCHEME_VERSION_MAJOR < 299
236 static char *(*dll_scheme_format)(char *format, int flen, int argc,
237 Scheme_Object **argv, long *rlen);
238 # else
239 static char *(*dll_scheme_format_utf8)(char *format, int flen, int argc,
240 Scheme_Object **argv, long *rlen);
241 static Scheme_Object *(*dll_scheme_get_param)(Scheme_Config *c, int pos);
242 # endif
243 static void (*dll_scheme_gc_ptr_ok)(void *p);
244 # if MZSCHEME_VERSION_MAJOR < 299
245 static char *(*dll_scheme_get_sized_string_output)(Scheme_Object *,
246 long *len);
247 # else
248 static char *(*dll_scheme_get_sized_byte_string_output)(Scheme_Object *,
249 long *len);
250 # endif
251 static Scheme_Object *(*dll_scheme_intern_symbol)(const char *name);
252 static Scheme_Object *(*dll_scheme_lookup_global)(Scheme_Object *symbol,
253 Scheme_Env *env);
254 static Scheme_Object *(*dll_scheme_make_closed_prim_w_arity)
255 (Scheme_Closed_Prim *prim, void *data, const char *name, mzshort mina,
256 mzshort maxa);
257 static Scheme_Object *(*dll_scheme_make_integer_value)(long i);
258 static Scheme_Object *(*dll_scheme_make_namespace)(int argc,
259 Scheme_Object *argv[]);
260 static Scheme_Object *(*dll_scheme_make_pair)(Scheme_Object *car,
261 Scheme_Object *cdr);
262 static Scheme_Object *(*dll_scheme_make_prim_w_arity)(Scheme_Prim *prim,
263 const char *name, mzshort mina, mzshort maxa);
264 # if MZSCHEME_VERSION_MAJOR < 299
265 static Scheme_Object *(*dll_scheme_make_string)(const char *chars);
266 static Scheme_Object *(*dll_scheme_make_string_output_port)();
267 # else
268 static Scheme_Object *(*dll_scheme_make_byte_string)(const char *chars);
269 static Scheme_Object *(*dll_scheme_make_byte_string_output_port)();
270 # endif
271 static Scheme_Object *(*dll_scheme_make_struct_instance)(Scheme_Object *stype,
272 int argc, Scheme_Object **argv);
273 static Scheme_Object **(*dll_scheme_make_struct_names)(Scheme_Object *base,
274 Scheme_Object *field_names, int flags, int *count_out);
275 static Scheme_Object *(*dll_scheme_make_struct_type)(Scheme_Object *base,
276 Scheme_Object *parent, Scheme_Object *inspector, int num_fields,
277 int num_uninit_fields, Scheme_Object *uninit_val,
278 Scheme_Object *properties
279 # if MZSCHEME_VERSION_MAJOR >= 299
280 , Scheme_Object *guard
281 # endif
282 );
283 static Scheme_Object **(*dll_scheme_make_struct_values)(
284 Scheme_Object *struct_type, Scheme_Object **names, int count,
285 int flags);
286 static Scheme_Type (*dll_scheme_make_type)(const char *name);
287 static Scheme_Object *(*dll_scheme_make_vector)(int size,
288 Scheme_Object *fill);
289 static void *(*dll_scheme_malloc_fail_ok)(void *(*f)(size_t), size_t);
290 static Scheme_Object *(*dll_scheme_open_input_file)(const char *name,
291 const char *who);
292 static Scheme_Env *(*dll_scheme_primitive_module)(Scheme_Object *name,
293 Scheme_Env *for_env);
294 static int (*dll_scheme_proper_list_length)(Scheme_Object *list);
295 static void (*dll_scheme_raise)(Scheme_Object *exn);
296 static Scheme_Object *(*dll_scheme_read)(Scheme_Object *port);
297 static void (*dll_scheme_signal_error)(const char *msg, ...);
298 static void (*dll_scheme_wrong_type)(const char *name, const char *expected,
299 int which, int argc, Scheme_Object **argv);
300 # if MZSCHEME_VERSION_MAJOR >= 299
301 static void (*dll_scheme_set_param)(Scheme_Config *c, int pos,
302 Scheme_Object *o);
303 static Scheme_Config *(*dll_scheme_current_config)(void);
304 static Scheme_Object *(*dll_scheme_char_string_to_byte_string)
305 (Scheme_Object *s);
306 # endif
307
308 /* arrays are imported directly */
309 # define scheme_eof dll_scheme_eof
310 # define scheme_false dll_scheme_false
311 # define scheme_void dll_scheme_void
312 # define scheme_null dll_scheme_null
313 # define scheme_true dll_scheme_true
314
315 /* pointers are GetProceAddress'ed as pointers to pointer */
316 # define scheme_current_thread (*dll_scheme_current_thread_ptr)
317 # define scheme_console_printf (*dll_scheme_console_printf_ptr)
318 # define scheme_console_output (*dll_scheme_console_output_ptr)
319 # define scheme_notify_multithread (*dll_scheme_notify_multithread_ptr)
320
321 /* and functions in a usual way */
322 # define GC_malloc dll_GC_malloc
323 # define GC_malloc_atomic dll_GC_malloc_atomic
324
325 # define scheme_add_global dll_scheme_add_global
326 # define scheme_add_global_symbol dll_scheme_add_global_symbol
327 # define scheme_apply dll_scheme_apply
328 # define scheme_basic_env dll_scheme_basic_env
329 # define scheme_builtin_value dll_scheme_builtin_value
330 # if MZSCHEME_VERSION_MAJOR >= 299
331 # define scheme_byte_string_to_char_string dll_scheme_byte_string_to_char_string
332 # endif
333 # define scheme_check_threads dll_scheme_check_threads
334 # define scheme_close_input_port dll_scheme_close_input_port
335 # define scheme_count_lines dll_scheme_count_lines
336 # define scheme_current_continuation_marks \
337 dll_scheme_current_continuation_marks
338 # define scheme_display dll_scheme_display
339 # define scheme_display_to_string dll_scheme_display_to_string
340 # define scheme_do_eval dll_scheme_do_eval
341 # define scheme_dont_gc_ptr dll_scheme_dont_gc_ptr
342 # define scheme_eq dll_scheme_eq
343 # define scheme_eval dll_scheme_eval
344 # define scheme_eval_string dll_scheme_eval_string
345 # define scheme_eval_string_all dll_scheme_eval_string_all
346 # define scheme_finish_primitive_module dll_scheme_finish_primitive_module
347 # if MZSCHEME_VERSION_MAJOR < 299
348 # define scheme_format dll_scheme_format
349 # else
350 # define scheme_format_utf8 dll_scheme_format_utf8
351 # endif
352 # define scheme_gc_ptr_ok dll_scheme_gc_ptr_ok
353 # if MZSCHEME_VERSION_MAJOR < 299
354 # define scheme_get_sized_string_output dll_scheme_get_sized_string_output
355 # else
356 # define scheme_get_sized_byte_string_output \
357 dll_scheme_get_sized_byte_string_output
358 # define scheme_get_param dll_scheme_get_param
359 # endif
360 # define scheme_intern_symbol dll_scheme_intern_symbol
361 # define scheme_lookup_global dll_scheme_lookup_global
362 # define scheme_make_closed_prim_w_arity dll_scheme_make_closed_prim_w_arity
363 # define scheme_make_integer_value dll_scheme_make_integer_value
364 # define scheme_make_namespace dll_scheme_make_namespace
365 # define scheme_make_pair dll_scheme_make_pair
366 # define scheme_make_prim_w_arity dll_scheme_make_prim_w_arity
367 # if MZSCHEME_VERSION_MAJOR < 299
368 # define scheme_make_string dll_scheme_make_string
369 # define scheme_make_string_output_port dll_scheme_make_string_output_port
370 # else
371 # define scheme_make_byte_string dll_scheme_make_byte_string
372 # define scheme_make_byte_string_output_port \
373 dll_scheme_make_byte_string_output_port
374 # endif
375 # define scheme_make_struct_instance dll_scheme_make_struct_instance
376 # define scheme_make_struct_names dll_scheme_make_struct_names
377 # define scheme_make_struct_type dll_scheme_make_struct_type
378 # define scheme_make_struct_values dll_scheme_make_struct_values
379 # define scheme_make_type dll_scheme_make_type
380 # define scheme_make_vector dll_scheme_make_vector
381 # define scheme_malloc_fail_ok dll_scheme_malloc_fail_ok
382 # define scheme_open_input_file dll_scheme_open_input_file
383 # define scheme_primitive_module dll_scheme_primitive_module
384 # define scheme_proper_list_length dll_scheme_proper_list_length
385 # define scheme_raise dll_scheme_raise
386 # define scheme_read dll_scheme_read
387 # define scheme_register_static dll_scheme_register_static
388 # define scheme_set_stack_base dll_scheme_set_stack_base
389 # define scheme_signal_error dll_scheme_signal_error
390 # define scheme_wrong_type dll_scheme_wrong_type
391 # if MZSCHEME_VERSION_MAJOR >= 299
392 # define scheme_set_param dll_scheme_set_param
393 # define scheme_current_config dll_scheme_current_config
394 # define scheme_char_string_to_byte_string \
395 dll_scheme_char_string_to_byte_string
396 # endif
397
398 typedef struct
399 {
400 char *name;
401 void **ptr;
402 } Thunk_Info;
403
404 static Thunk_Info mzgc_imports[] = {
405 {"GC_malloc", (void **)&dll_GC_malloc},
406 {"GC_malloc_atomic", (void **)&dll_GC_malloc_atomic},
407 {NULL, NULL}};
408
409 static Thunk_Info mzsch_imports[] = {
410 {"scheme_eof", (void **)&dll_scheme_eof},
411 {"scheme_false", (void **)&dll_scheme_false},
412 {"scheme_void", (void **)&dll_scheme_void},
413 {"scheme_null", (void **)&dll_scheme_null},
414 {"scheme_true", (void **)&dll_scheme_true},
415 {"scheme_current_thread", (void **)&dll_scheme_current_thread_ptr},
416 {"scheme_console_printf", (void **)&dll_scheme_console_printf_ptr},
417 {"scheme_console_output", (void **)&dll_scheme_console_output_ptr},
418 {"scheme_notify_multithread",
419 (void **)&dll_scheme_notify_multithread_ptr},
420 {"scheme_add_global", (void **)&dll_scheme_add_global},
421 {"scheme_add_global_symbol", (void **)&dll_scheme_add_global_symbol},
422 {"scheme_apply", (void **)&dll_scheme_apply},
423 {"scheme_basic_env", (void **)&dll_scheme_basic_env},
424 # if MZSCHEME_VERSION_MAJOR >= 299
425 {"scheme_byte_string_to_char_string", (void **)&dll_scheme_byte_string_to_char_string},
426 # endif
427 {"scheme_builtin_value", (void **)&dll_scheme_builtin_value},
428 {"scheme_check_threads", (void **)&dll_scheme_check_threads},
429 {"scheme_close_input_port", (void **)&dll_scheme_close_input_port},
430 {"scheme_count_lines", (void **)&dll_scheme_count_lines},
431 {"scheme_current_continuation_marks",
432 (void **)&dll_scheme_current_continuation_marks},
433 {"scheme_display", (void **)&dll_scheme_display},
434 {"scheme_display_to_string", (void **)&dll_scheme_display_to_string},
435 {"scheme_do_eval", (void **)&dll_scheme_do_eval},
436 {"scheme_dont_gc_ptr", (void **)&dll_scheme_dont_gc_ptr},
437 {"scheme_eq", (void **)&dll_scheme_eq},
438 {"scheme_eval", (void **)&dll_scheme_eval},
439 {"scheme_eval_string", (void **)&dll_scheme_eval_string},
440 {"scheme_eval_string_all", (void **)&dll_scheme_eval_string_all},
441 {"scheme_finish_primitive_module",
442 (void **)&dll_scheme_finish_primitive_module},
443 # if MZSCHEME_VERSION_MAJOR < 299
444 {"scheme_format", (void **)&dll_scheme_format},
445 # else
446 {"scheme_format_utf8", (void **)&dll_scheme_format_utf8},
447 {"scheme_get_param", (void **)&dll_scheme_get_param},
448 #endif
449 {"scheme_gc_ptr_ok", (void **)&dll_scheme_gc_ptr_ok},
450 # if MZSCHEME_VERSION_MAJOR < 299
451 {"scheme_get_sized_string_output",
452 (void **)&dll_scheme_get_sized_string_output},
453 # else
454 {"scheme_get_sized_byte_string_output",
455 (void **)&dll_scheme_get_sized_byte_string_output},
456 #endif
457 {"scheme_intern_symbol", (void **)&dll_scheme_intern_symbol},
458 {"scheme_lookup_global", (void **)&dll_scheme_lookup_global},
459 {"scheme_make_closed_prim_w_arity",
460 (void **)&dll_scheme_make_closed_prim_w_arity},
461 {"scheme_make_integer_value", (void **)&dll_scheme_make_integer_value},
462 {"scheme_make_namespace", (void **)&dll_scheme_make_namespace},
463 {"scheme_make_pair", (void **)&dll_scheme_make_pair},
464 {"scheme_make_prim_w_arity", (void **)&dll_scheme_make_prim_w_arity},
465 # if MZSCHEME_VERSION_MAJOR < 299
466 {"scheme_make_string", (void **)&dll_scheme_make_string},
467 {"scheme_make_string_output_port",
468 (void **)&dll_scheme_make_string_output_port},
469 # else
470 {"scheme_make_byte_string", (void **)&dll_scheme_make_byte_string},
471 {"scheme_make_byte_string_output_port",
472 (void **)&dll_scheme_make_byte_string_output_port},
473 # endif
474 {"scheme_make_struct_instance",
475 (void **)&dll_scheme_make_struct_instance},
476 {"scheme_make_struct_names", (void **)&dll_scheme_make_struct_names},
477 {"scheme_make_struct_type", (void **)&dll_scheme_make_struct_type},
478 {"scheme_make_struct_values", (void **)&dll_scheme_make_struct_values},
479 {"scheme_make_type", (void **)&dll_scheme_make_type},
480 {"scheme_make_vector", (void **)&dll_scheme_make_vector},
481 {"scheme_malloc_fail_ok", (void **)&dll_scheme_malloc_fail_ok},
482 {"scheme_open_input_file", (void **)&dll_scheme_open_input_file},
483 {"scheme_primitive_module", (void **)&dll_scheme_primitive_module},
484 {"scheme_proper_list_length", (void **)&dll_scheme_proper_list_length},
485 {"scheme_raise", (void **)&dll_scheme_raise},
486 {"scheme_read", (void **)&dll_scheme_read},
487 {"scheme_register_static", (void **)&dll_scheme_register_static},
488 {"scheme_set_stack_base", (void **)&dll_scheme_set_stack_base},
489 {"scheme_signal_error", (void **)&dll_scheme_signal_error},
490 {"scheme_wrong_type", (void **)&dll_scheme_wrong_type},
491 # if MZSCHEME_VERSION_MAJOR >= 299
492 {"scheme_set_param", (void **)&dll_scheme_set_param},
493 {"scheme_current_config", (void **)&dll_scheme_current_config},
494 {"scheme_char_string_to_byte_string",
495 (void **)&dll_scheme_char_string_to_byte_string},
496 # endif
497 {NULL, NULL}};
498
499 static HINSTANCE hMzGC = 0;
500 static HINSTANCE hMzSch = 0;
501
502 static void dynamic_mzscheme_end(void);
503 static int mzscheme_runtime_link_init(char *sch_dll, char *gc_dll,
504 int verbose);
505
506 static int
507 mzscheme_runtime_link_init(char *sch_dll, char *gc_dll, int verbose)
508 {
509 Thunk_Info *thunk = NULL;
510
511 if (hMzGC && hMzSch)
512 return OK;
513 hMzSch = LoadLibrary(sch_dll);
514 hMzGC = LoadLibrary(gc_dll);
515
516 if (!hMzSch)
517 {
518 if (verbose)
519 EMSG2(_(e_loadlib), sch_dll);
520 return FAIL;
521 }
522
523 if (!hMzGC)
524 {
525 if (verbose)
526 EMSG2(_(e_loadlib), gc_dll);
527 return FAIL;
528 }
529
530 for (thunk = mzsch_imports; thunk->name; thunk++)
531 {
532 if ((*thunk->ptr =
533 (void *)GetProcAddress(hMzSch, thunk->name)) == NULL)
534 {
535 FreeLibrary(hMzSch);
536 hMzSch = 0;
537 FreeLibrary(hMzGC);
538 hMzGC = 0;
539 if (verbose)
540 EMSG2(_(e_loadfunc), thunk->name);
541 return FAIL;
542 }
543 }
544 for (thunk = mzgc_imports; thunk->name; thunk++)
545 {
546 if ((*thunk->ptr =
547 (void *)GetProcAddress(hMzGC, thunk->name)) == NULL)
548 {
549 FreeLibrary(hMzSch);
550 hMzSch = 0;
551 FreeLibrary(hMzGC);
552 hMzGC = 0;
553 if (verbose)
554 EMSG2(_(e_loadfunc), thunk->name);
555 return FAIL;
556 }
557 }
558 return OK;
559 }
560
561 int
562 mzscheme_enabled(int verbose)
563 {
564 return mzscheme_runtime_link_init(
565 DYNAMIC_MZSCH_DLL, DYNAMIC_MZGC_DLL, verbose) == OK;
566 }
567
568 static void
569 dynamic_mzscheme_end(void)
570 {
571 if (hMzSch)
572 {
573 FreeLibrary(hMzSch);
574 hMzSch = 0;
575 }
576 if (hMzGC)
577 {
578 FreeLibrary(hMzGC);
579 hMzGC = 0;
580 }
581 }
582 #endif /* DYNAMIC_MZSCHEME */
583
584 /*
585 *========================================================================
586 * 1. MzScheme interpreter startup
587 *========================================================================
588 */
589
590 static Scheme_Type mz_buffer_type;
591 static Scheme_Type mz_window_type;
592
593 static int initialized = 0;
594
595 /* global environment */
596 static Scheme_Env *environment = NULL;
597 /* output/error handlers */
598 static Scheme_Object *curout = NULL;
599 static Scheme_Object *curerr = NULL;
600 /* vim:exn exception */
601 static Scheme_Object *exn_catching_apply = NULL;
602 static Scheme_Object *exn_p = NULL;
603 static Scheme_Object *exn_message = NULL;
604 static Scheme_Object *vim_exn = NULL; /* Vim Error exception */
605 /* values for exn:vim - constructor, predicate, accessors etc */
606 static Scheme_Object *vim_exn_names = NULL;
607 static Scheme_Object *vim_exn_values = NULL;
608
609 static long range_start;
610 static long range_end;
611
612 /* MzScheme threads scheduling stuff */
613 static int mz_threads_allow = 0;
614
615 #if defined(FEAT_GUI_W32)
616 static void CALLBACK timer_proc(HWND, UINT, UINT, DWORD);
617 static UINT timer_id = 0;
618 #elif defined(FEAT_GUI_GTK)
619 static gint timer_proc(gpointer);
620 static guint timer_id = 0;
621 #elif defined(FEAT_GUI_MOTIF) || defined(FEAT_GUI_ATHENA)
622 static void timer_proc(XtPointer, XtIntervalId *);
623 static XtIntervalId timer_id = (XtIntervalId)0;
624 #elif defined(FEAT_GUI_MAC)
625 pascal void timer_proc(EventLoopTimerRef, void *);
626 static EventLoopTimerRef timer_id = NULL;
627 static EventLoopTimerUPP timerUPP;
628 #endif
629
630 #ifndef FEAT_GUI_W32 /* Win32 console and Unix */
631 void
632 mzvim_check_threads(void)
633 {
634 /* Last time MzScheme threads were scheduled */
635 static time_t mz_last_time = 0;
636
637 if (mz_threads_allow && p_mzq > 0)
638 {
639 time_t now = time(NULL);
640
641 if ((now - mz_last_time) * 1000 > p_mzq)
642 {
643 mz_last_time = now;
644 scheme_check_threads();
645 }
646 }
647 }
648 #endif
649
650 #ifdef MZSCHEME_GUI_THREADS
651 static void setup_timer(void);
652 static void remove_timer(void);
653
654 /* timers are presented in GUI only */
655 # if defined(FEAT_GUI_W32)
656 static void CALLBACK
657 timer_proc(HWND hwnd, UINT uMsg, UINT idEvent, DWORD dwTime)
658 # elif defined(FEAT_GUI_GTK)
659 /*ARGSUSED*/
660 static gint
661 timer_proc(gpointer data)
662 # elif defined(FEAT_GUI_MOTIF) || defined(FEAT_GUI_ATHENA)
663 /* ARGSUSED */
664 static void
665 timer_proc(XtPointer timed_out, XtIntervalId *interval_id)
666 # elif defined(FEAT_GUI_MAC)
667 pascal void
668 timer_proc(EventLoopTimerRef theTimer, void *userData)
669 # endif
670 {
671 scheme_check_threads();
672 # if defined(FEAT_GUI_GTK)
673 return TRUE; /* continue receiving notifications */
674 # elif defined(FEAT_GUI_MOTIF) || defined(FEAT_GUI_ATHENA)
675 /* renew timeout */
676 if (mz_threads_allow && p_mzq > 0)
677 timer_id = XtAppAddTimeOut(app_context, p_mzq,
678 timer_proc, NULL);
679 # endif
680 }
681
682 static void
683 setup_timer(void)
684 {
685 # if defined(FEAT_GUI_W32)
686 timer_id = SetTimer(NULL, 0, p_mzq, timer_proc);
687 # elif defined(FEAT_GUI_GTK)
688 timer_id = gtk_timeout_add((guint32)p_mzq, (GtkFunction)timer_proc, NULL);
689 # elif defined(FEAT_GUI_MOTIF) || defined(FEAT_GUI_ATHENA)
690 timer_id = XtAppAddTimeOut(app_context, p_mzq, timer_proc, NULL);
691 # elif defined(FEAT_GUI_MAC)
692 timerUPP = NewEventLoopTimerUPP(timer_proc);
693 InstallEventLoopTimer(GetMainEventLoop(), p_mzq * kEventDurationMillisecond,
694 p_mzq * kEventDurationMillisecond, timerUPP, NULL, &timer_id);
695 # endif
696 }
697
698 static void
699 remove_timer(void)
700 {
701 # if defined(FEAT_GUI_W32)
702 KillTimer(NULL, timer_id);
703 # elif defined(FEAT_GUI_GTK)
704 gtk_timeout_remove(timer_id);
705 # elif defined(FEAT_GUI_MOTIF) || defined(FEAT_GUI_ATHENA)
706 XtRemoveTimeOut(timer_id);
707 # elif defined(FEAT_GUI_MAC)
708 RemoveEventLoopTimer(timer_id);
709 DisposeEventLoopTimerUPP(timerUPP);
710 # endif
711 timer_id = 0;
712 }
713
714 void
715 mzvim_reset_timer(void)
716 {
717 if (timer_id != 0)
718 remove_timer();
719 if (mz_threads_allow && p_mzq > 0 && gui.in_use)
720 setup_timer();
721 }
722
723 #endif /* MZSCHEME_GUI_THREADS */
724
725 static void
726 notify_multithread(int on)
727 {
728 mz_threads_allow = on;
729 #ifdef MZSCHEME_GUI_THREADS
730 if (on && timer_id == 0 && p_mzq > 0 && gui.in_use)
731 setup_timer();
732 if (!on && timer_id != 0)
733 remove_timer();
734 #endif
735 }
736
737 void
738 mzscheme_end(void)
739 {
740 #ifdef DYNAMIC_MZSCHEME
741 dynamic_mzscheme_end();
742 #endif
743 }
744
745 static void
746 startup_mzscheme(void)
747 {
748 Scheme_Object *proc_make_security_guard;
749
750 scheme_set_stack_base(NULL, 1);
751
752 MZ_REGISTER_STATIC(environment);
753 MZ_REGISTER_STATIC(curout);
754 MZ_REGISTER_STATIC(curerr);
755 MZ_REGISTER_STATIC(exn_catching_apply);
756 MZ_REGISTER_STATIC(exn_p);
757 MZ_REGISTER_STATIC(exn_message);
758 MZ_REGISTER_STATIC(vim_exn);
759 MZ_REGISTER_STATIC(vim_exn_names);
760 MZ_REGISTER_STATIC(vim_exn_values);
761
762 environment = scheme_basic_env();
763
764 /* redirect output */
765 scheme_console_output = do_output;
766 scheme_console_printf = do_printf;
767
768 #ifdef MZSCHEME_COLLECTS
769 /* setup 'current-library-collection-paths' parameter */
770 scheme_set_param(scheme_config, MZCONFIG_COLLECTION_PATHS,
771 scheme_make_pair(scheme_make_string(MZSCHEME_COLLECTS),
772 scheme_null));
773 #endif
774 #ifdef HAVE_SANDBOX
775 /* setup sandbox guards */
776 proc_make_security_guard = scheme_lookup_global(
777 scheme_intern_symbol("make-security-guard"),
778 environment);
779 if (proc_make_security_guard != NULL)
780 {
781 Scheme_Object *args[3];
782 Scheme_Object *guard;
783 args[0] = scheme_get_param(scheme_config, MZCONFIG_SECURITY_GUARD);
784 args[1] = scheme_make_prim_w_arity(sandbox_file_guard,
785 "sandbox-file-guard", 3, 3);
786 args[2] = scheme_make_prim_w_arity(sandbox_network_guard,
787 "sandbox-network-guard", 4, 4);
788 guard = scheme_apply(proc_make_security_guard, 3, args);
789 scheme_set_param(scheme_config, MZCONFIG_SECURITY_GUARD, guard);
790 }
791 #endif
792 /* Create buffer and window types for use in Scheme code */
793 mz_buffer_type = scheme_make_type("<vim-buffer>");
794 mz_window_type = scheme_make_type("<vim-window>");
795
796 register_vim_exn(environment);
797 make_modules(environment);
798
799 /*
800 * setup callback to receive notifications
801 * whether thread scheduling is (or not) required
802 */
803 scheme_notify_multithread = notify_multithread;
804 initialized = 1;
805 }
806
807 /*
808 * This routine is called for each new invocation of MzScheme
809 * to make sure things are properly initialized.
810 */
811 static int
812 mzscheme_init(void)
813 {
814 int do_require = FALSE;
815
816 if (!initialized)
817 {
818 do_require = TRUE;
819 #ifdef DYNAMIC_MZSCHEME
820 if (!mzscheme_enabled(TRUE))
821 {
822 EMSG(_("???: Sorry, this command is disabled, the MzScheme library could not be loaded."));
823 return -1;
824 }
825 #endif
826 startup_mzscheme();
827
828 if (mzscheme_io_init())
829 return -1;
830
831 }
832 /* recreate ports each call effectivelly clearing these ones */
833 curout = scheme_make_string_output_port();
834 curerr = scheme_make_string_output_port();
835 scheme_set_param(scheme_config, MZCONFIG_OUTPUT_PORT, curout);
836 scheme_set_param(scheme_config, MZCONFIG_ERROR_PORT, curerr);
837
838 if (do_require)
839 {
840 /* auto-instantiate in basic env */
841 eval_in_namespace("(require (prefix vimext: vimext))", do_eval,
842 environment, NULL);
843 }
844
845 return 0;
846 }
847
848 /*
849 * This routine fills the namespace with various important routines that can
850 * be used within MzScheme.
851 */
852 static void
853 mzscheme_interface_init(vim_mz_buffer *mzbuff)
854 {
855 Scheme_Object *attach;
856
857 mzbuff->env = (Scheme_Env *)scheme_make_namespace(0, NULL);
858
859 /*
860 * attach instantiated modules from global namespace
861 * so they can be easily instantiated in the buffer namespace
862 */
863 attach = scheme_lookup_global(
864 scheme_intern_symbol("namespace-attach-module"),
865 environment);
866
867 if (attach != NULL)
868 {
869 Scheme_Object *ret;
870 Scheme_Object *args[2];
871
872 args[0] = (Scheme_Object *)environment;
873 args[1] = scheme_intern_symbol("vimext");
874
875 ret = (Scheme_Object *)mzvim_apply(attach, 2, args);
876 }
877
878 add_vim_exn(mzbuff->env);
879 }
880
881 /*
882 *========================================================================
883 * 2. External Interface
884 *========================================================================
885 */
886
887 /*
888 * Evaluate command in namespace with exception handling
889 */
890 static int
891 eval_in_namespace(void *data, Scheme_Closed_Prim *what, Scheme_Env *env,
892 Scheme_Object **ret)
893 {
894 Scheme_Object *value;
895 Scheme_Object *exn;
896 Cmd_Info info; /* closure info */
897
898 info.data = data;
899 info.env = env;
900
901 scheme_set_param(scheme_config, MZCONFIG_ENV,
902 (Scheme_Object *) env);
903 /*
904 * ensure all evaluations will be in current buffer namespace,
905 * the second argument to scheme_eval_string isn't enough!
906 */
907 value = _apply_thunk_catch_exceptions(
908 scheme_make_closed_prim_w_arity(what, &info, "mzvim", 0, 0),
909 &exn);
910
911 if (!value)
912 {
913 value = extract_exn_message(exn);
914 /* Got an exn? */
915 if (value)
916 {
917 scheme_display(value, curerr); /* Send to stderr-vim */
918 do_flush();
919 }
920 /* `raise' was called on some arbitrary value */
921 return FAIL;
922 }
923
924 if (ret != NULL) /* if pointer to retval supported give it up */
925 *ret = value;
926 /* Print any result, as long as it's not a void */
927 else if (!SCHEME_VOIDP(value))
928 scheme_display(value, curout); /* Send to stdout-vim */
929
930 do_flush();
931 return OK;
932 }
933
934 /* :mzscheme */
935 static int
936 do_mzscheme_command(exarg_T *eap, void *data, Scheme_Closed_Prim *what)
937 {
938 if (mzscheme_init())
939 return FAIL;
940
941 range_start = eap->line1;
942 range_end = eap->line2;
943
944 return eval_in_namespace(data, what, get_vim_curr_buffer()->env, NULL);
945 }
946
947 /*
948 * Routine called by VIM when deleting a buffer
949 */
950 void
951 mzscheme_buffer_free(buf_T *buf)
952 {
953 if (buf->b_mzscheme_ref)
954 {
955 vim_mz_buffer *bp;
956
957 bp = buf->b_mzscheme_ref;
958 bp->buf = INVALID_BUFFER_VALUE;
959 buf->b_mzscheme_ref = NULL;
960 scheme_gc_ptr_ok(bp);
961 }
962 }
963
964 /*
965 * Routine called by VIM when deleting a Window
966 */
967 void
968 mzscheme_window_free(win_T *win)
969 {
970 if (win->w_mzscheme_ref)
971 {
972 vim_mz_window *wp;
973 wp = win->w_mzscheme_ref;
974 wp->win = INVALID_WINDOW_VALUE;
975 win->w_mzscheme_ref = NULL;
976 scheme_gc_ptr_ok(wp);
977 }
978 }
979
980 /*
981 * ":mzscheme" (or ":mz")
982 */
983 void
984 ex_mzscheme(exarg_T *eap)
985 {
986 char_u *script;
987
988 script = script_get(eap, eap->arg);
989 if (!eap->skip)
990 {
991 if (script == NULL)
992 do_mzscheme_command(eap, eap->arg, do_eval);
993 else
994 {
995 do_mzscheme_command(eap, script, do_eval);
996 vim_free(script);
997 }
998 }
999 }
1000
1001 /* eval MzScheme string */
1002 void *
1003 mzvim_eval_string(char_u *str)
1004 {
1005 Scheme_Object *ret = NULL;
1006 if (mzscheme_init())
1007 return FAIL;
1008
1009 eval_in_namespace(str, do_eval, get_vim_curr_buffer()->env, &ret);
1010 return ret;
1011 }
1012
1013 /*
1014 * apply MzScheme procedure with arguments,
1015 * handling errors
1016 */
1017 Scheme_Object *
1018 mzvim_apply(Scheme_Object *proc, int argc, Scheme_Object **argv)
1019 {
1020 Apply_Info data;
1021 Scheme_Object *ret = NULL;
1022
1023 if (mzscheme_init())
1024 return FAIL;
1025
1026 data.proc = proc;
1027 data.argc = argc;
1028 data.argv = argv;
1029
1030 eval_in_namespace(&data, do_apply, get_vim_curr_buffer()->env, &ret);
1031 return ret;
1032 }
1033
1034 static Scheme_Object *
1035 do_load(void *data, int noargc, Scheme_Object **noargv)
1036 {
1037 Cmd_Info *info = (Cmd_Info *)data;
1038 Scheme_Object *result = scheme_void;
1039 Scheme_Object *expr;
1040 char_u *file = scheme_malloc_fail_ok(
1041 scheme_malloc_atomic, MAXPATHL + 1);
1042 Port_Info *pinfo = (Port_Info *)(info->data);
1043
1044 /* make Vim expansion */
1045 expand_env((char_u *)pinfo->name, file, MAXPATHL);
1046 /* scheme_load looks strange working with namespaces and error handling*/
1047 pinfo->port = scheme_open_input_file(file, "mzfile");
1048 scheme_count_lines(pinfo->port); /* to get accurate read error location*/
1049
1050 /* Like REPL but print only last result */
1051 while (!SCHEME_EOFP(expr = scheme_read(pinfo->port)))
1052 result = scheme_eval(expr, info->env);
1053
1054 /* errors will be caught in do_mzscheme_comamnd and ex_mzfile */
1055 scheme_close_input_port(pinfo->port);
1056 pinfo->port = NULL;
1057 return result;
1058 }
1059
1060 /* :mzfile */
1061 void
1062 ex_mzfile(exarg_T *eap)
1063 {
1064 Port_Info pinfo;
1065
1066 pinfo.name = (char *)eap->arg;
1067 pinfo.port = NULL;
1068 if (do_mzscheme_command(eap, &pinfo, do_load) != OK
1069 && pinfo.port != NULL) /* looks like port was not closed */
1070 scheme_close_input_port(pinfo.port);
1071 }
1072
1073
1074 /*
1075 *========================================================================
1076 * Exception handling code -- cribbed form the MzScheme sources and
1077 * Matthew Flatt's "Inside PLT MzScheme" document.
1078 *========================================================================
1079 */
1080 static void
1081 init_exn_catching_apply(void)
1082 {
1083 if (!exn_catching_apply)
1084 {
1085 char *e =
1086 "(lambda (thunk) "
1087 "(with-handlers ([void (lambda (exn) (cons #f exn))]) "
1088 "(cons #t (thunk))))";
1089
1090 /* make sure we have a namespace with the standard syntax: */
1091 Scheme_Env *env = (Scheme_Env *)scheme_make_namespace(0, NULL);
1092 add_vim_exn(env);
1093
1094 exn_catching_apply = scheme_eval_string(e, env);
1095 exn_p = scheme_lookup_global(scheme_intern_symbol("exn?"), env);
1096 exn_message = scheme_lookup_global(
1097 scheme_intern_symbol("exn-message"), env);
1098 }
1099 }
1100
1101 /*
1102 * This function applies a thunk, returning the Scheme value if there's
1103 * no exception, otherwise returning NULL and setting *exn to the raised
1104 * value (usually an exn structure).
1105 */
1106 static Scheme_Object *
1107 _apply_thunk_catch_exceptions(Scheme_Object *f, Scheme_Object **exn)
1108 {
1109 Scheme_Object *v;
1110
1111 init_exn_catching_apply();
1112
1113 v = _scheme_apply(exn_catching_apply, 1, &f);
1114 /* v is a pair: (cons #t value) or (cons #f exn) */
1115
1116 if (SCHEME_TRUEP(SCHEME_CAR(v)))
1117 return SCHEME_CDR(v);
1118 else
1119 {
1120 *exn = SCHEME_CDR(v);
1121 return NULL;
1122 }
1123 }
1124
1125 static Scheme_Object *
1126 extract_exn_message(Scheme_Object *v)
1127 {
1128 init_exn_catching_apply();
1129
1130 if (SCHEME_TRUEP(_scheme_apply(exn_p, 1, &v)))
1131 return _scheme_apply(exn_message, 1, &v);
1132 else
1133 return NULL; /* Not an exn structure */
1134 }
1135
1136 static Scheme_Object *
1137 do_eval(void *s, int noargc, Scheme_Object **noargv)
1138 {
1139 Cmd_Info *info = (Cmd_Info *)s;
1140
1141 return scheme_eval_string_all((char *)(info->data), info->env, TRUE);
1142 }
1143
1144 static Scheme_Object *
1145 do_apply(void *a, int noargc, Scheme_Object **noargv)
1146 {
1147 Apply_Info *info = (Apply_Info *)(((Cmd_Info *)a)->data);
1148
1149 return scheme_apply(info->proc, info->argc, info->argv);
1150 }
1151
1152 /*
1153 *========================================================================
1154 * 3. MzScheme I/O Handlers
1155 *========================================================================
1156 */
1157 static void
1158 do_intrnl_output(char *mesg, long len, int error)
1159 {
1160 char *p, *prev;
1161
1162 prev = mesg;
1163 p = strchr(prev, '\n');
1164 while (p)
1165 {
1166 *p = '\0';
1167 if (error)
1168 EMSG(prev);
1169 else
1170 MSG(prev);
1171 prev = p + 1;
1172 p = strchr(prev, '\n');
1173 }
1174
1175 if (error)
1176 EMSG(prev);
1177 else
1178 MSG(prev);
1179 }
1180
1181 static void
1182 do_output(char *mesg, long len)
1183 {
1184 do_intrnl_output(mesg, len, 0);
1185 }
1186
1187 static void
1188 do_err_output(char *mesg, long len)
1189 {
1190 do_intrnl_output(mesg, len, 1);
1191 }
1192
1193 static void
1194 do_printf(char *format, ...)
1195 {
1196 do_intrnl_output(format, STRLEN(format), 1);
1197 }
1198
1199 static void
1200 do_flush(void)
1201 {
1202 char *buff;
1203 long length;
1204
1205 buff = scheme_get_sized_string_output(curerr, &length);
1206 if (length)
1207 {
1208 do_err_output(buff, length);
1209 return;
1210 }
1211
1212 buff = scheme_get_sized_string_output(curout, &length);
1213 if (length)
1214 do_output(buff, length);
1215 }
1216
1217 static int
1218 mzscheme_io_init(void)
1219 {
1220 /* Nothing needed so far... */
1221 return 0;
1222 }
1223
1224 /*
1225 *========================================================================
1226 * 4. Implementation of the Vim Features for MzScheme
1227 *========================================================================
1228 */
1229
1230 /* (command {command-string}) */
1231 static Scheme_Object *
1232 vim_command(void *data, int argc, Scheme_Object **argv)
1233 {
1234 Vim_Prim *prim = (Vim_Prim *)data;
1235 char *cmd = SCHEME_STR_VAL(GUARANTEE_STRING(prim->name, 0));
1236
1237 /* may be use do_cmdline_cmd? */
1238 do_cmdline((char_u *)cmd, NULL, NULL, DOCMD_NOWAIT|DOCMD_VERBOSE);
1239 update_screen(VALID);
1240
1241 raise_if_error();
1242 return scheme_void;
1243 }
1244
1245 /* (eval {expr-string}) */
1246 static Scheme_Object *
1247 vim_eval(void *data, int argc, Scheme_Object **argv)
1248 {
1249 #ifdef FEAT_EVAL
1250 Vim_Prim *prim = (Vim_Prim *)data;
1251 char *expr;
1252 char *str;
1253 Scheme_Object *result;
1254
1255 expr = SCHEME_STR_VAL(GUARANTEE_STRING(prim->name, 0));
1256
1257 str = (char *)eval_to_string((char_u *)expr, NULL, TRUE);
1258
1259 if (str == NULL)
1260 raise_vim_exn(_("invalid expression"));
1261
1262 result = scheme_make_string(str);
1263
1264 vim_free(str);
1265
1266 return result;
1267 #else
1268 raise_vim_exn(_("expressions disabled at compile time"));
1269 /* unreachable */
1270 return scheme_false;
1271 #endif
1272 }
1273
1274 /* (range-start) */
1275 static Scheme_Object *
1276 get_range_start(void *data, int argc, Scheme_Object **argv)
1277 {
1278 return scheme_make_integer(range_start);
1279 }
1280
1281 /* (range-end) */
1282 static Scheme_Object *
1283 get_range_end(void *data, int argc, Scheme_Object **argv)
1284 {
1285 return scheme_make_integer(range_end);
1286 }
1287
1288 /* (beep) */
1289 static Scheme_Object *
1290 mzscheme_beep(void *data, int argc, Scheme_Object **argv)
1291 {
1292 vim_beep();
1293 return scheme_void;
1294 }
1295
1296 static Scheme_Object *M_global = NULL;
1297
1298 /* (get-option {option-name}) [buffer/window] */
1299 static Scheme_Object *
1300 get_option(void *data, int argc, Scheme_Object **argv)
1301 {
1302 Vim_Prim *prim = (Vim_Prim *)data;
1303 char_u *name;
1304 long value;
1305 char_u *strval;
1306 int rc;
1307 Scheme_Object *rval;
1308 int opt_flags = 0;
1309 buf_T *save_curb = curbuf;
1310 win_T *save_curw = curwin;
1311
1312 name = (char_u *)SCHEME_STR_VAL(GUARANTEE_STRING(prim->name, 0));
1313
1314 if (argc > 1)
1315 {
1316 if (M_global == NULL)
1317 {
1318 MZ_REGISTER_STATIC(M_global);
1319 M_global = scheme_intern_symbol("global");
1320 }
1321
1322 if (argv[1] == M_global)
1323 opt_flags = OPT_GLOBAL;
1324 else if (SCHEME_VIMBUFFERP(argv[1]))
1325 {
1326 curbuf = get_valid_buffer(argv[1]);
1327 opt_flags = OPT_LOCAL;
1328 }
1329 else if (SCHEME_VIMWINDOWP(argv[1]))
1330 {
1331 win_T *win = get_valid_window(argv[1]);
1332
1333 curwin = win;
1334 curbuf = win->w_buffer;
1335 opt_flags = OPT_LOCAL;
1336 }
1337 else
1338 scheme_wrong_type(prim->name, "vim-buffer/window", 1, argc, argv);
1339 }
1340
1341 rc = get_option_value(name, &value, &strval, opt_flags);
1342 curbuf = save_curb;
1343 curwin = save_curw;
1344
1345 switch (rc)
1346 {
1347 case 1:
1348 return scheme_make_integer_value(value);
1349 case 0:
1350 rval = scheme_make_string(strval);
1351 vim_free(strval);
1352 return rval;
1353 case -1:
1354 case -2:
1355 raise_vim_exn(_("hidden option"));
1356 case -3:
1357 raise_vim_exn(_("unknown option"));
1358 }
1359 /* unreachable */
1360 return scheme_void;
1361 }
1362
1363 /* (set-option {option-changing-string} [buffer/window]) */
1364 static Scheme_Object *
1365 set_option(void *data, int argc, Scheme_Object **argv)
1366 {
1367 char_u *cmd;
1368 int opt_flags = 0;
1369 buf_T *save_curb = curbuf;
1370 win_T *save_curw = curwin;
1371 Vim_Prim *prim = (Vim_Prim *)data;
1372
1373 GUARANTEE_STRING(prim->name, 0);
1374 if (argc > 1)
1375 {
1376 if (M_global == NULL)
1377 {
1378 MZ_REGISTER_STATIC(M_global);
1379 M_global = scheme_intern_symbol("global");
1380 }
1381
1382 if (argv[1] == M_global)
1383 opt_flags = OPT_GLOBAL;
1384 else if (SCHEME_VIMBUFFERP(argv[1]))
1385 {
1386 curbuf = get_valid_buffer(argv[1]);
1387 opt_flags = OPT_LOCAL;
1388 }
1389 else if (SCHEME_VIMWINDOWP(argv[1]))
1390 {
1391 win_T *win = get_valid_window(argv[1]);
1392 curwin = win;
1393 curbuf = win->w_buffer;
1394 opt_flags = OPT_LOCAL;
1395 }
1396 else
1397 scheme_wrong_type(prim->name, "vim-buffer/window", 1, argc, argv);
1398 }
1399
1400 /* do_set can modify cmd, make copy */
1401 cmd = vim_strsave((char_u *)SCHEME_STR_VAL(argv[0]));
1402 do_set(cmd, opt_flags);
1403 vim_free(cmd);
1404 update_screen(NOT_VALID);
1405 curbuf = save_curb;
1406 curwin = save_curw;
1407 raise_if_error();
1408 return scheme_void;
1409 }
1410
1411 /*
1412 *===========================================================================
1413 * 5. Vim Window-related Manipulation Functions
1414 *===========================================================================
1415 */
1416
1417 /* (curr-win) */
1418 static Scheme_Object *
1419 get_curr_win(void *data, int argc, Scheme_Object **argv)
1420 {
1421 return (Scheme_Object *)get_vim_curr_window();
1422 }
1423
1424 /* (win-count) */
1425 static Scheme_Object *
1426 get_window_count(void *data, int argc, Scheme_Object **argv)
1427 {
1428 win_T *w;
1429 int n = 0;
1430
1431 for (w = firstwin; w != NULL; w = w->w_next)
1432 ++n;
1433 return scheme_make_integer(n);
1434 }
1435
1436 /* (get-win-list [buffer]) */
1437 static Scheme_Object *
1438 get_window_list(void *data, int argc, Scheme_Object **argv)
1439 {
1440 Vim_Prim *prim = (Vim_Prim *)data;
1441 vim_mz_buffer *buf;
1442 Scheme_Object *list;
1443 win_T *w;
1444
1445 buf = get_buffer_arg(prim->name, 0, argc, argv);
1446 list = scheme_null;
1447
1448 for (w = firstwin; w != NULL; w = w->w_next)
1449 if (w->w_buffer == buf->buf)
1450 list = scheme_make_pair(window_new(w), list);
1451
1452 return list;
1453 }
1454
1455 static Scheme_Object *
1456 window_new(win_T *win)
1457 {
1458 vim_mz_window *self;
1459
1460 /* We need to handle deletion of windows underneath us.
1461 * If we add a "w_mzscheme_ref" field to the win_T structure,
1462 * then we can get at it in win_free() in vim.
1463 *
1464 * On a win_free() we set the Scheme object's win_T *field
1465 * to an invalid value. We trap all uses of a window
1466 * object, and reject them if the win_T *field is invalid.
1467 */
1468 if (win->w_mzscheme_ref != NULL)
1469 return win->w_mzscheme_ref;
1470
1471 self = scheme_malloc_fail_ok(scheme_malloc, sizeof(vim_mz_window));
1472
1473 vim_memset(self, 0, sizeof(vim_mz_window));
1474 scheme_dont_gc_ptr(self); /* because win isn't visible to GC */
1475 win->w_mzscheme_ref = self;
1476 self->win = win;
1477 self->tag = mz_window_type;
1478
1479 return (Scheme_Object *)(self);
1480 }
1481
1482 /* (get-win-num [window]) */
1483 static Scheme_Object *
1484 get_window_num(void *data, int argc, Scheme_Object **argv)
1485 {
1486 Vim_Prim *prim = (Vim_Prim *)data;
1487 win_T *win = get_window_arg(prim->name, 0, argc, argv)->win;
1488 int nr = 1;
1489 win_T *wp;
1490
1491 for (wp = firstwin; wp != win; wp = wp->w_next)
1492 ++nr;
1493
1494 return scheme_make_integer(nr);
1495 }
1496
1497 /* (get-win-by-num {windownum}) */
1498 static Scheme_Object *
1499 get_window_by_num(void *data, int argc, Scheme_Object **argv)
1500 {
1501 Vim_Prim *prim = (Vim_Prim *)data;
1502 win_T *win;
1503 int fnum;
1504
1505 fnum = SCHEME_INT_VAL(GUARANTEE_INTEGER(prim->name, 0));
1506 if (fnum < 1)
1507 scheme_signal_error(_("window index is out of range"));
1508
1509 for (win = firstwin; win != NULL; win = win->w_next, --fnum)
1510 if (fnum == 1) /* to be 1-based */
1511 return window_new(win);
1512
1513 return scheme_false;
1514 }
1515
1516 /* (get-win-buffer [window]) */
1517 static Scheme_Object *
1518 get_window_buffer(void *data, int argc, Scheme_Object **argv)
1519 {
1520 Vim_Prim *prim = (Vim_Prim *)data;
1521 vim_mz_window *win = get_window_arg(prim->name, 0, argc, argv);
1522
1523 return buffer_new(win->win->w_buffer);
1524 }
1525
1526 /* (get-win-height [window]) */
1527 static Scheme_Object *
1528 get_window_height(void *data, int argc, Scheme_Object **argv)
1529 {
1530 Vim_Prim *prim = (Vim_Prim *)data;
1531 vim_mz_window *win = get_window_arg(prim->name, 0, argc, argv);
1532
1533 return scheme_make_integer(win->win->w_height);
1534 }
1535
1536 /* (set-win-height {height} [window]) */
1537 static Scheme_Object *
1538 set_window_height(void *data, int argc, Scheme_Object **argv)
1539 {
1540 Vim_Prim *prim = (Vim_Prim *)data;
1541 vim_mz_window *win;
1542 win_T *savewin;
1543 int height;
1544
1545 win = get_window_arg(prim->name, 1, argc, argv);
1546 height = SCHEME_INT_VAL(GUARANTEE_INTEGER(prim->name, 0));
1547
1548 #ifdef FEAT_GUI
1549 need_mouse_correct = TRUE;
1550 #endif
1551
1552 savewin = curwin;
1553 curwin = win->win;
1554 win_setheight(height);
1555 curwin = savewin;
1556
1557 raise_if_error();
1558 return scheme_void;
1559 }
1560
1561 #ifdef FEAT_VERTSPLIT
1562 /* (get-win-width [window]) */
1563 static Scheme_Object *
1564 get_window_width(void *data, int argc, Scheme_Object **argv)
1565 {
1566 Vim_Prim *prim = (Vim_Prim *)data;
1567 vim_mz_window *win = get_window_arg(prim->name, 0, argc, argv);
1568
1569 return scheme_make_integer(W_WIDTH(win->win));
1570 }
1571
1572 /* (set-win-width {width} [window]) */
1573 static Scheme_Object *
1574 set_window_width(void *data, int argc, Scheme_Object **argv)
1575 {
1576 Vim_Prim *prim = (Vim_Prim *)data;
1577 vim_mz_window *win;
1578 win_T *savewin;
1579 int width = 0;
1580
1581 win = get_window_arg(prim->name, 1, argc, argv);
1582 width = SCHEME_INT_VAL(GUARANTEE_INTEGER(prim->name, 0));
1583
1584 # ifdef FEAT_GUI
1585 need_mouse_correct = TRUE;
1586 # endif
1587
1588 savewin = curwin;
1589 curwin = win->win;
1590 win_setwidth(width);
1591 curwin = savewin;
1592
1593 raise_if_error();
1594 return scheme_void;
1595 }
1596 #endif
1597
1598 /* (get-cursor [window]) -> (line . col) */
1599 static Scheme_Object *
1600 get_cursor(void *data, int argc, Scheme_Object **argv)
1601 {
1602 Vim_Prim *prim = (Vim_Prim *)data;
1603 vim_mz_window *win;
1604 pos_T pos;
1605
1606 win = get_window_arg(prim->name, 0, argc, argv);
1607 pos = win->win->w_cursor;
1608 return scheme_make_pair(scheme_make_integer_value((long)pos.lnum),
1609 scheme_make_integer_value((long)pos.col + 1));
1610 }
1611
1612 /* (set-cursor (line . col) [window]) */
1613 static Scheme_Object *
1614 set_cursor(void *data, int argc, Scheme_Object **argv)
1615 {
1616 Vim_Prim *prim = (Vim_Prim *)data;
1617 vim_mz_window *win;
1618 long lnum = 0;
1619 long col = 0;
1620
1621 #ifdef HAVE_SANDBOX
1622 sandbox_check();
1623 #endif
1624 win = get_window_arg(prim->name, 1, argc, argv);
1625 GUARANTEE_PAIR(prim->name, 0);
1626
1627 if (!SCHEME_INTP(SCHEME_CAR(argv[0]))
1628 || !SCHEME_INTP(SCHEME_CDR(argv[0])))
1629 scheme_wrong_type(prim->name, "integer pair", 0, argc, argv);
1630
1631 lnum = SCHEME_INT_VAL(SCHEME_CAR(argv[0]));
1632 col = SCHEME_INT_VAL(SCHEME_CDR(argv[0])) - 1;
1633
1634 check_line_range(lnum, win->win->w_buffer);
1635 /* don't know how to catch invalid column value */
1636
1637 win->win->w_cursor.lnum = lnum;
1638 win->win->w_cursor.col = col;
1639 update_screen(VALID);
1640
1641 raise_if_error();
1642 return scheme_void;
1643 }
1644 /*
1645 *===========================================================================
1646 * 6. Vim Buffer-related Manipulation Functions
1647 * Note that each buffer should have its own private namespace.
1648 *===========================================================================
1649 */
1650
1651 /* (open-buff {filename}) */
1652 static Scheme_Object *
1653 mzscheme_open_buffer(void *data, int argc, Scheme_Object **argv)
1654 {
1655 Vim_Prim *prim = (Vim_Prim *)data;
1656 char *fname;
1657 int num = 0;
1658 Scheme_Object *onum;
1659
1660 #ifdef HAVE_SANDBOX
1661 sandbox_check();
1662 #endif
1663 fname = SCHEME_STR_VAL(GUARANTEE_STRING(prim->name, 0));
1664 /* TODO make open existing file */
1665 num = buflist_add(fname, BLN_LISTED | BLN_CURBUF);
1666
1667 if (num == 0)
1668 raise_vim_exn(_("couldn't open buffer"));
1669
1670 onum = scheme_make_integer(num);
1671 return get_buffer_by_num(data, 1, &onum);
1672 }
1673
1674 /* (get-buff-by-num {buffernum}) */
1675 static Scheme_Object *
1676 get_buffer_by_num(void *data, int argc, Scheme_Object **argv)
1677 {
1678 Vim_Prim *prim = (Vim_Prim *)data;
1679 buf_T *buf;
1680 int fnum;
1681
1682 fnum = SCHEME_INT_VAL(GUARANTEE_INTEGER(prim->name, 0));
1683
1684 for (buf = firstbuf; buf; buf = buf->b_next)
1685 if (buf->b_fnum == fnum)
1686 return buffer_new(buf);
1687
1688 return scheme_false;
1689 }
1690
1691 /* (get-buff-by-name {buffername}) */
1692 static Scheme_Object *
1693 get_buffer_by_name(void *data, int argc, Scheme_Object **argv)
1694 {
1695 Vim_Prim *prim = (Vim_Prim *)data;
1696 buf_T *buf;
1697 char_u *fname;
1698
1699 fname = SCHEME_STR_VAL(GUARANTEE_STRING(prim->name, 0));
1700
1701 for (buf = firstbuf; buf; buf = buf->b_next)
1702 if (buf->b_ffname == NULL || buf->b_sfname == NULL)
1703 /* empty string */
1704 {
1705 if (fname[0] == NUL)
1706 return buffer_new(buf);
1707 }
1708 else if (!fnamecmp(buf->b_ffname, fname)
1709 || !fnamecmp(buf->b_sfname, fname))
1710 /* either short or long filename matches */
1711 return buffer_new(buf);
1712
1713 return scheme_false;
1714 }
1715
1716 /* (get-next-buff [buffer]) */
1717 static Scheme_Object *
1718 get_next_buffer(void *data, int argc, Scheme_Object **argv)
1719 {
1720 Vim_Prim *prim = (Vim_Prim *)data;
1721 buf_T *buf = get_buffer_arg(prim->name, 0, argc, argv)->buf;
1722
1723 if (buf->b_next == NULL)
1724 return scheme_false;
1725 else
1726 return buffer_new(buf->b_next);
1727 }
1728
1729 /* (get-prev-buff [buffer]) */
1730 static Scheme_Object *
1731 get_prev_buffer(void *data, int argc, Scheme_Object **argv)
1732 {
1733 Vim_Prim *prim = (Vim_Prim *)data;
1734 buf_T *buf = get_buffer_arg(prim->name, 0, argc, argv)->buf;
1735
1736 if (buf->b_prev == NULL)
1737 return scheme_false;
1738 else
1739 return buffer_new(buf->b_prev);
1740 }
1741
1742 /* (get-buff-num [buffer]) */
1743 static Scheme_Object *
1744 get_buffer_num(void *data, int argc, Scheme_Object **argv)
1745 {
1746 Vim_Prim *prim = (Vim_Prim *)data;
1747 vim_mz_buffer *buf = get_buffer_arg(prim->name, 0, argc, argv);
1748
1749 return scheme_make_integer(buf->buf->b_fnum);
1750 }
1751
1752 /* (buff-count) */
1753 static Scheme_Object *
1754 get_buffer_count(void *data, int argc, Scheme_Object **argv)
1755 {
1756 buf_T *b;
1757 int n = 0;
1758
1759 for (b = firstbuf; b; b = b->b_next) ++n;
1760 return scheme_make_integer(n);
1761 }
1762
1763 /* (get-buff-name [buffer]) */
1764 static Scheme_Object *
1765 get_buffer_name(void *data, int argc, Scheme_Object **argv)
1766 {
1767 Vim_Prim *prim = (Vim_Prim *)data;
1768 vim_mz_buffer *buf = get_buffer_arg(prim->name, 0, argc, argv);
1769
1770 return scheme_make_string(buf->buf->b_ffname);
1771 }
1772
1773 /* (curr-buff) */
1774 static Scheme_Object *
1775 get_curr_buffer(void *data, int argc, Scheme_Object **argv)
1776 {
1777 return (Scheme_Object *)get_vim_curr_buffer();
1778 }
1779
1780 static Scheme_Object *
1781 buffer_new(buf_T *buf)
1782 {
1783 vim_mz_buffer *self;
1784
1785 /* We need to handle deletion of buffers underneath us.
1786 * If we add a "b_mzscheme_ref" field to the buf_T structure,
1787 * then we can get at it in buf_freeall() in vim.
1788 */
1789 if (buf->b_mzscheme_ref)
1790 return buf->b_mzscheme_ref;
1791
1792 self = scheme_malloc_fail_ok(scheme_malloc, sizeof(vim_mz_buffer));
1793
1794 vim_memset(self, 0, sizeof(vim_mz_buffer));
1795 scheme_dont_gc_ptr(self); /* because buf isn't visible to GC */
1796 buf->b_mzscheme_ref = self;
1797 self->buf = buf;
1798 self->tag = mz_buffer_type;
1799
1800 mzscheme_interface_init(self); /* Set up namespace */
1801
1802 return (Scheme_Object *)(self);
1803 }
1804
1805 /*
1806 * (get-buff-size [buffer])
1807 *
1808 * Get the size (number of lines) in the current buffer.
1809 */
1810 static Scheme_Object *
1811 get_buffer_size(void *data, int argc, Scheme_Object **argv)
1812 {
1813 Vim_Prim *prim = (Vim_Prim *)data;
1814 vim_mz_buffer *buf = get_buffer_arg(prim->name, 0, argc, argv);
1815
1816 return scheme_make_integer(buf->buf->b_ml.ml_line_count);
1817 }
1818
1819 /*
1820 * (get-buff-line {linenr} [buffer])
1821 *
1822 * Get a line from the specified buffer. The line number is
1823 * in Vim format (1-based). The line is returned as a MzScheme
1824 * string object.
1825 */
1826 static Scheme_Object *
1827 get_buffer_line(void *data, int argc, Scheme_Object **argv)
1828 {
1829 Vim_Prim *prim = (Vim_Prim *)data;
1830 vim_mz_buffer *buf;
1831 int linenr;
1832 char *line;
1833
1834 buf = get_buffer_arg(prim->name, 1, argc, argv);
1835 linenr = SCHEME_INT_VAL(GUARANTEE_INTEGER(prim->name, 0));
1836 line = ml_get_buf(buf->buf, (linenr_T)linenr, FALSE);
1837
1838 raise_if_error();
1839 return scheme_make_string(line);
1840 }
1841
1842
1843 /*
1844 * (get-buff-line-list {start} {end} [buffer])
1845 *
1846 * Get a list of lines from the specified buffer. The line numbers
1847 * are in Vim format (1-based). The range is from lo up to, but not
1848 * including, hi. The list is returned as a list of string objects.
1849 */
1850 static Scheme_Object *
1851 get_buffer_line_list(void *data, int argc, Scheme_Object **argv)
1852 {
1853 Vim_Prim *prim = (Vim_Prim *)data;
1854 vim_mz_buffer *buf;
1855 int i, hi, lo, n;
1856 Scheme_Object *list;
1857
1858 buf = get_buffer_arg(prim->name, 2, argc, argv);
1859 list = scheme_null;
1860 hi = SCHEME_INT_VAL(GUARANTEE_INTEGER(prim->name, 1));
1861 lo = SCHEME_INT_VAL(GUARANTEE_INTEGER(prim->name, 0));
1862
1863 /*
1864 * Handle some error conditions
1865 */
1866 if (lo < 0)
1867 lo = 0;
1868
1869 if (hi < 0)
1870 hi = 0;
1871 if (hi < lo)
1872 hi = lo;
1873
1874 n = hi - lo;
1875
1876 for (i = n; i >= 0; --i)
1877 {
1878 Scheme_Object *str = scheme_make_string(
1879 (char *)ml_get_buf(buf->buf, (linenr_T)(lo+i), FALSE));
1880 raise_if_error();
1881
1882 /* Set the list item */
1883 list = scheme_make_pair(str, list);
1884 }
1885
1886 return list;
1887 }
1888
1889 /*
1890 * (set-buff-line {linenr} {string/#f} [buffer])
1891 *
1892 * Replace a line in the specified buffer. The line number is
1893 * in Vim format (1-based). The replacement line is given as
1894 * an MzScheme string object. The object is checked for validity
1895 * and correct format. An exception is thrown if the values are not
1896 * the correct format.
1897 *
1898 * It returns a Scheme Object that indicates the length of the
1899 * string changed.
1900 */
1901 static Scheme_Object *
1902 set_buffer_line(void *data, int argc, Scheme_Object **argv)
1903 {
1904 /* First of all, we check the the of the supplied MzScheme object.
1905 * There are three cases:
1906 * 1. #f - this is a deletion.
1907 * 2. A string - this is a replacement.
1908 * 3. Anything else - this is an error.
1909 */
1910 Vim_Prim *prim = (Vim_Prim *)data;
1911 vim_mz_buffer *buf;
1912 Scheme_Object *line;
1913 char *save;
1914 buf_T *savebuf;
1915 int n;
1916
1917 #ifdef HAVE_SANDBOX
1918 sandbox_check();
1919 #endif
1920 n = SCHEME_INT_VAL(GUARANTEE_INTEGER(prim->name, 0));
1921 if (!SCHEME_STRINGP(argv[1]) && !SCHEME_FALSEP(argv[1]))
1922 scheme_wrong_type(prim->name, "string or #f", 1, argc, argv);
1923 line = argv[1];
1924 buf = get_buffer_arg(prim->name, 2, argc, argv);
1925
1926 check_line_range(n, buf->buf);
1927
1928 if (SCHEME_FALSEP(line))
1929 {
1930 savebuf = curbuf;
1931 curbuf = buf->buf;
1932
1933 if (u_savedel((linenr_T)n, 1L) == FAIL)
1934 {
1935 curbuf = savebuf;
1936 raise_vim_exn(_("cannot save undo information"));
1937 }
1938 else if (ml_delete((linenr_T)n, FALSE) == FAIL)
1939 {
1940 curbuf = savebuf;
1941 raise_vim_exn(_("cannot delete line"));
1942 }
1943 deleted_lines_mark((linenr_T)n, 1L);
1944 if (buf->buf == curwin->w_buffer)
1945 mz_fix_cursor(n, n + 1, -1);
1946
1947 curbuf = savebuf;
1948
1949 raise_if_error();
1950 return scheme_void;
1951 }
1952
1953 /* Otherwise it's a line */
1954 save = string_to_line(line);
1955 savebuf = curbuf;
1956
1957 curbuf = buf->buf;
1958
1959 if (u_savesub((linenr_T)n) == FAIL)
1960 {
1961 curbuf = savebuf;
1962 raise_vim_exn(_("cannot save undo information"));
1963 }
1964 else if (ml_replace((linenr_T)n, (char_u *)save, TRUE) == FAIL)
1965 {
1966 curbuf = savebuf;
1967 raise_vim_exn(_("cannot replace line"));
1968 }
1969 else
1970 changed_bytes((linenr_T)n, 0);
1971
1972 curbuf = savebuf;
1973
1974 raise_if_error();
1975 return scheme_void;
1976 }
1977
1978 /*
1979 * (set-buff-line-list {start} {end} {string-list/#f/null} [buffer])
1980 *
1981 * Replace a range of lines in the specified buffer. The line numbers are in
1982 * Vim format (1-based). The range is from lo up to, but not including, hi.
1983 * The replacement lines are given as a Scheme list of string objects. The
1984 * list is checked for validity and correct format.
1985 *
1986 * Errors are returned as a value of FAIL. The return value is OK on success.
1987 * If OK is returned and len_change is not NULL, *len_change is set to the
1988 * change in the buffer length.
1989 */
1990 static Scheme_Object *
1991 set_buffer_line_list(void *data, int argc, Scheme_Object **argv)
1992 {
1993 /* First of all, we check the type of the supplied MzScheme object.
1994 * There are three cases:
1995 * 1. #f - this is a deletion.
1996 * 2. A list - this is a replacement.
1997 * 3. Anything else - this is an error.
1998 */
1999 Vim_Prim *prim = (Vim_Prim *)data;
2000 vim_mz_buffer *buf;
2001 Scheme_Object *line_list;
2002 Scheme_Object *line;
2003 Scheme_Object *rest;
2004 char **array;
2005 buf_T *savebuf;
2006 int i, old_len, new_len, hi, lo;
2007 long extra;
2008
2009 #ifdef HAVE_SANDBOX
2010 sandbox_check();
2011 #endif
2012 lo = SCHEME_INT_VAL(GUARANTEE_INTEGER(prim->name, 0));
2013 hi = SCHEME_INT_VAL(GUARANTEE_INTEGER(prim->name, 1));
2014 if (!SCHEME_PAIRP(argv[2])
2015 && !SCHEME_FALSEP(argv[2]) && !SCHEME_NULLP(argv[2]))
2016 scheme_wrong_type(prim->name, "list or #f", 2, argc, argv);
2017 line_list = argv[2];
2018 buf = get_buffer_arg(prim->name, 3, argc, argv);
2019 old_len = hi - lo;
2020 if (old_len < 0) /* process inverse values wisely */
2021 {
2022 i = lo;
2023 lo = hi;
2024 hi = i;
2025 old_len = -old_len;
2026 }
2027 extra = 0;
2028
2029 check_line_range(lo, buf->buf); /* inclusive */
2030 check_line_range(hi - 1, buf->buf); /* exclisive */
2031
2032 if (SCHEME_FALSEP(line_list) || SCHEME_NULLP(line_list))
2033 {
2034 savebuf = curbuf;
2035 curbuf = buf->buf;
2036
2037 if (u_savedel((linenr_T)lo, (long)old_len) == FAIL)
2038 {
2039 curbuf = savebuf;
2040 raise_vim_exn(_("cannot save undo information"));
2041 }
2042 else
2043 {
2044 for (i = 0; i < old_len; i++)
2045 if (ml_delete((linenr_T)lo, FALSE) == FAIL)
2046 {
2047 curbuf = savebuf;
2048 raise_vim_exn(_("cannot delete line"));
2049 }
2050 deleted_lines_mark((linenr_T)lo, (long)old_len);
2051 if (buf->buf == curwin->w_buffer)
2052 mz_fix_cursor(lo, hi, -old_len);
2053 }
2054
2055 curbuf = savebuf;
2056
2057 raise_if_error();
2058 return scheme_void;
2059 }
2060
2061 /* List */
2062 new_len = scheme_proper_list_length(line_list);
2063 if (new_len < 0) /* improper or cyclic list */
2064 scheme_wrong_type(prim->name, "proper list",
2065 2, argc, argv);
2066
2067 /* Using MzScheme allocator, so we don't need to free this and
2068 * can safely keep pointers to GC collected strings
2069 */
2070 array = (char **)scheme_malloc_fail_ok(scheme_malloc,
2071 (unsigned)(new_len * sizeof(char *)));
2072
2073 rest = line_list;
2074 for (i = 0; i < new_len; ++i)
2075 {
2076 line = SCHEME_CAR(rest);
2077 rest = SCHEME_CDR(rest);
2078 if (!SCHEME_STRINGP(line))
2079 scheme_wrong_type(prim->name, "string-list", 2, argc, argv);
2080 array[i] = string_to_line(line);
2081 }
2082
2083 savebuf = curbuf;
2084 curbuf = buf->buf;
2085
2086 if (u_save((linenr_T)(lo-1), (linenr_T)hi) == FAIL)
2087 {
2088 curbuf = savebuf;
2089 raise_vim_exn(_("cannot save undo information"));
2090 }
2091
2092 /*
2093 * If the size of the range is reducing (ie, new_len < old_len) we
2094 * need to delete some old_len. We do this at the start, by
2095 * repeatedly deleting line "lo".
2096 */
2097 for (i = 0; i < old_len - new_len; ++i)
2098 {
2099 if (ml_delete((linenr_T)lo, FALSE) == FAIL)
2100 {
2101 curbuf = savebuf;
2102 raise_vim_exn(_("cannot delete line"));
2103 }
2104 extra--;
2105 }
2106
2107 /*
2108 * For as long as possible, replace the existing old_len with the
2109 * new old_len. This is a more efficient operation, as it requires
2110 * less memory allocation and freeing.
2111 */
2112 for (i = 0; i < old_len && i < new_len; i++)
2113 if (ml_replace((linenr_T)(lo+i), (char_u *)array[i], TRUE) == FAIL)
2114 {
2115 curbuf = savebuf;
2116 raise_vim_exn(_("cannot replace line"));
2117 }
2118
2119 /*
2120 * Now we may need to insert the remaining new_len. We don't need to
2121 * free the string passed back because MzScheme has control of that
2122 * memory.
2123 */
2124 while (i < new_len)
2125 {
2126 if (ml_append((linenr_T)(lo + i - 1),
2127 (char_u *)array[i], 0, FALSE) == FAIL)
2128 {
2129 curbuf = savebuf;
2130 raise_vim_exn(_("cannot insert line"));
2131 }
2132 ++i;
2133 ++extra;
2134 }
2135
2136 /*
2137 * Adjust marks. Invalidate any which lie in the
2138 * changed range, and move any in the remainder of the buffer.
2139 */
2140 mark_adjust((linenr_T)lo, (linenr_T)(hi - 1), (long)MAXLNUM, (long)extra);
2141 changed_lines((linenr_T)lo, 0, (linenr_T)hi, (long)extra);
2142
2143 if (buf->buf == curwin->w_buffer)
2144 mz_fix_cursor(lo, hi, extra);
2145 curbuf = savebuf;
2146
2147 raise_if_error();
2148 return scheme_void;
2149 }
2150
2151 /*
2152 * (insert-buff-line-list {linenr} {string/string-list} [buffer])
2153 *
2154 * Insert a number of lines into the specified buffer after the specifed line.
2155 * The line number is in Vim format (1-based). The lines to be inserted are
2156 * given as an MzScheme list of string objects or as a single string. The lines
2157 * to be added are checked for validity and correct format. Errors are
2158 * returned as a value of FAIL. The return value is OK on success.
2159 * If OK is returned and len_change is not NULL, *len_change
2160 * is set to the change in the buffer length.
2161 */
2162 static Scheme_Object *
2163 insert_buffer_line_list(void *data, int argc, Scheme_Object **argv)
2164 {
2165 Vim_Prim *prim = (Vim_Prim *)data;
2166 vim_mz_buffer *buf;
2167 Scheme_Object *list;
2168 Scheme_Object *line;
2169 Scheme_Object *rest;
2170 char **array;
2171 char *str;
2172 buf_T *savebuf;
2173 int i, n, size;
2174
2175 #ifdef HAVE_SANDBOX
2176 sandbox_check();
2177 #endif
2178 /*
2179 * First of all, we check the type of the supplied MzScheme object.
2180 * It must be a string or a list, or the call is in error.
2181 */
2182 n = SCHEME_INT_VAL(GUARANTEE_INTEGER(prim->name, 0));
2183 list = argv[1];
2184
2185 if (!SCHEME_STRINGP(list) && !SCHEME_PAIRP(list))
2186 scheme_wrong_type(prim->name, "string or list", 1, argc, argv);
2187 buf = get_buffer_arg(prim->name, 2, argc, argv);
2188
2189 if (n != 0) /* 0 can be used in insert */
2190 check_line_range(n, buf->buf);
2191 if (SCHEME_STRINGP(list))
2192 {
2193 str = string_to_line(list);
2194
2195 savebuf = curbuf;
2196 curbuf = buf->buf;
2197
2198 if (u_save((linenr_T)n, (linenr_T)(n+1)) == FAIL)
2199 {
2200 curbuf = savebuf;
2201 raise_vim_exn(_("cannot save undo information"));
2202 }
2203 else if (ml_append((linenr_T)n, (char_u *)str, 0, FALSE) == FAIL)
2204 {
2205 curbuf = savebuf;
2206 raise_vim_exn(_("cannot insert line"));
2207 }
2208 else
2209 appended_lines_mark((linenr_T)n, 1L);
2210
2211 curbuf = savebuf;
2212 update_screen(VALID);
2213
2214 raise_if_error();
2215 return scheme_void;
2216 }
2217
2218 /* List */
2219 size = scheme_proper_list_length(list);
2220 if (size < 0) /* improper or cyclic list */
2221 scheme_wrong_type(prim->name, "proper list",
2222 2, argc, argv);
2223
2224 /* Using MzScheme allocator, so we don't need to free this and
2225 * can safely keep pointers to GC collected strings
2226 */
2227 array = (char **)scheme_malloc_fail_ok(
2228 scheme_malloc, (unsigned)(size * sizeof(char *)));
2229
2230 rest = list;
2231 for (i = 0; i < size; ++i)
2232 {
2233 line = SCHEME_CAR(rest);
2234 rest = SCHEME_CDR(rest);
2235 array[i] = string_to_line(line);
2236 }
2237
2238 savebuf = curbuf;
2239 curbuf = buf->buf;
2240
2241 if (u_save((linenr_T)n, (linenr_T)(n + 1)) == FAIL)
2242 {
2243 curbuf = savebuf;
2244 raise_vim_exn(_("cannot save undo information"));
2245 }
2246 else
2247 {
2248 for (i = 0; i < size; ++i)
2249 if (ml_append((linenr_T)(n + i), (char_u *)array[i],
2250 0, FALSE) == FAIL)
2251 {
2252 curbuf = savebuf;
2253 raise_vim_exn(_("cannot insert line"));
2254 }
2255
2256 if (i > 0)
2257 appended_lines_mark((linenr_T)n, (long)i);
2258 }
2259
2260 curbuf = savebuf;
2261 update_screen(VALID);
2262
2263 raise_if_error();
2264 return scheme_void;
2265 }
2266
2267 /* (get-buff-namespace [buffer]) */
2268 static Scheme_Object *
2269 get_buffer_namespace(void *data, int argc, Scheme_Object **argv)
2270 {
2271 Vim_Prim *prim = (Vim_Prim *)data;
2272
2273 return (Scheme_Object *)get_buffer_arg(prim->name, 0, argc, argv)->env;
2274 }
2275
2276 /*
2277 * Predicates
2278 */
2279 /* (buff? obj) */
2280 static Scheme_Object *
2281 vim_bufferp(void *data, int argc, Scheme_Object **argv)
2282 {
2283 if (SCHEME_VIMBUFFERP(argv[0]))
2284 return scheme_true;
2285 else
2286 return scheme_false;
2287 }
2288
2289 /* (win? obj) */
2290 static Scheme_Object *
2291 vim_windowp(void *data, int argc, Scheme_Object **argv)
2292 {
2293 if (SCHEME_VIMWINDOWP(argv[0]))
2294 return scheme_true;
2295 else
2296 return scheme_false;
2297 }
2298
2299 /* (buff-valid? obj) */
2300 static Scheme_Object *
2301 vim_buffer_validp(void *data, int argc, Scheme_Object **argv)
2302 {
2303 if (SCHEME_VIMBUFFERP(argv[0])
2304 && ((vim_mz_buffer *)argv[0])->buf != INVALID_BUFFER_VALUE)
2305 return scheme_true;
2306 else
2307 return scheme_false;
2308 }
2309
2310 /* (win-valid? obj) */
2311 static Scheme_Object *
2312 vim_window_validp(void *data, int argc, Scheme_Object **argv)
2313 {
2314 if (SCHEME_VIMWINDOWP(argv[0])
2315 && ((vim_mz_window *)argv[0])->win != INVALID_WINDOW_VALUE)
2316 return scheme_true;
2317 else
2318 return scheme_false;
2319 }
2320
2321 /*
2322 *===========================================================================
2323 * Utilities
2324 *===========================================================================
2325 */
2326
2327 /*
2328 * Convert an MzScheme string into a Vim line.
2329 *
2330 * The result is in allocated memory. All internal nulls are replaced by
2331 * newline characters. It is an error for the string to contain newline
2332 * characters.
2333 *
2334 */
2335 static char *
2336 string_to_line(Scheme_Object *obj)
2337 {
2338 char *str;
2339 long len;
2340 int i;
2341
2342 str = scheme_display_to_string(obj, &len);
2343
2344 /* Error checking: String must not contain newlines, as we
2345 * are replacing a single line, and we must replace it with
2346 * a single line.
2347 */
2348 if (memchr(str, '\n', len))
2349 scheme_signal_error(_("string cannot contain newlines"));
2350
2351 /* Create a copy of the string, with internal nulls replaced by
2352 * newline characters, as is the vim convention.
2353 */
2354 for (i = 0; i < len; ++i)
2355 {
2356 if (str[i] == '\0')
2357 str[i] = '\n';
2358 }
2359
2360 str[i] = '\0';
2361
2362 return str;
2363 }
2364
2365 /*
2366 * Check to see whether a Vim error has been reported, or a keyboard
2367 * interrupt (from vim --> got_int) has been detected.
2368 */
2369 static int
2370 vim_error_check(void)
2371 {
2372 return (got_int || did_emsg);
2373 }
2374
2375 /*
2376 * register Scheme exn:vim
2377 */
2378 static void
2379 register_vim_exn(Scheme_Env *env)
2380 {
2381 Scheme_Object *exn_name = scheme_intern_symbol("exn:vim");
2382
2383 if (vim_exn == NULL)
2384 vim_exn = scheme_make_struct_type(exn_name,
2385 scheme_builtin_value("struct:exn"), NULL, 0, 0, NULL, NULL
2386 #if MZSCHEME_VERSION_MAJOR >= 299
2387 , NULL
2388 #endif
2389 );
2390
2391 if (vim_exn_values == NULL)
2392 {
2393 int nc = 0;
2394
2395 Scheme_Object **exn_names = scheme_make_struct_names(
2396 exn_name, scheme_null, 0, &nc);
2397 Scheme_Object **exn_values = scheme_make_struct_values(
2398 vim_exn, exn_names, nc, 0);
2399
2400 vim_exn_names = scheme_make_vector(nc, scheme_false);
2401 vim_exn_values = scheme_make_vector(nc, scheme_false);
2402 /* remember names and values */
2403 mch_memmove(SCHEME_VEC_ELS(vim_exn_names), exn_names,
2404 nc * sizeof(Scheme_Object *));
2405 mch_memmove(SCHEME_VEC_ELS(vim_exn_values), exn_values,
2406 nc * sizeof(Scheme_Object *));
2407 }
2408
2409 add_vim_exn(env);
2410 }
2411
2412 /*
2413 * Add stuff of exn:vim to env
2414 */
2415 static void
2416 add_vim_exn(Scheme_Env *env)
2417 {
2418 int i;
2419
2420 for (i = 0; i < SCHEME_VEC_SIZE(vim_exn_values); i++)
2421 scheme_add_global_symbol(SCHEME_VEC_ELS(vim_exn_names)[i],
2422 SCHEME_VEC_ELS(vim_exn_values)[i], env);
2423 }
2424
2425 /*
2426 * raise exn:vim, may be with additional info string
2427 */
2428 void
2429 raise_vim_exn(const char *add_info)
2430 {
2431 Scheme_Object *argv[2];
2432 char_u *fmt = _("Vim error: ~a");
2433
2434 if (add_info != NULL)
2435 {
2436 Scheme_Object *info = scheme_make_string(add_info);
2437 argv[0] = scheme_byte_string_to_char_string(scheme_make_string(
2438 scheme_format(fmt, strlen(fmt), 1, &info, NULL)));
2439 SCHEME_SET_IMMUTABLE(argv[0]);
2440 }
2441 else
2442 argv[0] = scheme_make_string(_("Vim error"));
2443
2444 argv[1] = scheme_current_continuation_marks();
2445
2446 scheme_raise(scheme_make_struct_instance(vim_exn, 2, argv));
2447 }
2448
2449 void
2450 raise_if_error(void)
2451 {
2452 if (vim_error_check())
2453 raise_vim_exn(NULL);
2454 }
2455
2456 /* get buffer:
2457 * either current
2458 * or passed as argv[argnum] with checks
2459 */
2460 static vim_mz_buffer *
2461 get_buffer_arg(const char *fname, int argnum, int argc, Scheme_Object **argv)
2462 {
2463 vim_mz_buffer *b;
2464
2465 if (argc < argnum + 1)
2466 return get_vim_curr_buffer();
2467 if (!SCHEME_VIMBUFFERP(argv[argnum]))
2468 scheme_wrong_type(fname, "vim-buffer", argnum, argc, argv);
2469 b = (vim_mz_buffer *)argv[argnum];
2470 (void)get_valid_buffer(argv[argnum]);
2471 return b;
2472 }
2473
2474 /* get window:
2475 * either current
2476 * or passed as argv[argnum] with checks
2477 */
2478 static vim_mz_window *
2479 get_window_arg(const char *fname, int argnum, int argc, Scheme_Object **argv)
2480 {
2481 vim_mz_window *w;
2482
2483 if (argc < argnum + 1)
2484 return get_vim_curr_window();
2485 w = (vim_mz_window *)argv[argnum];
2486 if (!SCHEME_VIMWINDOWP(argv[argnum]))
2487 scheme_wrong_type(fname, "vim-window", argnum, argc, argv);
2488 (void)get_valid_window(argv[argnum]);
2489 return w;
2490 }
2491
2492 /* get valid Vim buffer from Scheme_Object* */
2493 buf_T *get_valid_buffer(void *obj)
2494 {
2495 buf_T *buf = ((vim_mz_buffer *)obj)->buf;
2496
2497 if (buf == INVALID_BUFFER_VALUE)
2498 scheme_signal_error(_("buffer is invalid"));
2499 return buf;
2500 }
2501
2502 /* get valid Vim window from Scheme_Object* */
2503 win_T *get_valid_window(void *obj)
2504 {
2505 win_T *win = ((vim_mz_window *)obj)->win;
2506 if (win == INVALID_WINDOW_VALUE)
2507 scheme_signal_error(_("window is invalid"));
2508 return win;
2509 }
2510
2511 int
2512 mzthreads_allowed(void)
2513 {
2514 return mz_threads_allow;
2515 }
2516
2517 static int
2518 line_in_range(linenr_T lnum, buf_T *buf)
2519 {
2520 return (lnum > 0 && lnum <= buf->b_ml.ml_line_count);
2521 }
2522
2523 static void
2524 check_line_range(linenr_T lnum, buf_T *buf)
2525 {
2526 if (!line_in_range(lnum, buf))
2527 scheme_signal_error(_("linenr out of range"));
2528 }
2529
2530 /*
2531 * Check if deleting lines made the cursor position invalid
2532 * (or you'll get msg from Vim about invalid linenr).
2533 * Changed the lines from "lo" to "hi" and added "extra" lines (negative if
2534 * deleted). Got from if_python.c
2535 */
2536 static void
2537 mz_fix_cursor(int lo, int hi, int extra)
2538 {
2539 if (curwin->w_cursor.lnum >= lo)
2540 {
2541 /* Adjust the cursor position if it's in/after the changed
2542 * lines. */
2543 if (curwin->w_cursor.lnum >= hi)
2544 {
2545 curwin->w_cursor.lnum += extra;
2546 check_cursor_col();
2547 }
2548 else if (extra < 0)
2549 {
2550 curwin->w_cursor.lnum = lo;
2551 check_cursor();
2552 }
2553 changed_cline_bef_curs();
2554 }
2555 invalidate_botline();
2556 }
2557
2558 static Vim_Prim prims[]=
2559 {
2560 /*
2561 * Buffer-related commands
2562 */
2563 {get_buffer_line, "get-buff-line", 1, 2},
2564 {set_buffer_line, "set-buff-line", 2, 3},
2565 {get_buffer_line_list, "get-buff-line-list", 2, 3},
2566 {get_buffer_name, "get-buff-name", 0, 1},
2567 {get_buffer_num, "get-buff-num", 0, 1},
2568 {get_buffer_size, "get-buff-size", 0, 1},
2569 {set_buffer_line_list, "set-buff-line-list", 3, 4},
2570 {insert_buffer_line_list, "insert-buff-line-list", 2, 3},
2571 {get_curr_buffer, "curr-buff", 0, 0},
2572 {get_buffer_count, "buff-count", 0, 0},
2573 {get_next_buffer, "get-next-buff", 0, 1},
2574 {get_prev_buffer, "get-prev-buff", 0, 1},
2575 {mzscheme_open_buffer, "open-buff", 1, 1},
2576 {get_buffer_by_name, "get-buff-by-name", 1, 1},
2577 {get_buffer_by_num, "get-buff-by-num", 1, 1},
2578 {get_buffer_namespace, "get-buff-namespace", 0, 1},
2579 /*
2580 * Window-related commands
2581 */
2582 {get_curr_win, "curr-win", 0, 0},
2583 {get_window_count, "win-count", 0, 0},
2584 {get_window_by_num, "get-win-by-num", 1, 1},
2585 {get_window_num, "get-win-num", 0, 1},
2586 {get_window_buffer, "get-win-buffer", 0, 1},
2587 {get_window_height, "get-win-height", 0, 1},
2588 {set_window_height, "set-win-height", 1, 2},
2589 #ifdef FEAT_VERTSPLIT
2590 {get_window_width, "get-win-width", 0, 1},
2591 {set_window_width, "set-win-width", 1, 2},
2592 #endif
2593 {get_cursor, "get-cursor", 0, 1},
2594 {set_cursor, "set-cursor", 1, 2},
2595 {get_window_list, "get-win-list", 0, 1},
2596 /*
2597 * Vim-related commands
2598 */
2599 {vim_command, "command", 1, 1},
2600 {vim_eval, "eval", 1, 1},
2601 {get_range_start, "range-start", 0, 0},
2602 {get_range_end, "range-end", 0, 0},
2603 {mzscheme_beep, "beep", 0, 0},
2604 {get_option, "get-option", 1, 2},
2605 {set_option, "set-option", 1, 2},
2606 /*
2607 * small utilities
2608 */
2609 {vim_bufferp, "buff?", 1, 1},
2610 {vim_windowp, "win?", 1, 1},
2611 {vim_buffer_validp, "buff-valid?", 1, 1},
2612 {vim_window_validp, "win-valid?", 1, 1}
2613 };
2614
2615 /* return MzScheme wrapper for curbuf */
2616 static vim_mz_buffer *
2617 get_vim_curr_buffer(void)
2618 {
2619 if (curbuf->b_mzscheme_ref == NULL)
2620 return (vim_mz_buffer *)buffer_new(curbuf);
2621 else
2622 return (vim_mz_buffer *)curbuf->b_mzscheme_ref;
2623 }
2624
2625 /* return MzScheme wrapper for curwin */
2626 static vim_mz_window *
2627 get_vim_curr_window(void)
2628 {
2629 if (curwin->w_mzscheme_ref == NULL)
2630 return (vim_mz_window *)window_new(curwin);
2631 else
2632 return (vim_mz_window *)curwin->w_mzscheme_ref;
2633 }
2634
2635 static void
2636 make_modules(Scheme_Env *env)
2637 {
2638 int i;
2639 Scheme_Env *mod;
2640
2641 mod = scheme_primitive_module(scheme_intern_symbol("vimext"), env);
2642 /* all prims made closed so they can access their own names */
2643 for (i = 0; i < sizeof(prims)/sizeof(prims[0]); i++)
2644 {
2645 Vim_Prim *prim = prims + i;
2646 scheme_add_global(prim->name,
2647 scheme_make_closed_prim_w_arity(prim->prim, prim, prim->name,
2648 prim->mina, prim->maxa),
2649 mod);
2650 }
2651 scheme_add_global("global-namespace", (Scheme_Object *)environment, mod);
2652 scheme_finish_primitive_module(mod);
2653 }
2654
2655 #ifdef HAVE_SANDBOX
2656 static Scheme_Object *M_write = NULL;
2657 static Scheme_Object *M_read = NULL;
2658 static Scheme_Object *M_execute = NULL;
2659 static Scheme_Object *M_delete = NULL;
2660
2661 static void
2662 sandbox_check()
2663 {
2664 if (sandbox)
2665 raise_vim_exn(_("not allowed in the Vim sandbox"));
2666 }
2667
2668 /* security guards to force Vim's sandbox restrictions on MzScheme level */
2669 static Scheme_Object *
2670 sandbox_file_guard(int argc, Scheme_Object **argv)
2671 {
2672 if (sandbox)
2673 {
2674 Scheme_Object *requested_access = argv[2];
2675
2676 if (M_write == NULL)
2677 {
2678 MZ_REGISTER_STATIC(M_write);
2679 M_write = scheme_intern_symbol("write");
2680 }
2681 if (M_read == NULL)
2682 {
2683 MZ_REGISTER_STATIC(M_read);
2684 M_read = scheme_intern_symbol("read");
2685 }
2686 if (M_execute == NULL)
2687 {
2688 MZ_REGISTER_STATIC(M_execute);
2689 M_execute = scheme_intern_symbol("execute");
2690 }
2691 if (M_delete == NULL)
2692 {
2693 MZ_REGISTER_STATIC(M_delete);
2694 M_delete = scheme_intern_symbol("delete");
2695 }
2696
2697 while (!SCHEME_NULLP(requested_access))
2698 {
2699 Scheme_Object *item = SCHEME_CAR(requested_access);
2700 if (scheme_eq(item, M_write) || scheme_eq(item, M_read)
2701 || scheme_eq(item, M_execute) || scheme_eq(item, M_delete))
2702 {
2703 raise_vim_exn(_("not allowed in the Vim sandbox"));
2704 }
2705 requested_access = SCHEME_CDR(requested_access);
2706 }
2707 }
2708 return scheme_void;
2709 }
2710
2711 static Scheme_Object *
2712 sandbox_network_guard(int argc, Scheme_Object **argv)
2713 {
2714 return scheme_void;
2715 }
2716 #endif
2717
2718 #endif