Imported Upstream version 12.0

1 files changed, 77 insertions, 126 deletions

diff --git a/snd-xen.c b/snd-xen.c
index 9d91a57..a05b4ec 100644
--- a/snd-xen.c
+++ b/snd-xen.c
@@ -154,8 +154,8 @@ void redirect_xen_error_to(void (*handler)(const char *msg, void *ufd), void *da
 
 #if HAVE_SCHEME
   if (handler == NULL)
-    s7_symbol_set_value(s7, s7_make_symbol(s7, "*error-hook*"), s7_nil(s7));
-  else s7_eval_c_string(s7, "(set! *error-hook*                                      \n\
+    s7_eval_c_string(s7, "(set! (hook-functions *error-hook*) '())");
+  else s7_eval_c_string(s7, "(set! (hook-functions *error-hook*) (list               \n\
                                (lambda (tag args)                                    \n\
                                  (_snd_s7_error_handler_                             \n\
                                    (string-append                                    \n\
@@ -171,7 +171,7 @@ void redirect_xen_error_to(void (*handler)(const char *msg, void *ufd), void *da
                                                  (*error-info* 4)                    \n\
                                                  (*error-info* 3)                    \n\
                                                  (*error-info* 2))                   \n\
-                                         \"\")))))");
+                                         \"\"))))))");
 #endif
 }
 
@@ -302,8 +302,6 @@ void snd_rb_raise(XEN tag, XEN throw_args)
   bool need_comma = false;
   int size = 2048;
 
-  /* fprintf(stderr, "err: %s %s\n", XEN_AS_STRING(tag), XEN_AS_STRING(throw_args)); */
-
   if (strcmp(rb_id2name(tag), "Out_of_range") == 0) 
     err = rb_eRangeError;
   else
