forked from b4winckler/macvim
-
Notifications
You must be signed in to change notification settings - Fork 37
/
if_mzsch.c
3377 lines (3008 loc) · 90.8 KB
/
if_mzsch.c
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
/* 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,