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.
This commit is contained in:
Doug Evans
parent
4122867a42
commit
186fcde0c6
13 changed files with 90 additions and 38 deletions
|
|
@ -1,3 +1,17 @@
|
|||
2014-07-26 Ludovic Courtès <ludo@gnu.org>
|
||||
Doug Evans <xdje42@gmail.com>
|
||||
|
||||
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 <xdje42@gmail.com>
|
||||
|
||||
PR build/17105
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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";
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
||||
|
|
|
|||
|
|
@ -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 '())
|
||||
|
|
|
|||
|
|
@ -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"))))
|
||||
|
|
|
|||
33
gdb/guile/lib/gdb/support.scm
Normal file
33
gdb/guile/lib/gdb/support.scm
Normal file
|
|
@ -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))))
|
||||
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -1,3 +1,9 @@
|
|||
2014-07-26 Ludovic Courtès <ludo@gnu.org>
|
||||
Doug Evans <xdje42@gmail.com>
|
||||
|
||||
PR guile/17146
|
||||
* gdb.guile/types-module.exp: Add tests for wrong type arguments.
|
||||
|
||||
2014-07-25 Pedro Alves <palves@redhat.com>
|
||||
|
||||
* gdb.threads/signal-command-handle-nopass.c: New file.
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
Loading…
Reference in a new issue