1
2 /******************************************************************************
3 * MODULE : guile_tm.cpp
4 * DESCRIPTION: Interface to Guile
5 * COPYRIGHT : (C) 1999-2011 Joris van der Hoeven and Massimiliano Gubinelli
6 *******************************************************************************
7 * This software falls under the GNU general public license version 3 or later.
8 * It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
9 * in the root directory or <http://www.gnu.org/licenses/gpl-3.0.html>.
10 ******************************************************************************/
11
12 #ifdef __MINGW32__
13 //FIXME: if this include is not here we have compilation problems on mingw32
14 // (probably name clashes with Windows headers)
15 //#include "tree.hpp"
16 #endif
17 //#include "Glue/glue.hpp"
18
19 #include "guile_tm.hpp"
20 #include "blackbox.hpp"
21 #include "file.hpp"
22 #include "../Scheme/glue.hpp"
23 #include "convert.hpp" // tree_to_texmacs (should not belong here)
24
25 /******************************************************************************
26 * Installation of guile and initialization of guile
27 ******************************************************************************/
28
29 #if (defined(GUILE_C) || defined(GUILE_D))
30 static void (*old_call_back) (int, char**)= NULL;
31 static void
new_call_back(void * closure,int argc,char ** argv)32 new_call_back (void *closure, int argc, char** argv) {
33 (void) closure;
34
35 old_call_back (argc, argv);
36 }
37 #endif
38
39
40 int guile_argc;
41 char **guile_argv;
42
43 void
start_scheme(int argc,char ** argv,void (* call_back)(int,char **))44 start_scheme (int argc, char** argv, void (*call_back) (int, char**)) {
45 guile_argc = argc;
46 guile_argv = argv;
47 #if (defined(GUILE_C) || defined(GUILE_D))
48 old_call_back= call_back;
49 scm_boot_guile (argc, argv, new_call_back, 0);
50 #else
51 #ifdef DOTS_OK
52 gh_enter (argc, argv, (void (*)(...)) ((void*) call_back));
53 #else
54 gh_enter (argc, argv, call_back);
55 #endif
56 #endif
57 }
58
59
60
61 /******************************************************************************
62 * Catching errors (with thanks to Dale P. Smith)
63 ******************************************************************************/
64
65 SCM
TeXmacs_lazy_catcher(void * data,SCM tag,SCM throw_args)66 TeXmacs_lazy_catcher (void *data, SCM tag, SCM throw_args) {
67 SCM eport= scm_current_error_port();
68 scm_handle_by_message_noexit (data, tag, throw_args);
69 scm_force_output (eport);
70 scm_ithrow (tag, throw_args, 1);
71 return SCM_UNSPECIFIED; /* never returns */
72 }
73
74 SCM
TeXmacs_catcher(void * data,SCM tag,SCM args)75 TeXmacs_catcher (void *data, SCM tag, SCM args) {
76 (void) data;
77 return scm_cons (tag, args);
78 }
79
80 /******************************************************************************
81 * Evaluation of files
82 ******************************************************************************/
83
84 static SCM
TeXmacs_lazy_eval_file(char * file)85 TeXmacs_lazy_eval_file (char *file) {
86 return scm_internal_lazy_catch (SCM_BOOL_T,
87 (scm_t_catch_body) scm_c_primitive_load, file,
88 (scm_t_catch_handler) TeXmacs_lazy_catcher, file);
89 }
90
91 static SCM
TeXmacs_eval_file(char * file)92 TeXmacs_eval_file (char *file) {
93 return scm_internal_catch (SCM_BOOL_T,
94 (scm_t_catch_body) TeXmacs_lazy_eval_file, file,
95 (scm_t_catch_handler) TeXmacs_catcher, file);
96 }
97
98 SCM
eval_scheme_file(string file)99 eval_scheme_file (string file) {
100 //static int cumul= 0;
101 //timer tm;
102 if (DEBUG_STD) debug_std << "Evaluating " << file << "...\n";
103 c_string _file (file);
104 SCM result= TeXmacs_eval_file (_file);
105 //int extra= tm->watch (); cumul += extra;
106 //cout << extra << "\t" << cumul << "\t" << file << "\n";
107 return result;
108 }
109
110 /******************************************************************************
111 * Evaluation of strings
112 ******************************************************************************/
113
114 static SCM
TeXmacs_lazy_eval_string(char * s)115 TeXmacs_lazy_eval_string (char *s) {
116 return scm_internal_lazy_catch (SCM_BOOL_T,
117 (scm_t_catch_body) scm_c_eval_string, s,
118 (scm_t_catch_handler) TeXmacs_lazy_catcher, s);
119 }
120
121 static SCM
TeXmacs_eval_string(char * s)122 TeXmacs_eval_string (char *s) {
123 return scm_internal_catch (SCM_BOOL_T,
124 (scm_t_catch_body) TeXmacs_lazy_eval_string, s,
125 (scm_t_catch_handler) TeXmacs_catcher, s);
126 }
127
128 SCM
eval_scheme(string s)129 eval_scheme (string s) {
130 // cout << "Eval] " << s << "\n";
131 c_string _s (s);
132 SCM result= TeXmacs_eval_string (_s);
133 return result;
134 }
135
136 /******************************************************************************
137 * Using scheme objects as functions
138 ******************************************************************************/
139
140 struct arg_list { int n; SCM* a; };
141
142 static SCM
TeXmacs_call(arg_list * args)143 TeXmacs_call (arg_list* args) {
144 switch (args->n) {
145 case 0: return scm_call_0 (args->a[0]); break;
146 case 1: return scm_call_1 (args->a[0], args->a[1]); break;
147 case 2: return scm_call_2 (args->a[0], args->a[1], args->a[2]); break;
148 case 3:
149 return scm_call_3 (args->a[0], args->a[1], args->a[2], args->a[3]); break;
150 default:
151 {
152 int i;
153 SCM l= SCM_NULL;
154 for (i=args->n; i>=1; i--)
155 l= scm_cons (args->a[i], l);
156 return scm_apply_0 (args->a[0], l);
157 }
158 }
159 }
160
161 static SCM
TeXmacs_lazy_call_scm(arg_list * args)162 TeXmacs_lazy_call_scm (arg_list* args) {
163 return scm_internal_lazy_catch (SCM_BOOL_T,
164 (scm_t_catch_body) TeXmacs_call, (void*) args,
165 (scm_t_catch_handler) TeXmacs_lazy_catcher, (void*) args);
166 }
167
168 static SCM
TeXmacs_call_scm(arg_list * args)169 TeXmacs_call_scm (arg_list *args) {
170 return scm_internal_catch (SCM_BOOL_T,
171 (scm_t_catch_body) TeXmacs_lazy_call_scm, (void*) args,
172 (scm_t_catch_handler) TeXmacs_catcher, (void*) args);
173 }
174
175 SCM
call_scheme(SCM fun)176 call_scheme (SCM fun) {
177 SCM a[]= { fun }; arg_list args= { 0, a };
178 return TeXmacs_call_scm (&args);
179 }
180
181 SCM
call_scheme(SCM fun,SCM a1)182 call_scheme (SCM fun, SCM a1) {
183 SCM a[]= { fun, a1 }; arg_list args= { 1, a };
184 return TeXmacs_call_scm (&args);
185 }
186
187 SCM
call_scheme(SCM fun,SCM a1,SCM a2)188 call_scheme (SCM fun, SCM a1, SCM a2) {
189 SCM a[]= { fun, a1, a2 }; arg_list args= { 2, a };
190 return TeXmacs_call_scm (&args);
191 }
192
193 SCM
call_scheme(SCM fun,SCM a1,SCM a2,SCM a3)194 call_scheme (SCM fun, SCM a1, SCM a2, SCM a3) {
195 SCM a[]= { fun, a1, a2, a3 }; arg_list args= { 3, a };
196 return TeXmacs_call_scm (&args);
197 }
198
199 SCM
call_scheme(SCM fun,SCM a1,SCM a2,SCM a3,SCM a4)200 call_scheme (SCM fun, SCM a1, SCM a2, SCM a3, SCM a4) {
201 SCM a[]= { fun, a1, a2, a3, a4 }; arg_list args= { 4, a };
202 return TeXmacs_call_scm (&args);
203 }
204
205 SCM
call_scheme(SCM fun,array<SCM> a)206 call_scheme (SCM fun, array<SCM> a) {
207 const int n= N(a);
208 STACK_NEW_ARRAY(scm, SCM, n+1);
209 int i;
210 scm[0]= fun;
211 for (i=0; i<n; i++) scm[i+1]= a[i];
212 arg_list args= { n, scm };
213 SCM ret= TeXmacs_call_scm (&args);
214 STACK_DELETE_ARRAY(scm);
215 return ret;
216 }
217
218
219 /******************************************************************************
220 * Miscellaneous routines for use by glue only
221 ******************************************************************************/
222
223 string
scheme_dialect()224 scheme_dialect () {
225 #ifdef GUILE_A
226 return "guile-a";
227 #else
228 #ifdef GUILE_B
229 return "guile-b";
230 #else
231 #ifdef GUILE_C
232 return "guile-c";
233 #else
234 #ifdef GUILE_D
235 return "guile-d";
236 #else
237 return "unknown";
238 #endif
239 #endif
240 #endif
241 #endif
242 }
243
244 #if (defined(GUILE_C) || defined(GUILE_D))
245 #define SET_SMOB(smob,data,type) \
246 SCM_NEWSMOB (smob, SCM_UNPACK (type), data);
247 #else
248 #define SET_SMOB(smob,data,type) \
249 SCM_NEWCELL (smob); \
250 SCM_SETCAR (smob, (SCM) (type)); \
251 SCM_SETCDR (smob, (SCM) (data));
252 #endif
253
254
255 /******************************************************************************
256 * Booleans
257 ******************************************************************************/
258
259
260 SCM
bool_to_scm(bool flag)261 bool_to_scm (bool flag) {
262 return scm_bool2scm (flag);
263 }
264
265 #if (defined(GUILE_A) || defined(GUILE_B))
266 int
scm_to_bool(SCM flag)267 scm_to_bool (SCM flag) {
268 return scm_scm2bool (flag);
269 }
270 #endif
271
272 /******************************************************************************
273 * Integers
274 ******************************************************************************/
275
276 SCM
int_to_scm(int i)277 int_to_scm (int i) {
278 return scm_long2scm ((long) i);
279 }
280
281 SCM
long_to_scm(long l)282 long_to_scm (long l) {
283 return scm_long2scm (l);
284 }
285
286 #if (defined(GUILE_A) || defined(GUILE_B))
287 int
scm_to_int(SCM i)288 scm_to_int (SCM i) {
289 return (int) scm_scm2long (i);
290 }
291
292 long
scm_to_long(SCM l)293 scm_to_long (SCM l) {
294 return scm_scm2long (l);
295 }
296 #endif
297
298 /******************************************************************************
299 * Floating point numbers
300 ******************************************************************************/
301 #if 0
302 bool scm_is_double (scm o) {
303 return SCM_REALP(o);
304 }
305 #endif
306
307 SCM
double_to_scm(double i)308 double_to_scm (double i) {
309 return scm_double2scm (i);
310 }
311
312 #if (defined(GUILE_A) || defined(GUILE_B))
313 double
scm_to_double(SCM i)314 scm_to_double (SCM i) {
315 return scm_scm2double (i);
316 }
317 #endif
318
319 /******************************************************************************
320 * Strings
321 ******************************************************************************/
322
323
324 tmscm
string_to_tmscm(string s)325 string_to_tmscm (string s) {
326 c_string _s (s);
327 SCM r= scm_str2scm (_s, N(s));
328 return r;
329 }
330
331 string
tmscm_to_string(tmscm s)332 tmscm_to_string (tmscm s) {
333 guile_str_size_t len_r;
334 char* _r= scm_scm2str (s, &len_r);
335 string r (_r, len_r);
336 #ifdef OS_WIN32
337 scm_must_free(_r);
338 #else
339 free (_r);
340 #endif
341 return r;
342 }
343
344 /******************************************************************************
345 * Symbols
346 ******************************************************************************/
347
348 #if 0
349 bool tmscm_is_symbol (tmscm s) {
350 return SCM_NFALSEP (scm_symbol_p (s));
351 }
352 #endif
353
354 tmscm
symbol_to_tmscm(string s)355 symbol_to_tmscm (string s) {
356 c_string _s (s);
357 SCM r= scm_symbol2scm (_s);
358 return r;
359 }
360
361 string
tmscm_to_symbol(tmscm s)362 tmscm_to_symbol (tmscm s) {
363 guile_str_size_t len_r;
364 char* _r= scm_scm2symbol (s, &len_r);
365 string r (_r, len_r);
366 #ifdef OS_WIN32
367 scm_must_free(_r);
368 #else
369 free (_r);
370 #endif
371 return r;
372 }
373
374 /******************************************************************************
375 * Blackbox
376 ******************************************************************************/
377
378 static long blackbox_tag;
379
380 #define SCM_BLACKBOXP(t) \
381 (SCM_NIMP (t) && (((long) SCM_CAR (t)) == blackbox_tag))
382
383 bool
tmscm_is_blackbox(tmscm t)384 tmscm_is_blackbox (tmscm t) {
385 return SCM_BLACKBOXP (t);
386 }
387
388 tmscm
blackbox_to_tmscm(blackbox b)389 blackbox_to_tmscm (blackbox b) {
390 SCM blackbox_smob;
391 SET_SMOB (blackbox_smob, (void*) (tm_new<blackbox> (b)), (SCM) blackbox_tag);
392 return blackbox_smob;
393 }
394
395 blackbox
tmscm_to_blackbox(tmscm blackbox_smob)396 tmscm_to_blackbox (tmscm blackbox_smob) {
397 return *((blackbox*) SCM_CDR (blackbox_smob));
398 }
399
400 static SCM
mark_blackbox(SCM blackbox_smob)401 mark_blackbox (SCM blackbox_smob) {
402 (void) blackbox_smob;
403 return SCM_BOOL_F;
404 }
405
406 static scm_sizet
free_blackbox(SCM blackbox_smob)407 free_blackbox (SCM blackbox_smob) {
408 blackbox *ptr = (blackbox *) SCM_CDR (blackbox_smob);
409 tm_delete (ptr);
410 return 0;
411 }
412
413 int
print_blackbox(SCM blackbox_smob,SCM port,scm_print_state * pstate)414 print_blackbox (SCM blackbox_smob, SCM port, scm_print_state *pstate) {
415 (void) pstate;
416 string s = "<blackbox>";
417 int type_ = type_box (tmscm_to_blackbox(blackbox_smob)) ;
418 if (type_ == type_helper<tree>::id) {
419 tree t= tmscm_to_tree (blackbox_smob);
420 s= "<tree " * tree_to_texmacs (t) * ">";
421 }
422 else if (type_ == type_helper<observer>::id) {
423 s= "<observer>";
424 }
425 else if (type_ == type_helper<widget>::id) {
426 s= "<widget>";
427 }
428 else if (type_ == type_helper<promise<widget> >::id) {
429 s= "<promise-widget>";
430 }
431 else if (type_ == type_helper<command>::id) {
432 s= "<command>";
433 }
434 else if (type_ == type_helper<url>::id) {
435 url u= tmscm_to_url (blackbox_smob);
436 s= "<url " * as_string (u) * ">";
437 }
438 else if (type_ == type_helper<modification>::id) {
439 s= "<modification>";
440 }
441 else if (type_ == type_helper<patch>::id) {
442 s= "<patch>";
443 }
444
445 scm_display (string_to_tmscm (s), port);
446 return 1;
447 }
448
449 static SCM
cmp_blackbox(SCM t1,SCM t2)450 cmp_blackbox (SCM t1, SCM t2) {
451 return scm_bool2scm (tmscm_to_blackbox (t1) == tmscm_to_blackbox (t2));
452 }
453
454
455
456 /******************************************************************************
457 * Initialization
458 ******************************************************************************/
459
460
461 #ifdef SCM_NEWSMOB
462 void
initialize_smobs()463 initialize_smobs () {
464 blackbox_tag= scm_make_smob_type (const_cast<char*> ("blackbox"), 0);
465 scm_set_smob_mark (blackbox_tag, mark_blackbox);
466 scm_set_smob_free (blackbox_tag, free_blackbox);
467 scm_set_smob_print (blackbox_tag, print_blackbox);
468 scm_set_smob_equalp (blackbox_tag, cmp_blackbox);
469 }
470
471 #else
472
473 scm_smobfuns blackbox_smob_funcs = {
474 mark_blackbox, free_blackbox, print_blackbox, cmp_blackbox
475 };
476
477
478 void
initialize_smobs()479 initialize_smobs () {
480 blackbox_tag= scm_newsmob (&blackbox_smob_funcs);
481 }
482
483 #endif
484
485 tmscm object_stack;
486
487 void
initialize_scheme()488 initialize_scheme () {
489 const char* init_prg =
490 "(read-set! keywords 'prefix)\n"
491 "(read-enable 'positions)\n"
492 "(debug-enable 'debug)\n"
493 ";(debug-enable 'backtrace)\n"
494 "\n"
495 "(define (display-to-string obj)\n"
496 " (call-with-output-string\n"
497 " (lambda (port) (display obj port))))\n"
498 "(define (object->string obj)\n"
499 " (call-with-output-string\n"
500 " (lambda (port) (write obj port))))\n"
501 "\n"
502 "(define (texmacs-version) \"" TEXMACS_VERSION "\")\n"
503 "(define object-stack '(()))";
504
505 scm_c_eval_string (init_prg);
506 initialize_smobs ();
507 initialize_glue ();
508 object_stack= scm_lookup_string ("object-stack");
509
510 // uncomment to have a guile repl available at startup
511 // gh_repl(guile_argc, guile_argv);
512 //scm_shell (guile_argc, guile_argv);
513
514
515 }
516
517