1 /******************************************************************************
2 * MODULE : guile_tm.hpp
3 * DESCRIPTION: Everything which depends on the version of Guile
4 * should be move to this file
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 #ifndef GUILE_TM_H
13 #define GUILE_TM_H
14 #include "tm_configure.hpp"
15
16 #include "blackbox.hpp"
17 #include "array.hpp"
18
19
20 #ifdef __MINGW32__
21 // we redefine some symbols to avoid name clashes with Windows headers (included by Guile)
22 #define PATTERN WIN_PATTERN
23 #define STRING WIN_STRING
24 #define GROUP WIN_GROUP
25 #ifdef IN
26 #define MY_IN IN
27 #undef IN
28 #endif
29 #ifdef OUT
30 #define MY_OUT OUT
31 #undef OUT
32 #endif
33 #ifdef MENU_EVENT
34 #define MY_MENU_EVENT MENU_EVENT
35 #undef MENU_EVENT
36 #endif
37 #endif // __MINGW32__
38
39 #if defined(GUILE_D) || defined(GUILE_C)
40 #ifdef GUILE_BIN_guile18
41 #include <libguile18.h>
42 #else
43 #include <libguile.h>
44 #endif
45 #else
46 #include <guile/gh.h>
47 #endif
48
49 #ifdef __MINGW32__
50 // put things back
51 #undef STRING
52 #undef ERROR
53 #undef PATTERN
54 #undef GROUP
55 #undef IN
56 #undef OUT
57 #undef MENU_EVENT
58 #ifdef MY_MENU_EVENT
59 #define MENU_EVENT MY_MENU_EVENT
60 #undef MY_MENU_EVENT
61 #endif
62 #ifdef MY_IN
63 #define IN MY_IN
64 #undef MY_IN
65 #endif
66 #ifdef MY_OUT
67 #define OUT MY_OUT
68 #undef MY_OUT
69 #endif
70 #endif // __MINGW32__
71
72 #ifdef GUILE_D
73
74 #define SCM_NULL scm_list_n (SCM_UNDEFINED)
75 #define scm_bool2scm scm_from_bool
76 #define scm_is_list(x) scm_is_true(scm_list_p(x))
77 #define scm_scm2bool scm_is_true
78 #define scm_is_int scm_is_integer
79 #define scm_is_double scm_is_real
80 #define scm_new_procedure(name,r,a,b,c) scm_c_define_gsubr(name,a,b,c,(scm_t_subr)r)
81 #define scm_lookup_string(name) scm_variable_ref(scm_c_lookup(name))
82 #define scm_long2scm scm_long2num
83 #define scm_scm2long(x) scm_num2long(x,SCM_ARG1,"scm2long")
84 #define scm_double2scm scm_from_double
85 #define scm_scm2double scm_to_double
86 #define scm_str2scm scm_from_locale_stringn
87 #define scm_scm2str scm_to_locale_stringn
88 #define scm_symbol2scm scm_from_locale_symbol
89 #define scm_scm2symbol(x,y) scm_to_locale_stringn(scm_symbol_to_string(x),y)
90
91 #else
92 #ifdef GUILE_C
93
94 #define SCM_NULL scm_list_n (SCM_UNDEFINED)
95 #define scm_bool2scm scm_from_bool
96 #define scm_is_list(x) scm_is_true(scm_list_p(x))
97 #define scm_scm2bool scm_is_true
98 #define scm_is_int scm_is_integer
99 #define scm_is_double scm_is_real
100 #define scm_new_procedure(name,r,a,b,c) scm_c_define_gsubr(name,a,b,c,r)
101 #define scm_lookup_string(name) scm_variable_ref(scm_c_lookup(name))
102 #define scm_long2scm scm_long2num
103 #define scm_scm2long(x) scm_num2long(x,SCM_ARG1,"scm2long")
104 #define scm_double2scm scm_from_double
105 #define scm_scm2double scm_to_double
106 #define scm_str2scm scm_from_locale_stringn
107 #define scm_scm2str scm_to_locale_stringn
108 #define scm_symbol2scm scm_from_locale_symbol
109 #define scm_scm2symbol(x,y) scm_to_locale_stringn(scm_symbol_to_string(x),y)
110
111 #else
112 #ifdef GUILE_B
113
114 #define SCM_NULL gh_list (SCM_UNDEFINED)
115 #define scm_is_list(x) SCM_NFALSEP(scm_list_p(x))
116 #define scm_new_procedure(name,r,a,b,c) scm_c_define_gsubr(name,a,b,c,r)
117 #define scm_lookup_string(name) scm_variable_ref(scm_c_lookup(name))
118 #define scm_long2scm scm_long2num
119 #define scm_scm2long(x) scm_num2long(x,SCM_ARG1,"scm2long")
120
121 #define scm_is_null(x) SCM_NFALSEP(scm_null_p(x))
122 #define scm_is_pair(x) SCM_NFALSEP(scm_pair_p(x))
123 #define scm_is_bool(x) SCM_NFALSEP(scm_boolean_p(x))
124 #define scm_is_int SCM_INUMP
125 #define scm_is_double SCM_REALP
126 #define scm_is_string(obj) (SCM_NIMP(obj) && SCM_STRINGP(obj))
127 #define scm_is_symbol(x) SCM_NFALSEP(scm_symbol_p(x))
128
129 #define scm_bool2scm SCM_BOOL
130 #define scm_scm2bool SCM_NFALSEP
131 #define scm_long2scm scm_long2num
132 #define scm_scm2long(x) scm_num2long(x,SCM_ARG1,"scm2long")
133 #define scm_double2scm scm_make_real
134 #define scm_scm2double(x) scm_num2dbl(x,"scm2double")
135 #define scm_symbol2scm scm_str2symbol
136 #define scm_scm2symbol gh_symbol2newstr
137
138 #define scm_str2scm scm_mem2string
139 #define scm_scm2str gh_scm2newstr
140
141 #else
142 #ifdef GUILE_A
143
144 #define SCM_NULL gh_list (SCM_UNDEFINED)
145 #define scm_is_bool gh_boolean_p
146 #define scm_is_int SCM_INUMP
147 #define scm_is_double SCM_REALP
148 #define scm_is_string(obj) (SCM_NIMP(obj) && SCM_STRINGP(obj))
149 #define scm_is_symbol gh_symbol_p
150 #define scm_is_null gh_null_p
151 #define scm_is_pair gh_pair_p
152 #define scm_is_list gh_list_p
153
154 #define scm_bool2scm gh_bool2scm
155 #define scm_scm2bool gh_scm2bool
156 #define scm_long2scm gh_long2scm
157 #define scm_scm2long gh_scm2long
158 #define scm_double2scm gh_double2scm
159 #define scm_scm2double gh_scm2double
160 #define scm_str2scm gh_str2scm
161 #define scm_scm2str gh_scm2newstr
162 #define scm_symbol2scm gh_symbol2scm
163 #define scm_scm2symbol gh_symbol2newstr
164
165 #define scm_c_primitive_load gh_eval_file
166 #define scm_c_eval_string gh_eval_str
167 #define scm_apply_0 gh_apply
168 #define scm_call_0 gh_call0
169 #define scm_call_1 gh_call1
170 #define scm_call_2 gh_call2
171 #define scm_call_3 gh_call3
172 #define scm_new_procedure gh_new_procedure
173 #define scm_lookup_string gh_lookup
174
175 typedef SCM (*scm_t_catch_body) (void *data);
176 typedef SCM (*scm_t_catch_handler) (void *data, SCM tag, SCM throw_args);
177
178 #else
179
180 #error "At least one of the macros GUILE_{A,B,C,D} should be defined"
181
182 #endif // defined(GUILE_A)
183 #endif // defined(GUILE_B)
184 #endif // defined(GUILE_C)
185 #endif // defined(GUILE_D)
186
187 #define SCM_ARG8 8
188 #define SCM_ARG9 9
189 #define SCM_ARG10 10
190 #define SCM_ARG11 11
191
192 #ifdef DOTS_OK
193 typedef SCM (*FN)(...);
194 #else
195 typedef SCM (*FN)();
196 #endif
197
198 #if defined(GUILE_A) || defined(GUILE_B)
199 int scm_to_bool (SCM obj);
200 int scm_to_int (SCM obj);
201 long scm_to_long (SCM obj);
202 double scm_to_double (SCM obj);
203 #endif
204
205
206 typedef SCM tmscm;
207
208 bool tmscm_is_blackbox (tmscm obj);
209 tmscm blackbox_to_tmscm (blackbox b);
210 blackbox tmscm_to_blackbox (tmscm obj);
211
tmscm_null()212 inline tmscm tmscm_null () { return SCM_NULL; }
tmscm_true()213 inline tmscm tmscm_true () { return SCM_BOOL_T; }
tmscm_false()214 inline tmscm tmscm_false () { return SCM_BOOL_F; }
tmscm_set_car(tmscm a,tmscm b)215 inline void tmscm_set_car (tmscm a, tmscm b) { SCM_SETCAR(a,b); }
tmscm_set_cdr(tmscm a,tmscm b)216 inline void tmscm_set_cdr (tmscm a, tmscm b) { SCM_SETCDR(a,b); }
217
218
tmscm_is_equal(tmscm o1,tmscm o2)219 inline bool tmscm_is_equal (tmscm o1, tmscm o2) { return SCM_NFALSEP ( scm_equal_p(o1, o2)); }
220
221
222
tmscm_is_null(tmscm obj)223 inline bool tmscm_is_null (tmscm obj) { return scm_is_null (obj); }
tmscm_is_pair(tmscm obj)224 inline bool tmscm_is_pair (tmscm obj) { return scm_is_pair (obj); }
tmscm_is_list(tmscm obj)225 inline bool tmscm_is_list (tmscm obj) { return scm_is_list (obj); }
tmscm_is_bool(tmscm obj)226 inline bool tmscm_is_bool (tmscm obj) { return scm_is_bool (obj); }
tmscm_is_int(tmscm obj)227 inline bool tmscm_is_int (tmscm obj) { return scm_is_int (obj); }
tmscm_is_double(tmscm obj)228 inline bool tmscm_is_double (tmscm obj) { return scm_is_double (obj); }
tmscm_is_string(tmscm obj)229 inline bool tmscm_is_string (tmscm obj) { return scm_is_string (obj); }
tmscm_is_symbol(tmscm obj)230 inline bool tmscm_is_symbol (tmscm obj) { return scm_is_symbol (obj); }
231
tmscm_cons(tmscm obj1,tmscm obj2)232 inline tmscm tmscm_cons (tmscm obj1, tmscm obj2) { return scm_cons (obj1, obj2); }
tmscm_car(tmscm obj)233 inline tmscm tmscm_car (tmscm obj) { return SCM_CAR (obj); }
tmscm_cdr(tmscm obj)234 inline tmscm tmscm_cdr (tmscm obj) { return SCM_CDR (obj); }
tmscm_caar(tmscm obj)235 inline tmscm tmscm_caar (tmscm obj) { return SCM_CAAR (obj); }
tmscm_cadr(tmscm obj)236 inline tmscm tmscm_cadr (tmscm obj) { return SCM_CADR (obj); }
tmscm_cdar(tmscm obj)237 inline tmscm tmscm_cdar (tmscm obj) { return SCM_CDAR (obj); }
tmscm_cddr(tmscm obj)238 inline tmscm tmscm_cddr (tmscm obj) { return SCM_CDDR (obj); }
tmscm_caddr(tmscm obj)239 inline tmscm tmscm_caddr (tmscm obj) { return SCM_CADDR (obj); }
tmscm_cadddr(tmscm obj)240 inline tmscm tmscm_cadddr (tmscm obj) { return SCM_CADDDR (obj); }
241
242
243
244 SCM bool_to_scm (bool b);
245 SCM int_to_scm (int i);
246 SCM long_to_scm (long l);
247 SCM double_to_scm (double i);
248
249
250
bool_to_tmscm(bool b)251 inline tmscm bool_to_tmscm (bool b) { return bool_to_scm (b); }
int_to_tmscm(int i)252 inline tmscm int_to_tmscm (int i) { return int_to_scm (i); }
long_to_tmscm(long l)253 inline tmscm long_to_tmscm (long l) { return long_to_scm (l); }
double_to_tmscm(double i)254 inline tmscm double_to_tmscm (double i) { return double_to_scm (i); }
255 tmscm string_to_tmscm (string s);
256 tmscm symbol_to_tmscm (string s);
257
tmscm_to_bool(tmscm obj)258 inline bool tmscm_to_bool (tmscm obj) { return scm_to_bool (obj); }
tmscm_to_int(tmscm obj)259 inline int tmscm_to_int (tmscm obj) { return scm_to_int (obj); }
tmscm_to_double(tmscm obj)260 inline double tmscm_to_double (tmscm obj) { return scm_to_double (obj); }
261 string tmscm_to_string (tmscm obj);
262 string tmscm_to_symbol (tmscm obj);
263
264
265
266
267 tmscm eval_scheme_file (string name);
268 tmscm eval_scheme (string s);
269 tmscm call_scheme (tmscm fun);
270 tmscm call_scheme (tmscm fun, tmscm a1);
271 tmscm call_scheme (tmscm fun, tmscm a1, tmscm a2);
272 tmscm call_scheme (tmscm fun, tmscm a1, tmscm a2, tmscm a3);
273 tmscm call_scheme (tmscm fun, tmscm a1, tmscm a2, tmscm a3, tmscm a4);
274 tmscm call_scheme (tmscm fun, array<tmscm> a);
275
276
277 #define tmscm_install_procedure(name, func, args, p0, p1) \
278 scm_new_procedure (name, ( FN )( func ), args, p0, p1)
279
280 #define TMSCM_ASSERT(_cond, _arg, _pos, _subr) \
281 SCM_ASSERT(_cond, _arg, _pos, _subr)
282
283 #define TMSCM_ARG1 SCM_ARG1
284 #define TMSCM_ARG2 SCM_ARG2
285 #define TMSCM_ARG3 SCM_ARG3
286 #define TMSCM_ARG4 SCM_ARG4
287 #define TMSCM_ARG5 SCM_ARG5
288 #define TMSCM_ARG6 SCM_ARG6
289 #define TMSCM_ARG7 SCM_ARG7
290 #define TMSCM_ARG8 SCM_ARG8
291 #define TMSCM_ARG9 SCM_ARG9
292 #define TMSCM_ARG10 SCM_ARG10
293
294 #define TMSCM_UNSPECIFIED SCM_UNSPECIFIED
295
296
297 string scheme_dialect ();
298
299
300 #endif // defined GUILE_TM_H
301
302
303