[PATCH v2 1/2] guile: Compile and install Scheme files

[Doug Evans <dje at google dot com>]

Hi.

This is v2 of a patch set to compile the Scheme files when gdb is built.
Guile will auto-compile them as needed when they are loaded, just like Python,
but Guile is a bit too verbose about it.  In order to silence Guile,
this patch pre-compiles them.

Fortunately, guild (wrapper around the guile compiler) can cross-compile.
Therefore this works even if cross-compiling gdb.
To be conservative, configure.ac does a test compile, and if that
fails then guile support is disabled.
I have tested cross-compiling to i686-linux from amd64-linux,
and tested the resulting gdb.
I have also done a hand cross-compile from amd64-linux to i686-pc-mingw
(I didn't test that gdb+guile works in this case, just that the
cross-compile succeeded).

This first patch does some preparatory work for the real patch in 2/2.

This is PR guile/17146.

2014-07-21  Ludovic CourtÃs  <ludo@gnu.org>
	    Doug Evans  <xdje42@gmail.com>

	* data-directory/Makefile.in (GUILE_FILES): Add support.scm.
	* guile/lib/gdb/support.scm: New file.
	* guile/guile.c (gdbscm_init_module_name): Change to "gdb".
	* guile/lib/gdb.scm: Load gdb/init.scm as an include file.
	All uses updated.
	* guile/lib/gdb/init.scm (SCM_ARG1, SCM_ARG2): Moved to support.scm.
	All uses updated.
	(%assert-type): Ditto, and renamed to assert-type.
	(%exception-print-style): Delete.

	testsuite/
	* gdb.guile/types-module.exp: Add tests for wrong type arguments.

diff --git a/gdb/data-directory/Makefile.in b/gdb/data-directory/Makefile.in
index b9fcc03..26a507f 100644
--- a/gdb/data-directory/Makefile.in
+++ b/gdb/data-directory/Makefile.in
@@ -84,6 +84,7 @@ GUILE_FILES = \
 	gdb/init.scm \
 	gdb/iterator.scm \
 	gdb/printing.scm \
+	gdb/support.scm \
 	gdb/types.scm
 
 SYSTEM_GDBINIT_DIR = system-gdbinit
diff --git a/gdb/guile/guile.c b/gdb/guile/guile.c
index 05dba69..103c599 100644
--- a/gdb/guile/guile.c
+++ b/gdb/guile/guile.c
@@ -117,7 +117,7 @@ static SCM to_string_keyword;
 
 /* The name of the various modules (without the surrounding parens).  */
 const char gdbscm_module_name[] = "gdb";
-const char gdbscm_init_module_name[] = "gdb init";
+const char gdbscm_init_module_name[] = "gdb";
 
 /* The name of the bootstrap file.  */
 static const char boot_scm_filename[] = "boot.scm";
diff --git a/gdb/guile/lib/gdb.scm b/gdb/guile/lib/gdb.scm
index 120fcc6..048baf9 100644
--- a/gdb/guile/lib/gdb.scm
+++ b/gdb/guile/lib/gdb.scm
@@ -492,11 +492,11 @@
 
 ;; Load the rest of the Scheme side.
 
-(use-modules ((gdb init)))
+(include "gdb/init.scm")
 
 ;; These come from other files, but they're really part of this module.
 
