1 #if (defined(__GNUC__))
2 #ifndef _GNU_SOURCE
3 #define _GNU_SOURCE
4 #endif
5 #include <string.h>
6 #endif
7
8 #include "snd.h"
9 #include "clm2xen.h"
10
11 #define HAVE_SPECIAL_FUNCTIONS (!_MSC_VER)
12
13 /* Snd defines its own exit and delay
14 *
15 * In Ruby, rand is kernel_rand.
16 *
17 * In Forth, Snd's exit is named snd-exit.
18 */
19 /* error handlers */
20
21 static const char *io_error_names[IO_ERROR_NUM] = {"no error", "save-hook cancellation", "bad channel",
22 "can't reopen file", "too many open files", "unknown sndlib error",
23 "no memory", "can't open", "no filename", "bad sample type", "bad header type", "sndlib uninitialized",
24 "not a sound file", "file closed", "write error", "interrupted", "can't close",
25 "bad header", "disk full", "write protected", "can't read selection file",
26 "need write confirmation", "no changes", "io edit-hook cancellation", "can't create file"
27 };
28
io_error_name(io_error_t err)29 const char *io_error_name(io_error_t err)
30 {
31 if (err < IO_ERROR_NUM)
32 return(io_error_names[(int)err]);
33 return(mus_format("unknown io_error: %d", err));
34 }
35
36
37 /* this is needed as a C int below */
38 #ifndef USE_NO_GUI
39 #define USE_NO_GUI 0
40 #endif
41
42
run_snd_error_hook(const char * msg)43 static bool run_snd_error_hook(const char *msg)
44 {
45 return((Xen_hook_has_list(ss->snd_error_hook)) &&
46 (Xen_is_true(run_or_hook(ss->snd_error_hook,
47 Xen_list_1(C_string_to_Xen_string(msg)),
48 S_snd_error_hook))));
49 }
50
51
redirect_snd_warning_to(void (* handler)(const char * warning_msg,void * ufd),void * data)52 void redirect_snd_warning_to(void (*handler)(const char *warning_msg, void *ufd), void *data)
53 {
54 ss->snd_warning_handler = handler;
55 ss->snd_warning_data = data;
56 }
57
58
redirect_snd_error_to(void (* handler)(const char * error_msg,void * ufd),void * data)59 void redirect_snd_error_to(void (*handler)(const char *error_msg, void *ufd), void *data)
60 {
61 ss->snd_error_handler = handler;
62 ss->snd_error_data = data;
63 }
64
65
snd_error_1(const char * msg,bool with_redirection_and_hook)66 static void snd_error_1(const char *msg, bool with_redirection_and_hook)
67 {
68 if (with_redirection_and_hook)
69 {
70 if (ss->snd_error_handler)
71 {
72 /* make sure it doesn't call itself recursively */
73 void (*old_snd_error_handler)(const char *error_msg, void *data);
74 void *old_snd_error_data;
75 old_snd_error_handler = ss->snd_error_handler;
76 old_snd_error_data = ss->snd_error_data;
77 ss->snd_error_handler = NULL;
78 ss->snd_error_data = NULL;
79 (*(old_snd_error_handler))(msg, old_snd_error_data);
80 ss->snd_error_handler = old_snd_error_handler;
81 ss->snd_error_data = old_snd_error_data;
82 return;
83 }
84
85 if (run_snd_error_hook(msg))
86 return;
87 }
88 #if (USE_NO_GUI)
89 fprintf(stderr, "%s", msg);
90 #else
91 if (ss)
92 {
93 if (ss->batch_mode)
94 fprintf(stderr, "%s", msg);
95 #if ((!HAVE_EXTENSION_LANGUAGE) && (!USE_NO_GUI))
96 {
97 snd_info *sp;
98 sp = any_selected_sound();
99 if ((sp) && (sp->active))
100 status_report(sp, "%s", msg);
101 else post_it("Error", msg);
102 }
103 #endif
104 }
105 else
106 {
107 fprintf(stderr, "%s", msg);
108 fputc('\n', stderr);
109 }
110 #endif
111 /* end USE_NO_GUI */
112 }
113
114
snd_warning_1(const char * msg)115 static void snd_warning_1(const char *msg)
116 {
117 if (ss->snd_warning_handler)
118 {
119 /* make sure it doesn't call itself recursively */
120 void (*old_snd_warning_handler)(const char *msg, void *data);
121 void *old_snd_warning_data;
122 old_snd_warning_handler = ss->snd_warning_handler;
123 old_snd_warning_data = ss->snd_warning_data;
124 ss->snd_warning_handler = NULL;
125 ss->snd_warning_data = NULL;
126 (*(old_snd_warning_handler))(msg, old_snd_warning_data);
127 ss->snd_warning_handler = old_snd_warning_handler;
128 ss->snd_warning_data = old_snd_warning_data;
129 return;
130 }
131
132 if ((Xen_hook_has_list(ss->snd_warning_hook)) &&
133 (Xen_is_true(run_or_hook(ss->snd_warning_hook,
134 Xen_list_1(C_string_to_Xen_string(msg)),
135 S_snd_warning_hook))))
136 return;
137
138 if ((ss) && (!(ss->batch_mode)) && (ss->max_sounds > 0))
139 {
140 snd_info *sp;
141 sp = any_selected_sound();
142 if ((sp) && (sp->active))
143 status_report(sp, "%s", msg); /* make the Mac C compiler happy */
144 else
145 {
146 listener_append(msg);
147 fprintf(stderr, "%s", msg);
148 }
149 }
150 else fprintf(stderr, "%s", msg);
151 }
152
153
154 static int snd_error_buffer_size = 1024;
155 static char *snd_error_buffer = NULL;
156
snd_warning(const char * format,...)157 void snd_warning(const char *format, ...)
158 {
159 int bytes_needed = 0;
160 va_list ap;
161
162 if (!snd_error_buffer)
163 snd_error_buffer = (char *)calloc(snd_error_buffer_size, sizeof(char));
164 va_start(ap, format);
165
166 /* can't use vasprintf here -- we may jump anywhere leaving unclaimed memory behind
167 */
168 bytes_needed = vsnprintf(snd_error_buffer, snd_error_buffer_size, format, ap);
169 va_end(ap);
170
171 if (bytes_needed >= snd_error_buffer_size)
172 {
173 snd_error_buffer_size = bytes_needed * 2;
174 free(snd_error_buffer);
175 snd_error_buffer = (char *)calloc(snd_error_buffer_size, sizeof(char));
176
177 va_start(ap, format);
178 vsnprintf(snd_error_buffer, snd_error_buffer_size, format, ap);
179 va_end(ap);
180 }
181 snd_warning_1(snd_error_buffer);
182 }
183
184
snd_warning_without_format(const char * msg)185 void snd_warning_without_format(const char *msg)
186 {
187 snd_warning_1(msg);
188 }
189
190
snd_error(const char * format,...)191 void snd_error(const char *format, ...)
192 {
193 int bytes_needed = 0;
194 va_list ap;
195 if (!snd_error_buffer)
196 snd_error_buffer = (char *)calloc(snd_error_buffer_size, sizeof(char));
197
198 va_start(ap, format);
199 bytes_needed = vsnprintf(snd_error_buffer, snd_error_buffer_size, format, ap);
200 va_end(ap);
201
202 if (bytes_needed > snd_error_buffer_size)
203 {
204 snd_error_buffer_size = bytes_needed * 2;
205 free(snd_error_buffer);
206 snd_error_buffer = (char *)calloc(snd_error_buffer_size, sizeof(char));
207
208 va_start(ap, format);
209 vsnprintf(snd_error_buffer, snd_error_buffer_size, format, ap);
210 va_end(ap);
211 }
212 snd_error_1(snd_error_buffer, true);
213 }
214
215
snd_error_without_format(const char * msg)216 void snd_error_without_format(const char *msg)
217 {
218 snd_error_1(msg, true);
219 }
220
221
g_snd_error(Xen msg)222 static Xen g_snd_error(Xen msg)
223 {
224 /* this throws a 'snd-error error; it does not call snd_error_1 or friends above */
225 #define H_snd_error "(" S_snd_error " str): throws a 'snd-error error"
226 Xen_check_type(Xen_is_string(msg), msg, 1, S_snd_error, "a string");
227
228 if (!(run_snd_error_hook(Xen_string_to_C_string(msg)))) /* have to call this before the throw, else we end up at top level */
229 Xen_error(Xen_make_error_type("snd-error"),
230 Xen_list_2(C_string_to_Xen_string(S_snd_error ": ~A"),
231 msg));
232 return(msg);
233 }
234
235
g_snd_warning(Xen msg)236 static Xen g_snd_warning(Xen msg)
237 {
238 #define H_snd_warning "(" S_snd_warning " str): reports warning message str (normally in the status area)"
239 Xen_check_type(Xen_is_string(msg), msg, 1, S_snd_warning, "a string");
240 snd_warning("%s", Xen_string_to_C_string(msg));
241 return(msg);
242 }
243
244
245 static Xen clip_hook;
246
run_clip_hook(mus_float_t val)247 static mus_float_t run_clip_hook(mus_float_t val)
248 {
249 if (Xen_hook_has_list(clip_hook))
250 {
251 Xen result;
252 result = run_progn_hook(clip_hook,
253 Xen_list_1(C_double_to_Xen_real(val)),
254 S_clip_hook);
255 if (Xen_is_number(result))
256 return(Xen_real_to_C_double(result));
257 }
258 /* otherwise mimic the built-in default in io.c */
259 if (val >= 0.99999)
260 return(0.99999);
261 return(-1.0);
262 }
263
clip_hook_checker(void)264 static bool clip_hook_checker(void)
265 {
266 bool result;
267 result = Xen_hook_has_list(clip_hook);
268 if (result)
269 mus_clip_set_handler(run_clip_hook);
270 else mus_clip_set_handler(NULL);
271 return(result);
272 }
273
274
275
276
277 /* -------- protect Xen vars from GC -------- */
278
279 #if HAVE_SCHEME
280
snd_protect(Xen obj)281 int snd_protect(Xen obj) {return(s7_gc_protect(s7, obj));}
snd_unprotect_at(int loc)282 void snd_unprotect_at(int loc) {s7_gc_unprotect_at(s7, loc);}
283
284 #else
285 static Xen gc_protection;
286 static int gc_protection_size = 0;
287 #define DEFAULT_GC_VALUE Xen_undefined
288 static int gc_last_cleared = NOT_A_GC_LOC;
289 static int gc_last_set = NOT_A_GC_LOC;
290
snd_protect(Xen obj)291 int snd_protect(Xen obj)
292 {
293 int i, old_size;
294 Xen tmp;
295
296 if (gc_protection_size == 0)
297 {
298 gc_protection_size = 512;
299 gc_protection = Xen_make_vector(gc_protection_size, DEFAULT_GC_VALUE);
300 Xen_GC_protect(gc_protection);
301 Xen_vector_set(gc_protection, 0, obj);
302 gc_last_set = 0;
303 }
304 else
305 {
306 if ((gc_last_cleared >= 0) &&
307 Xen_is_eq(Xen_vector_ref(gc_protection, gc_last_cleared), DEFAULT_GC_VALUE))
308 {
309 /* we hit this branch about 2/3 of the time */
310 Xen_vector_set(gc_protection, gc_last_cleared, obj);
311 gc_last_set = gc_last_cleared;
312 gc_last_cleared = NOT_A_GC_LOC;
313
314 return(gc_last_set);
315 }
316
317 for (i = gc_last_set; i < gc_protection_size; i++)
318 if (Xen_is_eq(Xen_vector_ref(gc_protection, i), DEFAULT_GC_VALUE))
319 {
320 Xen_vector_set(gc_protection, i, obj);
321 gc_last_set = i;
322
323 return(gc_last_set);
324 }
325
326 for (i = 0; i < gc_last_set; i++)
327 if (Xen_is_eq(Xen_vector_ref(gc_protection, i), DEFAULT_GC_VALUE))
328 {
329 /* here we average 3 checks before a hit, so this isn't as bad as it looks */
330 Xen_vector_set(gc_protection, i, obj);
331 gc_last_set = i;
332
333 return(gc_last_set);
334 }
335
336 tmp = gc_protection;
337 old_size = gc_protection_size;
338 gc_protection_size *= 2;
339 gc_protection = Xen_make_vector(gc_protection_size, DEFAULT_GC_VALUE);
340 Xen_GC_protect(gc_protection);
341
342 for (i = 0; i < old_size; i++)
343 {
344 Xen_vector_set(gc_protection, i, Xen_vector_ref(tmp, i));
345 Xen_vector_set(tmp, i, DEFAULT_GC_VALUE);
346 }
347
348 Xen_vector_set(gc_protection, old_size, obj);
349
350 /* in Ruby, I think we can unprotect it */
351 #if HAVE_RUBY || HAVE_FORTH
352 Xen_GC_unprotect(tmp);
353 #endif
354 gc_last_set = old_size;
355 }
356 return(gc_last_set);
357 }
358
359
snd_unprotect_at(int loc)360 void snd_unprotect_at(int loc)
361 {
362 if (loc >= 0)
363 {
364 Xen_vector_set(gc_protection, loc, DEFAULT_GC_VALUE);
365 gc_last_cleared = loc;
366 }
367 }
368 #endif
369
370
371 /* -------- error handling -------- */
372
373 static char *last_file_loaded = NULL;
374
375 #if HAVE_SCHEME
g_snd_s7_error_handler(Xen args)376 static Xen g_snd_s7_error_handler(Xen args)
377 {
378 s7_pointer msg;
379 if (s7_is_pair(args))
380 msg = s7_car(args);
381 else msg = args;
382 Xen_check_type(Xen_is_string(msg), msg, 1, "_snd_s7_error_handler_", "a string");
383
384 if (ss->xen_error_handler)
385 (*(ss->xen_error_handler))(s7_string(msg), (void *)any_selected_sound()); /* not NULL! */
386 return(s7_f(s7));
387 }
388 #endif
389
390
redirect_xen_error_to(void (* handler)(const char * msg,void * ufd),void * data)391 void redirect_xen_error_to(void (*handler)(const char *msg, void *ufd), void *data)
392 {
393 ss->xen_error_handler = handler;
394 ss->xen_error_data = data;
395
396 #if HAVE_SCHEME
397 if (!handler)
398 s7_eval_c_string(s7, "(set! (hook-functions *error-hook*) ())");
399 else s7_eval_c_string(s7, "(set! (hook-functions *error-hook*) (list \n\
400 (lambda (hook) \n\
401 (let ((args (hook 'data))) \n\
402 (_snd_s7_error_handler_ \n\
403 (string-append \n\
404 (if (string? args) \n\
405 args \n\
406 (if (pair? args) \n\
407 (apply format #f args) \n\
408 \"\")) \n\
409 (with-let (owlet) \n\
410 (if (and error-code \n\
411 (string? error-file) \n\
412 (number? error-line)) \n\
413 (format #f \"~%~S[~D]: ~A~%\" error-file error-line error-code) \n\
414 \"\"))))))))");
415 #endif
416 }
417
418
redirect_snd_print_to(void (* handler)(const char * msg,void * ufd),void * data)419 static void redirect_snd_print_to(void (*handler)(const char *msg, void *ufd), void *data)
420 {
421 ss->snd_print_handler = handler;
422 ss->snd_print_data = data;
423 }
424
425
redirect_everything_to(void (* handler)(const char * msg,void * ufd),void * data)426 void redirect_everything_to(void (*handler)(const char *msg, void *ufd), void *data)
427 {
428 redirect_snd_error_to(handler, data);
429 redirect_xen_error_to(handler, data);
430 redirect_snd_warning_to(handler, data);
431 redirect_snd_print_to(handler, data);
432 }
433
434
redirect_errors_to(void (* handler)(const char * msg,void * ufd),void * data)435 void redirect_errors_to(void (*handler)(const char *msg, void *ufd), void *data)
436 {
437 redirect_snd_error_to(handler, data);
438 redirect_xen_error_to(handler, data);
439 redirect_snd_warning_to(handler, data);
440 }
441
442
443 static char *gl_print(Xen result);
444
445
446
447 /* ---------------- RUBY error handler ---------------- */
448
449 #if HAVE_RUBY
snd_format_if_needed(Xen args)450 static Xen snd_format_if_needed(Xen args)
451 {
452 /* if car has formatting info, use next arg as arg list for it */
453 Xen format_args = Xen_empty_list, cur_arg, result;
454 int i, start = 0, num_args, format_info_len, err_size = 8192;
455 bool got_tilde = false, was_formatted = false;
456 char *format_info = NULL, *errmsg = NULL;
457
458 num_args = Xen_list_length(args);
459 if (num_args == 1) return(Xen_car(args));
460
461 format_info = mus_strdup(Xen_string_to_C_string(Xen_car(args)));
462 format_info_len = mus_strlen(format_info);
463
464 if (Xen_is_cons(Xen_cadr(args)))
465 format_args = Xen_copy_arg(Xen_cadr(args)); /* protect Ruby case */
466 else format_args = Xen_cdr(args);
467
468 errmsg = (char *)calloc(err_size, sizeof(char));
469
470 for (i = 0; i < format_info_len; i++)
471 {
472 if (format_info[i] == '~')
473 {
474 strncat(errmsg, (char *)(format_info + start), i - start);
475 start = i + 2;
476 got_tilde = true;
477 }
478 else
479 {
480 if (got_tilde)
481 {
482 was_formatted = true;
483 got_tilde = false;
484 switch (format_info[i])
485 {
486 case '~': errmsg = mus_strcat(errmsg, "~", &err_size); break;
487 case '%': errmsg = mus_strcat(errmsg, "\n", &err_size); break;
488 case 'S':
489 case 'A':
490 if (!Xen_is_null(format_args))
491 {
492 cur_arg = Xen_car(format_args);
493 format_args = Xen_cdr(format_args);
494 if (Xen_is_vector(cur_arg))
495 {
496 char *vstr;
497 vstr = gl_print(cur_arg);
498 errmsg = mus_strcat(errmsg, vstr, &err_size);
499 free(vstr);
500 }
501 else
502 {
503 char *temp = NULL;
504 errmsg = mus_strcat(errmsg, temp = (char *)Xen_object_to_C_string(cur_arg), &err_size);
505 }
506 }
507 /* else ignore it */
508 break;
509 default: start = i - 1; break;
510 }
511 }
512 }
513 }
514 if (i > start)
515 strncat(errmsg, (char *)(format_info + start), i - start);
516 if (format_info) free(format_info);
517 if (!was_formatted)
518 {
519 char *temp = NULL;
520 errmsg = mus_strcat(errmsg, " ", &err_size);
521 errmsg = mus_strcat(errmsg, temp = (char *)Xen_object_to_C_string(Xen_cadr(args)), &err_size);
522
523 if (num_args > 2)
524 {
525 if (!Xen_is_false(Xen_caddr(args))) start = 2; else start = 3;
526 for (i = start; i < num_args; i++)
527 {
528 char *temp = NULL;
529 errmsg = mus_strcat(errmsg, " ", &err_size);
530 errmsg = mus_strcat(errmsg, temp = (char *)Xen_object_to_C_string(Xen_list_ref(args, i)), &err_size);
531 }
532 }
533 }
534 result = C_string_to_Xen_string(errmsg);
535 free(errmsg);
536 return(result);
537 }
538
snd_rb_raise(Xen tag,Xen throw_args)539 void snd_rb_raise(Xen tag, Xen throw_args)
540 {
541 static char *msg = NULL;
542 Xen err = rb_eStandardError, bt;
543 int size = 2048;
544 char *idname;
545
546 if (msg) free(msg);
547 msg = (char *)calloc(size, sizeof(char));
548
549 idname = (char *)rb_id2name(tag);
550 if (strcmp(idname, "Out_of_range") == 0)
551 err = rb_eRangeError;
552 else
553 if (strcmp(idname, "Wrong_type_arg") == 0)
554 err = rb_eTypeError;
555
556 msg = mus_strcat(msg, idname, &size);
557 if (strcmp(idname, "Mus_error") == 0)
558 msg = mus_strcat(msg, ": ", &size);
559 else msg = mus_strcat(msg, " in ", &size);
560 msg = mus_strcat(msg, Xen_string_to_C_string(snd_format_if_needed(throw_args)), &size);
561
562 bt = rb_funcall(err, rb_intern("caller"), 0);
563
564 if (Xen_vector_length(bt) > 0)
565 {
566 int i;
567 msg = mus_strcat(msg, "\n", &size);
568 for (i = 0; i < Xen_vector_length(bt); i++)
569 {
570 msg = mus_strcat(msg, Xen_string_to_C_string(Xen_vector_ref(bt, i)), &size);
571 msg = mus_strcat(msg, "\n", &size);
572 }
573 }
574
575 if (strcmp(idname, "Snd_error") != 0)
576 {
577 if (!(run_snd_error_hook(msg)))
578 {
579 if (ss->xen_error_handler)
580 {
581 /* make sure it doesn't call itself recursively */
582 void (*old_xen_error_handler)(const char *msg, void *data);
583 void *old_xen_error_data;
584 old_xen_error_handler = ss->xen_error_handler;
585 old_xen_error_data = ss->xen_error_data;
586 ss->xen_error_handler = NULL;
587 ss->xen_error_data = NULL;
588 (*(old_xen_error_handler))(msg, old_xen_error_data);
589 ss->xen_error_handler = old_xen_error_handler;
590 ss->xen_error_data = old_xen_error_data;
591 }
592 }
593 }
594
595 rb_raise(err, "%s", msg);
596 }
597 #endif
598 /* end HAVE_RUBY */
599
600
601
602 #if HAVE_EXTENSION_LANGUAGE
603
snd_catch_any(Xen_catch_t body,void * body_data,const char * caller)604 Xen snd_catch_any(Xen_catch_t body, void *body_data, const char *caller)
605 {
606 return((*body)(body_data));
607 }
608
609 #else
610
611 /* no extension language but user managed to try to evaluate something
612 * can this happen?
613 */
snd_catch_any(Xen_catch_t body,void * body_data,const char * caller)614 Xen snd_catch_any(Xen_catch_t body, void *body_data, const char *caller)
615 {
616 snd_error("This version of Snd has no extension language, so there's no way for %s to evaluate anything", caller);
617 return(Xen_false);
618 }
619 #endif
620
621
procedure_arity_ok(Xen proc,int args)622 bool procedure_arity_ok(Xen proc, int args)
623 {
624 #if HAVE_SCHEME
625 return(s7_is_aritable(s7, proc, args));
626 #else
627 Xen arity;
628 int rargs;
629 arity = Xen_arity(proc);
630 rargs = Xen_integer_to_C_int(arity);
631
632 #if HAVE_RUBY
633 return(xen_rb_arity_ok(rargs, args));
634 #endif
635
636 #if HAVE_FORTH
637 return(rargs == args);
638 #endif
639 #endif
640 return(true);
641 }
642
643
procedure_ok(Xen proc,int args,const char * caller,const char * arg_name,int argn)644 char *procedure_ok(Xen proc, int args, const char *caller, const char *arg_name, int argn)
645 {
646 /* if string returned, needs to be freed */
647
648 if (!(Xen_is_procedure(proc)))
649 {
650 if (!Xen_is_false(proc)) /* #f as explicit arg to clear */
651 return(mus_format(" %s is not a procedure!", (arg_name) ? arg_name : caller));
652 }
653 else
654 {
655 int rargs;
656 Xen arity;
657 arity = Xen_arity(proc);
658
659 #if HAVE_RUBY
660 rargs = Xen_integer_to_C_int(arity);
661 if (!xen_rb_arity_ok(rargs, args))
662 return(mus_format(" %s function should take %d args, not %d", (arg_name) ? arg_name : caller, args, (rargs < 0) ? (-rargs) : rargs));
663 #endif
664
665 #if HAVE_SCHEME
666 {
667 int oargs, loc;
668
669 loc = snd_protect(arity);
670 rargs = Xen_integer_to_C_int(Xen_car(arity));
671 oargs = Xen_integer_to_C_int(Xen_cdr(arity));
672 snd_unprotect_at(loc);
673
674 if (rargs > args)
675 return(mus_format(" %s function should take %d argument%s, but instead requires %d",
676 (arg_name) ? arg_name : caller, args, (args != 1) ? "s" : "", rargs));
677
678 if ((rargs + oargs) < args)
679 return(mus_format(" %s function should accept at least %d argument%s, but instead accepts only %d",
680 (arg_name) ? arg_name : caller, args, (args != 1) ? "s" : "", rargs + oargs));
681 }
682 #endif
683
684 #if HAVE_FORTH
685 rargs = Xen_integer_to_C_int(arity);
686 if (rargs != args)
687 return(mus_format(" %s function should take %d args, not %d", (arg_name) ? arg_name : caller, args, rargs));
688 #endif
689 }
690 return(NULL);
691 }
692
693
snd_no_such_file_error(const char * caller,Xen filename)694 Xen snd_no_such_file_error(const char *caller, Xen filename)
695 {
696 Xen_error(NO_SUCH_FILE,
697 Xen_list_4(C_string_to_Xen_string("no-such-file: ~A ~S: ~A"),
698 C_string_to_Xen_string(caller),
699 filename,
700 C_string_to_Xen_string(snd_open_strerror())));
701 return(Xen_false);
702 }
703
704
snd_no_such_channel_error(const char * caller,Xen snd,Xen chn)705 Xen snd_no_such_channel_error(const char *caller, Xen snd, Xen chn)
706 {
707 int index = NOT_A_SOUND;
708
709 if (Xen_is_integer(snd))
710 index = Xen_integer_to_C_int(snd);
711 else
712 {
713 if (xen_is_sound(snd))
714 index = Xen_sound_to_C_int(snd);
715 }
716
717 if ((index >= 0) &&
718 (index < ss->max_sounds) &&
719 (snd_ok(ss->sounds[index]))) /* good grief... */
720 {
721 snd_info *sp;
722 sp = ss->sounds[index];
723 Xen_error(NO_SUCH_CHANNEL,
724 Xen_list_6(C_string_to_Xen_string("no-such-channel: (~A: sound: ~A, chan: ~A) (~S, chans: ~A))"),
725 C_string_to_Xen_string(caller),
726 snd,
727 chn,
728 C_string_to_Xen_string(sp->short_filename),
729 C_int_to_Xen_integer(sp->nchans)));
730 }
731 Xen_error(NO_SUCH_CHANNEL,
732 Xen_list_4(C_string_to_Xen_string("no-such-channel: (~A: sound: ~A, chan: ~A)"),
733 C_string_to_Xen_string(caller),
734 snd,
735 chn));
736 return(Xen_false);
737 }
738
739
snd_no_active_selection_error(const char * caller)740 Xen snd_no_active_selection_error(const char *caller)
741 {
742 Xen_error(Xen_make_error_type("no-active-selection"),
743 Xen_list_2(C_string_to_Xen_string("~A: no active selection"),
744 C_string_to_Xen_string(caller)));
745 return(Xen_false);
746 }
747
748
snd_bad_arity_error(const char * caller,Xen errstr,Xen proc)749 Xen snd_bad_arity_error(const char *caller, Xen errstr, Xen proc)
750 {
751 Xen_error(Xen_make_error_type("bad-arity"),
752 Xen_list_3(C_string_to_Xen_string("~A,~A"),
753 C_string_to_Xen_string(caller),
754 errstr));
755 return(Xen_false);
756 }
757
758
759
760 /* -------- various evaluators (within our error handler) -------- */
761
eval_str_wrapper(void * data)762 Xen eval_str_wrapper(void *data)
763 {
764 return(Xen_eval_C_string((char *)data));
765 }
766
767
eval_file_wrapper(void * data)768 static Xen eval_file_wrapper(void *data)
769 {
770 last_file_loaded = (char *)data;
771 Xen_load((char *)data);
772 last_file_loaded = NULL;
773 return(Xen_true);
774 }
775
776
g_print_1(Xen obj)777 static char *g_print_1(Xen obj) /* free return val */
778 {
779 #if HAVE_SCHEME
780 return(Xen_object_to_C_string(obj));
781 #endif
782
783 #if HAVE_FORTH || HAVE_RUBY
784 return(mus_strdup(Xen_object_to_C_string(obj)));
785 #endif
786
787 #if (!HAVE_EXTENSION_LANGUAGE)
788 return(NULL);
789 #endif
790 }
791
792
gl_print(Xen result)793 static char *gl_print(Xen result)
794 {
795 char *newbuf, *str = NULL;
796 int i, ilen, savelen;
797
798 #if HAVE_SCHEME
799 /* expand \t first
800 * but... "#\\t" is the character t not a tab indication!
801 * (object->string #\t) or worse #\tab
802 */
803 #define TAB_SPACES 4
804 int tabs = 0, len, j = 0;
805
806 newbuf = g_print_1(result);
807 len = mus_strlen(newbuf);
808
809 for (i = 0; i < len - 1; i++)
810 if (((i == 0) || ((newbuf[i - 1] != '\\') && (newbuf[i - 1] != '#'))) &&
811 (newbuf[i] == '\\') &&
812 (newbuf[i + 1] == 't'))
813 tabs++;
814
815 if (tabs == 0)
816 return(newbuf);
817
818 ilen = len + tabs * TAB_SPACES;
819 str = (char *)calloc(ilen, sizeof(char));
820
821 for (i = 0; i < len - 1; i++)
822 {
823 if (((i == 0) || (newbuf[i - 1] != '\\')) &&
824 (newbuf[i] == '\\') &&
825 (newbuf[i + 1] == 't'))
826 {
827 int k;
828 for (k = 0; k < TAB_SPACES; k++)
829 str[j + k] = ' ';
830 j += TAB_SPACES;
831 i++;
832 }
833 else str[j++] = newbuf[i];
834 }
835 str[j] = newbuf[len - 1];
836
837 free(newbuf);
838 return(str);
839 #endif
840
841 /* specialize vectors which can be enormous in this context */
842 if ((!(Xen_is_vector(result))) ||
843 ((int)(Xen_vector_length(result)) <= print_length(ss)))
844 return(g_print_1(result));
845
846 ilen = print_length(ss);
847 newbuf = (char *)calloc(128, sizeof(char));
848 savelen = 128;
849
850 #if HAVE_FORTH
851 snprintf(newbuf, 128, "#(");
852 #endif
853
854 #if HAVE_RUBY
855 snprintf(newbuf, 128, "[");
856 #endif
857
858 for (i = 0; i < ilen; i++)
859 {
860 str = g_print_1(Xen_vector_ref(result, i));
861 if ((str) && (*str))
862 {
863 if (i != 0)
864 {
865 #if HAVE_RUBY
866 newbuf = mus_strcat(newbuf, ",", &savelen);
867 #endif
868 newbuf = mus_strcat(newbuf, " ", &savelen);
869 }
870 newbuf = mus_strcat(newbuf, str, &savelen);
871 free(str);
872 }
873 }
874
875 #if HAVE_FORTH
876 newbuf = mus_strcat(newbuf, " ...)", &savelen);
877 #endif
878
879 #if HAVE_RUBY
880 newbuf = mus_strcat(newbuf, " ...]", &savelen);
881 #endif
882
883 return(newbuf);
884 }
885
886
snd_display_result(const char * str,const char * endstr)887 void snd_display_result(const char *str, const char *endstr)
888 {
889 if (ss->snd_print_handler)
890 {
891 /* make sure it doesn't call itself recursively */
892 void (*old_snd_print_handler)(const char *msg, void *data);
893 void *old_snd_print_data;
894 old_snd_print_handler = ss->snd_print_handler;
895 old_snd_print_data = ss->snd_print_data;
896 ss->snd_print_handler = NULL;
897 ss->snd_print_data = NULL;
898 (*(old_snd_print_handler))(str, old_snd_print_data);
899 ss->snd_print_handler = old_snd_print_handler;
900 ss->snd_print_data = old_snd_print_data;
901 }
902 else
903 {
904 if (endstr) listener_append(endstr);
905 listener_append_and_prompt(str);
906 }
907 }
908
909
snd_report_result(Xen result,const char * buf)910 void snd_report_result(Xen result, const char *buf)
911 {
912 char *str;
913 str = gl_print(result);
914 snd_display_result(str, buf);
915 if (str) free(str);
916 }
917
918
snd_report_listener_result(Xen form)919 void snd_report_listener_result(Xen form)
920 {
921 snd_report_result(form, "\n");
922 }
923
924
925 static char *stdin_str = NULL;
926
clear_stdin(void)927 void clear_stdin(void)
928 {
929 if (stdin_str) free(stdin_str);
930 stdin_str = NULL;
931 }
932
933
934 #if HAVE_SCHEME
check_balance(const char * expr,int start,int end)935 static int check_balance(const char *expr, int start, int end)
936 {
937 int i;
938 bool not_whitespace = false;
939 int paren_count = 0;
940 bool prev_separator = true;
941 bool quote_wait = false;
942
943 i = start;
944 while (i < end)
945 {
946 switch (expr[i])
947 {
948 case ';' :
949 /* skip till newline. */
950 do {
951 i++;
952 } while ((i < end) && (expr[i] != '\n'));
953 break;
954
955 case ' ':
956 case '\n':
957 case '\t':
958 case '\r':
959 if ((not_whitespace) && (paren_count == 0) && (!quote_wait))
960 return(i);
961 else
962 {
963 prev_separator = true;
964 i++;
965 }
966 break;
967
968 case '\"' :
969 if ((not_whitespace) && (paren_count == 0) && (!quote_wait))
970 return(i);
971 else
972 {
973 /* skip past ", ignoring \", some cases:
974 * "\"\"" '("\"\"") "\\" "#\\(" "'(\"#\\\")"
975 */
976 while (i < end)
977 {
978 i++;
979 if (expr[i] == '\\')
980 i++;
981 else
982 {
983 if (expr[i] == '\"')
984 break;
985 }
986 }
987 i++;
988 if (paren_count == 0)
989 {
990 if (i < end)
991 return(i);
992 else return(0);
993 }
994 else
995 {
996 prev_separator = true;
997 not_whitespace = true;
998 quote_wait = false;
999 }
1000 }
1001 break;
1002
1003 case '#':
1004 if ((i < end - 1) &&
1005 (expr[i + 1] == '|'))
1006 {
1007 /* (+ #| a comment |# 2 1) */
1008 i++;
1009 do {
1010 i++;
1011 } while (((expr[i] != '|') || (expr[i + 1] != '#')) && (i < end));
1012 i++;
1013 break;
1014 }
1015 else
1016 {
1017 /* (set! *#readers* (cons (cons #\c (lambda (str) (apply make-rectangular (read)))) *#readers*))
1018 */
1019 if ((not_whitespace) && (paren_count == 0) && (!quote_wait))
1020 return(i);
1021 else
1022 {
1023 bool found_it = false;
1024 if (prev_separator)
1025 {
1026 int k, incr = 0;
1027 for (k = i + 1; k < end; k++)
1028 {
1029 if (expr[k] == '(')
1030 {
1031 /* should we look at the readers here? I want to support #c(1 2) for example */
1032 not_whitespace = false;
1033 prev_separator = false;
1034 incr = k - i;
1035 break;
1036 }
1037 else
1038 {
1039 if ((!isdigit((int)expr[k])) && /* #2d(...)? */
1040 (!isalpha((int)expr[k])) && /* #c(1 2)? */
1041 (expr[k] != 'D') &&
1042 (expr[k] != 'd') &&
1043 (expr[k] != '=') && /* what is this for? */
1044 (expr[k] != '#')) /* perhaps #1d(#(1 2) 3) ? */
1045 break;
1046 }
1047 }
1048 if (incr > 0)
1049 {
1050 i += incr;
1051 found_it = true;
1052 }
1053 }
1054 if (!found_it)
1055 {
1056 if ((i + 2 < end) && (expr[i + 1] == '\\') &&
1057 ((expr[i + 2] == ')') || (expr[i + 2] == ';') || (expr[i + 2] == '\"') || (expr[i + 2] == '(')))
1058 i += 3;
1059 else
1060 {
1061 prev_separator = false;
1062 quote_wait = false;
1063 not_whitespace = true;
1064 i++;
1065 }
1066 }
1067 }
1068 }
1069 break;
1070
1071 case '(' :
1072 if ((not_whitespace) && (paren_count == 0) && (!quote_wait))
1073 return(i - 1); /* 'a(...) -- ignore the (...) */
1074 else
1075 {
1076 i++;
1077 paren_count++;
1078 not_whitespace = true;
1079 prev_separator = true;
1080 quote_wait = false;
1081 }
1082 break;
1083
1084 case ')' :
1085 paren_count--;
1086 if ((not_whitespace) && (paren_count == 0))
1087 return(i + 1);
1088 else
1089 {
1090 i++;
1091 not_whitespace = true;
1092 prev_separator = true;
1093 quote_wait = false;
1094 }
1095 break;
1096
1097 case '\'' :
1098 case '`' : /* `(1 2) */
1099 if (prev_separator)
1100 quote_wait = true;
1101 not_whitespace = true;
1102 i++;
1103 break;
1104
1105 case ',': /* `,(+ 1 2) */
1106 case '@': /* `,@(list 1 2) */
1107 prev_separator = false;
1108 not_whitespace = true;
1109 i++;
1110 break;
1111
1112 default:
1113 prev_separator = false;
1114 quote_wait = false;
1115 not_whitespace = true;
1116 i++;
1117 break;
1118 }
1119 }
1120
1121 return(0);
1122 }
1123 #endif
1124
1125
stdin_check_for_full_expression(const char * newstr)1126 char *stdin_check_for_full_expression(const char *newstr)
1127 {
1128 #if HAVE_SCHEME
1129 int end_of_text;
1130 #endif
1131 if (stdin_str)
1132 {
1133 char *str;
1134 str = stdin_str;
1135 stdin_str = (char *)calloc(mus_strlen(str) + mus_strlen(newstr) + 2, sizeof(char));
1136 strcat(stdin_str, str);
1137 strcat(stdin_str, newstr);
1138 free(str);
1139 }
1140 else stdin_str = mus_strdup(newstr);
1141 #if HAVE_SCHEME
1142 end_of_text = check_balance(stdin_str, 0, mus_strlen(stdin_str));
1143 if (end_of_text > 0)
1144 {
1145 if (end_of_text + 1 < mus_strlen(stdin_str))
1146 stdin_str[end_of_text + 1] = 0;
1147 return(stdin_str);
1148 }
1149 return(NULL);
1150 #endif
1151 return(stdin_str);
1152 }
1153
stdin_free_str(void)1154 void stdin_free_str(void)
1155 {
1156 if (stdin_str) free(stdin_str);
1157 stdin_str = NULL;
1158 }
1159
1160
string_to_stdout(const char * msg,void * ignored)1161 static void string_to_stdout(const char *msg, void *ignored)
1162 {
1163 if (msg)
1164 fprintf(stdout, "%s\n", msg);
1165 }
1166
1167
snd_eval_stdin_str(const char * buf)1168 void snd_eval_stdin_str(const char *buf)
1169 {
1170 /* we may get incomplete expressions here */
1171 /* (Ilisp always sends a complete expression, but it may be broken into two or more pieces from read's point of view) */
1172
1173 char *str = NULL;
1174 if (mus_strlen(buf) == 0) return;
1175
1176 str = stdin_check_for_full_expression(buf);
1177 if (str)
1178 {
1179 Xen result;
1180 int loc;
1181
1182 redirect_everything_to(string_to_stdout, NULL);
1183 result = snd_catch_any(eval_str_wrapper, (void *)str, str);
1184 redirect_everything_to(NULL, NULL);
1185
1186 loc = snd_protect(result);
1187 stdin_free_str();
1188
1189 str = gl_print(result);
1190 string_to_stdout(str, NULL);
1191
1192 if (mus_strlen(stdin_prompt(ss)) > 0)
1193 {
1194 fprintf(stdout, "%s", stdin_prompt(ss));
1195 fflush(stdout);
1196 }
1197
1198 if (str) free(str);
1199 snd_unprotect_at(loc);
1200 }
1201 }
1202
1203
string_to_stderr_and_listener(const char * msg,void * ignore)1204 static void string_to_stderr_and_listener(const char *msg, void *ignore)
1205 {
1206 fprintf(stderr, "%s\n", msg);
1207 if (listener_exists()) /* the idea here is to save startup errors until we can post them */
1208 {
1209 listener_append((char *)msg);
1210 listener_append("\n");
1211 }
1212 else
1213 {
1214 if (ss->startup_errors)
1215 {
1216 char *temp;
1217 temp = ss->startup_errors;
1218 ss->startup_errors = mus_format("%s\n%s %s\n", ss->startup_errors, listener_prompt(ss), msg);
1219 free(temp);
1220 }
1221 else ss->startup_errors = mus_strdup(msg); /* initial prompt is already there */
1222 }
1223 }
1224
1225
snd_load_init_file_1(const char * filename)1226 static bool snd_load_init_file_1(const char *filename)
1227 {
1228 char *fullname;
1229 bool happy = false;
1230 fullname = mus_expand_filename(filename);
1231 if (mus_file_probe(fullname))
1232 {
1233 char *expr;
1234 happy = true;
1235 #if HAVE_SCHEME
1236 expr = mus_format("(load %s)", fullname);
1237 #endif
1238
1239 #if HAVE_RUBY || HAVE_FORTH
1240 expr = mus_format("load(%s)", fullname);
1241 #endif
1242 snd_catch_any(eval_file_wrapper, (void *)fullname, expr);
1243 free(expr);
1244 }
1245
1246 if (fullname) free(fullname);
1247 return(happy);
1248 }
1249
1250
snd_load_init_file(bool no_global,bool no_init)1251 void snd_load_init_file(bool no_global, bool no_init)
1252 {
1253 /* look for ".snd" on the home directory; return true if an error occurred (to try to get that info to the user's attention) */
1254 /* called only in snd-g|xmain.c at initialization time */
1255
1256 /* changed Oct-05 because the Scheme/Ruby/Forth choices are becoming a hassle --
1257 * now save-options has its own file ~/.snd_prefs_ruby|forth|s7 which is loaded first, if present
1258 * then ~/.snd_ruby|forth|s7, if present
1259 * then ~/.snd for backwards compatibility
1260 * snd_options does not write ~/.snd anymore, but overwrites the .snd_prefs_* file
1261 * use set init files only change the ~/.snd choice
1262 *
1263 * there are parallel choices for the global configuration file: /etc/snd_ruby|forth|s7.conf
1264 */
1265
1266 #if HAVE_EXTENSION_LANGUAGE
1267 #if HAVE_RUBY
1268 #define SND_EXT_CONF "/etc/snd_ruby.conf"
1269 #define SND_PREFS "~/.snd_prefs_ruby"
1270 #define SND_INIT "~/.snd_ruby"
1271 #endif
1272
1273 #if HAVE_FORTH
1274 #define SND_EXT_CONF "/etc/snd_forth.conf"
1275 #define SND_PREFS "~/.snd_prefs_forth"
1276 #define SND_INIT "~/.snd_forth"
1277 #endif
1278
1279 #if HAVE_SCHEME
1280 #define SND_EXT_CONF "/etc/snd_s7.conf"
1281 #define SND_PREFS "~/.snd_prefs_s7"
1282 #define SND_INIT "~/.snd_s7"
1283 #endif
1284
1285 #define SND_INIT_FILE_ENVIRONMENT_NAME "SND_INIT_FILE"
1286 #if (defined(_MSC_VER) || __CYGWIN__)
1287 #define INIT_FILE_NAME "snd-init"
1288 #else
1289 #define INIT_FILE_NAME "~/.snd"
1290 #endif
1291
1292 #define SND_CONF "/etc/snd.conf"
1293 redirect_snd_print_to(string_to_stdout, NULL);
1294 redirect_errors_to(string_to_stderr_and_listener, NULL);
1295
1296 /* check for global configuration files (/etc/snd*) */
1297 if (!no_global)
1298 {
1299 snd_load_init_file_1(SND_EXT_CONF);
1300 snd_load_init_file_1(SND_CONF);
1301 }
1302
1303 /* now load local init file(s) */
1304 if (!no_init)
1305 {
1306 char *temp;
1307 snd_load_init_file_1(SND_PREFS); /* check for possible prefs dialog output */
1308 snd_load_init_file_1(SND_INIT);
1309 temp = getenv(SND_INIT_FILE_ENVIRONMENT_NAME);
1310 if (temp)
1311 snd_load_init_file_1(temp);
1312 else snd_load_init_file_1(INIT_FILE_NAME);
1313 }
1314
1315 redirect_everything_to(NULL, NULL);
1316 #endif
1317 }
1318
1319
1320 static char *find_source_file(const char *orig);
1321
snd_load_file(const char * filename)1322 void snd_load_file(const char *filename)
1323 {
1324 char *str, *str2 = NULL;
1325
1326 str = mus_expand_filename(filename);
1327 if (!(mus_file_probe(str)))
1328 {
1329 char *temp;
1330 temp = find_source_file(str);
1331 free(str);
1332 str = temp;
1333 }
1334 if (!str)
1335 {
1336 snd_error("can't load %s: %s", filename, snd_open_strerror());
1337 return;
1338 }
1339
1340 str2 = mus_format("(load \"%s\")", filename); /* currently unused in Forth and Ruby */
1341 snd_catch_any(eval_file_wrapper, (void *)str, str2);
1342 if (str) free(str);
1343 if (str2) free(str2);
1344 }
1345
1346
g_snd_print(Xen msg)1347 static Xen g_snd_print(Xen msg)
1348 {
1349 #define H_snd_print "(" S_snd_print " str): display str in the listener window"
1350 char *str = NULL;
1351
1352 if (Xen_is_string(msg))
1353 str = mus_strdup(Xen_string_to_C_string(msg));
1354 else
1355 {
1356 if (Xen_is_char(msg))
1357 {
1358 str = (char *)calloc(2, sizeof(char));
1359 str[0] = Xen_char_to_C_char(msg);
1360 }
1361 else str = gl_print(msg);
1362 }
1363
1364 if (str)
1365 {
1366 listener_append(str);
1367 free(str);
1368 }
1369 /* used to check for event in Motif case, but that is very dangerous -- check for infinite loop C-c needs to be somewhere else */
1370 return(msg);
1371 }
1372
1373
check_features_list(const char * features)1374 void check_features_list(const char *features)
1375 {
1376 /* check for list of features, report any missing, exit (for compsnd) */
1377 /* this can't be in snd.c because we haven't fully initialized the extension language and so on at that point */
1378 if (!features) return;
1379
1380 #if HAVE_SCHEME
1381 Xen_eval_C_string(mus_format("(for-each \
1382 (lambda (f) \
1383 (if (not (provided? f)) \
1384 (display (format #f \"~%%no ~A!~%%~%%\" f)))) \
1385 (list %s))", features));
1386 #endif
1387
1388 #if HAVE_RUBY
1389 /* provided? is defined in clm.rb */
1390 Xen_eval_C_string(mus_format("[%s].each do |f|\n\
1391 unless $LOADED_FEATURES.map do |ff| File.basename(ff) end.member?(f.to_s.tr(\"_\", \"-\"))\n\
1392 $stderr.printf(\"\\nno %%s!\\n\\n\", f.id2name)\n\
1393 end\n\
1394 end\n", features));
1395 #endif
1396
1397 #if HAVE_FORTH
1398 Xen_eval_C_string(mus_format("let: \
1399 '( %s ) each { f }\
1400 f provided? unless \
1401 \"\\nno %%s!\\n\\n\" '( f ) fth-print \
1402 then \
1403 end-each \
1404 ;let",
1405 features));
1406 #endif
1407 snd_exit(0);
1408 }
1409
1410
string_to_mus_float_t(const char * str,mus_float_t lo,const char * field_name)1411 mus_float_t string_to_mus_float_t(const char *str, mus_float_t lo, const char *field_name)
1412 {
1413 #if HAVE_EXTENSION_LANGUAGE
1414 Xen res;
1415 res = snd_catch_any(eval_str_wrapper, (void *)str, "string->float");
1416 if (Xen_is_number(res))
1417 {
1418 mus_float_t f;
1419 f = Xen_real_to_C_double(res);
1420 if (f < lo)
1421 snd_error("%s: %.3f is invalid", field_name, f);
1422 else return(f);
1423 }
1424 else snd_error("%s is not a number", str);
1425 return(0.0);
1426 #else
1427 float res = 0.0;
1428 if (str)
1429 {
1430 if (!(sscanf(str, "%f", &res)))
1431 snd_error("%s is not a number", str);
1432 else
1433 {
1434 if (res < lo)
1435 snd_error("%s: %.3f is invalid", field_name, res);
1436 }
1437 }
1438 return((mus_float_t)res);
1439 #endif
1440 }
1441
1442
string_to_int(const char * str,int lo,const char * field_name)1443 int string_to_int(const char *str, int lo, const char *field_name)
1444 {
1445 #if HAVE_EXTENSION_LANGUAGE
1446 Xen res;
1447 res = snd_catch_any(eval_str_wrapper, (void *)str, "string->int");
1448 if (Xen_is_number(res))
1449 {
1450 int val;
1451 val = Xen_integer_to_C_int(res);
1452 if (val < lo)
1453 snd_error("%s: %d is invalid", field_name, val);
1454 else return(val);
1455 }
1456 else snd_error("%s: %s is not a number", field_name, str);
1457 return(0);
1458 #else
1459 int res = 0;
1460 if (str)
1461 {
1462 if (!(sscanf(str, "%12d", &res)))
1463 snd_error("%s: %s is not a number", field_name, str);
1464 else
1465 {
1466 if (res < lo)
1467 snd_error("%s: %d is invalid", field_name, res);
1468 }
1469 }
1470 return(res);
1471 #endif
1472 }
1473
1474
string_to_mus_long_t(const char * str,mus_long_t lo,const char * field_name)1475 mus_long_t string_to_mus_long_t(const char *str, mus_long_t lo, const char *field_name)
1476 {
1477 #if HAVE_EXTENSION_LANGUAGE
1478 Xen res;
1479
1480 res = snd_catch_any(eval_str_wrapper, (void *)str, "string->mus_long_t");
1481 if (Xen_is_number(res))
1482 {
1483 mus_long_t val;
1484 val = Xen_llong_to_C_llong(res);
1485 if (val < lo)
1486 snd_error("%s: %" print_mus_long " is invalid", field_name, val);
1487 else return(val);
1488 }
1489 else snd_error("%s: %s is not a number", field_name, str);
1490 return(0);
1491 #else
1492 mus_long_t res = 0;
1493 if (str)
1494 {
1495 if (!(sscanf(str, "%" print_mus_long, &res)))
1496 snd_error("%s: %s is not a number", field_name, str);
1497 else
1498 {
1499 if (res < lo)
1500 snd_error("%s: %" print_mus_long " is invalid", field_name, res);
1501 }
1502 }
1503 return(res);
1504 #endif
1505 }
1506
1507
run_progn_hook(Xen hook,Xen args,const char * caller)1508 Xen run_progn_hook(Xen hook, Xen args, const char *caller)
1509 {
1510 #if HAVE_SCHEME
1511 return(s7_call(s7, hook, args));
1512 #else
1513 Xen result = Xen_false;
1514 Xen procs = Xen_hook_list(hook);
1515
1516 while (!Xen_is_null(procs))
1517 {
1518 result = Xen_apply(Xen_car(procs), args, caller);
1519 procs = Xen_cdr(procs);
1520 }
1521
1522 return(result);
1523 #endif
1524 }
1525
1526
run_hook(Xen hook,Xen args,const char * caller)1527 Xen run_hook(Xen hook, Xen args, const char *caller)
1528 {
1529 #if HAVE_SCHEME
1530 return(s7_call(s7, hook, args));
1531 #else
1532 Xen procs = Xen_hook_list(hook);
1533
1534 while (!Xen_is_null(procs))
1535 {
1536 if (!(Xen_is_eq(args, Xen_empty_list)))
1537 Xen_apply(Xen_car(procs), args, caller);
1538 else Xen_call_with_no_args(Xen_car(procs), caller);
1539 procs = Xen_cdr(procs);
1540 }
1541
1542 return(Xen_false);
1543 #endif
1544 }
1545
1546
run_or_hook(Xen hook,Xen args,const char * caller)1547 Xen run_or_hook(Xen hook, Xen args, const char *caller)
1548 {
1549 #if HAVE_SCHEME
1550 return(s7_call(s7, hook, args));
1551 #else
1552 Xen result = Xen_false; /* (or): #f */
1553 Xen hook_result = Xen_false;
1554 Xen procs = Xen_hook_list(hook);
1555
1556 while (!Xen_is_null(procs))
1557 {
1558 if (!(Xen_is_eq(args, Xen_empty_list)))
1559 result = Xen_apply(Xen_car(procs), args, caller);
1560 else result = Xen_call_with_no_args(Xen_car(procs), caller);
1561 if (!Xen_is_false(result))
1562 hook_result = result;
1563 procs = Xen_cdr(procs);
1564 }
1565
1566 return(hook_result);
1567 #endif
1568 }
1569
1570
1571
1572 #if HAVE_SCHEME && (!_MSC_VER)
1573 #include <dlfcn.h>
1574 /* these are included because libtool's dlopen is incredibly stupid */
1575
1576 /* apparently netBSD does not have dlerror?
1577 #ifdef __NetBSD__
1578 #define dlerror() g_strerror(errno)
1579 #endif
1580
1581 to get symbols from current program: handle = dlopen(NULL, RTLD_GLOBAL | RTLD_LAZY);
1582 */
1583
g_dlopen(Xen name,Xen flags)1584 static Xen g_dlopen(Xen name, Xen flags)
1585 {
1586 #define H_dlopen "(dlopen lib (flags RTLD_LAZY)) loads the dynamic library 'lib' and returns a handle for it (for dlinit and dlclose)"
1587 const char *cname;
1588 Xen_check_type(Xen_is_string(name), name, 1, "dlopen", "a string (filename)");
1589 cname = Xen_string_to_C_string(name);
1590 if (cname)
1591 {
1592 void *handle;
1593 handle = dlopen(cname, RTLD_LAZY);
1594 if (!handle)
1595 {
1596 char *longname;
1597
1598 longname = mus_expand_filename(cname);
1599 if (Xen_is_integer(flags))
1600 handle = dlopen(longname, Xen_integer_to_C_int(flags));
1601 else handle = dlopen(longname, RTLD_LAZY);
1602 free(longname);
1603
1604 if (!handle)
1605 {
1606 char *err;
1607 err = (char *)dlerror();
1608 if ((err) && (*err))
1609 return(C_string_to_Xen_string(err));
1610 return(Xen_false);
1611 }
1612 }
1613 return(Xen_wrap_C_pointer(handle));
1614 }
1615 return(Xen_false);
1616 }
1617
1618
g_dlclose(Xen handle)1619 static Xen g_dlclose(Xen handle)
1620 {
1621 #define H_dlclose "(dlclose handle) may close the library referred to by 'handle'."
1622 Xen_check_type(Xen_is_wrapped_c_pointer(handle), handle, 1, "dlclose", "a library handle");
1623 return(C_int_to_Xen_integer(dlclose((void *)(Xen_unwrap_C_pointer(handle)))));
1624 }
1625
1626
g_dlerror(void)1627 static Xen g_dlerror(void)
1628 {
1629 #define H_dlerror "(dlerror) returns a string describing the last dlopen/dlinit/dlclose error"
1630 return(C_string_to_Xen_string(dlerror()));
1631 }
1632
1633
g_dlsym(Xen handle,Xen func)1634 static Xen g_dlsym(Xen handle, Xen func)
1635 {
1636 #define H_dlsym "(dlsym library function-name) returns a pointer to function in library, or #f."
1637 void *proc;
1638
1639 Xen_check_type(Xen_is_wrapped_c_pointer(handle), handle, 1, "dlsym", "a library handle");
1640 Xen_check_type(Xen_is_string(func), func, 2, "dlsym", "a string (function name)");
1641
1642 proc = dlsym((void *)(Xen_unwrap_C_pointer(handle)), Xen_string_to_C_string(func));
1643 if (!proc) return(Xen_false);
1644 return(Xen_wrap_C_pointer(func));
1645 }
1646
1647
g_dlinit(Xen handle,Xen func)1648 static Xen g_dlinit(Xen handle, Xen func)
1649 {
1650 #define H_dlinit "(dlinit handle func) calls 'func' from the library referred to by 'handle'."
1651 typedef void *(*snd_dl_func)(void);
1652 void *proc;
1653
1654 Xen_check_type(Xen_is_wrapped_c_pointer(handle), handle, 1, "dlinit", "a library handle");
1655 Xen_check_type(Xen_is_string(func), func, 2, "dlinit", "a string (init func name)");
1656
1657 proc = dlsym((void *)(Xen_unwrap_C_pointer(handle)), Xen_string_to_C_string(func));
1658 if (!proc) return(C_string_to_Xen_string(dlerror()));
1659 ((snd_dl_func)proc)();
1660 return(Xen_true);
1661 }
1662 #endif
1663
g_little_endian(void)1664 static Xen g_little_endian(void)
1665 {
1666 #if MUS_LITTLE_ENDIAN
1667 return(Xen_true);
1668 #else
1669 return(Xen_false);
1670 #endif
1671 }
1672
1673
g_snd_global_state(void)1674 static Xen g_snd_global_state(void)
1675 {
1676 return(Xen_wrap_C_pointer(ss));
1677 }
1678
1679
1680 #if (!HAVE_SCHEME)
1681 /* fmod is the same as modulo in s7:
1682 (do ((i 0 (+ i 1)))
1683 ((= i 100))
1684 (let ((val1 (- (random 1.0) 2.0))
1685 (val2 (- (random 1.0) 2.0)))
1686 (let ((f (fmod val1 val2))
1687 (m (modulo val1 val2)))
1688 (if (> (abs (- f m)) 1e-9)
1689 (format *stderr* "~A ~A -> ~A ~A~%" val1 val2 f m)))))
1690 */
1691
g_fmod(Xen a,Xen b)1692 static Xen g_fmod(Xen a, Xen b)
1693 {
1694 double val, x, y;
1695 Xen_check_type(Xen_is_number(a), a, 1, "fmod", " a number");
1696 Xen_check_type(Xen_is_number(b), b, 2, "fmod", " a number");
1697 x = Xen_real_to_C_double(a);
1698 y = Xen_real_to_C_double(b);
1699 val = fmod(x, y);
1700 if (((y > 0.0) && (val < 0.0)) ||
1701 ((y < 0.0) && (val > 0.0)))
1702 return(C_double_to_Xen_real(val + y));
1703 return(C_double_to_Xen_real(val));
1704 }
1705 #endif
1706
1707
1708 #if HAVE_SPECIAL_FUNCTIONS || HAVE_GSL
1709 #define S_bes_j0 "bes-j0"
1710 #define S_bes_j1 "bes-j1"
1711 #define S_bes_jn "bes-jn"
1712 #define S_bes_y0 "bes-y0"
1713 #define S_bes_y1 "bes-y1"
1714 #define S_bes_yn "bes-yn"
1715 #endif
1716
1717
1718 #if HAVE_SCHEME && WITH_GMP && HAVE_SPECIAL_FUNCTIONS
1719
1720 #include <gmp.h>
1721 #include <mpfr.h>
1722 #include <mpc.h>
1723
big_math_1(Xen x,int (* mpfr_math)(mpfr_ptr,mpfr_srcptr,mpfr_rnd_t))1724 static Xen big_math_1(Xen x,
1725 int (*mpfr_math)(mpfr_ptr, mpfr_srcptr, mpfr_rnd_t))
1726 {
1727 s7_pointer val;
1728 mpfr_t y;
1729 mpfr_init_set(y, *s7_big_real(x), GMP_RNDN);
1730 mpfr_math(y, y, GMP_RNDN);
1731 val = s7_make_big_real(s7, &y);
1732 mpfr_clear(y);
1733 return(val);
1734 }
1735
1736
big_j0(Xen x)1737 static Xen big_j0(Xen x) {return(big_math_1(x, mpfr_j0));}
big_j1(Xen x)1738 static Xen big_j1(Xen x) {return(big_math_1(x, mpfr_j1));}
big_y0(Xen x)1739 static Xen big_y0(Xen x) {return(big_math_1(x, mpfr_y0));}
big_y1(Xen x)1740 static Xen big_y1(Xen x) {return(big_math_1(x, mpfr_y1));}
1741
big_erf(Xen x)1742 static Xen big_erf(Xen x) {return(big_math_1(x, mpfr_erf));}
big_erfc(Xen x)1743 static Xen big_erfc(Xen x) {return(big_math_1(x, mpfr_erfc));}
1744
1745
big_math_2(Xen n,Xen x,int (* mpfr_math)(mpfr_ptr,long,mpfr_srcptr,mpfr_rnd_t))1746 static Xen big_math_2(Xen n, Xen x,
1747 int (*mpfr_math)(mpfr_ptr, long, mpfr_srcptr, mpfr_rnd_t))
1748 {
1749 s7_pointer val;
1750 mpfr_t y;
1751 mpfr_init_set(y, *s7_big_real(x), GMP_RNDN);
1752 mpfr_math(y, Xen_integer_to_C_int(n), y, GMP_RNDN);
1753 val = s7_make_big_real(s7, &y);
1754 mpfr_clear(y);
1755 return(val);
1756 }
1757
1758
big_jn(Xen n,Xen x)1759 static Xen big_jn(Xen n, Xen x) {return(big_math_2(n, x, mpfr_jn));}
big_yn(Xen n,Xen x)1760 static Xen big_yn(Xen n, Xen x) {return(big_math_2(n, x, mpfr_yn));}
1761
1762
1763 /* bes-i0 from G&R 8.447, 8.451, A&S 9.6.12, 9.7.1, arprec bessel.cpp */
1764
big_i0(Xen ux)1765 static Xen big_i0(Xen ux)
1766 {
1767 int k;
1768 mpfr_t sum, x, x1, x2, eps;
1769 mpfr_init_set_ui(sum, 0, GMP_RNDN);
1770 mpfr_init_set(x, *s7_big_real(ux), GMP_RNDN);
1771 mpfr_init_set_ui(sum, 1, GMP_RNDN);
1772 mpfr_init_set_ui(x1, 1, GMP_RNDN);
1773 mpfr_init_set_ui(eps, 2, GMP_RNDN);
1774 mpfr_pow_si(eps, eps, -mpfr_get_default_prec(), GMP_RNDN);
1775 mpfr_init_set_ui(x2, mpfr_get_default_prec(), GMP_RNDN);
1776 mpfr_div_ui(x2, x2, 2, GMP_RNDN);
1777 if (mpfr_cmpabs(x, x2) < 0)
1778 {
1779 mpfr_mul(x, x, x, GMP_RNDN); /* x = ux^2 */
1780 for (k = 1; k < 10000; k++)
1781 {
1782 mpfr_set_ui(x2, k, GMP_RNDN); /* x2 = k */
1783 mpfr_mul(x2, x2, x2, GMP_RNDN); /* x2 = k^2 */
1784 mpfr_div(x1, x1, x2, GMP_RNDN); /* x1 = x1/x2 */
1785 mpfr_mul(x1, x1, x, GMP_RNDN); /* x1 = x1*x */
1786 mpfr_div_ui(x1, x1, 4, GMP_RNDN); /* x1 = x1/4 */
1787 if (mpfr_cmp(x1, eps) < 0)
1788 break;
1789 mpfr_add(sum, sum, x1, GMP_RNDN); /* sum += x1 */
1790 }
1791 /* takes usually ca 10 to 40 iterations */
1792 }
1793 else
1794 {
1795 mpfr_t den, num;
1796 mpfr_init(den);
1797 mpfr_init(num);
1798 mpfr_abs(x, x, GMP_RNDN);
1799 for (k = 1; k < 10000; k++)
1800 {
1801 mpfr_set(x2, x1, GMP_RNDN);
1802 mpfr_set_ui(den, k, GMP_RNDN);
1803 mpfr_mul_ui(den, den, 8, GMP_RNDN);
1804 mpfr_mul(den, den, x, GMP_RNDN);
1805 mpfr_set_ui(num, k, GMP_RNDN);
1806 mpfr_mul_ui(num, num, 2, GMP_RNDN);
1807 mpfr_sub_ui(num, num, 1, GMP_RNDN);
1808 mpfr_mul(num, num, num, GMP_RNDN);
1809 mpfr_div(num, num, den, GMP_RNDN);
1810 mpfr_mul(x1, x1, num, GMP_RNDN);
1811 mpfr_add(sum, sum, x1, GMP_RNDN);
1812 if (mpfr_cmp(x1, eps) < 0)
1813 {
1814 mpfr_const_pi(x2, GMP_RNDN);
1815 mpfr_mul_ui(x2, x2, 2, GMP_RNDN);
1816 mpfr_mul(x2, x2, x, GMP_RNDN);
1817 mpfr_sqrt(x2, x2, GMP_RNDN); /* sqrt(2*pi*x) */
1818 mpfr_div(sum, sum, x2, GMP_RNDN);
1819 mpfr_exp(x1, x, GMP_RNDN);
1820 mpfr_mul(sum, sum, x1, GMP_RNDN); /* sum * e^x / sqrt(2*pi*x) */
1821 break;
1822 }
1823 if (mpfr_cmp(x1, x2) > 0)
1824 {
1825 fprintf(stderr, "bes-i0 has screwed up");
1826 break;
1827 }
1828 }
1829 mpfr_clear(den);
1830 mpfr_clear(num);
1831 }
1832 mpfr_clear(x1);
1833 mpfr_clear(x2);
1834 mpfr_clear(x);
1835 mpfr_clear(eps);
1836 return(s7_make_big_real(s7, &sum));
1837 }
1838
1839
1840 /* fft
1841 * (define hi (make-vector 8))
1842 * (define ho (make-vector 8))
1843 * (do ((i 0 (+ i 1))) ((= i 8)) (vector-set! hi i (bignum "0.0")) (vector-set! ho i (bignum "0.0")))
1844 * (vector-set! ho 1 (bignum "-1.0"))
1845 * (vector-set! ho 1 (bignum "-1.0"))
1846 * (bignum-fft hi ho 8)
1847 *
1848 * this is tricky -- perhaps a bad idea. vector elements are changed in place which means
1849 * they better be unique! and there are no checks that each element actually is a bignum
1850 * which means we'll segfault if a normal real leaks through.
1851 *
1852 * bignum_fft is say 200 times slower than the same size fftw call, and takes more space than
1853 * I can account for: 2^20 29 secs ~.5 Gb, 2^24 11 mins ~5Gb. I think there should be
1854 * the vector element (8), the mpfr_t space (16 or 32), the s7_cell (28 or 32), and the value pointer (8),
1855 * and the heap pointer loc (8) so 2^24 should be (* 2 (expt 2 24) (+ 8 8 8 8 32 32)) = 3 Gb, not 5. 2^25 25 min 10.6?
1856 * I think the extra is in the free space in the heap -- it can be adding 1/4 of the total.
1857 */
1858
bignum_fft(s7_scheme * sc,s7_pointer args)1859 static s7_pointer bignum_fft(s7_scheme *sc, s7_pointer args)
1860 {
1861 #define H_bignum_fft "(bignum-fft rl im n (sign 1)) performs a multiprecision fft on the vectors of bigfloats rl and im"
1862
1863 int n, sign = 1;
1864 s7_pointer *rl, *im;
1865
1866 int m, j, mh, ldm, lg, i, i2, j2, imh;
1867 mpfr_t ur, ui, u, vr, vi, angle, c, s, temp;
1868
1869 #define big_rl(n) (*(s7_big_real(rl[n])))
1870 #define big_im(n) (*(s7_big_real(im[n])))
1871
1872 n = s7_integer(s7_list_ref(sc, args, 2));
1873 if (s7_list_length(sc, args) > 3)
1874 sign = s7_integer(s7_list_ref(sc, args, 3));
1875
1876 rl = s7_vector_elements(s7_list_ref(sc, args, 0));
1877 im = s7_vector_elements(s7_list_ref(sc, args, 1));
1878
1879 /* scramble(rl, im, n); */
1880 {
1881 int i, m, j;
1882 s7_pointer vr, vi;
1883 j = 0;
1884 for (i = 0; i < n; i++)
1885 {
1886 if (j > i)
1887 {
1888 vr = rl[j];
1889 vi = im[j];
1890 rl[j] = rl[i];
1891 im[j] = im[i];
1892 rl[i] = vr;
1893 im[i] = vi;
1894 }
1895 m = n >> 1;
1896 while ((m >= 2) && (j >= m))
1897 {
1898 j -= m;
1899 m = m >> 1;
1900 }
1901 j += m;
1902 }
1903 }
1904
1905 imh = (int)(log(n + 1) / log(2.0));
1906 m = 2;
1907 ldm = 1;
1908 mh = n >> 1;
1909
1910 mpfr_init(angle); /* angle = (M_PI * sign) */
1911 mpfr_const_pi(angle, GMP_RNDN);
1912 if (sign == -1)
1913 mpfr_neg(angle, angle, GMP_RNDN);
1914
1915 mpfr_init(c);
1916 mpfr_init(s);
1917 mpfr_init(ur);
1918 mpfr_init(ui);
1919 mpfr_init(u);
1920 mpfr_init(vr);
1921 mpfr_init(vi);
1922 mpfr_init(temp);
1923
1924 for (lg = 0; lg < imh; lg++)
1925 {
1926 mpfr_cos(c, angle, GMP_RNDN); /* c = cos(angle) */
1927 mpfr_sin(s, angle, GMP_RNDN); /* s = sin(angle) */
1928 mpfr_set_ui(ur, 1, GMP_RNDN); /* ur = 1.0 */
1929 mpfr_set_ui(ui, 0, GMP_RNDN); /* ui = 0.0 */
1930 for (i2 = 0; i2 < ldm; i2++)
1931 {
1932 i = i2;
1933 j = i2 + ldm;
1934 for (j2 = 0; j2 < mh; j2++)
1935 {
1936 mpfr_set(temp, big_im(j), GMP_RNDN); /* vr = ur * rl[j] - ui * im[j] */
1937 mpfr_mul(temp, temp, ui, GMP_RNDN);
1938 mpfr_set(vr, big_rl(j), GMP_RNDN);
1939 mpfr_mul(vr, vr, ur, GMP_RNDN);
1940 mpfr_sub(vr, vr, temp, GMP_RNDN);
1941
1942 mpfr_set(temp, big_rl(j), GMP_RNDN); /* vi = ur * im[j] + ui * rl[j] */
1943 mpfr_mul(temp, temp, ui, GMP_RNDN);
1944 mpfr_set(vi, big_im(j), GMP_RNDN);
1945 mpfr_mul(vi, vi, ur, GMP_RNDN);
1946 mpfr_add(vi, vi, temp, GMP_RNDN);
1947
1948 mpfr_set(big_rl(j), big_rl(i), GMP_RNDN); /* rl[j] = rl[i] - vr */
1949 mpfr_sub(big_rl(j), big_rl(j), vr, GMP_RNDN);
1950
1951 mpfr_set(big_im(j), big_im(i), GMP_RNDN); /* im[j] = im[i] - vi */
1952 mpfr_sub(big_im(j), big_im(j), vi, GMP_RNDN);
1953
1954 mpfr_add(big_rl(i), big_rl(i), vr, GMP_RNDN); /* rl[i] += vr */
1955 mpfr_add(big_im(i), big_im(i), vi, GMP_RNDN); /* im[i] += vi */
1956
1957 i += m;
1958 j += m;
1959 }
1960
1961 mpfr_set(u, ur, GMP_RNDN); /* u = ur */
1962 mpfr_set(temp, ui, GMP_RNDN); /* ur = (ur * c) - (ui * s) */
1963 mpfr_mul(temp, temp, s, GMP_RNDN);
1964 mpfr_mul(ur, ur, c, GMP_RNDN);
1965 mpfr_sub(ur, ur, temp, GMP_RNDN);
1966
1967 mpfr_set(temp, u, GMP_RNDN); /* ui = (ui * c) + (u * s) */
1968 mpfr_mul(temp, temp, s, GMP_RNDN);
1969 mpfr_mul(ui, ui, c, GMP_RNDN);
1970 mpfr_add(ui, ui, temp, GMP_RNDN);
1971 }
1972 mh >>= 1;
1973 ldm = m;
1974
1975 mpfr_div_ui(angle, angle, 2, GMP_RNDN); /* angle *= 0.5 */
1976 m <<= 1;
1977 }
1978 return(s7_f(sc));
1979 }
1980
1981 #endif
1982
1983
1984 #if HAVE_SPECIAL_FUNCTIONS && (!HAVE_GSL)
g_j0(Xen x)1985 static Xen g_j0(Xen x)
1986 {
1987 #define H_j0 "(" S_bes_j0 " x): returns the regular cylindrical bessel function value J0(x)"
1988 #if (!HAVE_SCHEME)
1989 Xen_check_type(Xen_is_number(x), x, 1, S_bes_j0, " a number");
1990 #endif
1991
1992 #if HAVE_SCHEME && WITH_GMP
1993 if ((s7_is_bignum(x)) &&
1994 (s7_is_real(x)) &&
1995 (!(s7_is_rational(x))))
1996 return(big_j0(x));
1997 #endif
1998 return(C_double_to_Xen_real(j0(Xen_real_to_C_double(x))));
1999 }
2000
2001
g_j1(Xen x)2002 static Xen g_j1(Xen x)
2003 {
2004 #define H_j1 "(" S_bes_j1 " x): returns the regular cylindrical bessel function value J1(x)"
2005 #if (!HAVE_SCHEME)
2006 Xen_check_type(Xen_is_number(x), x, 1, S_bes_j1, " a number");
2007 #endif
2008
2009 #if HAVE_SCHEME && WITH_GMP
2010 if ((s7_is_bignum(x)) &&
2011 (s7_is_real(x)) &&
2012 (!(s7_is_rational(x))))
2013 return(big_j1(x));
2014 #endif
2015 return(C_double_to_Xen_real(j1(Xen_real_to_C_double(x))));
2016 }
2017
2018
g_jn(Xen order,Xen x)2019 static Xen g_jn(Xen order, Xen x)
2020 {
2021 #define H_jn "(" S_bes_jn " n x): returns the regular cylindrical bessel function value Jn(x)"
2022 Xen_check_type(Xen_is_integer(order), x, 1, S_bes_jn, " an int");
2023 #if (!HAVE_SCHEME)
2024 Xen_check_type(Xen_is_number(x), x, 2, S_bes_jn, " a number");
2025 #endif
2026
2027 #if HAVE_SCHEME && WITH_GMP
2028 if ((s7_is_bignum(x)) &&
2029 (s7_is_real(x)) &&
2030 (!(s7_is_rational(x))))
2031 return(big_jn(order, x));
2032 #endif
2033 return(C_double_to_Xen_real(jn(Xen_integer_to_C_int(order), Xen_real_to_C_double(x))));
2034 }
2035
2036
g_y0(Xen x)2037 static Xen g_y0(Xen x)
2038 {
2039 #define H_y0 "(" S_bes_y0 " x): returns the irregular cylindrical bessel function value Y0(x)"
2040 Xen_check_type(Xen_is_number(x), x, 1, S_bes_y0, " a number");
2041 #if HAVE_SCHEME && WITH_GMP
2042 if ((s7_is_bignum(x)) &&
2043 (s7_is_real(x)) &&
2044 (!(s7_is_rational(x))))
2045 return(big_y0(x));
2046 #endif
2047 return(C_double_to_Xen_real(y0(Xen_real_to_C_double(x))));
2048 }
2049
2050
g_y1(Xen x)2051 static Xen g_y1(Xen x)
2052 {
2053 #define H_y1 "(" S_bes_y1 " x): returns the irregular cylindrical bessel function value Y1(x)"
2054 Xen_check_type(Xen_is_number(x), x, 1, S_bes_y1, " a number");
2055 #if HAVE_SCHEME && WITH_GMP
2056 if ((s7_is_bignum(x)) &&
2057 (s7_is_real(x)) &&
2058 (!(s7_is_rational(x))))
2059 return(big_y1(x));
2060 #endif
2061 return(C_double_to_Xen_real(y1(Xen_real_to_C_double(x))));
2062 }
2063
2064
g_yn(Xen order,Xen x)2065 static Xen g_yn(Xen order, Xen x)
2066 {
2067 #define H_yn "(" S_bes_yn " n x): returns the irregular cylindrical bessel function value Yn(x)"
2068 Xen_check_type(Xen_is_integer(order), x, 1, S_bes_yn, " an int");
2069 Xen_check_type(Xen_is_number(x), x, 2, S_bes_yn, " a number");
2070 #if HAVE_SCHEME && WITH_GMP
2071 if ((s7_is_bignum(x)) &&
2072 (s7_is_real(x)) &&
2073 (!(s7_is_rational(x))))
2074 return(big_yn(order, x));
2075 #endif
2076 return(C_double_to_Xen_real(yn(Xen_integer_to_C_int(order), Xen_real_to_C_double(x))));
2077 }
2078
2079
g_erf(Xen x)2080 static Xen g_erf(Xen x)
2081 {
2082 #define H_erf "(erf x): returns the error function erf(x)"
2083 Xen_check_type(Xen_is_number(x), x, 1, "erf", " a number");
2084 #if HAVE_SCHEME && WITH_GMP
2085 if ((s7_is_bignum(x)) &&
2086 (s7_is_real(x)) &&
2087 (!(s7_is_rational(x))))
2088 return(big_erf(x));
2089 #endif
2090 return(C_double_to_Xen_real(erf(Xen_real_to_C_double(x))));
2091 }
2092
2093
g_erfc(Xen x)2094 static Xen g_erfc(Xen x)
2095 {
2096 #define H_erfc "(erfc x): returns the complementary error function erfc(x)"
2097 Xen_check_type(Xen_is_number(x), x, 1, "erfc", " a number");
2098 #if HAVE_SCHEME && WITH_GMP
2099 if ((s7_is_bignum(x)) &&
2100 (s7_is_real(x)) &&
2101 (!(s7_is_rational(x))))
2102 return(big_erfc(x));
2103 #endif
2104 return(C_double_to_Xen_real(erfc(Xen_real_to_C_double(x))));
2105 }
2106
2107
g_lgamma(Xen x)2108 static Xen g_lgamma(Xen x)
2109 {
2110 #define H_lgamma "(lgamma x): returns the log of the gamma function at x"
2111 Xen_check_type(Xen_is_number(x), x, 1, "lgamma", " a number");
2112 return(C_double_to_Xen_real(lgamma(Xen_real_to_C_double(x))));
2113 }
2114 #endif
2115
2116
2117 #define S_bes_i0 "bes-i0"
2118
g_i0(Xen x)2119 static Xen g_i0(Xen x)
2120 {
2121 #define H_i0 "(" S_bes_i0 " x): returns the modified cylindrical bessel function value I0(x)"
2122 Xen_check_type(Xen_is_number(x), x, 1, S_bes_i0, " a number");
2123 #if HAVE_SCHEME && WITH_GMP
2124 if ((s7_is_bignum(x)) &&
2125 (s7_is_real(x)) &&
2126 (!(s7_is_rational(x))))
2127 return(big_i0(x));
2128 #endif
2129 return(C_double_to_Xen_real(mus_bessi0(Xen_real_to_C_double(x)))); /* uses GSL if possible */
2130 }
2131
2132
2133 /* ---------------------------------------- use GSL ---------------------------------------- */
2134 #if HAVE_GSL
2135
2136 /* include all the bessel functions, etc */
2137 #include <gsl/gsl_sf_bessel.h>
2138
g_j0(Xen x)2139 static Xen g_j0(Xen x)
2140 {
2141 #define H_j0 "(" S_bes_j0 " x): returns the regular cylindrical bessel function value J0(x)"
2142 Xen_check_type(Xen_is_number(x), x, 1, S_bes_j0, " a number");
2143
2144 #if HAVE_SCHEME && WITH_GMP
2145 if ((s7_is_bignum(x)) &&
2146 (s7_is_real(x)) &&
2147 (!(s7_is_rational(x))))
2148 return(big_j0(x));
2149 #endif
2150 return(C_double_to_Xen_real(gsl_sf_bessel_J0(Xen_real_to_C_double(x))));
2151 }
2152
2153
g_j1(Xen x)2154 static Xen g_j1(Xen x)
2155 {
2156 #define H_j1 "(" S_bes_j1 " x): returns the regular cylindrical bessel function value J1(x)"
2157 Xen_check_type(Xen_is_number(x), x, 1, S_bes_j1, " a number");
2158
2159 #if HAVE_SCHEME && WITH_GMP
2160 if ((s7_is_bignum(x)) &&
2161 (s7_is_real(x)) &&
2162 (!(s7_is_rational(x))))
2163 return(big_j1(x));
2164 #endif
2165 return(C_double_to_Xen_real(gsl_sf_bessel_J1(Xen_real_to_C_double(x))));
2166 }
2167
2168
g_jn(Xen order,Xen x)2169 static Xen g_jn(Xen order, Xen x)
2170 {
2171 #define H_jn "(" S_bes_jn " n x): returns the regular cylindrical bessel function value Jn(x)"
2172 Xen_check_type(Xen_is_integer(order), x, 1, S_bes_jn, " an int");
2173 Xen_check_type(Xen_is_number(x), x, 2, S_bes_jn, " a number");
2174
2175 #if HAVE_SCHEME && WITH_GMP
2176 if ((s7_is_bignum(x)) &&
2177 (s7_is_real(x)) &&
2178 (!(s7_is_rational(x))))
2179 return(big_jn(order, x));
2180 #endif
2181 return(C_double_to_Xen_real(gsl_sf_bessel_Jn(Xen_integer_to_C_int(order), Xen_real_to_C_double(x))));
2182 }
2183
2184
g_y0(Xen x)2185 static Xen g_y0(Xen x)
2186 {
2187 #define H_y0 "(" S_bes_y0 " x): returns the irregular cylindrical bessel function value Y0(x)"
2188 Xen_check_type(Xen_is_number(x), x, 1, S_bes_y0, " a number");
2189 #if HAVE_SCHEME && WITH_GMP
2190 if ((s7_is_bignum(x)) &&
2191 (s7_is_real(x)) &&
2192 (!(s7_is_rational(x))))
2193 return(big_y0(x));
2194 #endif
2195 return(C_double_to_Xen_real(gsl_sf_bessel_Y0(Xen_real_to_C_double(x))));
2196 }
2197
2198
g_y1(Xen x)2199 static Xen g_y1(Xen x)
2200 {
2201 #define H_y1 "(" S_bes_y1 " x): returns the irregular cylindrical bessel function value Y1(x)"
2202 Xen_check_type(Xen_is_number(x), x, 1, S_bes_y1, " a number");
2203 #if HAVE_SCHEME && WITH_GMP
2204 if ((s7_is_bignum(x)) &&
2205 (s7_is_real(x)) &&
2206 (!(s7_is_rational(x))))
2207 return(big_y1(x));
2208 #endif
2209 return(C_double_to_Xen_real(gsl_sf_bessel_Y1(Xen_real_to_C_double(x))));
2210 }
2211
2212
g_yn(Xen order,Xen x)2213 static Xen g_yn(Xen order, Xen x)
2214 {
2215 #define H_yn "(" S_bes_yn " n x): returns the irregular cylindrical bessel function value Yn(x)"
2216 Xen_check_type(Xen_is_integer(order), x, 1, S_bes_yn, " an int");
2217 Xen_check_type(Xen_is_number(x), x, 2, S_bes_yn, " a number");
2218 #if HAVE_SCHEME && WITH_GMP
2219 if ((s7_is_bignum(x)) &&
2220 (s7_is_real(x)) &&
2221 (!(s7_is_rational(x))))
2222 return(big_yn(order, x));
2223 #endif
2224 return(C_double_to_Xen_real(gsl_sf_bessel_Yn(Xen_integer_to_C_int(order), Xen_real_to_C_double(x))));
2225 }
2226
2227 #define S_bes_i1 "bes-i1"
2228 #define S_bes_in "bes-in"
2229 #define S_bes_k0 "bes-k0"
2230 #define S_bes_k1 "bes-k1"
2231 #define S_bes_kn "bes-kn"
2232
g_i1(Xen x)2233 static Xen g_i1(Xen x)
2234 {
2235 #define H_i1 "(" S_bes_i1 " x): returns the regular cylindrical bessel function value I1(x)"
2236 Xen_check_type(Xen_is_number(x), x, 1, S_bes_i1, " a number");
2237 return(C_double_to_Xen_real(gsl_sf_bessel_I1(Xen_real_to_C_double(x))));
2238 }
2239
2240
g_in(Xen order,Xen x)2241 static Xen g_in(Xen order, Xen x)
2242 {
2243 #define H_in "(" S_bes_in " n x): returns the regular cylindrical bessel function value In(x)"
2244 Xen_check_type(Xen_is_integer(order), x, 1, S_bes_in, " an int");
2245 Xen_check_type(Xen_is_number(x), x, 2, S_bes_in, " a number");
2246 return(C_double_to_Xen_real(gsl_sf_bessel_In(Xen_integer_to_C_int(order), Xen_real_to_C_double(x))));
2247 }
2248
2249
g_k0(Xen x)2250 static Xen g_k0(Xen x)
2251 {
2252 #define H_k0 "(" S_bes_k0 " x): returns the irregular cylindrical bessel function value K0(x)"
2253 Xen_check_type(Xen_is_number(x), x, 1, S_bes_k0, " a number");
2254 return(C_double_to_Xen_real(gsl_sf_bessel_K0(Xen_real_to_C_double(x))));
2255 }
2256
2257
g_k1(Xen x)2258 static Xen g_k1(Xen x)
2259 {
2260 #define H_k1 "(" S_bes_k1 " x): returns the irregular cylindrical bessel function value K1(x)"
2261 Xen_check_type(Xen_is_number(x), x, 1, S_bes_k1, " a number");
2262 return(C_double_to_Xen_real(gsl_sf_bessel_K1(Xen_real_to_C_double(x))));
2263 }
2264
2265
g_kn(Xen order,Xen x)2266 static Xen g_kn(Xen order, Xen x)
2267 {
2268 #define H_kn "(" S_bes_kn " n x): returns the irregular cylindrical bessel function value Kn(x)"
2269 Xen_check_type(Xen_is_integer(order), x, 1, S_bes_kn, " an int");
2270 Xen_check_type(Xen_is_number(x), x, 2, S_bes_kn, " a number");
2271 return(C_double_to_Xen_real(gsl_sf_bessel_Kn(Xen_integer_to_C_int(order), Xen_real_to_C_double(x))));
2272 }
2273
2274
2275 #include <gsl/gsl_sf_erf.h>
g_erf(Xen x)2276 static Xen g_erf(Xen x)
2277 {
2278 #define H_erf "(erf x): returns the error function erf(x)"
2279 Xen_check_type(Xen_is_number(x), x, 1, "erf", " a number");
2280 #if HAVE_SCHEME && WITH_GMP
2281 if ((s7_is_bignum(x)) &&
2282 (s7_is_real(x)) &&
2283 (!(s7_is_rational(x))))
2284 return(big_erf(x));
2285 #endif
2286 return(C_double_to_Xen_real(gsl_sf_erf(Xen_real_to_C_double(x))));
2287 }
2288
2289
g_erfc(Xen x)2290 static Xen g_erfc(Xen x)
2291 {
2292 #define H_erfc "(erfc x): returns the complementary error function value erfc(x)"
2293 Xen_check_type(Xen_is_number(x), x, 1, "erfc", " a number");
2294 #if HAVE_SCHEME && WITH_GMP
2295 if ((s7_is_bignum(x)) &&
2296 (s7_is_real(x)) &&
2297 (!(s7_is_rational(x))))
2298 return(big_erfc(x));
2299 #endif
2300 return(C_double_to_Xen_real(gsl_sf_erfc(Xen_real_to_C_double(x))));
2301 }
2302
2303
2304 #include <gsl/gsl_sf_gamma.h>
g_lgamma(Xen x)2305 static Xen g_lgamma(Xen x)
2306 {
2307 #define H_lgamma "(lgamma x): returns the log of the gamma function at x"
2308 Xen_check_type(Xen_is_number(x), x, 1, "lgamma", " a number");
2309 return(C_double_to_Xen_real(gsl_sf_lngamma(Xen_real_to_C_double(x))));
2310 }
2311
2312
2313
2314 #include <gsl/gsl_sf_ellint.h>
g_gsl_ellipk(Xen k)2315 static Xen g_gsl_ellipk(Xen k)
2316 {
2317 double f;
2318 #define H_gsl_ellipk "(gsl-ellipk k): returns the complete elliptic integral k"
2319 Xen_check_type(Xen_is_number(k), k, 1, "gsl-ellipk", "a number");
2320 f = Xen_real_to_C_double(k);
2321 Xen_check_type(f >= 0.0, k, 1, "gsl-ellipk", "a non-negative number");
2322 return(C_double_to_Xen_real(gsl_sf_ellint_Kcomp(sqrt(Xen_real_to_C_double(k)), GSL_PREC_APPROX)));
2323 }
2324
2325
2326 #include <gsl/gsl_sf_elljac.h>
g_gsl_ellipj(Xen u,Xen m)2327 static Xen g_gsl_ellipj(Xen u, Xen m)
2328 {
2329 #define H_gsl_ellipj "(gsl-ellipj u m): returns the Jacobian elliptic functions sn, cn, and dn of u and m"
2330 double sn = 0.0, cn = 0.0, dn = 0.0;
2331 Xen_check_type(Xen_is_number(u), u, 1, "gsl-ellipj", "a number");
2332 Xen_check_type(Xen_is_number(m), m, 2, "gsl-ellipj", "a number");
2333 gsl_sf_elljac_e(Xen_real_to_C_double(u),
2334 Xen_real_to_C_double(m),
2335 &sn, &cn, &dn);
2336 return(Xen_list_3(C_double_to_Xen_real(sn),
2337 C_double_to_Xen_real(cn),
2338 C_double_to_Xen_real(dn)));
2339 }
2340
2341
2342 #include <gsl/gsl_version.h>
2343 #if ((GSL_MAJOR_VERSION >= 1) && (GSL_MINOR_VERSION >= 9))
2344 #define HAVE_GSL_EIGEN_NONSYMMV_WORKSPACE 1
2345 #endif
2346
2347 #if HAVE_GSL_EIGEN_NONSYMMV_WORKSPACE
2348
2349 /* eignevector/values, from gsl/doc/examples/eigen_nonsymm.c */
2350
2351 #include <gsl/gsl_math.h>
2352 #include <gsl/gsl_eigen.h>
2353
g_gsl_eigenvectors(Xen matrix)2354 static Xen g_gsl_eigenvectors(Xen matrix)
2355 {
2356 double *data;
2357 int i, j, len;
2358 Xen values = Xen_false, vectors = Xen_false;
2359
2360 #if HAVE_SCHEME
2361 Xen_check_type(s7_is_float_vector(matrix), matrix, 1, "gsl-eigenvectors", "a float vector");
2362 len = (int)sqrt(s7_vector_length(matrix));
2363 data = (double *)s7_float_vector_elements(matrix);
2364 #else
2365 vct *v;
2366 Xen_check_type(mus_is_vct(matrix), matrix, 1, "gsl-eigenvectors", "a vct");
2367 v = Xen_to_vct(matrix);
2368 len = (int)sqrt(mus_vct_length(v));
2369 data = mus_vct_data(v);
2370 #endif
2371
2372 {
2373 gsl_matrix_view m = gsl_matrix_view_array(data, len, len);
2374 gsl_vector_complex *eval = gsl_vector_complex_alloc(len);
2375 gsl_matrix_complex *evec = gsl_matrix_complex_alloc(len, len);
2376 gsl_eigen_nonsymmv_workspace *w = gsl_eigen_nonsymmv_alloc(len);
2377 gsl_eigen_nonsymmv(&m.matrix, eval, evec, w);
2378 gsl_eigen_nonsymmv_free(w);
2379 gsl_eigen_nonsymmv_sort(eval, evec, GSL_EIGEN_SORT_ABS_DESC);
2380
2381 {
2382 int values_loc, vectors_loc;
2383
2384 values = Xen_make_vector(len, Xen_integer_zero);
2385 values_loc = snd_protect(values);
2386 vectors = Xen_make_vector(len, Xen_false);
2387 vectors_loc = snd_protect(vectors);
2388
2389 for (i = 0; i < len; i++)
2390 {
2391 Xen vect;
2392 #if HAVE_SCHEME
2393 s7_double *fv_data;
2394 #endif
2395 gsl_complex eval_i = gsl_vector_complex_get(eval, i);
2396 gsl_vector_complex_view evec_i = gsl_matrix_complex_column(evec, i);
2397 Xen_vector_set(values, i, C_double_to_Xen_real(GSL_REAL(eval_i)));
2398
2399 #if HAVE_SCHEME
2400 vect = s7_make_float_vector(s7, len, 1, NULL);
2401 fv_data = s7_float_vector_elements(vect);
2402 #else
2403 vect = Xen_make_vector(len, Xen_integer_zero);
2404 #endif
2405 Xen_vector_set(vectors, i, vect);
2406
2407 for (j = 0; j < len; j++)
2408 {
2409 gsl_complex z = gsl_vector_complex_get(&evec_i.vector, j);
2410 #if HAVE_SCHEME
2411 fv_data[j] = GSL_REAL(z);
2412 #else
2413 Xen_vector_set(vect, j, C_double_to_Xen_real(GSL_REAL(z)));
2414 #endif
2415 }
2416 }
2417 snd_unprotect_at(values_loc);
2418 snd_unprotect_at(vectors_loc);
2419 }
2420
2421 gsl_vector_complex_free(eval);
2422 gsl_matrix_complex_free(evec);
2423 }
2424
2425 #if (!HAVE_SCHEME)
2426 free(data);
2427 #endif
2428 return(Xen_list_2(values, vectors));
2429 }
2430 #endif
2431
2432
2433 #if HAVE_COMPLEX_TRIG && HAVE_COMPLEX_NUMBERS
2434 #include <gsl/gsl_poly.h>
2435 #include <complex.h>
2436
g_gsl_roots(Xen poly)2437 static Xen g_gsl_roots(Xen poly)
2438 {
2439 #define H_gsl_roots "(gsl-roots poly): roots of poly"
2440 int i, n, loc;
2441 double *p;
2442 double complex *z;
2443 gsl_poly_complex_workspace *w;
2444 Xen result;
2445
2446 /* gsl_roots: balance_companion_matrix gets hung if the vector is multidimensional */
2447 Xen_check_type((Xen_is_vector(poly)) && (Xen_vector_rank(poly) == 1), poly, 1, "gsl-roots", "a vector");
2448
2449 n = Xen_vector_length(poly);
2450 w = gsl_poly_complex_workspace_alloc(n);
2451 z = (double complex *)calloc(n, sizeof(double complex));
2452 p = (double *)calloc(n, sizeof(double));
2453
2454 #if HAVE_SCHEME
2455 if (s7_is_float_vector(poly))
2456 {
2457 s7_double *e;
2458 e = s7_float_vector_elements(poly);
2459 for (i = 0; i < n; i++)
2460 p[i] = e[i];
2461 }
2462 else
2463 {
2464 for (i = 0; i < n; i++)
2465 p[i] = Xen_real_to_C_double(Xen_vector_ref(poly, i));
2466 }
2467 #else
2468 for (i = 0; i < n; i++)
2469 p[i] = Xen_real_to_C_double(Xen_vector_ref(poly, i));
2470 #endif
2471
2472 gsl_poly_complex_solve(p, n, w, (gsl_complex_packed_ptr)z);
2473 gsl_poly_complex_workspace_free (w);
2474
2475 result = Xen_make_vector(n - 1, Xen_integer_zero);
2476 loc = snd_protect(result);
2477 for (i = 0; i < n - 1; i++)
2478 if (__imag__(z[i]) != 0.0)
2479 Xen_vector_set(result, i, C_complex_to_Xen_complex(z[i]));
2480 else Xen_vector_set(result, i, C_double_to_Xen_real(__real__(z[i])));
2481
2482 free(z);
2483 free(p);
2484 snd_unprotect_at(loc);
2485 return(result);
2486 }
2487 #endif
2488 #endif
2489
2490
2491
2492 /* -------- source file extensions list -------- */
2493
2494 static char **source_file_extensions = NULL;
2495 static int source_file_extensions_size = 0;
2496 static int source_file_extensions_end = 0;
2497 static int default_source_file_extensions = 0;
2498
add_source_file_extension(const char * ext)2499 static void add_source_file_extension(const char *ext)
2500 {
2501 int i;
2502 for (i = 0; i < source_file_extensions_end; i++)
2503 if (mus_strcmp(ext, source_file_extensions[i]))
2504 return;
2505 if (source_file_extensions_end == source_file_extensions_size)
2506 {
2507 source_file_extensions_size += 8;
2508 if (!source_file_extensions)
2509 source_file_extensions = (char **)calloc(source_file_extensions_size, sizeof(char *));
2510 else source_file_extensions = (char **)realloc(source_file_extensions, source_file_extensions_size * sizeof(char *));
2511 }
2512 source_file_extensions[source_file_extensions_end] = mus_strdup(ext);
2513 source_file_extensions_end++;
2514 }
2515
2516
is_source_file(const char * name)2517 bool is_source_file(const char *name)
2518 {
2519 if (!name) return(false);
2520 if (source_file_extensions)
2521 {
2522 int i, dot_loc = -1, len;
2523 len = strlen(name);
2524
2525 for (i = 0; i < len; i++)
2526 if (name[i] == '.')
2527 dot_loc = i;
2528 /* dot_loc is last dot in the name */
2529
2530 if ((dot_loc > 0) &&
2531 (dot_loc < len - 1))
2532 {
2533 const char *ext;
2534
2535 ext = (const char *)(name + dot_loc + 1);
2536 for (i = 0; i < source_file_extensions_end; i++)
2537 if (mus_strcmp(ext, source_file_extensions[i]))
2538 return(true);
2539 }
2540 }
2541 return(false);
2542 }
2543
2544
save_added_source_file_extensions(FILE * fd)2545 void save_added_source_file_extensions(FILE *fd)
2546 {
2547 if (source_file_extensions_end > default_source_file_extensions)
2548 {
2549 int i;
2550 for (i = default_source_file_extensions; i < source_file_extensions_end; i++)
2551 {
2552 #if HAVE_SCHEME
2553 fprintf(fd, "(%s \"%s\")\n", S_add_source_file_extension, source_file_extensions[i]);
2554 #endif
2555
2556 #if HAVE_RUBY
2557 fprintf(fd, "%s(\"%s\")\n", to_proc_name(S_add_source_file_extension), source_file_extensions[i]);
2558 #endif
2559
2560 #if HAVE_FORTH
2561 fprintf(fd, "\"%s\" %s drop\n", source_file_extensions[i], S_add_source_file_extension);
2562 #endif
2563 }
2564 }
2565 }
2566
2567
g_add_source_file_extension(Xen ext)2568 static Xen g_add_source_file_extension(Xen ext)
2569 {
2570 #define H_add_source_file_extension "(" S_add_source_file_extension " ext): add the file extension 'ext' to the list of source file extensions"
2571 Xen_check_type(Xen_is_string(ext), ext, 1, S_add_source_file_extension, "a string");
2572 add_source_file_extension(Xen_string_to_C_string(ext));
2573 return(ext);
2574 }
2575
2576
find_source_file(const char * orig)2577 static char *find_source_file(const char *orig)
2578 {
2579 int i;
2580 for (i = 0; i < source_file_extensions_end; i++)
2581 {
2582 char *str;
2583 str = mus_format("%s.%s", orig, source_file_extensions[i]);
2584 if (mus_file_probe(str))
2585 return(str);
2586 free(str);
2587 }
2588 return(NULL);
2589 }
2590
2591
2592 /* list-in-vector|list, vector-in-list|vector, cobj-in-vector|list obj-in-cobj
2593 * string-ci-in-vector? hash-table cases?
2594 * most of this could be done via for-each
2595 */
2596
2597 #if HAVE_SCHEME && (!_MSC_VER)
2598 Xen_wrap_2_optional_args(g_dlopen_w, g_dlopen)
2599 Xen_wrap_1_arg(g_dlclose_w, g_dlclose)
2600 Xen_wrap_no_args(g_dlerror_w, g_dlerror)
2601 Xen_wrap_2_args(g_dlinit_w, g_dlinit)
2602 Xen_wrap_2_args(g_dlsym_w, g_dlsym)
2603 #endif
2604 #if HAVE_SCHEME
2605 Xen_wrap_1_arg(g_snd_s7_error_handler_w, g_snd_s7_error_handler);
2606 #endif
2607
2608 Xen_wrap_1_arg(g_snd_print_w, g_snd_print)
2609 Xen_wrap_no_args(g_little_endian_w, g_little_endian)
2610 Xen_wrap_no_args(g_snd_global_state_w, g_snd_global_state)
2611 Xen_wrap_1_arg(g_add_source_file_extension_w, g_add_source_file_extension)
2612
2613 #if (!HAVE_SCHEME)
2614 Xen_wrap_2_args(g_fmod_w, g_fmod)
2615 #endif
2616
2617 #if HAVE_SPECIAL_FUNCTIONS || HAVE_GSL
2618 Xen_wrap_1_arg(g_j0_w, g_j0)
2619 Xen_wrap_1_arg(g_j1_w, g_j1)
2620 Xen_wrap_2_args(g_jn_w, g_jn)
2621 Xen_wrap_1_arg(g_y0_w, g_y0)
2622 Xen_wrap_1_arg(g_y1_w, g_y1)
2623 Xen_wrap_2_args(g_yn_w, g_yn)
2624 Xen_wrap_1_arg(g_erf_w, g_erf)
2625 Xen_wrap_1_arg(g_erfc_w, g_erfc)
2626 Xen_wrap_1_arg(g_lgamma_w, g_lgamma)
2627 #endif
2628
2629 Xen_wrap_1_arg(g_i0_w, g_i0)
2630
2631 #if HAVE_GSL
2632 Xen_wrap_1_arg(g_i1_w, g_i1)
2633 Xen_wrap_2_args(g_in_w, g_in)
2634 Xen_wrap_1_arg(g_k0_w, g_k0)
2635 Xen_wrap_1_arg(g_k1_w, g_k1)
2636 Xen_wrap_2_args(g_kn_w, g_kn)
2637
2638 Xen_wrap_1_arg(g_gsl_ellipk_w, g_gsl_ellipk)
2639 Xen_wrap_2_args(g_gsl_ellipj_w, g_gsl_ellipj)
2640 #if HAVE_GSL_EIGEN_NONSYMMV_WORKSPACE
2641 Xen_wrap_1_arg(g_gsl_eigenvectors_w, g_gsl_eigenvectors)
2642 #endif
2643
2644 #if HAVE_COMPLEX_TRIG && HAVE_COMPLEX_NUMBERS
2645 Xen_wrap_1_arg(g_gsl_roots_w, g_gsl_roots)
2646 #endif
2647 #endif
2648
2649 #if HAVE_EXTENSION_LANGUAGE
2650 #if HAVE_SCHEME
2651 #if USE_MOTIF
2652 void Init_libxm(s7_scheme *sc);
2653 #endif
2654 #if HAVE_GL
2655 void Init_libgl(s7_scheme *sc);
2656 #endif
2657 #else /* not s7 */
2658 #if USE_MOTIF
2659 void Init_libxm(void);
2660 #endif
2661 #if HAVE_GL
2662 void Init_libgl(void);
2663 #endif
2664 #endif
2665 #endif
2666
legalize_path(const char * in_str)2667 static char *legalize_path(const char *in_str)
2668 {
2669 int inlen;
2670 char *out_str;
2671 int inpos, outpos = 0;
2672
2673 inlen = mus_strlen(in_str);
2674 out_str = (char *)calloc(inlen * 2, sizeof(char));
2675
2676 for (inpos = 0; inpos < inlen; inpos++)
2677 {
2678 if (in_str[inpos] == '\\')
2679 out_str[outpos++] = '\\';
2680 out_str[outpos++] = in_str[inpos];
2681 }
2682
2683 return(out_str);
2684 }
2685
2686
2687 #if HAVE_GL
g_snd_gl_context(void)2688 static Xen g_snd_gl_context(void)
2689 {
2690 #if USE_MOTIF
2691 return(Xen_list_2(C_string_to_Xen_symbol("GLXContext"), Xen_wrap_C_pointer(ss->cx)));
2692 #endif
2693 }
2694
Xen_wrap_no_args(g_snd_gl_context_w,g_snd_gl_context)2695 Xen_wrap_no_args(g_snd_gl_context_w, g_snd_gl_context)
2696 #endif
2697
2698
2699
2700 /* -------------------------------------------------------------------------------- */
2701
2702 Xen_wrap_1_arg(g_snd_error_w, g_snd_error)
2703 Xen_wrap_1_arg(g_snd_warning_w, g_snd_warning)
2704
2705 void g_xen_initialize(void)
2706 {
2707 #if HAVE_SCHEME
2708 s7_pointer pl_dr, pl_dir, pl_ss, pl_b, s, i, b, r, d, t;
2709 #if WITH_GMP
2710 s7_pointer v;
2711 #endif
2712 #if HAVE_GSL_EIGEN_NONSYMMV_WORKSPACE
2713 s7_pointer pl_pf;
2714 #endif
2715 #if HAVE_GSL
2716 s7_pointer pl_prr;
2717 #endif
2718 #if HAVE_GSL || HAVE_GL
2719 s7_pointer p;
2720 p = s7_make_symbol(s7, "pair?");
2721 #endif
2722 s = s7_make_symbol(s7, "string?");
2723 i = s7_make_symbol(s7, "integer?");
2724 b = s7_make_symbol(s7, "boolean?");
2725 r = s7_make_symbol(s7, "real?");
2726 d = s7_make_symbol(s7, "float?");
2727 #if WITH_GMP
2728 v = s7_make_symbol(s7, "vector?");
2729 #endif
2730 t = s7_t(s7);
2731 pl_ss = s7_make_signature(s7, 2, s, s);
2732 pl_dr = s7_make_circular_signature(s7, 1, 2, d, r);
2733 #if HAVE_GSL
2734 pl_prr = s7_make_signature(s7, 3, p, r, r);
2735 #endif
2736 pl_dir = s7_make_signature(s7, 3, d, i, r);
2737 pl_b = s7_make_signature(s7, 1, b);
2738 #if HAVE_GSL_EIGEN_NONSYMMV_WORKSPACE
2739 pl_pf = s7_make_signature(s7, 2, s7_make_symbol(s7, "pair?"), s7_make_symbol(s7, "float-vector?"));
2740 #endif
2741 #endif
2742
2743 #if HAVE_RUBY
2744 rb_gc_disable();
2745 #endif
2746
2747 Xen_define_typed_procedure(S_snd_error, g_snd_error_w, 1, 0, 0, H_snd_error, pl_ss);
2748 Xen_define_typed_procedure(S_snd_warning, g_snd_warning_w, 1, 0, 0, H_snd_warning, pl_ss);
2749
2750 #if HAVE_SCHEME
2751 #define H_snd_error_hook S_snd_error_hook " (message): called upon snd_error. \
2752 If it returns " PROC_TRUE ", Snd flushes the error (it assumes you've reported it via the hook):\n\
2753 (hook-push " S_snd_error_hook "\n\
2754 (lambda (hook) (" S_play " \"bong.snd\")))"
2755
2756 #define H_snd_warning_hook S_snd_warning_hook " (message): called upon snd_warning. \
2757 If it returns " PROC_TRUE ", Snd flushes the warning (it assumes you've reported it via the hook):\n\
2758 (define without-warnings\n\
2759 (lambda (thunk)\n\
2760 (define no-warning (lambda (hook) (set! (hook 'result) #t)))\n\
2761 (hook-push snd-warning-hook no-warning) \n\
2762 (thunk)\n\
2763 (hook-remove snd-warning-hook no-warning)))"
2764 #endif
2765 #if HAVE_RUBY
2766 #define H_snd_error_hook S_snd_error_hook " (error-message): called upon snd_error. \
2767 If it returns true, Snd flushes the error (it assumes you've reported it via the hook):\n\
2768 $snd_error_hook.add-hook!(\"error\") do |msg|\n\
2769 play(\"bong.snd\")\n\
2770 false\n\
2771 end"
2772
2773 #define H_snd_warning_hook S_snd_warning_hook " (warning-message): called upon snd_warning. \
2774 If it returns true, Snd flushes the warning (it assumes you've reported it via the hook)\n\
2775 def without_warning(&body)\n\
2776 $snd_warning_hook.add_hook!(\"no_warning\") do |msg| true end\n\
2777 ret = body.call\n\
2778 $snd_warning_hook.remove_hook!(\"no_warning\")\n\
2779 ret\n\
2780 end\n\
2781 # without_warning do " S_snd_warning "(\"not shown\") end"
2782 #endif
2783 #if HAVE_FORTH
2784 #define H_snd_error_hook S_snd_error_hook " (error-message): called upon snd_error. \
2785 If it returns " PROC_TRUE ", Snd flushes the error (it assumes you've reported it via the hook):\n\
2786 " S_snd_error_hook " lambda: <{ msg }>\n\
2787 \"bong.snd\" " S_play " drop\n\
2788 #f\n\
2789 ; add-hook!"
2790
2791 #define H_snd_warning_hook S_snd_warning_hook " (warning-message): called upon snd_warning. \
2792 If it returns " PROC_TRUE ", Snd flushes the warning (it assumes you've reported it via the hook)\n\
2793 : no-warning <{ msg -- f }> #t ;\n\
2794 : without-warnings <{ xt -- }>\n\
2795 " S_snd_warning_hook " <'> no-warning add-hook!\n\
2796 xt execute\n\
2797 " S_snd_warning_hook " <'> no-warning remove-hook! drop\n\
2798 ;\n\
2799 \\ lambda: ( -- ) \"not shown\" " S_snd_warning " ; without-warning\n\
2800 "
2801 #endif
2802
2803 ss->snd_error_hook = Xen_define_hook(S_snd_error_hook, "(make-hook 'message)", 1, H_snd_error_hook);
2804 ss->snd_warning_hook = Xen_define_hook(S_snd_warning_hook, "(make-hook 'message)", 1, H_snd_warning_hook);
2805
2806 #define H_clip_hook S_clip_hook " (val) is called each time a sample is about to \
2807 be clipped upon being written to a sound file. The hook function can return the new value to \
2808 be written, or rely on the default (-1.0 or 1.0 depending on the sign of 'val')."
2809
2810 clip_hook = Xen_define_hook(S_clip_hook, "(make-hook 'val)", 1, H_clip_hook);
2811 mus_clip_set_handler_and_checker(NULL, clip_hook_checker);
2812
2813 add_source_file_extension(Xen_file_extension);
2814 #if HAVE_SCHEME
2815 add_source_file_extension("cl");
2816 add_source_file_extension("lisp");
2817 add_source_file_extension("init"); /* for slib */
2818 #endif
2819
2820 #if HAVE_FORTH
2821 add_source_file_extension("fth");
2822 add_source_file_extension("fsm");
2823 #endif
2824 add_source_file_extension("marks"); /* from save-marks */
2825 default_source_file_extensions = source_file_extensions_end;
2826
2827 Xen_define_typed_procedure("snd-global-state", g_snd_global_state_w, 0, 0, 0, "internal testing function", s7_make_signature(s7, 1, t));
2828 Xen_define_typed_procedure(S_add_source_file_extension, g_add_source_file_extension_w, 1, 0, 0, H_add_source_file_extension,
2829 s7_make_signature(s7, 2, s, s));
2830
2831 ss->snd_open_file_hook = Xen_define_simple_hook("(make-hook 'reason)", 1);
2832 Xen_GC_protect(ss->snd_open_file_hook);
2833
2834 ss->effects_hook = Xen_define_hook(S_effects_hook, "(make-hook)", 0, "called when something changes that the effects dialogs care about");
2835
2836 Init_sndlib();
2837
2838 #if HAVE_FORTH
2839 fth_add_loaded_files("sndlib.so");
2840 #endif
2841
2842 #if (!HAVE_SCHEME)
2843 gc_protection = Xen_false;
2844 #endif
2845
2846 Xen_define_typed_procedure(S_snd_print, g_snd_print_w, 1, 0, 0, H_snd_print, pl_ss);
2847 Xen_define_typed_procedure("little-endian?", g_little_endian_w, 0, 0, 0, "return " PROC_TRUE " if host is little endian", pl_b);
2848
2849 #if HAVE_SCHEME
2850 Xen_eval_C_string("(define fmod modulo)");
2851 #else
2852 Xen_define_procedure("fmod", g_fmod_w, 2, 0, 0, "C's fmod");
2853 #endif
2854
2855 #if HAVE_SPECIAL_FUNCTIONS || HAVE_GSL
2856 Xen_define_typed_procedure(S_bes_j0, g_j0_w, 1, 0, 0, H_j0, pl_dr);
2857 Xen_define_typed_procedure(S_bes_j1, g_j1_w, 1, 0, 0, H_j1, pl_dr);
2858 Xen_define_typed_procedure(S_bes_jn, g_jn_w, 2, 0, 0, H_jn, pl_dir);
2859 Xen_define_typed_procedure(S_bes_y0, g_y0_w, 1, 0, 0, H_y0, pl_dr);
2860 Xen_define_typed_procedure(S_bes_y1, g_y1_w, 1, 0, 0, H_y1, pl_dr);
2861 Xen_define_typed_procedure(S_bes_yn, g_yn_w, 2, 0, 0, H_yn, pl_dir);
2862 Xen_define_typed_procedure("erf", g_erf_w, 1, 0, 0, H_erf, pl_dr);
2863 Xen_define_typed_procedure("erfc", g_erfc_w, 1, 0, 0, H_erfc, pl_dr);
2864 Xen_define_typed_procedure("lgamma", g_lgamma_w, 1, 0, 0, H_lgamma, pl_dr);
2865 #endif
2866
2867 Xen_define_typed_procedure(S_bes_i0, g_i0_w, 1, 0, 0, H_i0, pl_dr);
2868
2869 #if HAVE_GSL
2870 Xen_define_typed_procedure(S_bes_i1, g_i1_w, 1, 0, 0, H_i1, pl_dr);
2871 Xen_define_typed_procedure(S_bes_in, g_in_w, 2, 0, 0, H_in, pl_dir);
2872 Xen_define_typed_procedure(S_bes_k0, g_k0_w, 1, 0, 0, H_k0, pl_dr);
2873 Xen_define_typed_procedure(S_bes_k1, g_k1_w, 1, 0, 0, H_k1, pl_dr);
2874 Xen_define_typed_procedure(S_bes_kn, g_kn_w, 2, 0, 0, H_kn, pl_dir);
2875
2876 Xen_define_typed_procedure("gsl-ellipk", g_gsl_ellipk_w, 1, 0, 0, H_gsl_ellipk, pl_dr);
2877 Xen_define_typed_procedure("gsl-ellipj", g_gsl_ellipj_w, 2, 0, 0, H_gsl_ellipj, pl_prr);
2878
2879 #if HAVE_GSL_EIGEN_NONSYMMV_WORKSPACE
2880 Xen_define_typed_procedure("gsl-eigenvectors", g_gsl_eigenvectors_w, 1, 0, 0, "returns eigenvalues and eigenvectors", pl_pf);
2881 #endif
2882
2883 #if HAVE_COMPLEX_TRIG && HAVE_COMPLEX_NUMBERS
2884 Xen_define_typed_procedure("gsl-roots", g_gsl_roots_w, 1, 0, 0, H_gsl_roots, NULL);
2885 #endif
2886 #endif
2887
2888 #if HAVE_SCHEME && WITH_GMP
2889 s7_define_typed_function(s7, "bignum-fft", bignum_fft, 3, 1, false, H_bignum_fft, s7_make_signature(s7, 5, b, v, v, i, i));
2890 #endif
2891
2892 g_init_base();
2893 g_init_utils();
2894 g_init_marks();
2895 g_init_regions();
2896 g_init_selection();
2897 g_init_mix();
2898 g_init_fft(); /* needs to precede snd-chn init */
2899 g_init_chn();
2900 g_init_kbd();
2901 g_init_sig();
2902 g_init_print();
2903 g_init_edits();
2904 g_init_listener();
2905 g_init_help();
2906 g_init_menu();
2907 g_init_main();
2908 g_init_snd();
2909 g_init_dac(); /* needs to follow snd and mix */
2910 g_init_file();
2911 g_init_data();
2912 g_init_env();
2913 g_init_find();
2914 #if (!USE_NO_GUI)
2915 g_init_gxcolormaps();
2916 g_init_draw();
2917 g_init_axis();
2918 #if USE_MOTIF
2919 g_init_motif();
2920 #endif
2921 #endif
2922
2923 #if HAVE_SCHEME && (!_MSC_VER)
2924 Xen_define_typed_procedure("dlopen", g_dlopen_w, 1, 1 ,0, H_dlopen, s7_make_signature(s7, 3, t, s, i));
2925 Xen_define_typed_procedure("dlclose", g_dlclose_w, 1, 0 ,0, H_dlclose, s7_make_signature(s7, 2, i, t));
2926 Xen_define_typed_procedure("dlerror", g_dlerror_w, 0, 0 ,0, H_dlerror, s7_make_signature(s7, 1, s));
2927 Xen_define_typed_procedure("dlinit", g_dlinit_w, 2, 0 ,0, H_dlinit, s7_make_signature(s7, 3, b, t, s));
2928 Xen_define_typed_procedure("dlsym", g_dlsym_w, 2, 0 ,0, H_dlsym, s7_make_signature(s7, 3, t, t, s));
2929
2930 Xen_define_constant("RTLD_LAZY", RTLD_LAZY, "dlopen flag");
2931 Xen_define_constant("RTLD_NOW", RTLD_NOW, "dlopen flag");
2932 Xen_define_constant("RTLD_GLOBAL", RTLD_GLOBAL, "dlopen flag");
2933 #endif
2934
2935 #if HAVE_SCHEME && (!USE_NO_GUI)
2936 s7_eval_c_string(s7,
2937 "(define debug.scm-init \
2938 (let ((old-let (top-level-let))) \
2939 (lambda () \
2940 (set! ((funclet trace-in) '*debug-port*) *listener-port*) \
2941 (set! ((funclet trace-in) '*debug-start-output*) newline) \
2942 (set! ((funclet trace-in) '*debug-end-output*) (lambda (p) #f)) \
2943 (set! ((funclet trace-in) '*debug-repl*) \
2944 (lambda (call e) \
2945 (set! (top-level-let) e) \
2946 (set! listener-prompt \"break>\"))))))");
2947 #endif
2948
2949 #if HAVE_LADSPA && HAVE_EXTENSION_LANGUAGE
2950 g_ladspa_to_snd();
2951 #endif
2952
2953 #ifdef SCRIPTS_DIR
2954 Xen_add_to_load_path((char *)SCRIPTS_DIR);
2955 #endif
2956
2957 {
2958 char *pwd, *legal_pwd;
2959 pwd = mus_getcwd();
2960 legal_pwd = legalize_path(pwd);
2961 Xen_add_to_load_path(legal_pwd);
2962 free(legal_pwd);
2963 }
2964
2965 #if HAVE_SCHEME
2966 Xen_define_typed_procedure("_snd_s7_error_handler_", g_snd_s7_error_handler_w, 1, 0, 0, "internal error redirection for snd/s7",
2967 s7_make_signature(s7, 2, b, s));
2968
2969 Xen_eval_C_string("(define redo-edit redo)"); /* consistency with Ruby */
2970 Xen_eval_C_string("(define undo-edit undo)");
2971
2972 /* Xen_eval_C_string("(define (procedure-name proc) (if (procedure? proc) (format #f \"~A\" proc) #f))"); */
2973 /* needed in snd-test.scm and hooks.scm */
2974
2975 Xen_eval_C_string("\
2976 (define* (apropos name (port #f) (e (rootlet))) \
2977 \"(apropos name (port *stdout*) (env (rootlet))) looks for 'name' as a part of any symbol name, and sends matches to 'port'\" \
2978 (let ((ap-name (if (string? name) \
2979 name \
2980 (if (symbol? name) \
2981 (symbol->string name) \
2982 (error 'wrong-type-arg \"apropos argument 1 should be a string or a symbol\")))) \
2983 (ap-env (if (let? e) \
2984 e \
2985 (error 'wrong-type-arg \"apropos argument 3 should be an environment\"))) \
2986 (ap-port (if (or (not port) (output-port? port)) \
2987 port \
2988 (error 'wrong-type-arg \"apropos argument 2 should be an output port\")))) \
2989 (for-each \
2990 (lambda (binding) \
2991 (if (and (pair? binding) \
2992 (string-position ap-name (symbol->string (car binding)))) \
2993 (snd-print \
2994 (format ap-port \"~%~A: ~A\" \
2995 (car binding) \
2996 (if (procedure? (cdr binding)) \
2997 (documentation (cdr binding)) \
2998 (cdr binding)))))) \
2999 ap-env) \
3000 #f))");
3001
3002 Xen_eval_C_string("\
3003 (define break-ok #f)\
3004 (define break-exit #f) ; a kludge to get 2 funcs to share a local variable\n\
3005 (define break-enter #f)\
3006 \
3007 (let ((saved-listener-prompt (listener-prompt)))\
3008 (set! break-exit (lambda ()\
3009 (hook-clear read-hook)\
3010 (set! (listener-prompt) saved-listener-prompt)\
3011 #f))\
3012 (set! break-enter (lambda ()\
3013 (set! saved-listener-prompt (listener-prompt)))))\
3014 \
3015 (define-macro (break)\
3016 `(let ((__break__ (curlet)))\
3017 (break-enter)\
3018 (set! (listener-prompt) (format #f \"~A>\" (if (defined? __func__) __func__ 'break)))\
3019 (call/cc\
3020 (lambda (return)\
3021 (set! break-ok return) ; save current program loc so (break-ok) continues from the break\n\
3022 (hook-push read-hook ; anything typed in the listener is evaluated in the environment of the break call\n\
3023 (lambda (str)\
3024 (eval-string str __break__)))\
3025 (error 'snd-top-level))) ; jump back to the top level\n\
3026 (break-exit))) ; we get here if break-ok is called\n\
3027 ");
3028
3029 #endif
3030
3031 #if HAVE_FORTH
3032 Xen_eval_C_string("<'> redo alias redo-edit"); /* consistency with Ruby */
3033 Xen_eval_C_string("<'> undo alias undo-edit");
3034 Xen_eval_C_string(": clm-print ( fmt :optional args -- ) fth-format snd-print drop ;");
3035 #endif
3036
3037 #if HAVE_RUBY
3038 Xen_eval_C_string("def clm_print(str, *args)\n\
3039 snd_print format(str, *args)\n\
3040 end");
3041 #endif
3042
3043 #if HAVE_GL
3044 Xen_define_typed_procedure("snd-gl-context", g_snd_gl_context_w, 0, 0, 0, "GL Context", s7_make_signature(s7, 1, p));
3045 #endif
3046
3047 #if HAVE_EXTENSION_LANGUAGE
3048 #if USE_MOTIF
3049 #if HAVE_SCHEME
3050 {
3051 s7_pointer motif, old_shadow;
3052 s7_define_constant(s7, "*motif*", motif = s7_inlet(s7, s7_nil(s7)));
3053 old_shadow = s7_set_shadow_rootlet(s7, motif);
3054 Init_libxm(s7);
3055 s7_set_shadow_rootlet(s7, old_shadow);
3056 }
3057 #else
3058 Init_libxm();
3059 #endif
3060 #if HAVE_FORTH
3061 fth_add_loaded_files("libxm.so");
3062 #endif
3063 #endif
3064
3065 #if HAVE_GL
3066 #if HAVE_SCHEME
3067 {
3068 s7_pointer gl, old_shadow;
3069 s7_define_constant(s7, "*gl*", gl = s7_inlet(s7, s7_nil(s7)));
3070 old_shadow = s7_set_shadow_rootlet(s7, gl);
3071 Init_libgl(s7);
3072 s7_set_shadow_rootlet(s7, old_shadow);
3073 }
3074 #else
3075 Init_libgl();
3076 #endif /* s7 */
3077 #endif /* gl */
3078 #endif /* extension language */
3079
3080 #if HAVE_ALSA
3081 Xen_provide_feature("alsa");
3082 #endif
3083
3084 #if HAVE_OSS
3085 Xen_provide_feature("oss");
3086 #endif
3087
3088 #if MUS_PULSEAUDIO
3089 Xen_provide_feature("pulse-audio");
3090 #endif
3091
3092 #if MUS_JACK
3093 Xen_provide_feature("jack");
3094 #endif
3095
3096 #if HAVE_GSL
3097 Xen_provide_feature("gsl");
3098 #endif
3099
3100 #if USE_MOTIF
3101 Xen_provide_feature("snd-motif");
3102 #endif
3103
3104 #if USE_NO_GUI
3105 Xen_provide_feature("snd-nogui");
3106 #endif
3107
3108 #if HAVE_FORTH
3109 Xen_provide_feature("snd-forth");
3110 #endif
3111
3112 #if HAVE_SCHEME
3113 Xen_provide_feature("snd-s7");
3114 #endif
3115
3116 #if WITH_AUDIO
3117 Xen_provide_feature("audio");
3118 #endif
3119
3120 #if ENABLE_WEBSERVER
3121 Xen_provide_feature("webserver");
3122 #endif
3123
3124 #if HAVE_RUBY
3125 Xen_provide_feature("snd-ruby");
3126 /* we need to set up the search path so that load and require will work as in the program irb */
3127 {
3128 Xen paths;
3129 int i, len;
3130 paths = rb_gv_get("$:");
3131 /* this is printed as
3132 * ["/home/bil/ruby-snd", "/usr/local/share/snd", "/usr/local/lib/ruby/site_ruby/2.0.0", ...]
3133 */
3134 len = Xen_vector_length(paths);
3135 for (i = 0; i < len; i++)
3136 Xen_add_to_load_path(Xen_string_to_C_string(Xen_vector_ref(paths, i)));
3137 }
3138 #endif
3139
3140 Xen_provide_feature("snd");
3141 Xen_provide_feature("snd" SND_MAJOR_VERSION);
3142 Xen_provide_feature("snd-" SND_MAJOR_VERSION "." SND_MINOR_VERSION);
3143
3144 #if HAVE_RUBY
3145 rb_gc_enable();
3146 #endif
3147
3148 }
3149
3150