1 /* gi.c --- buffer against libguile interface churn
2 *
3 * Copyright (C) 2011-2013 Thien-Thi Nguyen
4 *
5 * This is free software; you can redistribute it and/or modify it
6 * under the terms of the GNU General Public License as published by
7 * the Free Software Foundation; either version 3, or (at your option)
8 * any later version.
9 *
10 * This software is distributed in the hope that it will be useful,
11 * but WITHOUT ANY WARRANTY; without even the implied warranty of
12 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 * General Public License for more details.
14 *
15 * You should have received a copy of the GNU General Public License
16 * along with this package. If not, see <http://www.gnu.org/licenses/>.
17 */
18
19 #include "config.h"
20 #include <string.h>
21 #include <libguile.h>
22
23 #define COMBINED(maj,min) ((100 * (maj)) + (min))
24
25 #if defined SCM_MAJOR_VERSION && defined SCM_MINOR_VERSION
26 #define GUILE_COMBINED_V COMBINED (SCM_MAJOR_VERSION, SCM_MINOR_VERSION)
27 #else
28 #define GUILE_COMBINED_V COMBINED (1, 4)
29 #endif
30
31 #define GUILE_V_LT(maj,min) (GUILE_COMBINED_V < COMBINED (maj, min))
32 #define GUILE_V_GE(maj,min) (! GUILE_V_LT (maj, min))
33
34 /* If the system Guile is 1.8 but we are compiling for 2.0, for example,
35 avoid pulling in the system Guile gh.h. */
36 #if defined HAVE_GUILE_GH_H && GUILE_V_LT (1, 9)
37 # include <guile/gh.h>
38 #endif
39
40 #include "timidity.h"
41 #include "unused.h"
42
43 #define V19 GUILE_V_GE (1, 9)
44 #define V17 GUILE_V_GE (1, 7)
45 #define V15 GUILE_V_GE (1, 5)
46
47 void *
gi_malloc(size_t len,const char * name)48 gi_malloc (size_t len, const char *name)
49 {
50 #if V17
51 return scm_gc_malloc (len, name);
52 #else
53 return scm_must_malloc (len, name);
54 #endif
55 }
56
57 void *
gi_realloc(void * mem,size_t olen,size_t nlen,const char * name)58 gi_realloc (void *mem, size_t olen, size_t nlen, const char *name)
59 {
60 #if V17
61 return scm_gc_realloc (mem, olen, nlen, name);
62 #else
63 return scm_must_realloc (mem, olen, nlen, name);
64 #endif
65 }
66
67 #if V17
68 #define POSSIBLY_UNUSED_GI_FREE_PARAM
69 #else
70 #define POSSIBLY_UNUSED_GI_FREE_PARAM UNUSED
71 #endif
72
73 void
gi_free(void * mem,POSSIBLY_UNUSED_GI_FREE_PARAM size_t len,POSSIBLY_UNUSED_GI_FREE_PARAM const char * name)74 gi_free (void *mem,
75 POSSIBLY_UNUSED_GI_FREE_PARAM size_t len,
76 POSSIBLY_UNUSED_GI_FREE_PARAM const char *name)
77 {
78 #if V17
79 scm_gc_free (mem, len, name);
80 #else
81 scm_must_free (mem);
82 #endif
83 }
84
85 #if V17 /* FIXME: Is this the correct demarcation? */
86 #define POSSIBLY_UNUSED_GI_SMOB_FREE_RV_PARAM UNUSED
87 #else
88 #define POSSIBLY_UNUSED_GI_SMOB_FREE_RV_PARAM
89 #endif
90
91 size_t
gi_smob_free_rv(POSSIBLY_UNUSED_GI_SMOB_FREE_RV_PARAM size_t len)92 gi_smob_free_rv (POSSIBLY_UNUSED_GI_SMOB_FREE_RV_PARAM size_t len)
93 {
94 #if V17 /* FIXME: Is this the correct demarcation? */
95 return 0;
96 #else
97 return len;
98 #endif
99 }
100
101 #if V15
102 #define gc_protect scm_gc_protect_object
103 #define gc_unprotect scm_gc_unprotect_object
104 #else
105 #define gc_protect scm_protect_object
106 #define gc_unprotect scm_unprotect_object
107 #endif
108
109 SCM
gi_gc_protect(SCM obj)110 gi_gc_protect (SCM obj)
111 {
112 return gc_protect (obj);
113 }
114
115 SCM
gi_gc_unprotect(SCM obj)116 gi_gc_unprotect (SCM obj)
117 {
118 return gc_unprotect (obj);
119 }
120
121 #if V19
122 #define mem2scm(len,ptr) scm_from_locale_stringn (ptr, len)
123 #define mem02scm(ptr) scm_from_locale_string (ptr)
124 #elif V17
125 #define mem2scm(len,ptr) scm_mem2string (ptr, len)
126 #define mem02scm(ptr) scm_makfrom0str (ptr)
127 #elif V15
128 #define mem2scm(len,ptr) scm_makfromstr (ptr, len)
129 #define mem02scm(ptr) scm_makfrom0str (ptr)
130 #else
131 #define mem2scm(len,ptr) gh_str2scm (ptr, len)
132 #define mem02scm(ptr) gh_str02scm (ptr)
133 #endif
134
135 SCM
gi_nstring2scm(size_t len,char const * s)136 gi_nstring2scm (size_t len, char const *s)
137 {
138 return mem2scm (len, s);
139 }
140
141 SCM
gi_string2scm(char const * s)142 gi_string2scm (char const * s)
143 {
144 return mem02scm (s);
145 }
146
147 #if V19
148 #define symbol2scm scm_from_locale_symbol
149 #elif V15
150 #define symbol2scm scm_str2symbol
151 #else
152 #define symbol2scm gh_symbol2scm
153 #endif
154
155 SCM
gi_symbol2scm(char const * name)156 gi_symbol2scm (char const * name)
157 {
158 return symbol2scm (name);
159 }
160
161 #if V19
162 #define integer2scm scm_from_signed_integer
163 #define nnint2scm scm_from_unsigned_integer
164 #elif V15
165 #define integer2scm scm_long2num
166 #define nnint2scm scm_ulong2num
167 #else
168 #define integer2scm gh_long2scm
169 #define nnint2scm gh_ulong2scm
170 #endif
171
172 SCM
gi_integer2scm(long int n)173 gi_integer2scm (long int n)
174 {
175 return integer2scm (n);
176 }
177
178 SCM
gi_nnint2scm(unsigned long int n)179 gi_nnint2scm (unsigned long int n)
180 {
181 return nnint2scm (n);
182 }
183
184 #if V15
185 #define list_3(a1,a2,a3) scm_list_n (a1, a2, a3, SCM_UNDEFINED)
186 #else
187 #define list_3(a1,a2,a3) scm_listify (a1, a2, a3, SCM_UNDEFINED)
188 #endif
189
190 SCM
gi_list_3(SCM a1,SCM a2,SCM a3)191 gi_list_3 (SCM a1, SCM a2, SCM a3)
192 {
193 return list_3 (a1, a2, a3);
194 }
195
196 #if V15
197 #define list_5(a1,a2,a3,a4,a5) scm_list_n (a1, a2, a3, a4, a5, SCM_UNDEFINED)
198 #else
199 #define list_5(a1,a2,a3,a4,a5) scm_listify (a1, a2, a3, a4, a5, SCM_UNDEFINED)
200 #endif
201
202 SCM
gi_list_5(SCM a1,SCM a2,SCM a3,SCM a4,SCM a5)203 gi_list_5 (SCM a1, SCM a2, SCM a3, SCM a4, SCM a5)
204 {
205 return list_5 (a1, a2, a3, a4, a5);
206 }
207
208 extern SCM
gi_n_vector(size_t len,SCM fill)209 gi_n_vector (size_t len, SCM fill)
210 {
211 #if V15
212 return scm_c_make_vector (len, fill);
213 #else
214 return scm_make_vector (integer2scm (len), fill);
215 #endif
216 }
217
218 #if V15
219 #define eval_string scm_c_eval_string
220 #else
221 #define eval_string gh_eval_str
222 #endif
223
224 SCM
gi_eval_string(char const * string)225 gi_eval_string (char const *string)
226 {
227 return eval_string (string);
228 }
229
230 SCM
gi_lookup(char const * string)231 gi_lookup (char const *string)
232 {
233 SCM rv;
234
235 #if V19
236 rv = scm_c_private_lookup ("guile-user", string);
237 rv = scm_variable_ref (rv);
238 #elif V15
239 rv = scm_sym2var (symbol2scm (string),
240 scm_current_module_lookup_closure (),
241 SCM_BOOL_F);
242 rv = SCM_FALSEP (rv)
243 ? SCM_UNDEFINED
244 : scm_variable_ref (rv);
245 #else
246 rv = gh_lookup (string);
247 #endif
248
249 return rv;
250 }
251
252 int
gi_scm2int(SCM number)253 gi_scm2int (SCM number)
254 {
255 #if V15
256 return scm_to_int (number);
257 #else
258 return gh_scm2int (number);
259 #endif
260 }
261
262 long
gi_scm2long(SCM number)263 gi_scm2long (SCM number)
264 {
265 #if V15
266 return scm_to_long (number);
267 #else
268 return gh_scm2long (number);
269 #endif
270 }
271
272 unsigned long
gi_scm2ulong(SCM number)273 gi_scm2ulong (SCM number)
274 {
275 #if V15
276 return scm_to_ulong (number);
277 #else
278 return gh_scm2ulong (number);
279 #endif
280 }
281
282 size_t
gi_string_length(SCM string)283 gi_string_length (SCM string)
284 {
285 return gi_scm2ulong (scm_string_length (string));
286 }
287
288 int
gi_nfalsep(SCM obj)289 gi_nfalsep (SCM obj)
290 {
291 #if V17
292 return ! scm_is_false (obj);
293 #else
294 return SCM_NFALSEP (obj);
295 #endif
296 }
297
298 int
gi_stringp(SCM obj)299 gi_stringp (SCM obj)
300 {
301 #if V17
302 return scm_is_string (obj);
303 #else
304 return gi_nfalsep (scm_string_p (obj));
305 #endif
306 }
307
308 int
gi_symbolp(SCM obj)309 gi_symbolp (SCM obj)
310 {
311 #if V17
312 return scm_is_symbol (obj);
313 #else
314 return gi_nfalsep (scm_symbol_p (obj));
315 #endif
316 }
317
318 int
gi_exactp(SCM obj)319 gi_exactp (SCM obj)
320 {
321 #ifdef SCM_EXACTP
322 return SCM_EXACTP (obj);
323 #else
324 return gi_nfalsep (scm_number_p (obj))
325 && gi_nfalsep (scm_exact_p (obj));
326 #endif
327 }
328
329 int
gi_get_xrep(char * buf,size_t len,SCM symbol_or_string)330 gi_get_xrep (char *buf, size_t len, SCM symbol_or_string)
331 {
332 SCM obj;
333 size_t actual;
334
335 /* You're joking, right? */
336 if (! len)
337 return -1;
338
339 obj = gi_symbolp (symbol_or_string)
340 ? scm_symbol_to_string (symbol_or_string)
341 : symbol_or_string;
342 actual = gi_string_length (obj);
343 if (len < actual + 1)
344 return -1;
345
346 #if V17
347 {
348 size_t sanity;
349
350 sanity = scm_to_locale_stringbuf (obj, buf, len);
351 assert (sanity == actual);
352 }
353 #else
354 {
355 int sanity;
356 char *stage = gh_scm2newstr (obj, &sanity);
357
358 assert (sanity == (int) actual);
359 memcpy (buf, stage, actual);
360 scm_must_free (stage);
361 }
362 #endif
363
364 /* Murphy was an optimist. */
365 buf[actual] = '\0';
366 return actual;
367 }
368
369 void
gi_define(const char * name,SCM value)370 gi_define (const char *name, SCM value)
371 {
372 #if V15
373 scm_c_define (name, value);
374 #else
375 gh_define (name, value);
376 #endif
377 }
378
379 SCM
gi_primitive_eval(SCM form)380 gi_primitive_eval (SCM form)
381 {
382 #if V15
383 return scm_primitive_eval_x (form);
384 #else
385 return scm_eval_x (form);
386 #endif
387 }
388
389 SCM
gi_primitive_load(const char * filename)390 gi_primitive_load (const char *filename)
391 {
392 #if V15
393 return scm_c_primitive_load (filename);
394 #else
395 return scm_primitive_load (gi_string2scm (filename));
396 #endif
397 }
398
399 /* Depending on the smob implementation of Guile we use different
400 functions in order to create a new smob tag. It is also necessary to
401 apply a smob `free' function for older Guile versions because it is
402 called unconditionally and has no reasonable default function. */
403
404 svz_smob_tag_t
gi_make_tag(const char * description,size_t sz,const void * fn_free,const void * fn_print,const void * fn_equal)405 gi_make_tag (const char *description, size_t sz,
406 const void *fn_free,
407 const void *fn_print,
408 const void *fn_equal)
409 {
410 svz_smob_tag_t tag;
411
412 #ifdef SCM_SMOB_DATA
413
414 tag = scm_make_smob_type (description, sz);
415 scm_set_smob_free (tag, fn_free ? fn_free : scm_free0);
416 scm_set_smob_print (tag, fn_print);
417 if (fn_equal)
418 scm_set_smob_equalp (tag, fn_equal);
419
420 #else /* !defined SCM_SMOB_DATA */
421
422 scm_smobfuns mfpe = {
423 NULL, /* mark */
424 fn_free ? fn_free : scm_free0,
425 fn_print,
426 fn_equal
427 };
428
429 tag = scm_newsmob (&mfpe);
430
431 #endif /* !defined SCM_SMOB_DATA */
432
433 return tag;
434 }
435
436 int
gi_smob_tagged_p(SCM obj,svz_smob_tag_t tag)437 gi_smob_tagged_p (SCM obj, svz_smob_tag_t tag)
438 {
439 return SCM_NIMP (obj)
440 && tag == SCM_TYP16 (obj);
441 }
442
443 #ifndef SCM_NEWSMOB
444 #define SCM_NEWSMOB(value, tag, data) do \
445 { \
446 SCM_NEWCELL (value); \
447 SCM_SETCDR (value, data); \
448 SCM_SETCAR (value, tag); \
449 } \
450 while (0)
451 #endif
452 #ifndef SCM_RETURN_NEWSMOB
453 #define SCM_RETURN_NEWSMOB(tag, data) do \
454 { \
455 SCM value; \
456 SCM_NEWSMOB (value, tag, data); \
457 return value; \
458 } \
459 while (0)
460 #endif
461
462 SCM
gi_make_smob(svz_smob_tag_t tag,void * data)463 gi_make_smob (svz_smob_tag_t tag, void *data)
464 {
465 SCM_RETURN_NEWSMOB (tag, data);
466 }
467
468 void *
gi_smob_data(SCM smob)469 gi_smob_data (SCM smob)
470 {
471 #ifndef SCM_SMOB_DATA
472 return (void *) SCM_CDR (smob);
473 #else
474 return (void *) SCM_SMOB_DATA (smob);
475 #endif
476 }
477
478 SCM
gi_hash_clear_x(SCM table)479 gi_hash_clear_x (SCM table)
480 {
481 #if V17
482 return scm_hash_clear_x (table);
483 #else
484 scm_vector_fill_x (table, SCM_EOL);
485 #endif
486 }
487
488 /* gi.c ends here */
489