From: Doug Evans Date: Sun, 27 Jul 2014 00:01:09 +0000 (-0700) Subject: PR guile/17146 preparatory work. X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=186fcde0c6134aed28526d925b1360db95d47171;p=binutils-gdb.git PR guile/17146 preparatory work. * 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/ChangeLog b/gdb/ChangeLog index a4cee807210..3520177ebe7 100644 --- a/gdb/ChangeLog +++ b/gdb/ChangeLog @@ -1,3 +1,17 @@ +2014-07-26 Ludovic Courtès + Doug Evans + + PR guile/17146 + * 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. + 2014-07-26 Doug Evans PR build/17105 diff --git a/gdb/data-directory/Makefile.in b/gdb/data-directory/Makefile.in index c7497db5d6a..b05dba55496 100644 --- a/gdb/data-directory/Makefile.in +++ b/gdb/data-directory/Makefile.in @@ -87,6 +87,7 @@ GUILE_FILE_LIST = \ gdb/init.scm \ gdb/iterator.scm \ gdb/printing.scm \ + gdb/support.scm \ gdb/types.scm @HAVE_GUILE_TRUE@GUILE_FILES = $(GUILE_FILE_LIST) diff --git a/gdb/guile/guile.c b/gdb/guile/guile.c index 6bc078f7791..e81cb4c8ea8 100644 --- a/gdb/guile/guile.c +++ b/gdb/guile/guile.c @@ -120,7 +120,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 4fd4699b939..552bfe9ed7c 100644 --- a/gdb/guile/lib/gdb.scm +++ b/gdb/guile/lib/gdb.scm @@ -494,11 +494,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 8c0bb354df8..6159354d209 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 ffded84d01b..9e5a53efb22 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 7607d4967a7..98888ed3ac9 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 . -(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 9cfbe85b8d0..27489314920 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 . (define-module (gdb iterator) - #:use-module (gdb)) + #:use-module (gdb) + #:use-module (gdb support)) (define-public (make-list-iterator l) "Return a 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 2d1274f984d..4e4fb914408 100644 --- a/gdb/guile/lib/gdb/printing.scm +++ b/gdb/guile/lib/gdb/printing.scm @@ -23,13 +23,13 @@ pretty-printers set-pretty-printers! 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) @@ -39,13 +39,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) @@ -55,4 +56,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 00000000000..dc6c20f65f9 --- /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 . + +(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 31ea19276d3..296d17005b3 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/ChangeLog b/gdb/testsuite/ChangeLog index e088b9baf68..f64371c9cff 100644 --- a/gdb/testsuite/ChangeLog +++ b/gdb/testsuite/ChangeLog @@ -1,3 +1,9 @@ +2014-07-26 Ludovic Courtès + Doug Evans + + PR guile/17146 + * gdb.guile/types-module.exp: Add tests for wrong type arguments. + 2014-07-25 Pedro Alves * gdb.threads/signal-command-handle-nopass.c: New file. diff --git a/gdb/testsuite/gdb.guile/types-module.exp b/gdb/testsuite/gdb.guile/types-module.exp index 8562f3ccc68..4dd5ee484db 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\\): #.*" \ + "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\\): #.*" \ + "make-enum-hashtable from int"