]> git.donarmstrong.com Git - lilypond.git/blob - lily/include/lily-guile.hh
443713b6b63055156f5147d5730f622da04c225e
[lilypond.git] / lily / include / lily-guile.hh
1 /*
2   lily-guile.hh encapsulate guile
3
4   source file of the GNU LilyPond music typesetter
5
6   (c) 1998--2004 Jan Nieuwenhuizen <janneke@gnu.org>
7 */
8
9 #ifndef LILY_GUILE_HH
10 #define LILY_GUILE_HH
11
12
13 /*
14   TODO: the  GH interface is deprecated as of GUILE 1.6
15
16   Remove all gh_XXX functions.
17  */
18 #include <guile/gh.h>
19
20
21 /* GUILE only includes version in headers (libguile/version.h) as of
22    1.5.x.  For some strange reason, they call it SCM.*VERSION.
23
24    Not including config.h here, saves a lot of unnecessary
25    recompiles. */
26 #include <libguile.h>
27
28 #ifndef GUILE_MAJOR_VERSION
29 #ifdef SCM_MAJOR_VERSION
30 #define GUILE_MAJOR_VERSION SCM_MAJOR_VERSION
31 #define GUILE_MINOR_VERSION SCM_MINOR_VERSION
32 #define GUILE_PATCH_LEVEL SCM_MICRO_VERSION
33 #else
34 #include "config.h"
35 #endif
36 #endif
37
38 #include "drul-array.hh"
39
40
41 /* Guile 1.4.x compatibility */
42 #if GUILE_MINOR_VERSION < 5
43
44 #define scm_t_bits scm_bits_t
45
46 #define fix_guile_1_4_gh_scm2newstr(str, lenp) gh_scm2newstr (str, (int*)lenp)
47 #define gh_scm2newstr(str, lenp) fix_guile_1_4_gh_scm2newstr (str, lenp)
48
49 #define fix_guile_1_4_scm_primitive_eval(form) scm_eval_3 (form, 1, SCM_EOL)
50 #define scm_primitive_eval(form) fix_guile_1_4_scm_primitive_eval (form)
51
52 #define scm_int2num(x) scm_long2num (x)  
53 #define scm_current_module() (SCM)0
54 #define scm_set_current_module(x) (void)x
55 #define scm_c_resolve_module(x) (SCM)0
56
57 inline SCM scm_c_make_vector  (int k, SCM val) {
58   return scm_make_vector (SCM_MAKINUM (k), val);
59 }
60 #define scm_c_define_gsubr scm_make_gsubr
61 #define scm_c_eval_string(str) gh_eval_str ((char*)str)
62 #define scm_remember_upto_here_1(s) scm_remember (&s)
63 #define scm_gc_protect_object scm_protect_object
64 #define scm_gc_unprotect_object scm_unprotect_object
65 #define scm_list_n scm_listify
66 #define SCM_STRING_CHARS SCM_CHARS
67 #define SCM_STRING_LENGTH SCM_LENGTH
68 #define SCM_SYMBOL_CHARS SCM_CHARS
69 #define SCM_SYMBOL_LENGTH SCM_LENGTH
70 #define SCM_VECTOR_LENGTH SCM_LENGTH
71
72 #define SMOB_FREE_RETURN_VAL(CL) sizeof(CL) 
73 #define scm_done_free(x) 
74 #endif
75
76 #ifndef SMOB_FREE_RETURN_VAL
77 #define SMOB_FREE_RETURN_VAL(CL) 0
78 #endif
79
80
81 #if GUILE_MINOR_VERSION < 7
82 #define scm_gc_unregister_collectable_memory(a,b,c) scm_done_free(b)
83 #define scm_gc_register_collectable_memory(a,b,c) scm_done_malloc(b)
84 #define SCM_VECTOR_REF(v,i) (SCM_VELTS((v))[(i)])
85 #define scm_hash_table_p scm_vector_p 
86
87 #endif
88
89 #include "direction.hh"
90 #include "flower-proto.hh"
91
92 #ifndef SCM_PACK
93 #define SCM_PACK(x) ((SCM) x)
94
95 #endif
96 #ifndef SCM_UNPACK
97 #define SCM_UNPACK(x) ( x)
98 #endif
99
100 /*
101   conversion functions follow the GUILE naming convention, i.e.
102
103     A ly_B2A (B b);
104  */
105
106 SCM ly_last (SCM list);
107 SCM ly_write2scm (SCM s);
108 SCM ly_deep_copy (SCM);
109 SCM ly_truncate_list (int k, SCM l );
110
111
112 /*
113   Unreliable on gcc2
114  */
115 // #define CACHE_SYMBOLS
116
117
118 #if (__GNUC__ > 2)
119 /*
120   todo: should add check for x86 as well
121  */
122 #define CACHE_SYMBOLS
123 #endif
124
125
126 #ifdef CACHE_SYMBOLS
127
128
129 /*
130   Using this trick we cache the value of gh_symbol2scm ("fooo") where
131   "fooo" is a constant string. This is done at the cost of one static
132   variable per ly_symbol2scm() use, and one boolean evaluation for
133   every call.
134
135   The overall speedup of lily is about 5% on a run of wtk1-fugue2
136
137 */
138 #define ly_symbol2scm(x) ({ static SCM cached;  \
139  SCM value = cached;  /* We store this one locally, since G++ -O2 fucks up else */   \
140  if ( __builtin_constant_p ((x)))\
141  {  if (!cached)\
142      value = cached =  scm_gc_protect_object (gh_symbol2scm((x)));\
143  } else\
144   value = gh_symbol2scm ((char*) (x)); \
145   value; })
146 #else
147 inline SCM ly_symbol2scm(char const* x) { return gh_symbol2scm((x)); }
148 #endif 
149
150
151
152 String ly_scm2string (SCM s);
153 String ly_symbol2string (SCM);
154 SCM ly_offset2scm (Offset);
155 Offset ly_scm2offset (SCM);
156 SCM ly_assoc_chain (SCM key, SCM achain);
157 SCM ly_assoc_cdr (SCM key, SCM alist);
158 Interval ly_scm2interval (SCM);
159 Drul_array<Real> ly_scm2realdrul (SCM);
160 Slice int_list_to_slice (SCM l);
161 SCM ly_interval2scm (Drul_array<Real>);
162
163 Real robust_scm2double (SCM, double);
164 int robust_scm2int (SCM, int);
165 Drul_array<Real> robust_scm2drul (SCM, Drul_array<Real>);
166 Interval robust_scm2interval (SCM, Drul_array<Real>);
167 Offset robust_scm2offset (SCM, Offset);
168
169 SCM ly_quote_scm (SCM s);
170 bool type_check_assignment (SCM val, SCM sym,  SCM type_symbol) ;
171 String print_scm_val (SCM val);
172 SCM ly_number2string (SCM s);
173
174 SCM parse_symbol_list (char const *);
175 SCM robust_list_ref(int i, SCM l);
176 SCM alist_to_hashq (SCM);
177
178 inline SCM ly_cdr (SCM x) { return SCM_CDR (x); }
179 inline SCM ly_car (SCM x) { return SCM_CAR (x); } 
180 inline SCM ly_caar (SCM x) { return SCM_CAAR (x); }
181 inline SCM ly_cdar (SCM x) { return SCM_CDAR (x); }
182 inline SCM ly_cadr (SCM x) { return SCM_CADR (x); }
183 inline SCM ly_cddr (SCM x) { return SCM_CDDR (x); }
184 inline SCM ly_caddr (SCM x) { return SCM_CADDR (x); }
185 inline SCM ly_cdadr (SCM x) { return SCM_CDADR (x); }
186 inline SCM ly_caadr (SCM x) { return SCM_CAADR (x); }
187 /* inserts at front, removing dublicates */
188 inline SCM ly_assoc_front_x(SCM alist, SCM key, SCM val)
189 {
190   return scm_acons(key, val, scm_assoc_remove_x (alist, key));
191 }
192 #ifdef PARANOID
193 #define gh_pair_p ly_pair_p
194 bool ly_pair_p (SCM x);
195 #else
196 inline bool ly_pair_p (SCM x) { return SCM_NFALSEP (scm_pair_p (x)); }
197 #endif
198 inline bool ly_symbol_p (SCM x) { return SCM_SYMBOLP (x); }
199 inline bool ly_number_p (SCM x) { return SCM_NUMBERP (x); }
200 inline bool ly_procedure_p (SCM x) { return SCM_NFALSEP (scm_procedure_p (x)); }
201
202 /*
203   display and print newline.
204  */
205 extern "C" { 
206 void ly_display_scm (SCM s);
207 }
208
209 #include "array.hh"
210
211 void read_lily_scm_file (String);
212 void ly_init_guile ();
213
214 bool is_direction (SCM s);
215 bool is_number_pair (SCM);
216 bool is_axis (SCM);
217
218 /*
219   these conversion functions also do a typecheck on the argument, and
220   return a default value if S has the wrong type.
221 */
222
223 Direction to_dir (SCM s);
224 bool to_boolean (SCM s);
225
226 void init_ly_protection ();
227 unsigned int ly_scm_hash (SCM s);
228
229 SCM index_get_cell (SCM cell, Direction d);
230 SCM index_set_cell (SCM cell, Direction d, SCM val);
231
232 SCM ly_snoc (SCM s, SCM list);
233 SCM ly_split_list (SCM s, SCM list);
234 SCM ly_unique (SCM list);
235
236
237
238 /*
239   snarfing.
240  */
241 void add_scm_init_func (void (*) ());
242
243 extern "C" {
244 typedef SCM (*Scheme_function_unknown) ();
245 }
246
247 #if __GNUC__ > 2 || __GNUC_MINOR__ >= 96
248 typedef SCM (*Scheme_function_0) ();
249 typedef SCM (*Scheme_function_1) (SCM);
250 typedef SCM (*Scheme_function_2) (SCM,SCM);      
251 typedef SCM (*Scheme_function_3) (SCM,SCM, SCM);         
252 #else
253 typedef SCM (*Scheme_function_0) (...);
254 typedef SCM (*Scheme_function_1) (...);
255 typedef SCM (*Scheme_function_2) (...);
256 typedef SCM (*Scheme_function_3) (...);
257 #endif
258
259 #define DECLARE_SCHEME_CALLBACK(NAME,ARGS) \
260         static SCM NAME ARGS; \
261         static SCM NAME ## _proc
262
263 #define MAKE_SCHEME_CALLBACK(TYPE, FUNC, ARGCOUNT) \
264 SCM TYPE :: FUNC ## _proc;\
265 void                                                            \
266 TYPE ## _ ## FUNC ## _init_functions ()                                 \
267 {                                                               \
268   TYPE :: FUNC ## _proc = gh_new_procedure ## ARGCOUNT  ## _0 (#TYPE "::" #FUNC, \
269  ((Scheme_function_ ## ARGCOUNT)TYPE :: FUNC));                                 \
270   scm_c_export (#TYPE "::" #FUNC, NULL);\
271 }                                                               \
272                                                                 \
273 ADD_SCM_INIT_FUNC (TYPE ## _ ## FUNC ## _callback, TYPE ## _ ## FUNC ## _init_functions);       \
274
275
276 void ly_add_function_documentation (SCM proc, char const * fname,
277                                     char const * varlist,
278                                     char const * doc);
279
280 #define ADD_SCM_INIT_FUNC(name, func)\
281 class name ## _scm_initter {                    \
282 public:\
283   name ## _scm_initter ()                       \
284   {                                             \
285     add_scm_init_func (func);           \
286   }                                             \
287 } _ ## name ## _scm_initter;                    \
288 /* end define */
289
290 #define LY_DEFINE_WITHOUT_DECL(INITPREFIX, FNAME, PRIMNAME, REQ, OPT, VAR, ARGLIST, DOCSTRING) \
291 SCM FNAME ## _proc;\
292 void \
293 INITPREFIX ## init ()\
294 {\
295  FNAME ## _proc \
296     = scm_c_define_gsubr (PRIMNAME,REQ, OPT, VAR, (Scheme_function_unknown) FNAME);\
297   ly_add_function_documentation ( FNAME ## _proc ,PRIMNAME, #ARGLIST,  DOCSTRING);\
298   scm_c_export (PRIMNAME,NULL);\
299 }\
300 ADD_SCM_INIT_FUNC (INITPREFIX ## init_unique_prefix, INITPREFIX ## init);\
301 SCM \
302 FNAME ARGLIST\
303
304
305 #define LY_DEFINE(FNAME, PRIMNAME, REQ, OPT, VAR, ARGLIST, DOCSTRING) \
306 SCM FNAME ARGLIST ; \
307 LY_DEFINE_WITHOUT_DECL(FNAME, FNAME, PRIMNAME, REQ, OPT, VAR, ARGLIST, DOCSTRING) 
308
309
310 #define LY_DEFINE_MEMBER_FUNCTION(CLASS, FNAME, PRIMNAME, REQ, OPT, VAR, ARGLIST, DOCSTRING) \
311 SCM FNAME ARGLIST ; \
312 LY_DEFINE_WITHOUT_DECL(CLASS ## FNAME,  CLASS::FNAME, PRIMNAME, REQ, OPT, VAR, ARGLIST, DOCSTRING) 
313
314
315 #endif /* LILY_GUILE_HH */