PR guile/17146

	* acinclude.m4 (GDB_GUILE_PROGRAM_NAMES): New macro.
	(GDB_GUILD_TARGET_FLAG, GDB_TRY_GUILD): New macros.
	* configure.ac: Try to use guild to compile an scm file, if it fails
	then disable guile support.
	* configure: Regenerate.
	* data-directory/Makefile.in (GUILE_SOURCE_FILES): Renamed from
	GUILE_FILE_LIST.
	(GUILE_COMPILED_FILES): New variable.
	(GUILE_FILES) Update.
	(GUILD, GUILD_TARGET_FLAG, GUILD_COMPILE_FLAGS): New variables.
	(stamp-guile): Compile scm files.
	* guile/guile.c (boot_guile_support): New function.
	(standard_throw_args_p): New function.
	(print_standard_throw_error, print_throw_error): New functions.
	(handle_boot_error): New function.
	(initialize_scheme_side): Rewrite to call boot_guile_support.
	* guile/lib/gdb/boot.scm: Update %load-compiled-path.  Load gdb.go.
	* guile/lib/gdb/init.scm (%silence-compiler-warnings%): New function.

3 files changed, 127 insertions, 20 deletions

diff --git a/gdb/guile/guile.c b/gdb/guile/guile.c
index e81cb4c..1c0923d 100644
--- a/gdb/guile/guile.c
+++ b/gdb/guile/guile.c
@@ -510,6 +510,111 @@ Return the name of the target configuration." },
   END_FUNCTIONS
 };
 
+/* Load BOOT_SCM_FILE, the first Scheme file that gets loaded.  */
+
+static SCM
+boot_guile_support (void *boot_scm_file)
+{
+  /* Load boot.scm without compiling it (there's no need to compile it).
+     The other files should have been compiled already, and boot.scm is
+     expected to adjust '%load-compiled-path' accordingly.  If they haven't
+     been compiled, Guile will auto-compile them. The important thing to keep
+     in mind is that there's a >= 100x speed difference between compiled and
+     non-compiled files.  */
+  return scm_c_primitive_load ((const char *) boot_scm_file);
+}
+
+/* Return non-zero if ARGS has the "standard" format for throw args.
+   The standard format is:
+   (function format-string (format-string-args-list) ...).
+   FUNCTION is #f if no function was recorded.  */
+
+static int
+standard_throw_args_p (SCM args)
+{
+  if (gdbscm_is_true (scm_list_p (args))
+      && scm_ilength (args) >= 3)
+    {
+      /* The function in which the error occurred.  */
+      SCM arg0 = scm_list_ref (args, scm_from_int (0));
+      /* The format string.  */
+      SCM arg1 = scm_list_ref (args, scm_from_int (1));
+      /* The arguments of the format string.  */
+      SCM arg2 = scm_list_ref (args, scm_from_int (2));
+
+      if ((scm_is_string (arg0) || gdbscm_is_false (arg0))
+	  && scm_is_string (arg1)
+	  && gdbscm_is_true (scm_list_p (arg2)))
+	return 1;
+    }
+
+  return 0;
+}
+
+/* Print the error recorded in a "standard" throw args.  */
+
+static void
+print_standard_throw_error (SCM args)
+{
+  /* The function in which the error occurred.  */
+  SCM arg0 = scm_list_ref (args, scm_from_int (0));
+  /* The format string.  */
+  SCM arg1 = scm_list_ref (args, scm_from_int (1));
+  /* The arguments of the format string.  */
+  SCM arg2 = scm_list_ref (args, scm_from_int (2));
+
+  /* ARG0 is #f if no function was recorded.  */
+  if (gdbscm_is_true (arg0))
+    {
+      scm_simple_format (scm_current_error_port (),
+			 scm_from_latin1_string (_("Error in function ~s:~%")),
+			 scm_list_1 (arg0));
+    }
+  scm_simple_format (scm_current_error_port (), arg1, arg2);
+}
+
+/* Print the error message recorded in KEY, ARGS, the arguments to throw.
+   Normally we let Scheme print the error message.
+   This function is used when Scheme initialization fails.
+   We can still use the Scheme C API though.  */
+
+static void
+print_throw_error (SCM key, SCM args)
+{
+  /* IWBN to call gdbscm_print_exception_with_stack here, but Guile didn't
+     boot successfully so play it safe and avoid it.  The "format string" and
+     its args are embedded in ARGS, but the content of ARGS depends on KEY.
+     Make sure ARGS has the expected canonical content before trying to use
+     it.  */
+  if (standard_throw_args_p (args))
+    print_standard_throw_error (args);
+  else
+    {
+      scm_simple_format (scm_current_error_port (),
+			 scm_from_latin1_string (_("Throw to key `~a' with args `~s'.~%")),
+			 scm_list_2 (key, args));
+    }
+}
+
+/* Handle an exception thrown while loading BOOT_SCM_FILE.  */
+
+static SCM
+handle_boot_error (void *boot_scm_file, SCM key, SCM args)
+{
+  fprintf_unfiltered (gdb_stderr, ("Exception caught while booting Guile.\n"));
+
+  print_throw_error (key, args);
+
+  fprintf_unfiltered (gdb_stderr, "\n");
+  warning (_("Could not complete Guile gdb module initialization from:\n"
+	     "%s.\n"
+	     "Limited Guile support is available.\n"
+	     "Suggest passing --data-directory=/path/to/gdb/data-directory.\n"),
+	   (const char *) boot_scm_file);
+
+  return SCM_UNSPECIFIED;
+}
+
 /* Load gdb/boot.scm, the Scheme side of GDB/Guile support.
    Note: This function assumes it's called within the gdb module.  */
 
