Imported Upstream version 11.4

1 files changed, 84 insertions, 71 deletions

diff --git a/snd-xen.c b/snd-xen.c
index 93a650b..9cfe717 100644
--- a/snd-xen.c
+++ b/snd-xen.c
@@ -1,19 +1,6 @@
 #include "snd.h"
 #include "clm2xen.h"
 
-/* we often use the pair (selected-sound) (selected-channel) or whatever,
- *         and these are always paired in the argument lists, so if we had a
- *         C function that returned both as a (scheme) multiple-value, we
- *         could simply plug that in wherever the other 2 were wanted.
- *         Actually, this should work as well:
- *         (define (sc)
- *           (if (not (null? sounds))
- *               (values (or (selected-sound) (car (sounds)))
- *                       (or (selected-channel) 0))
- *               (values #f 0)))
- *         and similarly in other such cases. [end chn edpos]
- */
-
 /* Snd defines its own exit and delay
  *
  *   In Scheme, delay is protected in clm2xen.c as make-promise
@@ -203,28 +190,42 @@ XEN snd_protected_at(int loc)
 
 static char *last_file_loaded = NULL;
 
-void redirect_xen_error_to(void (*handler)(const char *msg, void *ufd), void *data)
+#if HAVE_SCHEME
+static XEN g_snd_s7_error_handler(XEN args)
 {
-  ss->xen_error_handler = handler;
-  ss->xen_error_data = data;
+#if MUS_DEBUGGING
+  fprintf(stderr, "error: %s\n", s7_object_to_c_string(s7, args));
+#endif
+  if (ss->xen_error_handler)
+    (*(ss->xen_error_handler))(s7_string(s7_car(args)), (void *)NULL);
+  return(s7_f(s7));
 }
+#endif
 
 
-#if (!HAVE_SCHEME) && (!HAVE_FORTH)
-static void call_xen_error_handler(const char *msg)
+void redirect_xen_error_to(void (*handler)(const char *msg, void *ufd), void *data)
 {
-  /* make sure it doesn't call itself recursively */
-  void (*old_xen_error_handler)(const char *msg, void *data);
-  void *old_xen_error_data;
-  old_xen_error_handler = ss->xen_error_handler;
-  old_xen_error_data = ss->xen_error_data;
-  ss->xen_error_handler = NULL;
-  ss->xen_error_data = NULL;
-  (*(old_xen_error_handler))(msg, old_xen_error_data);
-  ss->xen_error_handler = old_xen_error_handler;
-  ss->xen_error_data = old_xen_error_data;
-}
+  ss->xen_error_handler = handler;
+  ss->xen_error_data = data;
+
+#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\
+                               (lambda (tag args)                             \n\
+                                 (_snd_s7_error_handler_                      \n\
+                                   (string-append                             \n\
+                                     (apply format #f (car args) (cdr args))  \n\
+                                     (if (and (*error-info* 2)                \n\
+                                              (string? (*error-info* 4))      \n\
+                                              (number? (*error-info* 3)))     \n\
+                                         (format #f \"~%~S[~D]: ~A~%\"        \n\
+                                                 (*error-info* 4)             \n\
+                                                 (*error-info* 3)             \n\
+                                                 (*error-info* 2))            \n\
+                                         \"\")))))");
 #endif
+}
 
 
 void redirect_snd_print_to(void (*handler)(const char *msg, void *ufd), void *data)
@@ -253,6 +254,9 @@ void redirect_errors_to(void (*handler)(const char *msg, void *ufd), void *data)
 
 static char *gl_print(XEN result);
 
+
+/* ---------------- RUBY error handler ---------------- */
+
 #if HAVE_RUBY
 static XEN snd_format_if_needed(XEN args)
 {
@@ -341,12 +345,8 @@ static XEN snd_format_if_needed(XEN args)
   free(errmsg);
   return(result);
 }
-#endif
-
 
-/* ---------------- RUBY error handler ---------------- */
 
-#if HAVE_RUBY
 void snd_rb_raise(XEN tag, XEN throw_args)
 {
   static char *msg = NULL;
@@ -409,7 +409,18 @@ void snd_rb_raise(XEN tag, XEN throw_args)
       if (!(run_snd_error_hook(msg)))
 	{
 	  if (ss->xen_error_handler)
-	    call_xen_error_handler(msg);
+	    {
+	      /* make sure it doesn't call itself recursively */
+	      void (*old_xen_error_handler)(const char *msg, void *data);
+	      void *old_xen_error_data;
+	      old_xen_error_handler = ss->xen_error_handler;
+	      old_xen_error_data = ss->xen_error_data;
+	      ss->xen_error_handler = NULL;
+	      ss->xen_error_data = NULL;
+	      (*(old_xen_error_handler))(msg, old_xen_error_data);
+	      ss->xen_error_handler = old_xen_error_handler;
+	      ss->xen_error_data = old_xen_error_data;
+	    }
 	}
     }
 
@@ -420,13 +431,6 @@ void snd_rb_raise(XEN tag, XEN throw_args)
 
 
 
-/* if error occurs in sndlib, mus-error wants to throw to user-defined catch
- *   (or our own global catch), but if the sndlib function was not called by the user, 
- *   the attempt to throw to a non-existent catch tag exits the main program!!
- *   so, we only throw if catch_exists.
- */
-
-
 #if HAVE_EXTENSION_LANGUAGE
 
 XEN snd_catch_any(XEN_CATCH_BODY_TYPE body, void *body_data, const char *caller)
@@ -557,7 +561,8 @@ char *procedure_ok(XEN proc, int args, const char *caller, const char *arg_name,
 XEN snd_no_such_file_error(const char *caller, XEN filename)
 {
   XEN_ERROR(NO_SUCH_FILE,
-	    XEN_LIST_3(C_TO_XEN_STRING(caller),
+	    XEN_LIST_4(C_TO_XEN_STRING("no-such-file: ~A ~S: ~A"),
+		       C_TO_XEN_STRING(caller),
 		       filename,
 		       C_TO_XEN_STRING(snd_open_strerror())));
   return(XEN_FALSE);
@@ -583,15 +588,16 @@ XEN snd_no_such_channel_error(const char *caller, XEN snd, XEN chn)
     {
       sp = ss->sounds[index];
       XEN_ERROR(NO_SUCH_CHANNEL,
-		XEN_LIST_3(C_TO_XEN_STRING(caller),
-			   C_TO_XEN_STRING("chan: ~A, sound index: ~A (~A, chans: ~A)"),
-			   XEN_LIST_4(chn, 
-				      snd, 
-				      C_TO_XEN_STRING(sp->short_filename), 
-				      C_TO_XEN_INT(sp->nchans))));
+		XEN_LIST_6(C_TO_XEN_STRING("no-such-channel: (~A: sound: ~A, chan: ~A) (~S, chans: ~A))"),
+			   C_TO_XEN_STRING(caller),
+			   snd, 
+			   chn, 
+			   C_TO_XEN_STRING(sp->short_filename), 
+			   C_TO_XEN_INT(sp->nchans)));
     }
   XEN_ERROR(NO_SUCH_CHANNEL,
-	    XEN_LIST_3(C_TO_XEN_STRING(caller),
+	    XEN_LIST_4(C_TO_XEN_STRING("no-such-channel: (~A: sound: ~A, chan: ~A)"),
+		       C_TO_XEN_STRING(caller),
 		       snd,
 		       chn));
   return(XEN_FALSE);
@@ -601,7 +607,8 @@ XEN snd_no_such_channel_error(const char *caller, XEN snd, XEN chn)
 XEN snd_no_active_selection_error(const char *caller)
 {
   XEN_ERROR(XEN_ERROR_TYPE("no-active-selection"),
-	    XEN_LIST_1(C_TO_XEN_STRING(caller)));
+	    XEN_LIST_2(C_TO_XEN_STRING("~A: no active selection"),
+		       C_TO_XEN_STRING(caller)));
   return(XEN_FALSE);
 }
 
@@ -609,9 +616,9 @@ XEN snd_no_active_selection_error(const char *caller)
 XEN snd_bad_arity_error(const char *caller, XEN errstr, XEN proc)
 {
   XEN_ERROR(XEN_ERROR_TYPE("bad-arity"),
-            XEN_LIST_3(C_TO_XEN_STRING(caller),
-                       errstr,
-		       proc));
+            XEN_LIST_3(C_TO_XEN_STRING("~A,~A"),
+		       C_TO_XEN_STRING(caller),
+                       errstr));
   return(XEN_FALSE);
 }
 
@@ -2388,6 +2395,20 @@ static char *find_source_file(const char *orig)
 }
 
 
+#if MUS_DEBUGGING && HAVE_SCHEME
+static XEN g_test_load(XEN name)
+{
+  XEN_LOAD_FILE(XEN_TO_C_STRING(name));
+  return(XEN_FALSE);
+}
+#ifdef XEN_ARGIFY_1
+  XEN_NARGIFY_1(g_test_load_w, g_test_load)
+#else
+  #define g_test_load_w g_test_load
+#endif
+#endif
+
+
 #ifdef XEN_ARGIFY_1
 #if HAVE_SCHEME && HAVE_DLFCN_H
   XEN_NARGIFY_1(g_dlopen_w, g_dlopen)
@@ -2395,6 +2416,9 @@ static char *find_source_file(const char *orig)
   XEN_NARGIFY_0(g_dlerror_w, g_dlerror)
   XEN_NARGIFY_2(g_dlinit_w, g_dlinit)
 #endif
+#if HAVE_SCHEME
+  XEN_VARGIFY(g_snd_s7_error_handler_w, g_snd_s7_error_handler);
+#endif
 
 XEN_NARGIFY_1(g_snd_print_w, g_snd_print)
 XEN_NARGIFY_0(g_little_endian_w, g_little_endian)
@@ -2452,6 +2476,9 @@ XEN_NARGIFY_1(g_add_watcher_w, g_add_watcher)
   #define g_dlerror_w g_dlerror
   #define g_dlinit_w g_dlinit
 #endif
+#if HAVE_SCHEME
+  #define g_snd_s7_error_handler_w g_snd_s7_error_handler
+#endif
 
 #define g_snd_print_w g_snd_print
 #define g_little_endian_w g_little_endian
@@ -2647,6 +2674,9 @@ void g_xen_initialize(void)
 #if MUS_DEBUGGING
   XEN_DEFINE_PROCEDURE("snd-sound-pointer", g_snd_sound_pointer_w, 1, 0, 0, "internal testing function");
 #endif
+#if MUS_DEBUGGING && HAVE_SCHEME
+  XEN_DEFINE_PROCEDURE("_test_load_", g_test_load_w, 1, 0, 0, "internal testing function");
+#endif
 
   Init_sndlib();
 
@@ -2810,6 +2840,7 @@ If it returns some non-#f result, Snd assumes you've sent the text out yourself,
 
 #if HAVE_SCHEME
   init_listener_ports();
+  XEN_DEFINE_PROCEDURE("_snd_s7_error_handler_", g_snd_s7_error_handler_w,  0, 0, 1, "internal error redirection for snd/s7");
 
   XEN_EVAL_C_STRING("(define redo-edit redo)");        /* consistency with Ruby */
   XEN_EVAL_C_STRING("(define undo-edit undo)");
@@ -2817,10 +2848,6 @@ If it returns some non-#f result, Snd assumes you've sent the text out yourself,
   XEN_EVAL_C_STRING("(define (procedure-name proc) (format #f \"~A\" proc))");
   /* needed in snd-test.scm and hooks.scm */
 
-  XEN_EVAL_C_STRING("(define (symbol-append . args) \"(symbol-append . args) makes a new symbol from its args\"\
-                       (string->symbol (apply string-append (map symbol->string args))))");
-  /* taken from guile ice-9/boot9.scm, used by KM's stuff (gui.scm etc) */
-
   XEN_EVAL_C_STRING("\
         (define (apropos name)\
           (define (substring? subs s)\
@@ -2856,20 +2883,6 @@ If it returns some non-#f result, Snd assumes you've sent the text out yourself,
 	         (apropos-1 frame)))\
            (current-environment)))");
 
-
-  /* a second stab at a break point handler for s7 
-
-     I think Scheme should support stuff like:
-
-     (let ((local-var 32))
-       (define (proc1 arg)
-         (+ local-var arg))
-       (define (proc2 arg)
-         (- local-var arg)))
-
-     which gives shared local variables without the annoying set! two-step
-  */
-
   XEN_EVAL_C_STRING("\
 (define break-ok #f)\
 (define break-exit #f)  ; a kludge to get 2 funcs to share a local variable\n\