-(re-export
+(export
 
  ;; init.scm
  orig-input-port
diff --git a/gdb/guile/lib/gdb/boot.scm b/gdb/guile/lib/gdb/boot.scm
index 8c0bb35..6159354 100644
--- a/gdb/guile/lib/gdb/boot.scm
+++ b/gdb/guile/lib/gdb/boot.scm
@@ -26,5 +26,5 @@
 (load-from-path "gdb.scm")
 
 ;; Now that the Scheme side support is loaded, initialize it.
-(let ((init-proc (@@ (gdb init) %initialize!)))
+(let ((init-proc (@@ (gdb) %initialize!)))
   (init-proc))
diff --git a/gdb/guile/lib/gdb/experimental.scm b/gdb/guile/lib/gdb/experimental.scm
index ffded84..9e5a53e 100644
--- a/gdb/guile/lib/gdb/experimental.scm
+++ b/gdb/guile/lib/gdb/experimental.scm
@@ -22,8 +22,7 @@
 ;; E.g., (gdb experimental ports), etc.
 
 (define-module (gdb experimental)
-  #:use-module (gdb)
-  #:use-module (gdb init))
+  #:use-module (gdb))
 
 ;; These are defined in C.
 (define-public with-gdb-output-to-port (@@ (gdb) %with-gdb-output-to-port))
diff --git a/gdb/guile/lib/gdb/init.scm b/gdb/guile/lib/gdb/init.scm
index 7607d49..98888ed 100644
--- a/gdb/guile/lib/gdb/init.scm
+++ b/gdb/guile/lib/gdb/init.scm
@@ -17,20 +17,13 @@
 ;; You should have received a copy of the GNU General Public License
 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
 
-(define-module (gdb init)
-  #:use-module (gdb))
-
-(define-public SCM_ARG1 1)
-(define-public SCM_ARG2 2)
+;; This file is included by (gdb).
 
 ;; The original i/o ports.  In case the user wants them back.
 (define %orig-input-port #f)
 (define %orig-output-port #f)
 (define %orig-error-port #f)
 
-;; %exception-print-style is exported as "private" by gdb.
-(define %exception-print-style (@@ (gdb) %exception-print-style))
-
 ;; Keys for GDB-generated exceptions.
 ;; gdb:with-stack is handled separately.
 
@@ -142,15 +135,6 @@
 
 	  (%print-exception-message port frame key args)))))
 
-;; Internal utility to check the type of an argument, akin to SCM_ASSERT_TYPE.
-;; It's public so other gdb modules can use it.
-
-(define-public (%assert-type test-result arg pos func-name)
-  (if (not test-result)
-      (scm-error 'wrong-type-arg func-name
-		 "Wrong type argument in position ~a: ~s"
-		 (list pos arg) (list arg))))
-
 ;; Internal utility called during startup to initialize the Scheme side of
 ;; GDB+Guile.
 
diff --git a/gdb/guile/lib/gdb/iterator.scm b/gdb/guile/lib/gdb/iterator.scm
index 9cfbe85..2748931 100644
--- a/gdb/guile/lib/gdb/iterator.scm
+++ b/gdb/guile/lib/gdb/iterator.scm
@@ -19,11 +19,12 @@
 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (gdb iterator)
-  #:use-module (gdb))
+  #:use-module (gdb)
+  #:use-module (gdb support))
 
 (define-public (make-list-iterator l)
   "Return a <gdb:iterator> object for a list."
-  (%assert-type (list? l) l SCM_ARG1 'make-list-iterator)
+  (assert-type (list? l) l SCM_ARG1 'make-list-iterator "list")
   (let ((next! (lambda (iter)
 		 (let ((l (iterator-progress iter)))
 		   (if (eq? l '())
diff --git a/gdb/guile/lib/gdb/printing.scm b/gdb/guile/lib/gdb/printing.scm
index eac9417..53ae83d 100644
--- a/gdb/guile/lib/gdb/printing.scm
+++ b/gdb/guile/lib/gdb/printing.scm
@@ -22,13 +22,13 @@
 		(*pretty-printers* pretty-printer? objfile? progspace?
 		 objfile-pretty-printers set-objfile-pretty-printers!
 		 progspace-pretty-printers set-progspace-pretty-printers!))
-  #:use-module (gdb init))
+  #:use-module (gdb support))
 
 (define-public (prepend-pretty-printer! obj matcher)
   "Add MATCHER to the beginning of the pretty-printer list for OBJ.
 If OBJ is #f, add MATCHER to the global list."
-  (%assert-type (pretty-printer? matcher) matcher SCM_ARG1
-		'prepend-pretty-printer!)
+  (assert-type (pretty-printer? matcher) matcher SCM_ARG1
+	       'prepend-pretty-printer! "pretty-printer")
   (cond ((eq? obj #f)
 	 (set! *pretty-printers* (cons matcher *pretty-printers*)))
 	((objfile? obj)
@@ -38,13 +38,14 @@ If OBJ is #f, add MATCHER to the global list."
 	 (set-progspace-pretty-printers!
 	  obj (cons matcher (progspace-pretty-printers obj))))
 	(else
-	 (%assert-type #f obj SCM_ARG1 'prepend-pretty-printer!))))
+	 (assert-type #f obj SCM_ARG1 'prepend-pretty-printer!
+		      "#f, objfile, or progspace"))))
 
 (define-public (append-pretty-printer! obj matcher)
   "Add MATCHER to the end of the pretty-printer list for OBJ.
 If OBJ is #f, add MATCHER to the global list."
-  (%assert-type (pretty-printer? matcher) matcher SCM_ARG1
-		'append-pretty-printer!)
+  (assert-type (pretty-printer? matcher) matcher SCM_ARG1
+	       'append-pretty-printer! "pretty-printer")
   (cond ((eq? obj #f)
 	 (set! *pretty-printers* (append! *pretty-printers* (list matcher))))
 	((objfile? obj)
@@ -54,4 +55,5 @@ If OBJ is #f, add MATCHER to the global list."
 	 (set-progspace-pretty-printers!
 	  obj (append! (progspace-pretty-printers obj) (list matcher))))
 	(else
-	 (%assert-type #f obj SCM_ARG1 'append-pretty-printer!))))
+	 (assert-type #f obj SCM_ARG1 'append-pretty-printer!
+		      "#f, objfile, or progspace"))))
diff --git a/gdb/guile/lib/gdb/support.scm b/gdb/guile/lib/gdb/support.scm
new file mode 100644
index 0000000..dc6c20f
--- /dev/null
+++ b/gdb/guile/lib/gdb/support.scm
@@ -0,0 +1,33 @@
+;; Internal support routines.
+;;
+;; Copyright (C) 2014 Free Software Foundation, Inc.
+;;
+;; This file is part of GDB.
+;;
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gdb support))
+
+;; Symbolic values for the ARG parameter of assert-type.
+
+(define-public SCM_ARG1 1)
+(define-public SCM_ARG2 2)
+
+;; Utility to check the type of an argument, akin to SCM_ASSERT_TYPE.
+
+(define-public (assert-type test-result arg pos func-name expecting)
+  (if (not test-result)
+      (scm-error 'wrong-type-arg func-name
+		 "Wrong type argument in position ~a (expecting ~a): ~s"
+		 (list pos expecting arg) (list arg))))
diff --git a/gdb/guile/lib/gdb/types.scm b/gdb/guile/lib/gdb/types.scm
index 31ea192..296d170 100644
--- a/gdb/guile/lib/gdb/types.scm
+++ b/gdb/guile/lib/gdb/types.scm
@@ -16,8 +16,8 @@
 
 (define-module (gdb types)
   #:use-module (gdb)
-  #:use-module (gdb init)
-  #:use-module (gdb iterator))
+  #:use-module (gdb iterator)
+  #:use-module (gdb support))
 
 (define-public (type-has-field-deep? type field-name)
   "Return #t if the type, including baseclasses, has the specified field.
@@ -50,8 +50,8 @@
       (set! type (type-target type)))
   (set! type (type-strip-typedefs type))
 
-  (%assert-type (memq (type-code type) (list TYPE_CODE_STRUCT TYPE_CODE_UNION))
-		type SCM_ARG1 'type-has-field-deep?)
+  (assert-type (memq (type-code type) (list TYPE_CODE_STRUCT TYPE_CODE_UNION))
+	       type SCM_ARG1 'type-has-field-deep? "struct or union")
 
   (search-class type))
 
@@ -69,8 +69,8 @@
   Raises:
     wrong-type-arg: The type is not an enum."
 
-  (%assert-type (= (type-code enum-type) TYPE_CODE_ENUM)
-		enum-type SCM_ARG1 'make-enum-hashtable)
+  (assert-type (= (type-code enum-type) TYPE_CODE_ENUM)
+	       enum-type SCM_ARG1 'make-enum-hashtable "enum")
   (let ((htab (make-hash-table)))
     (for-each (lambda (enum)
 		(hash-set! htab (field-name enum) (field-enumval enum)))
diff --git a/gdb/testsuite/gdb.guile/types-module.exp b/gdb/testsuite/gdb.guile/types-module.exp
index 8562f3c..4dd5ee4 100644
--- a/gdb/testsuite/gdb.guile/types-module.exp
+++ b/gdb/testsuite/gdb.guile/types-module.exp
@@ -43,8 +43,20 @@ gdb_test "guile (print (type-has-field? d \"base_member\"))" \
 gdb_test "guile (print (type-has-field-deep? d \"base_member\"))" \
     "= #t" "type-has-field-deep? member in baseclass"
 
+gdb_test "guile (print (type-has-field-deep? (lookup-type \"int\") \"base_member\"))" \
+    "ERROR: .*Wrong type argument in position 1 \\(expecting struct or union\\): #<gdb:type int>.*" \
+    "type-has-field-deep? from int"
+
 gdb_scm_test_silent_cmd "guile (define enum-htab (make-enum-hashtable (lookup-type \"enum_type\")))" \
     "create enum hash table"
 
 gdb_test "guile (print (hash-ref enum-htab \"B\"))" \
     "= 1" "verify make-enum-hashtable"
+
+gdb_test "guile (define bad-enum-htab (make-enum-hashtable #f))" \
+    "ERROR: .*Wrong type argument in position 1 \\(expecting gdb:type\\): #f.*" \
+    "make-enum-hashtable from #f"
+
+gdb_test "guile (define bad-enum-htab (make-enum-hashtable (lookup-type \"int\")))" \
+    "ERROR: .*Wrong type argument in position 1 \\(expecting enum\\): #<gdb:type int>.*" \
+    "make-enum-hashtable from int"