@@ -523,23 +628,8 @@ initialize_scheme_side (void)
   boot_scm_path = concat (guile_datadir, SLASH_STRING, "gdb",
 			  SLASH_STRING, boot_scm_filename, NULL);
 
-  /* While scm_c_primitive_load works, the loaded code is not compiled,
-     instead it is left to be interpreted.  Eh?
-     Anyways, this causes a ~100x slowdown, so we only use it to load
-     gdb/boot.scm, and then let boot.scm do the rest.  */
-  msg = gdbscm_safe_source_script (boot_scm_path);
-
-  if (msg != NULL)
-    {
-      fprintf_filtered (gdb_stderr, "%s", msg);
-      xfree (msg);
-      warning (_("\n"
-		 "Could not complete Guile gdb module initialization from:\n"
-		 "%s.\n"
-		 "Limited Guile support is available.\n"
-		 "Suggest passing --data-directory=/path/to/gdb/data-directory.\n"),
-	       boot_scm_path);
-    }
+  scm_c_catch (SCM_BOOL_T, boot_guile_support, boot_scm_path,
+	       handle_boot_error, boot_scm_path, NULL, NULL);
 
   xfree (boot_scm_path);
 }
diff --git a/gdb/guile/lib/gdb/boot.scm b/gdb/guile/lib/gdb/boot.scm
index 6159354..9463f10 100644
--- a/gdb/guile/lib/gdb/boot.scm
+++ b/gdb/guile/lib/gdb/boot.scm
@@ -21,9 +21,20 @@
 ;; loaded with it are not compiled.  So we do very little here, and do
 ;; most of the initialization elsewhere.
 
-;; guile-data-directory is provided by the C code.
-(add-to-load-path (guile-data-directory))
-(load-from-path "gdb.scm")
+;; Initialize the source and compiled file search paths.
+;; Note: 'guile-data-directory' is provided by the C code.
+(let ((module-dir (guile-data-directory)))
+  (set! %load-path (cons module-dir %load-path))
+  (set! %load-compiled-path (cons module-dir %load-compiled-path)))
+
+;; Load the (gdb) module.  This needs to be done here because C code relies on
+;; the availability of Scheme bindings such as '%print-exception-with-stack'.
+;; Note: as of Guile 2.0.11, 'primitive-load' evaluates the code and 'load'
+;; somehow ignores the '.go', hence 'load-compiled'.
+(let ((gdb-go-file (search-path %load-compiled-path "gdb.go")))
+  (if gdb-go-file
+      (load-compiled gdb-go-file)
+      (error "Unable to find gdb.go file.")))
 
 ;; Now that the Scheme side support is loaded, initialize it.
 (let ((init-proc (@@ (gdb) %initialize!)))
diff --git a/gdb/guile/lib/gdb/init.scm b/gdb/guile/lib/gdb/init.scm
index 98888ed..53cce2e 100644
--- a/gdb/guile/lib/gdb/init.scm
+++ b/gdb/guile/lib/gdb/init.scm
@@ -147,6 +147,12 @@
   (set! %orig-input-port (set-current-input-port (input-port)))
   (set! %orig-output-port (set-current-output-port (output-port)))
   (set! %orig-error-port (set-current-error-port (error-port))))
+
+;; Dummy routine to silence "possibly unused local top-level variable"
+;; warnings from the compiler.
+
+(define-public (%silence-compiler-warnings%)
+  (list %print-exception-with-stack %initialize!))
 
 ;; Public routines.