@@ -460,12 +458,10 @@ char *procedure_ok(XEN proc, int args, const char *caller, const char *arg_name,
     {
       arity = XEN_ARITY(proc);
 
-      /* fprintf(stderr,"procedure_ok: %s arity: %s %p\n", XEN_AS_STRING(proc), XEN_AS_STRING(arity), proc); */
-
 #if HAVE_RUBY
       rargs = XEN_TO_C_INT(arity);
       if (!xen_rb_arity_ok(rargs, args))
- 	return(mus_format(_("%s function (%s arg %d) should take %d args, not %d"),
+ 	return(mus_format("%s function (%s arg %d) should take %d args, not %d",
  			  arg_name, caller, argn, args, (rargs < 0) ? (-rargs) : rargs));
 #endif
 
@@ -481,16 +477,16 @@ char *procedure_ok(XEN proc, int args, const char *caller, const char *arg_name,
 	snd_unprotect_at(loc);
 
 	if (rargs > args)
-	  return(mus_format(_("%s function (%s arg %d) should take %d argument%s, but instead requires %d"),
+	  return(mus_format("%s function (%s arg %d) should take %d argument%s, but instead requires %d",
 			    arg_name, caller, argn, args, (args != 1) ? "s" : "", rargs));
 
 	if ((restargs == 0) && ((rargs + oargs) < args))
-	  return(mus_format(_("%s function (%s arg %d) should accept at least %d argument%s, but instead accepts only %d"),
+	  return(mus_format("%s function (%s arg %d) should accept at least %d argument%s, but instead accepts only %d",
 			    arg_name, caller, argn, args, (args != 1) ? "s" : "", rargs + oargs));
 
 	if ((args == 0) &&
 	    ((rargs != 0) || (oargs != 0) || (restargs != 0)))
-	  return(mus_format(_("%s function (%s arg %d) should take no args, not %d"), 
+	  return(mus_format("%s function (%s arg %d) should take no args, not %d", 
 			    arg_name, caller, argn, rargs + oargs + restargs));
       }
 #endif
@@ -498,7 +494,7 @@ char *procedure_ok(XEN proc, int args, const char *caller, const char *arg_name,
 #if HAVE_FORTH
       rargs = XEN_TO_C_INT(arity);
       if (rargs != args)
-	return(mus_format(_("%s function (%s arg %d) should take %d args, not %d"),
+	return(mus_format("%s function (%s arg %d) should take %d args, not %d",
 			  arg_name, caller, argn, args, rargs));
 #endif
     }
@@ -638,6 +634,8 @@ static char *gl_print(XEN result)
 
 #if HAVE_SCHEME
   /* expand \t first (neither gtk nor motif handles this automatically)
+   *   but... "#\\t" is the character t not a tab indication!
+   *   (object->string #\t)
    */
   #define TAB_SPACES 4
   int tabs = 0, len, j = 0;
@@ -646,7 +644,9 @@ static char *gl_print(XEN result)
   len = mus_strlen(newbuf);
 
   for (i = 0; i < len - 1; i++)
-    if ((newbuf[i] == '\\') && (newbuf[i + 1] == 't'))
+    if (((i == 0) || (newbuf[i - 1] != '\\')) && 
+	(newbuf[i] == '\\') && 
+	(newbuf[i + 1] == 't'))
       tabs++;
 
   if (tabs == 0)
@@ -657,7 +657,9 @@ static char *gl_print(XEN result)
 
   for (i = 0; i < len - 1; i++)
     {
-      if ((newbuf[i] == '\\') && (newbuf[i + 1] == 't'))
+      if (((i == 0) || (newbuf[i - 1] != '\\')) && 
+	  (newbuf[i] == '\\') && 
+	  (newbuf[i + 1] == 't'))
 	{
 	  int k;
 	  for (k = 0; k < TAB_SPACES; k++)
@@ -821,8 +823,7 @@ void snd_eval_stdin_str(const char *buf)
 
       loc = snd_protect(result);
       if (stdin_str) free(stdin_str);
-
-      /* same as str here; if c-g! evaluated from stdin, clear_listener is called which frees/nullifies stdin_str */
+      /* same as str here */
       stdin_str = NULL;
       str = gl_print(result);
       string_to_stdout(str, NULL);
@@ -913,6 +914,7 @@ void snd_load_init_file(bool no_global, bool no_init)
    *
    * there are parallel choices for the global configuration file: /etc/snd_ruby|forth|s7.conf
    */
+
 #if HAVE_EXTENSION_LANGUAGE
 #if HAVE_RUBY
   #define SND_EXT_CONF "/etc/snd_ruby.conf"
@@ -984,7 +986,7 @@ void snd_load_file(const char *filename)
     }
   if (!str)
     {
-      snd_error(_("can't load %s: %s"), filename, snd_open_strerror());
+      snd_error("can't load %s: %s", filename, snd_open_strerror());
       return;
     }
 
@@ -1028,7 +1030,6 @@ static XEN g_snd_print(XEN msg)
   listener_append(str);
   if (str) free(str);
   /* used to check for event in Motif case, but that is very dangerous -- check for infinite loop C-c needs to be somewhere else */
-  /*   now I think you can use SIGUSR1 (kill -10) instead */
   return(msg);
 }
 
@@ -1098,21 +1099,21 @@ mus_float_t string_to_mus_float_t(const char *str, mus_float_t lo, const char *f
     {
       f = XEN_TO_C_DOUBLE(res);
       if (f < lo)
-	snd_error(_("%s: %.3f is invalid"), field_name, f);
+	snd_error("%s: %.3f is invalid", field_name, f);
       else return(f);
     }
-  else snd_error(_("%s is not a number"), str);
+  else snd_error("%s is not a number", str);
   return(0.0);
 #else
   mus_float_t res = 0.0;
   if (str) 
     {
       if (!(sscanf(str, "%f", &res)))
-	snd_error(_("%s is not a number"), str);
+	snd_error("%s is not a number", str);
       else
 	{
 	  if (res < lo)
-	    snd_error(_("%s: %.3f is invalid"), field_name, res);
+	    snd_error("%s: %.3f is invalid", field_name, res);
 	}
     }
   return(res);
@@ -1130,21 +1131,21 @@ int string_to_int(const char *str, int lo, const char *field_name)
       int val;
       val = XEN_TO_C_INT(res);
       if (val < lo)
-	snd_error(_("%s: %d is invalid"), field_name, val);
+	snd_error("%s: %d is invalid", field_name, val);
       else return(val);
     }
-  else snd_error(_("%s: %s is not a number"), field_name, str);
+  else snd_error("%s: %s is not a number", field_name, str);
   return(0);
 #else
   int res = 0;
   if (str) 
     {
       if (!(sscanf(str, "%d", &res)))
-	snd_error(_("%s: %s is not a number"), field_name, str);
+	snd_error("%s: %s is not a number", field_name, str);
       else
 	{
 	  if (res < lo)
-	    snd_error(_("%s: %d is invalid"), field_name, res);
+	    snd_error("%s: %d is invalid", field_name, res);
 	}
     }
   return(res);
@@ -1163,21 +1164,21 @@ mus_long_t string_to_mus_long_t(const char *str, mus_long_t lo, const char *fiel
       mus_long_t val;
       val = XEN_TO_C_INT64_T(res);
       if (val < lo)
-	snd_error(_("%s: " MUS_LD " is invalid"), field_name, val);
+	snd_error("%s: " MUS_LD " is invalid", field_name, val);
       else return(val);
     }
-  else snd_error(_("%s: %s is not a number"), field_name, str);
+  else snd_error("%s: %s is not a number", field_name, str);
   return(0);
 #else
   mus_long_t res = 0;
   if (str) 
     {
       if (!(sscanf(str, MUS_LD , &res)))
-	snd_error(_("%s: %s is not a number"), field_name, str);
+	snd_error("%s: %s is not a number", field_name, str);
       else
 	{
 	  if (res < lo)
-	    snd_error(_("%s: " MUS_LD " is invalid"), field_name, res);
+	    snd_error("%s: " MUS_LD " is invalid", field_name, res);
 	}
     }
   return(res);
@@ -1250,7 +1251,7 @@ XEN run_or_hook(XEN hook, XEN args, const char *caller)
 #endif
   XEN result = XEN_FALSE; /* (or): #f */
   XEN hook_result = XEN_FALSE;
-  XEN procs = XEN_HOOK_PROCEDURES (hook);
+  XEN procs = XEN_HOOK_PROCEDURES(hook);
 
 #if HAVE_SCHEME
   gc_loc = s7_gc_protect(s7, args);
@@ -1383,6 +1384,18 @@ static XEN g_snd_sound_pointer(XEN snd)
 #endif
 
 
+#if (!HAVE_SCHEME)
+/* fmod is the same as modulo in s7:
+   (do ((i 0 (+ i 1))) 
+       ((= i 100)) 
+     (let ((val1 (- (random 1.0) 2.0)) 
+           (val2 (- (random 1.0) 2.0)))
+       (let ((f (fmod val1 val2)) 
+             (m (modulo val1 val2))) 
+         (if (> (abs (- f m)) 1e-9) 
+             (format *stderr* "~A ~A -> ~A ~A~%" val1 val2 f m)))))
+*/
+
 static XEN g_fmod(XEN a, XEN b)
 {
   double val, x, y;
@@ -1396,6 +1409,7 @@ static XEN g_fmod(XEN a, XEN b)
     return(C_TO_XEN_DOUBLE(val + y));
   return(C_TO_XEN_DOUBLE(val));
 }
+#endif
 
 
 #if HAVE_SPECIAL_FUNCTIONS || HAVE_GSL
@@ -2202,83 +2216,6 @@ static XEN g_gsl_roots(XEN poly)
 #endif
 
 
-/* -------- watchers -------- */
-
-#define NOT_A_WATCHER -1
-#define INITIAL_WATCHERS_SIZE 8
-#define WATCHERS_SIZE_INCREMENT 8
-
-static int *watchers = NULL;
-static int watchers_size = 0;
-
-static XEN g_delete_watcher(XEN id)
-{
-  int w;
-  #define H_delete_watcher "(" S_delete_watcher " id): removes the watcher associated with the integer 'id'"
-  XEN_ASSERT_TYPE(XEN_INTEGER_P(id), id, XEN_ONLY_ARG, S_delete_watcher, "an integer");
-
-  w = XEN_TO_C_INT(id);
-  if ((w >= 0) && 
-      (w < watchers_size) &&
-      (watchers[w] != NOT_A_WATCHER))
-    {
-      snd_unprotect_at(watchers[w]);
-      watchers[w] = NOT_A_WATCHER;
-    }
-  return(id);
-}
-
-
-void run_watchers(void)
-{
-  if (watchers)
-    {
-      int i;
-      for (i = 0; i < watchers_size; i++)
-	if (watchers[i] != NOT_A_WATCHER)
-	  XEN_CALL_0(snd_protected_at(watchers[i]), "run watcher");
-    }
-}
-
-
-static XEN g_add_watcher(XEN func)
-{
-  int i, floc = 0;
-  #define H_add_watcher "(" S_add_watcher " func): adds 'func' (a function of no arguments) to the watcher list, and \
-returns its id (an integer, used by " S_delete_watcher "). "
-
-  XEN_ASSERT_TYPE(XEN_PROCEDURE_P(func) && XEN_REQUIRED_ARGS_OK(func, 0), func, XEN_ONLY_ARG, S_add_watcher, "a function of no args");
-
-  if (watchers_size == 0)
-    {
-      watchers_size = INITIAL_WATCHERS_SIZE;
-      watchers = (int *)calloc(watchers_size, sizeof(int));
-      for (i = 0; i < watchers_size; i++) watchers[i] = NOT_A_WATCHER;
-    }
-  else
-    {
-      floc = -1;
-      for (i = 0; i < watchers_size; i++)
-	if (watchers[i] == NOT_A_WATCHER)
-	  {
-	    floc = i;
-	    break;
-	  }
-      if (floc == -1)
-	{
-	  floc = watchers_size;
-	  watchers_size += WATCHERS_SIZE_INCREMENT;
-	  watchers = (int *)realloc(watchers, watchers_size * sizeof(int));
-	  for (i = floc; i < watchers_size; i++) watchers[i] = NOT_A_WATCHER;
-	}
-    }
-
-  watchers[floc] = snd_protect(func);
-  return(C_TO_XEN_INT(floc));
-}
-
-
-
 
 /* -------- source file extensions list -------- */
 
@@ -2596,7 +2533,9 @@ XEN_NARGIFY_1(g_add_source_file_extension_w, g_add_source_file_extension)
   XEN_NARGIFY_1(g_snd_sound_pointer_w, g_snd_sound_pointer)
 #endif
 
+#if (!HAVE_SCHEME)
 XEN_NARGIFY_2(g_fmod_w, g_fmod)
+#endif
 
 #if HAVE_SPECIAL_FUNCTIONS || HAVE_GSL
   XEN_NARGIFY_1(g_j0_w, g_j0)
@@ -2631,9 +2570,6 @@ XEN_NARGIFY_1(g_i0_w, g_i0)
   #endif
 #endif
 
-XEN_NARGIFY_1(g_delete_watcher_w, g_delete_watcher)
-XEN_NARGIFY_1(g_add_watcher_w, g_add_watcher)
-
 #else
 /* not argify */
 
@@ -2654,7 +2590,11 @@ XEN_NARGIFY_1(g_add_watcher_w, g_add_watcher)
 #if MUS_DEBUGGING
   #define g_snd_sound_pointer_w g_snd_sound_pointer
 #endif
+
+#if (!HAVE_SCHEME)
 #define g_fmod_w g_fmod
+#endif
+
 #if HAVE_SPECIAL_FUNCTIONS || HAVE_GSL
   #define g_j0_w g_j0
   #define g_j1_w g_j1
@@ -2685,9 +2625,6 @@ XEN_NARGIFY_1(g_add_watcher_w, g_add_watcher)
     #define g_gsl_roots_w g_gsl_roots
   #endif
 #endif
-#define g_delete_watcher_w g_delete_watcher
-#define g_add_watcher_w g_add_watcher
-
 #endif
 
 
@@ -2729,7 +2666,7 @@ static char *legalize_path(const char *in_str)
 static XEN g_snd_glx_context(void)
 {
   return(XEN_LIST_2(C_STRING_TO_XEN_SYMBOL("GLXContext"), 
-		    XEN_WRAP_C_POINTER(ss->sgx->cx)));
+		    XEN_WRAP_C_POINTER(ss->cx)));
 } 
 
 
@@ -2761,6 +2698,14 @@ void g_xen_initialize(void)
   XEN_DEFINE_PROCEDURE("snd-global-state", g_snd_global_state_w, 0, 0, 0, "internal testing function");
   XEN_DEFINE_PROCEDURE(S_add_source_file_extension, g_add_source_file_extension_w, 1, 0, 0, H_add_source_file_extension);
 
+  ss->snd_open_file_hook = XEN_DEFINE_SIMPLE_HOOK(1);
+  ss->snd_selection_hook = XEN_DEFINE_SIMPLE_HOOK(1);
+
+  XEN_PROTECT_FROM_GC(ss->snd_open_file_hook);
+  XEN_PROTECT_FROM_GC(ss->snd_selection_hook);
+
+  ss->effects_hook = XEN_DEFINE_HOOK(S_effects_hook, 0, "called when something changes that the effects dialogs care about");
+
 #if MUS_DEBUGGING
   XEN_DEFINE_PROCEDURE("snd-sound-pointer", g_snd_sound_pointer_w, 1, 0, 0, "internal testing function");
 #endif
@@ -2780,7 +2725,12 @@ void g_xen_initialize(void)
 
   XEN_DEFINE_PROCEDURE(S_snd_print,      g_snd_print_w,     1, 0, 0, H_snd_print);
   XEN_DEFINE_PROCEDURE("little-endian?", g_little_endian_w, 0, 0, 0, "return " PROC_TRUE " if host is little endian");
+
+#if HAVE_SCHEME
+  XEN_EVAL_C_STRING("(define fmod modulo)");
+#else
   XEN_DEFINE_PROCEDURE("fmod",           g_fmod_w,          2, 0, 0, "C's fmod");
+#endif
 
 #if HAVE_SPECIAL_FUNCTIONS || HAVE_GSL
   XEN_DEFINE_PROCEDURE(S_bes_j0, g_j0_w,     1, 0, 0, H_j0);
@@ -2824,9 +2774,6 @@ void g_xen_initialize(void)
   s7_define_function(s7, "bignum-fft", bignum_fft, 3, 1, false, H_bignum_fft);
 #endif
 
-  XEN_DEFINE_PROCEDURE(S_delete_watcher, g_delete_watcher_w, 1, 0, 0, H_delete_watcher);
-  XEN_DEFINE_PROCEDURE(S_add_watcher,    g_add_watcher_w,    1, 0, 0, H_add_watcher);
-
 #if HAVE_SCHEME
   s7_define_function(s7, "char-position", g_char_position, 2, 1, false, H_char_position);
   s7_define_function(s7, "string-position", g_string_position, 2, 1, false, H_string_position);
@@ -2836,8 +2783,8 @@ void g_xen_initialize(void)
   s7_define_function(s7, "string-ci-list-position", g_string_ci_list_position, 2, 1, false, H_string_ci_list_position);
 
   #define H_print_hook S_print_hook " (text): called each time some Snd-generated response (text) is about to be appended to the listener. \
-If it returns some non-#f result, Snd assumes you've sent the text out yourself, as well as any needed prompt. \n\
-  (add-hook! "S_print_hook "\n\
+If it returns some non-" PROC_FALSE " result, Snd assumes you've sent the text out yourself, as well as any needed prompt. \n\
+  (add-hook! " S_print_hook "\n\
     (lambda (msg) \n\
       (" S_snd_print "\n\
         (format #f \"~A~%[~A]~%~A\" \n\
@@ -2943,7 +2890,7 @@ If it returns some non-#f result, Snd assumes you've sent the text out yourself,
   /* needed in snd-test.scm and hooks.scm */
 
   XEN_EVAL_C_STRING("\
-        (define (apropos name)\
+        (define* (apropos name port)\
           (define (substring? subs s)\
             (let* ((start 0)\
 	           (ls (string-length s))\
@@ -2961,11 +2908,14 @@ If it returns some non-#f result, Snd assumes you've sent the text out yourself,
             (for-each\
              (lambda (binding)\
                (if (substring? name (symbol->string (car binding)))\
-	           (format (current-output-port) \"~A: ~A~%\" \
-	        	   (car binding) \
-	        	   (if (procedure? (cdr binding))\
-	        	       (procedure-documentation (cdr binding))\
-	        	       (cdr binding)))))\
+                   (let ((str (format #f \"~%~A: ~A\" \
+	        	              (car binding) \
+	        	              (if (procedure? (cdr binding))\
+	        	                  (procedure-documentation (cdr binding))\
+	        	                  (cdr binding)))))\
+                     (if (not port)\
+                         (snd-print str)\
+	                 (display str port)))))\
              alist))\
           (if (or (not (string? name))\
                   (= (length name) 0))\
@@ -3151,4 +3101,5 @@ If it returns some non-#f result, Snd assumes you've sent the text out yourself,
 
   XEN_YES_WE_HAVE("snd");
   XEN_YES_WE_HAVE("snd" SND_MAJOR_VERSION);
+  XEN_YES_WE_HAVE("snd-" SND_MAJOR_VERSION "." SND_MINOR_VERSION);
 }